Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH.hs @ 9d049fb4

History | View | Annotate | Download (46.9 kB)

1
{-# LANGUAGE ExistentialQuantification, ParallelListComp, TemplateHaskell #-}
2

    
3
{-| TemplateHaskell helper for Ganeti Haskell code.
4

    
5
As TemplateHaskell require that splices be defined in a separate
6
module, we combine all the TemplateHaskell functionality that HTools
7
needs in this module (except the one for unittests).
8

    
9
-}
10

    
11
{-
12

    
13
Copyright (C) 2011, 2012 Google Inc.
14

    
15
This program is free software; you can redistribute it and/or modify
16
it under the terms of the GNU General Public License as published by
17
the Free Software Foundation; either version 2 of the License, or
18
(at your option) any later version.
19

    
20
This program is distributed in the hope that it will be useful, but
21
WITHOUT ANY WARRANTY; without even the implied warranty of
22
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
23
General Public License for more details.
24

    
25
You should have received a copy of the GNU General Public License
26
along with this program; if not, write to the Free Software
27
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28
02110-1301, USA.
29

    
30
-}
31

    
32
module Ganeti.THH ( declareSADT
33
                  , declareLADT
34
                  , declareILADT
35
                  , declareIADT
36
                  , makeJSONInstance
37
                  , deCamelCase
38
                  , genOpID
39
                  , genAllConstr
40
                  , genAllOpIDs
41
                  , PyValue(..)
42
                  , PyValueEx(..)
43
                  , OpCodeDescriptor
44
                  , genOpCode
45
                  , genStrOfOp
46
                  , genStrOfKey
47
                  , genLuxiOp
48
                  , Field (..)
49
                  , simpleField
50
                  , withDoc
51
                  , defaultField
52
                  , optionalField
53
                  , optionalNullSerField
54
                  , renameField
55
                  , customField
56
                  , timeStampFields
57
                  , uuidFields
58
                  , serialFields
59
                  , tagsFields
60
                  , TagSet
61
                  , buildObject
62
                  , buildObjectSerialisation
63
                  , buildParam
64
                  , DictObject(..)
65
                  , genException
66
                  , excErrMsg
67
                  ) where
68

    
69
import Control.Monad (liftM)
70
import Data.Char
71
import Data.List
72
import qualified Data.Set as Set
73
import Language.Haskell.TH
74

    
75
import qualified Text.JSON as JSON
76
import Text.JSON.Pretty (pp_value)
77

    
78
import Ganeti.JSON
79

    
80
import Data.Maybe
81
import Data.Functor ((<$>))
82

    
83
-- * Exported types
84

    
85
-- | Class of objects that can be converted to 'JSObject'
86
-- lists-format.
87
class DictObject a where
88
  toDict :: a -> [(String, JSON.JSValue)]
89

    
90
-- | Optional field information.
91
data OptionalType
92
  = NotOptional           -- ^ Field is not optional
93
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
94
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
95
  deriving (Show, Eq)
96

    
97
-- | Serialised field data type.
98
data Field = Field { fieldName        :: String
99
                   , fieldType        :: Q Type
100
                   , fieldRead        :: Maybe (Q Exp)
101
                   , fieldShow        :: Maybe (Q Exp)
102
                   , fieldExtraKeys   :: [String]
103
                   , fieldDefault     :: Maybe (Q Exp)
104
                   , fieldConstr      :: Maybe String
105
                   , fieldIsOptional  :: OptionalType
106
                   , fieldDoc         :: String
107
                   }
108

    
109
-- | Generates a simple field.
110
simpleField :: String -> Q Type -> Field
111
simpleField fname ftype =
112
  Field { fieldName        = fname
113
        , fieldType        = ftype
114
        , fieldRead        = Nothing
115
        , fieldShow        = Nothing
116
        , fieldExtraKeys   = []
117
        , fieldDefault     = Nothing
118
        , fieldConstr      = Nothing
119
        , fieldIsOptional  = NotOptional
120
        , fieldDoc         = ""
121
        }
122

    
123
withDoc :: String -> Field -> Field
124
withDoc doc field =
125
  field { fieldDoc = doc }
126

    
127
-- | Sets the renamed constructor field.
128
renameField :: String -> Field -> Field
129
renameField constrName field = field { fieldConstr = Just constrName }
130

    
131
-- | Sets the default value on a field (makes it optional with a
132
-- default value).
133
defaultField :: Q Exp -> Field -> Field
134
defaultField defval field = field { fieldDefault = Just defval }
135

    
136
-- | Marks a field optional (turning its base type into a Maybe).
137
optionalField :: Field -> Field
138
optionalField field = field { fieldIsOptional = OptionalOmitNull }
139

    
140
-- | Marks a field optional (turning its base type into a Maybe), but
141
-- with 'Nothing' serialised explicitly as /null/.
142
optionalNullSerField :: Field -> Field
143
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
144

    
145
-- | Sets custom functions on a field.
146
customField :: Name      -- ^ The name of the read function
147
            -> Name      -- ^ The name of the show function
148
            -> [String]  -- ^ The name of extra field keys
149
            -> Field     -- ^ The original field
150
            -> Field     -- ^ Updated field
151
customField readfn showfn extra field =
152
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
153
        , fieldExtraKeys = extra }
154

    
155
-- | Computes the record name for a given field, based on either the
156
-- string value in the JSON serialisation or the custom named if any
157
-- exists.
158
fieldRecordName :: Field -> String
159
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
160
  fromMaybe (camelCase name) alias
161

    
162
-- | Computes the preferred variable name to use for the value of this
163
-- field. If the field has a specific constructor name, then we use a
164
-- first-letter-lowercased version of that; otherwise, we simply use
165
-- the field name. See also 'fieldRecordName'.
166
fieldVariable :: Field -> String
167
fieldVariable f =
168
  case (fieldConstr f) of
169
    Just name -> ensureLower name
170
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
171

    
172
-- | Compute the actual field type (taking into account possible
173
-- optional status).
174
actualFieldType :: Field -> Q Type
175
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
176
                  | otherwise = t
177
                  where t = fieldType f
178

    
179
-- | Checks that a given field is not optional (for object types or
180
-- fields which should not allow this case).
181
checkNonOptDef :: (Monad m) => Field -> m ()
182
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
183
                      , fieldName = name }) =
184
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
185
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
186
                      , fieldName = name }) =
187
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
188
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
189
  fail $ "Default field " ++ name ++ " used in parameter declaration"
190
checkNonOptDef _ = return ()
191

    
192
-- | Produces the expression that will de-serialise a given
193
-- field. Since some custom parsing functions might need to use the
194
-- entire object, we do take and pass the object to any custom read
195
-- functions.
196
loadFn :: Field   -- ^ The field definition
197
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
198
       -> Q Exp   -- ^ The entire object in JSON object format
199
       -> Q Exp   -- ^ Resulting expression
200
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
201
loadFn _ expr _ = expr
202

    
203
-- * Common field declarations
204

    
205
-- | Timestamp fields description.
206
timeStampFields :: [Field]
207
timeStampFields =
208
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
209
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
210
    ]
211

    
212
-- | Serial number fields description.
213
serialFields :: [Field]
214
serialFields =
215
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
216

    
217
-- | UUID fields description.
218
uuidFields :: [Field]
219
uuidFields = [ simpleField "uuid" [t| String |] ]
220

    
221
-- | Tag set type alias.
222
type TagSet = Set.Set String
223

    
224
-- | Tag field description.
225
tagsFields :: [Field]
226
tagsFields = [ defaultField [| Set.empty |] $
227
               simpleField "tags" [t| TagSet |] ]
228

    
229
-- * Internal types
230

    
231
-- | A simple field, in constrast to the customisable 'Field' type.
232
type SimpleField = (String, Q Type)
233

    
234
-- | A definition for a single constructor for a simple object.
235
type SimpleConstructor = (String, [SimpleField])
236

    
237
-- | A definition for ADTs with simple fields.
238
type SimpleObject = [SimpleConstructor]
239

    
240
-- | A type alias for an opcode constructor of a regular object.
241
type OpCodeConstructor = (String, Q Type, String, [Field], String)
242

    
243
-- | A type alias for a Luxi constructor of a regular object.
244
type LuxiConstructor = (String, [Field])
245

    
246
-- * Helper functions
247

    
248
-- | Ensure first letter is lowercase.
249
--
250
-- Used to convert type name to function prefix, e.g. in @data Aa ->
251
-- aaToRaw@.
252
ensureLower :: String -> String
253
ensureLower [] = []
254
ensureLower (x:xs) = toLower x:xs
255

    
256
-- | Ensure first letter is uppercase.
257
--
258
-- Used to convert constructor name to component
259
ensureUpper :: String -> String
260
ensureUpper [] = []
261
ensureUpper (x:xs) = toUpper x:xs
262

    
263
-- | Helper for quoted expressions.
264
varNameE :: String -> Q Exp
265
varNameE = varE . mkName
266

    
267
-- | showJSON as an expression, for reuse.
268
showJSONE :: Q Exp
269
showJSONE = varE 'JSON.showJSON
270

    
271
-- | makeObj as an expression, for reuse.
272
makeObjE :: Q Exp
273
makeObjE = varE 'JSON.makeObj
274

    
275
-- | fromObj (Ganeti specific) as an expression, for reuse.
276
fromObjE :: Q Exp
277
fromObjE = varE 'fromObj
278

    
279
-- | ToRaw function name.
280
toRawName :: String -> Name
281
toRawName = mkName . (++ "ToRaw") . ensureLower
282

    
283
-- | FromRaw function name.
284
fromRawName :: String -> Name
285
fromRawName = mkName . (++ "FromRaw") . ensureLower
286

    
287
-- | Converts a name to it's varE\/litE representations.
288
reprE :: Either String Name -> Q Exp
289
reprE = either stringE varE
290

    
291
-- | Smarter function application.
292
--
293
-- This does simply f x, except that if is 'id', it will skip it, in
294
-- order to generate more readable code when using -ddump-splices.
295
appFn :: Exp -> Exp -> Exp
296
appFn f x | f == VarE 'id = x
297
          | otherwise = AppE f x
298

    
299
-- | Builds a field for a normal constructor.
300
buildConsField :: Q Type -> StrictTypeQ
301
buildConsField ftype = do
302
  ftype' <- ftype
303
  return (NotStrict, ftype')
304

    
305
-- | Builds a constructor based on a simple definition (not field-based).
306
buildSimpleCons :: Name -> SimpleObject -> Q Dec
307
buildSimpleCons tname cons = do
308
  decl_d <- mapM (\(cname, fields) -> do
309
                    fields' <- mapM (buildConsField . snd) fields
310
                    return $ NormalC (mkName cname) fields') cons
311
  return $ DataD [] tname [] decl_d [''Show, ''Eq]
312

    
313
-- | Generate the save function for a given type.
314
genSaveSimpleObj :: Name                            -- ^ Object type
315
                 -> String                          -- ^ Function name
316
                 -> SimpleObject                    -- ^ Object definition
317
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
318
                 -> Q (Dec, Dec)
319
genSaveSimpleObj tname sname opdefs fn = do
320
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
321
      fname = mkName sname
322
  cclauses <- mapM fn opdefs
323
  return $ (SigD fname sigt, FunD fname cclauses)
324

    
325
-- * Template code for simple raw type-equivalent ADTs
326

    
327
-- | Generates a data type declaration.
328
--
329
-- The type will have a fixed list of instances.
330
strADTDecl :: Name -> [String] -> Dec
331
strADTDecl name constructors =
332
  DataD [] name []
333
          (map (flip NormalC [] . mkName) constructors)
334
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
335

    
336
-- | Generates a toRaw function.
337
--
338
-- This generates a simple function of the form:
339
--
340
-- @
341
-- nameToRaw :: Name -> /traw/
342
-- nameToRaw Cons1 = var1
343
-- nameToRaw Cons2 = \"value2\"
344
-- @
345
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
346
genToRaw traw fname tname constructors = do
347
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
348
  -- the body clauses, matching on the constructor and returning the
349
  -- raw value
350
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
351
                             (normalB (reprE v)) []) constructors
352
  return [SigD fname sigt, FunD fname clauses]
353

    
354
-- | Generates a fromRaw function.
355
--
356
-- The function generated is monadic and can fail parsing the
357
-- raw value. It is of the form:
358
--
359
-- @
360
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
361
-- nameFromRaw s | s == var1       = Cons1
362
--               | s == \"value2\" = Cons2
363
--               | otherwise = fail /.../
364
-- @
365
genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
366
genFromRaw traw fname tname constructors = do
367
  -- signature of form (Monad m) => String -> m $name
368
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
369
  -- clauses for a guarded pattern
370
  let varp = mkName "s"
371
      varpe = varE varp
372
  clauses <- mapM (\(c, v) -> do
373
                     -- the clause match condition
374
                     g <- normalG [| $varpe == $(reprE v) |]
375
                     -- the clause result
376
                     r <- [| return $(conE (mkName c)) |]
377
                     return (g, r)) constructors
378
  -- the otherwise clause (fallback)
379
  oth_clause <- do
380
    g <- normalG [| otherwise |]
381
    r <- [|fail ("Invalid string value for type " ++
382
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
383
    return (g, r)
384
  let fun = FunD fname [Clause [VarP varp]
385
                        (GuardedB (clauses++[oth_clause])) []]
386
  return [SigD fname sigt, fun]
387

    
388
-- | Generates a data type from a given raw format.
389
--
390
-- The format is expected to multiline. The first line contains the
391
-- type name, and the rest of the lines must contain two words: the
392
-- constructor name and then the string representation of the
393
-- respective constructor.
394
--
395
-- The function will generate the data type declaration, and then two
396
-- functions:
397
--
398
-- * /name/ToRaw, which converts the type to a raw type
399
--
400
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
401
--
402
-- Note that this is basically just a custom show\/read instance,
403
-- nothing else.
404
declareADT
405
  :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
406
declareADT fn traw sname cons = do
407
  let name = mkName sname
408
      ddecl = strADTDecl name (map fst cons)
409
      -- process cons in the format expected by genToRaw
410
      cons' = map (\(a, b) -> (a, fn b)) cons
411
  toraw <- genToRaw traw (toRawName sname) name cons'
412
  fromraw <- genFromRaw traw (fromRawName sname) name cons'
413
  return $ ddecl:toraw ++ fromraw
414

    
415
declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
416
declareLADT = declareADT Left
417

    
418
declareILADT :: String -> [(String, Int)] -> Q [Dec]
419
declareILADT sname cons = do
420
  consNames <- sequence [ newName ('_':n) | (n, _) <- cons ]
421
  consFns <- concat <$> sequence
422
             [ do sig <- sigD n [t| Int |]
423
                  let expr = litE (IntegerL (toInteger i))
424
                  fn <- funD n [clause [] (normalB expr) []]
425
                  return [sig, fn]
426
             | n <- consNames
427
             | (_, i) <- cons ]
428
  let cons' = [ (n, n') | (n, _) <- cons | n' <- consNames ]
429
  (consFns ++) <$> declareADT Right ''Int sname cons'
430

    
431
declareIADT :: String -> [(String, Name)] -> Q [Dec]
432
declareIADT = declareADT Right ''Int
433

    
434
declareSADT :: String -> [(String, Name)] -> Q [Dec]
435
declareSADT = declareADT Right ''String
436

    
437
-- | Creates the showJSON member of a JSON instance declaration.
438
--
439
-- This will create what is the equivalent of:
440
--
441
-- @
442
-- showJSON = showJSON . /name/ToRaw
443
-- @
444
--
445
-- in an instance JSON /name/ declaration
446
genShowJSON :: String -> Q Dec
447
genShowJSON name = do
448
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
449
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
450

    
451
-- | Creates the readJSON member of a JSON instance declaration.
452
--
453
-- This will create what is the equivalent of:
454
--
455
-- @
456
-- readJSON s = case readJSON s of
457
--                Ok s' -> /name/FromRaw s'
458
--                Error e -> Error /description/
459
-- @
460
--
461
-- in an instance JSON /name/ declaration
462
genReadJSON :: String -> Q Dec
463
genReadJSON name = do
464
  let s = mkName "s"
465
  body <- [| case JSON.readJSON $(varE s) of
466
               JSON.Ok s' -> $(varE (fromRawName name)) s'
467
               JSON.Error e ->
468
                   JSON.Error $ "Can't parse raw value for type " ++
469
                           $(stringE name) ++ ": " ++ e ++ " from " ++
470
                           show $(varE s)
471
           |]
472
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
473

    
474
-- | Generates a JSON instance for a given type.
475
--
476
-- This assumes that the /name/ToRaw and /name/FromRaw functions
477
-- have been defined as by the 'declareSADT' function.
478
makeJSONInstance :: Name -> Q [Dec]
479
makeJSONInstance name = do
480
  let base = nameBase name
481
  showJ <- genShowJSON base
482
  readJ <- genReadJSON base
483
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
484

    
485
-- * Template code for opcodes
486

    
487
-- | Transforms a CamelCase string into an_underscore_based_one.
488
deCamelCase :: String -> String
489
deCamelCase =
490
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
491

    
492
-- | Transform an underscore_name into a CamelCase one.
493
camelCase :: String -> String
494
camelCase = concatMap (ensureUpper . drop 1) .
495
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
496

    
497
-- | Computes the name of a given constructor.
498
constructorName :: Con -> Q Name
499
constructorName (NormalC name _) = return name
500
constructorName (RecC name _)    = return name
501
constructorName x                = fail $ "Unhandled constructor " ++ show x
502

    
503
-- | Extract all constructor names from a given type.
504
reifyConsNames :: Name -> Q [String]
505
reifyConsNames name = do
506
  reify_result <- reify name
507
  case reify_result of
508
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
509
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
510
                \ type constructor but got '" ++ show o ++ "'"
511

    
512
-- | Builds the generic constructor-to-string function.
513
--
514
-- This generates a simple function of the following form:
515
--
516
-- @
517
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
518
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
519
-- @
520
--
521
-- This builds a custom list of name\/string pairs and then uses
522
-- 'genToRaw' to actually generate the function.
523
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
524
genConstrToStr trans_fun name fname = do
525
  cnames <- reifyConsNames name
526
  let svalues = map (Left . trans_fun) cnames
527
  genToRaw ''String (mkName fname) name $ zip cnames svalues
528

    
529
-- | Constructor-to-string for OpCode.
530
genOpID :: Name -> String -> Q [Dec]
531
genOpID = genConstrToStr deCamelCase
532

    
533
-- | Builds a list with all defined constructor names for a type.
534
--
535
-- @
536
-- vstr :: String
537
-- vstr = [...]
538
-- @
539
--
540
-- Where the actual values of the string are the constructor names
541
-- mapped via @trans_fun@.
542
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
543
genAllConstr trans_fun name vstr = do
544
  cnames <- reifyConsNames name
545
  let svalues = sort $ map trans_fun cnames
546
      vname = mkName vstr
547
      sig = SigD vname (AppT ListT (ConT ''String))
548
      body = NormalB (ListE (map (LitE . StringL) svalues))
549
  return $ [sig, ValD (VarP vname) body []]
550

    
551
-- | Generates a list of all defined opcode IDs.
552
genAllOpIDs :: Name -> String -> Q [Dec]
553
genAllOpIDs = genAllConstr deCamelCase
554

    
555
-- | OpCode parameter (field) type.
556
type OpParam = (String, Q Type, Q Exp)
557

    
558
-- * Python code generation
559

    
560
-- | Converts Haskell values into Python values
561
--
562
-- This is necessary for the default values of opcode parameters and
563
-- return values.  For example, if a default value or return type is a
564
-- Data.Map, then it must be shown as a Python dictioanry.
565
class PyValue a where
566
  showValue :: a -> String
567

    
568
-- | Encapsulates Python default values
569
data PyValueEx = forall a. PyValue a => PyValueEx a
570

    
571
instance PyValue PyValueEx where
572
  showValue (PyValueEx x) = showValue x
573

    
574
-- | Transfers opcode data between the opcode description (through
575
-- @genOpCode@) and the Python code generation functions.
576
type OpCodeDescriptor =
577
  (String, String, String, [String],
578
   [String], [Maybe PyValueEx], [String], String)
579

    
580
-- | Strips out the module name
581
--
582
-- @
583
-- pyBaseName "Data.Map" = "Map"
584
-- @
585
pyBaseName :: String -> String
586
pyBaseName str =
587
  case span (/= '.') str of
588
    (x, []) -> x
589
    (_, _:x) -> pyBaseName x
590

    
591
-- | Converts a Haskell type name into a Python type name.
592
--
593
-- @
594
-- pyTypename "Bool" = "ht.TBool"
595
-- @
596
pyTypeName :: Show a => a -> String
597
pyTypeName name =
598
  "ht.T" ++ (case pyBaseName (show name) of
599
                "()" -> "None"
600
                "Map" -> "DictOf"
601
                "Set" -> "SetOf"
602
                "ListSet" -> "SetOf"
603
                "Either" -> "Or"
604
                "GenericContainer" -> "DictOf"
605
                "JSValue" -> "Any"
606
                "JSObject" -> "Object"
607
                str -> str)
608

    
609
-- | Converts a Haskell type into a Python type.
610
--
611
-- @
612
-- pyType [Int] = "ht.TListOf(ht.TInt)"
613
-- @
614
pyType :: Type -> Q String
615
pyType (AppT typ1 typ2) =
616
  do t <- pyCall typ1 typ2
617
     return $ t ++ ")"
618

    
619
pyType (ConT name) = return (pyTypeName name)
620
pyType ListT = return "ht.TListOf"
621
pyType (TupleT 0) = return "ht.TNone"
622
pyType (TupleT _) = return "ht.TTupleOf"
623
pyType typ = error $ "unhandled case for type " ++ show typ
624
        
625
-- | Converts a Haskell type application into a Python type.
626
--
627
-- @
628
-- Maybe Int = "ht.TMaybe(ht.TInt)"
629
-- @
630
pyCall :: Type -> Type -> Q String
631
pyCall (AppT typ1 typ2) arg =
632
  do t <- pyCall typ1 typ2
633
     targ <- pyType arg
634
     return $ t ++ ", " ++ targ
635

    
636
pyCall typ1 typ2 =
637
  do t1 <- pyType typ1
638
     t2 <- pyType typ2
639
     return $ t1 ++ "(" ++ t2
640

    
641
-- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
642
-- where @opt@ determines if the converted type is optional (i.e.,
643
-- Maybe).
644
--
645
-- @
646
-- pyType False [Int] = "ht.TListOf(ht.TInt)" (mandatory)
647
-- pyType True [Int] = "ht.TMaybe(ht.TListOf(ht.TInt))" (optional)
648
-- @
649
pyOptionalType :: Bool -> Type -> Q String
650
pyOptionalType opt typ
651
  | opt = do t <- pyType typ
652
             return $ "ht.TMaybe(" ++ t ++ ")"
653
  | otherwise = pyType typ
654

    
655
-- | Optionally encapsulates default values in @PyValueEx@.
656
--
657
-- @maybeApp exp typ@ returns a quoted expression that encapsulates
658
-- the default value @exp@ of an opcode parameter cast to @typ@ in a
659
-- @PyValueEx@, if @exp@ is @Just@.  Otherwise, it returns a quoted
660
-- expression with @Nothing@.
661
maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
662
maybeApp Nothing _ =
663
  [| Nothing |]
664

    
665
maybeApp (Just expr) typ =
666
  [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]
667

    
668

    
669
-- | Generates a Python type according to whether the field is
670
-- optional
671
genPyType :: OptionalType -> Q Type -> Q ExpQ
672
genPyType opt typ =
673
  do t <- typ
674
     stringE <$> pyOptionalType (opt /= NotOptional) t
675

    
676
-- | Generates Python types from opcode parameters.
677
genPyTypes :: [Field] -> Q ExpQ
678
genPyTypes fs =
679
  listE <$> mapM (\f -> genPyType (fieldIsOptional f) (fieldType f)) fs
680

    
681
-- | Generates Python default values from opcode parameters.
682
genPyDefaults :: [Field] -> ExpQ
683
genPyDefaults fs =
684
  listE $ map (\f -> maybeApp (fieldDefault f) (fieldType f)) fs
685

    
686
-- | Generates a Haskell function call to "showPyClass" with the
687
-- necessary information on how to build the Python class string.
688
pyClass :: OpCodeConstructor -> ExpQ
689
pyClass (consName, consType, consDoc, consFields, consDscField) =
690
  do let pyClassVar = varNameE "showPyClass"
691
         consName' = stringE consName
692
     consType' <- genPyType NotOptional consType
693
     let consDoc' = stringE consDoc
694
         consFieldNames = listE $ map (stringE . fieldName) consFields
695
         consFieldDocs = listE $ map (stringE . fieldDoc) consFields
696
     consFieldTypes <- genPyTypes consFields
697
     let consFieldDefaults = genPyDefaults consFields
698
     [| ($consName',
699
         $consType',
700
         $consDoc',
701
         $consFieldNames,
702
         $consFieldTypes,
703
         $consFieldDefaults,
704
         $consFieldDocs,
705
         consDscField) |]
706

    
707
-- | Generates a function called "pyClasses" that holds the list of
708
-- all the opcode descriptors necessary for generating the Python
709
-- opcodes.
710
pyClasses :: [OpCodeConstructor] -> Q [Dec]
711
pyClasses cons =
712
  do let name = mkName "pyClasses"
713
         sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
714
     fn <- FunD name <$> (:[]) <$> declClause cons
715
     return [sig, fn]
716
  where declClause c =
717
          clause [] (normalB (ListE <$> mapM pyClass c)) []
718

    
719
-- | Converts from an opcode constructor to a Luxi constructor.
720
opcodeConsToLuxiCons :: (a, b, c, d, e) -> (a, d)
721
opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)
722

    
723
-- | Generates the OpCode data type.
724
--
725
-- This takes an opcode logical definition, and builds both the
726
-- datatype and the JSON serialisation out of it. We can't use a
727
-- generic serialisation since we need to be compatible with Ganeti's
728
-- own, so we have a few quirks to work around.
729
genOpCode :: String              -- ^ Type name to use
730
          -> [OpCodeConstructor] -- ^ Constructor name and parameters
731
          -> Q [Dec]
732
genOpCode name cons = do
733
  let tname = mkName name
734
  decl_d <- mapM (\(cname, _, _, fields, _) -> do
735
                    -- we only need the type of the field, without Q
736
                    fields' <- mapM (fieldTypeInfo "op") fields
737
                    return $ RecC (mkName cname) fields')
738
            cons
739
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
740
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
741
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
742
               (map opcodeConsToLuxiCons cons) saveConstructor True
743
  (loadsig, loadfn) <- genLoadOpCode cons
744
  pyDecls <- pyClasses cons
745
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs ++ pyDecls
746

    
747
-- | Generates the function pattern returning the list of fields for a
748
-- given constructor.
749
genOpConsFields :: OpCodeConstructor -> Clause
750
genOpConsFields (cname, _, _, fields, _) =
751
  let op_id = deCamelCase cname
752
      fvals = map (LitE . StringL) . sort . nub $
753
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
754
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
755

    
756
-- | Generates a list of all fields of an opcode constructor.
757
genAllOpFields  :: String              -- ^ Function name
758
                -> [OpCodeConstructor] -- ^ Object definition
759
                -> (Dec, Dec)
760
genAllOpFields sname opdefs =
761
  let cclauses = map genOpConsFields opdefs
762
      other = Clause [WildP] (NormalB (ListE [])) []
763
      fname = mkName sname
764
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
765
  in (SigD fname sigt, FunD fname (cclauses++[other]))
766

    
767
-- | Generates the \"save\" clause for an entire opcode constructor.
768
--
769
-- This matches the opcode with variables named the same as the
770
-- constructor fields (just so that the spliced in code looks nicer),
771
-- and passes those name plus the parameter definition to 'saveObjectField'.
772
saveConstructor :: LuxiConstructor -- ^ The constructor
773
                -> Q Clause        -- ^ Resulting clause
774
saveConstructor (sname, fields) = do
775
  let cname = mkName sname
776
  fnames <- mapM (newName . fieldVariable) fields
777
  let pat = conP cname (map varP fnames)
778
  let felems = map (uncurry saveObjectField) (zip fnames fields)
779
      -- now build the OP_ID serialisation
780
      opid = [| [( $(stringE "OP_ID"),
781
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
782
      flist = listE (opid:felems)
783
      -- and finally convert all this to a json object
784
      flist' = [| concat $flist |]
785
  clause [pat] (normalB flist') []
786

    
787
-- | Generates the main save opcode function.
788
--
789
-- This builds a per-constructor match clause that contains the
790
-- respective constructor-serialisation code.
791
genSaveOpCode :: Name                          -- ^ Object ype
792
              -> String                        -- ^ To 'JSValue' function name
793
              -> String                        -- ^ To 'JSObject' function name
794
              -> [LuxiConstructor]             -- ^ Object definition
795
              -> (LuxiConstructor -> Q Clause) -- ^ Constructor save fn
796
              -> Bool                          -- ^ Whether to generate
797
                                               -- obj or just a
798
                                               -- list\/tuple of values
799
              -> Q [Dec]
800
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
801
  tdclauses <- mapM fn opdefs
802
  let typecon = ConT tname
803
      jvalname = mkName jvalstr
804
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
805
      tdname = mkName tdstr
806
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
807
  jvalclause <- if gen_object
808
                  then [| $makeObjE . $(varE tdname) |]
809
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
810
  return [ SigD tdname tdsig
811
         , FunD tdname tdclauses
812
         , SigD jvalname jvalsig
813
         , ValD (VarP jvalname) (NormalB jvalclause) []]
814

    
815
-- | Generates load code for a single constructor of the opcode data type.
816
loadConstructor :: OpCodeConstructor -> Q Exp
817
loadConstructor (sname, _, _, fields, _) = do
818
  let name = mkName sname
819
  fbinds <- mapM loadObjectField fields
820
  let (fnames, fstmts) = unzip fbinds
821
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
822
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
823
  return $ DoE fstmts'
824

    
825
-- | Generates the loadOpCode function.
826
genLoadOpCode :: [OpCodeConstructor] -> Q (Dec, Dec)
827
genLoadOpCode opdefs = do
828
  let fname = mkName "loadOpCode"
829
      arg1 = mkName "v"
830
      objname = mkName "o"
831
      opid = mkName "op_id"
832
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
833
                                 (JSON.readJSON $(varE arg1)) |]
834
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
835
  -- the match results (per-constructor blocks)
836
  mexps <- mapM loadConstructor opdefs
837
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
838
  let mpats = map (\(me, (consName, _, _, _, _)) ->
839
                       let mp = LitP . StringL . deCamelCase $ consName
840
                       in Match mp (NormalB me) []
841
                  ) $ zip mexps opdefs
842
      defmatch = Match WildP (NormalB fails) []
843
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
844
      body = DoE [st1, st2, cst]
845
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
846
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
847

    
848
-- * Template code for luxi
849

    
850
-- | Constructor-to-string for LuxiOp.
851
genStrOfOp :: Name -> String -> Q [Dec]
852
genStrOfOp = genConstrToStr id
853

    
854
-- | Constructor-to-string for MsgKeys.
855
genStrOfKey :: Name -> String -> Q [Dec]
856
genStrOfKey = genConstrToStr ensureLower
857

    
858
-- | Generates the LuxiOp data type.
859
--
860
-- This takes a Luxi operation definition and builds both the
861
-- datatype and the function transforming the arguments to JSON.
862
-- We can't use anything less generic, because the way different
863
-- operations are serialized differs on both parameter- and top-level.
864
--
865
-- There are two things to be defined for each parameter:
866
--
867
-- * name
868
--
869
-- * type
870
--
871
genLuxiOp :: String -> [LuxiConstructor] -> Q [Dec]
872
genLuxiOp name cons = do
873
  let tname = mkName name
874
  decl_d <- mapM (\(cname, fields) -> do
875
                    -- we only need the type of the field, without Q
876
                    fields' <- mapM actualFieldType fields
877
                    let fields'' = zip (repeat NotStrict) fields'
878
                    return $ NormalC (mkName cname) fields'')
879
            cons
880
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
881
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
882
               cons saveLuxiConstructor False
883
  req_defs <- declareSADT "LuxiReq" .
884
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
885
                  cons
886
  return $ declD:save_decs ++ req_defs
887

    
888
-- | Generates the \"save\" clause for entire LuxiOp constructor.
889
saveLuxiConstructor :: LuxiConstructor -> Q Clause
890
saveLuxiConstructor (sname, fields) = do
891
  let cname = mkName sname
892
  fnames <- mapM (newName . fieldVariable) fields
893
  let pat = conP cname (map varP fnames)
894
  let felems = map (uncurry saveObjectField) (zip fnames fields)
895
      flist = [| concat $(listE felems) |]
896
  clause [pat] (normalB flist) []
897

    
898
-- * "Objects" functionality
899

    
900
-- | Extract the field's declaration from a Field structure.
901
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
902
fieldTypeInfo field_pfx fd = do
903
  t <- actualFieldType fd
904
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
905
  return (n, NotStrict, t)
906

    
907
-- | Build an object declaration.
908
buildObject :: String -> String -> [Field] -> Q [Dec]
909
buildObject sname field_pfx fields = do
910
  let name = mkName sname
911
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
912
  let decl_d = RecC name fields_d
913
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
914
  ser_decls <- buildObjectSerialisation sname fields
915
  return $ declD:ser_decls
916

    
917
-- | Generates an object definition: data type and its JSON instance.
918
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
919
buildObjectSerialisation sname fields = do
920
  let name = mkName sname
921
  savedecls <- genSaveObject saveObjectField sname fields
922
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
923
  shjson <- objectShowJSON sname
924
  rdjson <- objectReadJSON sname
925
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
926
                 [rdjson, shjson]
927
  return $ savedecls ++ [loadsig, loadfn, instdecl]
928

    
929
-- | The toDict function name for a given type.
930
toDictName :: String -> Name
931
toDictName sname = mkName ("toDict" ++ sname)
932

    
933
-- | Generates the save object functionality.
934
genSaveObject :: (Name -> Field -> Q Exp)
935
              -> String -> [Field] -> Q [Dec]
936
genSaveObject save_fn sname fields = do
937
  let name = mkName sname
938
  fnames <- mapM (newName . fieldVariable) fields
939
  let pat = conP name (map varP fnames)
940
  let tdname = toDictName sname
941
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
942

    
943
  let felems = map (uncurry save_fn) (zip fnames fields)
944
      flist = listE felems
945
      -- and finally convert all this to a json object
946
      tdlist = [| concat $flist |]
947
      iname = mkName "i"
948
  tclause <- clause [pat] (normalB tdlist) []
949
  cclause <- [| $makeObjE . $(varE tdname) |]
950
  let fname = mkName ("save" ++ sname)
951
  sigt <- [t| $(conT name) -> JSON.JSValue |]
952
  return [SigD tdname tdsigt, FunD tdname [tclause],
953
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
954

    
955
-- | Generates the code for saving an object's field, handling the
956
-- various types of fields that we have.
957
saveObjectField :: Name -> Field -> Q Exp
958
saveObjectField fvar field =
959
  case fieldIsOptional field of
960
    OptionalOmitNull -> [| case $(varE fvar) of
961
                             Nothing -> []
962
                             Just v  -> [( $nameE, JSON.showJSON v )]
963
                         |]
964
    OptionalSerializeNull -> [| case $(varE fvar) of
965
                                  Nothing -> [( $nameE, JSON.JSNull )]
966
                                  Just v  -> [( $nameE, JSON.showJSON v )]
967
                              |]
968
    NotOptional ->
969
      case fieldShow field of
970
        -- Note: the order of actual:extra is important, since for
971
        -- some serialisation types (e.g. Luxi), we use tuples
972
        -- (positional info) rather than object (name info)
973
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
974
        Just fn -> [| let (actual, extra) = $fn $fvarE
975
                      in ($nameE, JSON.showJSON actual):extra
976
                    |]
977
  where nameE = stringE (fieldName field)
978
        fvarE = varE fvar
979

    
980
-- | Generates the showJSON clause for a given object name.
981
objectShowJSON :: String -> Q Dec
982
objectShowJSON name = do
983
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
984
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
985

    
986
-- | Generates the load object functionality.
987
genLoadObject :: (Field -> Q (Name, Stmt))
988
              -> String -> [Field] -> Q (Dec, Dec)
989
genLoadObject load_fn sname fields = do
990
  let name = mkName sname
991
      funname = mkName $ "load" ++ sname
992
      arg1 = mkName $ if null fields then "_" else "v"
993
      objname = mkName "o"
994
      opid = mkName "op_id"
995
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
996
                                 (JSON.readJSON $(varE arg1)) |]
997
  fbinds <- mapM load_fn fields
998
  let (fnames, fstmts) = unzip fbinds
999
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
1000
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
1001
      -- FIXME: should we require an empty dict for an empty type?
1002
      -- this allows any JSValue right now
1003
      fstmts' = if null fields
1004
                  then retstmt
1005
                  else st1:fstmts ++ retstmt
1006
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
1007
  return $ (SigD funname sigt,
1008
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
1009

    
1010
-- | Generates code for loading an object's field.
1011
loadObjectField :: Field -> Q (Name, Stmt)
1012
loadObjectField field = do
1013
  let name = fieldVariable field
1014
  fvar <- newName name
1015
  -- these are used in all patterns below
1016
  let objvar = varNameE "o"
1017
      objfield = stringE (fieldName field)
1018
      loadexp =
1019
        if fieldIsOptional field /= NotOptional
1020
          -- we treat both optional types the same, since
1021
          -- 'maybeFromObj' can deal with both missing and null values
1022
          -- appropriately (the same)
1023
          then [| $(varE 'maybeFromObj) $objvar $objfield |]
1024
          else case fieldDefault field of
1025
                 Just defv ->
1026
                   [| $(varE 'fromObjWithDefault) $objvar
1027
                      $objfield $defv |]
1028
                 Nothing -> [| $fromObjE $objvar $objfield |]
1029
  bexp <- loadFn field loadexp objvar
1030

    
1031
  return (fvar, BindS (VarP fvar) bexp)
1032

    
1033
-- | Builds the readJSON instance for a given object name.
1034
objectReadJSON :: String -> Q Dec
1035
objectReadJSON name = do
1036
  let s = mkName "s"
1037
  body <- [| case JSON.readJSON $(varE s) of
1038
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
1039
               JSON.Error e ->
1040
                 JSON.Error $ "Can't parse value for type " ++
1041
                       $(stringE name) ++ ": " ++ e
1042
           |]
1043
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
1044

    
1045
-- * Inheritable parameter tables implementation
1046

    
1047
-- | Compute parameter type names.
1048
paramTypeNames :: String -> (String, String)
1049
paramTypeNames root = ("Filled"  ++ root ++ "Params",
1050
                       "Partial" ++ root ++ "Params")
1051

    
1052
-- | Compute information about the type of a parameter field.
1053
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
1054
paramFieldTypeInfo field_pfx fd = do
1055
  t <- actualFieldType fd
1056
  let n = mkName . (++ "P") . (field_pfx ++) .
1057
          fieldRecordName $ fd
1058
  return (n, NotStrict, AppT (ConT ''Maybe) t)
1059

    
1060
-- | Build a parameter declaration.
1061
--
1062
-- This function builds two different data structures: a /filled/ one,
1063
-- in which all fields are required, and a /partial/ one, in which all
1064
-- fields are optional. Due to the current record syntax issues, the
1065
-- fields need to be named differrently for the two structures, so the
1066
-- partial ones get a /P/ suffix.
1067
buildParam :: String -> String -> [Field] -> Q [Dec]
1068
buildParam sname field_pfx fields = do
1069
  let (sname_f, sname_p) = paramTypeNames sname
1070
      name_f = mkName sname_f
1071
      name_p = mkName sname_p
1072
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
1073
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
1074
  let decl_f = RecC name_f fields_f
1075
      decl_p = RecC name_p fields_p
1076
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
1077
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
1078
  ser_decls_f <- buildObjectSerialisation sname_f fields
1079
  ser_decls_p <- buildPParamSerialisation sname_p fields
1080
  fill_decls <- fillParam sname field_pfx fields
1081
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
1082
           buildParamAllFields sname fields ++
1083
           buildDictObjectInst name_f sname_f
1084

    
1085
-- | Builds a list of all fields of a parameter.
1086
buildParamAllFields :: String -> [Field] -> [Dec]
1087
buildParamAllFields sname fields =
1088
  let vname = mkName ("all" ++ sname ++ "ParamFields")
1089
      sig = SigD vname (AppT ListT (ConT ''String))
1090
      val = ListE $ map (LitE . StringL . fieldName) fields
1091
  in [sig, ValD (VarP vname) (NormalB val) []]
1092

    
1093
-- | Builds the 'DictObject' instance for a filled parameter.
1094
buildDictObjectInst :: Name -> String -> [Dec]
1095
buildDictObjectInst name sname =
1096
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
1097
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
1098

    
1099
-- | Generates the serialisation for a partial parameter.
1100
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
1101
buildPParamSerialisation sname fields = do
1102
  let name = mkName sname
1103
  savedecls <- genSaveObject savePParamField sname fields
1104
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
1105
  shjson <- objectShowJSON sname
1106
  rdjson <- objectReadJSON sname
1107
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
1108
                 [rdjson, shjson]
1109
  return $ savedecls ++ [loadsig, loadfn, instdecl]
1110

    
1111
-- | Generates code to save an optional parameter field.
1112
savePParamField :: Name -> Field -> Q Exp
1113
savePParamField fvar field = do
1114
  checkNonOptDef field
1115
  let actualVal = mkName "v"
1116
  normalexpr <- saveObjectField actualVal field
1117
  -- we have to construct the block here manually, because we can't
1118
  -- splice-in-splice
1119
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
1120
                                       (NormalB (ConE '[])) []
1121
                             , Match (ConP 'Just [VarP actualVal])
1122
                                       (NormalB normalexpr) []
1123
                             ]
1124

    
1125
-- | Generates code to load an optional parameter field.
1126
loadPParamField :: Field -> Q (Name, Stmt)
1127
loadPParamField field = do
1128
  checkNonOptDef field
1129
  let name = fieldName field
1130
  fvar <- newName name
1131
  -- these are used in all patterns below
1132
  let objvar = varNameE "o"
1133
      objfield = stringE name
1134
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
1135
  bexp <- loadFn field loadexp objvar
1136
  return (fvar, BindS (VarP fvar) bexp)
1137

    
1138
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
1139
buildFromMaybe :: String -> Q Dec
1140
buildFromMaybe fname =
1141
  valD (varP (mkName $ "n_" ++ fname))
1142
         (normalB [| $(varE 'fromMaybe)
1143
                        $(varNameE $ "f_" ++ fname)
1144
                        $(varNameE $ "p_" ++ fname) |]) []
1145

    
1146
-- | Builds a function that executes the filling of partial parameter
1147
-- from a full copy (similar to Python's fillDict).
1148
fillParam :: String -> String -> [Field] -> Q [Dec]
1149
fillParam sname field_pfx fields = do
1150
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
1151
      (sname_f, sname_p) = paramTypeNames sname
1152
      oname_f = "fobj"
1153
      oname_p = "pobj"
1154
      name_f = mkName sname_f
1155
      name_p = mkName sname_p
1156
      fun_name = mkName $ "fill" ++ sname ++ "Params"
1157
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
1158
                (NormalB . VarE . mkName $ oname_f) []
1159
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
1160
                (NormalB . VarE . mkName $ oname_p) []
1161
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
1162
                $ map (mkName . ("n_" ++)) fnames
1163
  le_new <- mapM buildFromMaybe fnames
1164
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
1165
  let sig = SigD fun_name funt
1166
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
1167
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
1168
      fun = FunD fun_name [fclause]
1169
  return [sig, fun]
1170

    
1171
-- * Template code for exceptions
1172

    
1173
-- | Exception simple error message field.
1174
excErrMsg :: (String, Q Type)
1175
excErrMsg = ("errMsg", [t| String |])
1176

    
1177
-- | Builds an exception type definition.
1178
genException :: String                  -- ^ Name of new type
1179
             -> SimpleObject -- ^ Constructor name and parameters
1180
             -> Q [Dec]
1181
genException name cons = do
1182
  let tname = mkName name
1183
  declD <- buildSimpleCons tname cons
1184
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
1185
                         uncurry saveExcCons
1186
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
1187
  return [declD, loadsig, loadfn, savesig, savefn]
1188

    
1189
-- | Generates the \"save\" clause for an entire exception constructor.
1190
--
1191
-- This matches the exception with variables named the same as the
1192
-- constructor fields (just so that the spliced in code looks nicer),
1193
-- and calls showJSON on it.
1194
saveExcCons :: String        -- ^ The constructor name
1195
            -> [SimpleField] -- ^ The parameter definitions for this
1196
                             -- constructor
1197
            -> Q Clause      -- ^ Resulting clause
1198
saveExcCons sname fields = do
1199
  let cname = mkName sname
1200
  fnames <- mapM (newName . fst) fields
1201
  let pat = conP cname (map varP fnames)
1202
      felems = if null fnames
1203
                 then conE '() -- otherwise, empty list has no type
1204
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
1205
  let tup = tupE [ litE (stringL sname), felems ]
1206
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
1207

    
1208
-- | Generates load code for a single constructor of an exception.
1209
--
1210
-- Generates the code (if there's only one argument, we will use a
1211
-- list, not a tuple:
1212
--
1213
-- @
1214
-- do
1215
--  (x1, x2, ...) <- readJSON args
1216
--  return $ Cons x1 x2 ...
1217
-- @
1218
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
1219
loadExcConstructor inname sname fields = do
1220
  let name = mkName sname
1221
  f_names <- mapM (newName . fst) fields
1222
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
1223
  let binds = case f_names of
1224
                [x] -> BindS (ListP [VarP x])
1225
                _   -> BindS (TupP (map VarP f_names))
1226
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
1227
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
1228

    
1229
{-| Generates the loadException function.
1230

    
1231
This generates a quite complicated function, along the lines of:
1232

    
1233
@
1234
loadFn (JSArray [JSString name, args]) = case name of
1235
   "A1" -> do
1236
     (x1, x2, ...) <- readJSON args
1237
     return $ A1 x1 x2 ...
1238
   "a2" -> ...
1239
   s -> fail $ "Unknown exception" ++ s
1240
loadFn v = fail $ "Expected array but got " ++ show v
1241
@
1242
-}
1243
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
1244
genLoadExc tname sname opdefs = do
1245
  let fname = mkName sname
1246
  exc_name <- newName "name"
1247
  exc_args <- newName "args"
1248
  exc_else <- newName "s"
1249
  arg_else <- newName "v"
1250
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
1251
  -- default match for unknown exception name
1252
  let defmatch = Match (VarP exc_else) (NormalB fails) []
1253
  -- the match results (per-constructor blocks)
1254
  str_matches <-
1255
    mapM (\(s, params) -> do
1256
            body_exp <- loadExcConstructor exc_args s params
1257
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
1258
    opdefs
1259
  -- the first function clause; we can't use [| |] due to TH
1260
  -- limitations, so we have to build the AST by hand
1261
  let clause1 = Clause [ConP 'JSON.JSArray
1262
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
1263
                                            VarP exc_args]]]
1264
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
1265
                                        (VarE exc_name))
1266
                          (str_matches ++ [defmatch]))) []
1267
  -- the fail expression for the second function clause
1268
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
1269
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
1270
                |]
1271
  -- the second function clause
1272
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
1273
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
1274
  return $ (SigD fname sigt, FunD fname [clause1, clause2])