Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH.hs @ e82d1e98

History | View | Annotate | Download (46.2 kB)

1
{-# LANGUAGE ExistentialQuantification, 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
                  , declareIADT
35
                  , makeJSONInstance
36
                  , deCamelCase
37
                  , genOpID
38
                  , genAllConstr
39
                  , genAllOpIDs
40
                  , PyValue(..)
41
                  , PyValueEx(..)
42
                  , OpCodeDescriptor
43
                  , genOpCode
44
                  , genStrOfOp
45
                  , genStrOfKey
46
                  , genLuxiOp
47
                  , Field (..)
48
                  , simpleField
49
                  , withDoc
50
                  , defaultField
51
                  , optionalField
52
                  , optionalNullSerField
53
                  , renameField
54
                  , customField
55
                  , timeStampFields
56
                  , uuidFields
57
                  , serialFields
58
                  , tagsFields
59
                  , TagSet
60
                  , buildObject
61
                  , buildObjectSerialisation
62
                  , buildParam
63
                  , DictObject(..)
64
                  , genException
65
                  , excErrMsg
66
                  ) where
67

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

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

    
77
import Ganeti.JSON
78

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

    
82
-- * Exported types
83

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
202
-- * Common field declarations
203

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

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

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

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

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

    
228
-- * Internal types
229

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

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

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

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

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

    
245
-- * Helper functions
246

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
417
declareIADT :: String -> [(String, Name)] -> Q [Dec]
418
declareIADT = declareADT Right ''Int
419

    
420
declareSADT :: String -> [(String, Name)] -> Q [Dec]
421
declareSADT = declareADT Right ''String
422

    
423
-- | Creates the showJSON member of a JSON instance declaration.
424
--
425
-- This will create what is the equivalent of:
426
--
427
-- @
428
-- showJSON = showJSON . /name/ToRaw
429
-- @
430
--
431
-- in an instance JSON /name/ declaration
432
genShowJSON :: String -> Q Dec
433
genShowJSON name = do
434
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
435
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
436

    
437
-- | Creates the readJSON member of a JSON instance declaration.
438
--
439
-- This will create what is the equivalent of:
440
--
441
-- @
442
-- readJSON s = case readJSON s of
443
--                Ok s' -> /name/FromRaw s'
444
--                Error e -> Error /description/
445
-- @
446
--
447
-- in an instance JSON /name/ declaration
448
genReadJSON :: String -> Q Dec
449
genReadJSON name = do
450
  let s = mkName "s"
451
  body <- [| case JSON.readJSON $(varE s) of
452
               JSON.Ok s' -> $(varE (fromRawName name)) s'
453
               JSON.Error e ->
454
                   JSON.Error $ "Can't parse raw value for type " ++
455
                           $(stringE name) ++ ": " ++ e ++ " from " ++
456
                           show $(varE s)
457
           |]
458
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
459

    
460
-- | Generates a JSON instance for a given type.
461
--
462
-- This assumes that the /name/ToRaw and /name/FromRaw functions
463
-- have been defined as by the 'declareSADT' function.
464
makeJSONInstance :: Name -> Q [Dec]
465
makeJSONInstance name = do
466
  let base = nameBase name
467
  showJ <- genShowJSON base
468
  readJ <- genReadJSON base
469
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
470

    
471
-- * Template code for opcodes
472

    
473
-- | Transforms a CamelCase string into an_underscore_based_one.
474
deCamelCase :: String -> String
475
deCamelCase =
476
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
477

    
478
-- | Transform an underscore_name into a CamelCase one.
479
camelCase :: String -> String
480
camelCase = concatMap (ensureUpper . drop 1) .
481
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
482

    
483
-- | Computes the name of a given constructor.
484
constructorName :: Con -> Q Name
485
constructorName (NormalC name _) = return name
486
constructorName (RecC name _)    = return name
487
constructorName x                = fail $ "Unhandled constructor " ++ show x
488

    
489
-- | Extract all constructor names from a given type.
490
reifyConsNames :: Name -> Q [String]
491
reifyConsNames name = do
492
  reify_result <- reify name
493
  case reify_result of
494
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
495
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
496
                \ type constructor but got '" ++ show o ++ "'"
497

    
498
-- | Builds the generic constructor-to-string function.
499
--
500
-- This generates a simple function of the following form:
501
--
502
-- @
503
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
504
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
505
-- @
506
--
507
-- This builds a custom list of name\/string pairs and then uses
508
-- 'genToRaw' to actually generate the function.
509
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
510
genConstrToStr trans_fun name fname = do
511
  cnames <- reifyConsNames name
512
  let svalues = map (Left . trans_fun) cnames
513
  genToRaw ''String (mkName fname) name $ zip cnames svalues
514

    
515
-- | Constructor-to-string for OpCode.
516
genOpID :: Name -> String -> Q [Dec]
517
genOpID = genConstrToStr deCamelCase
518

    
519
-- | Builds a list with all defined constructor names for a type.
520
--
521
-- @
522
-- vstr :: String
523
-- vstr = [...]
524
-- @
525
--
526
-- Where the actual values of the string are the constructor names
527
-- mapped via @trans_fun@.
528
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
529
genAllConstr trans_fun name vstr = do
530
  cnames <- reifyConsNames name
531
  let svalues = sort $ map trans_fun cnames
532
      vname = mkName vstr
533
      sig = SigD vname (AppT ListT (ConT ''String))
534
      body = NormalB (ListE (map (LitE . StringL) svalues))
535
  return $ [sig, ValD (VarP vname) body []]
536

    
537
-- | Generates a list of all defined opcode IDs.
538
genAllOpIDs :: Name -> String -> Q [Dec]
539
genAllOpIDs = genAllConstr deCamelCase
540

    
541
-- | OpCode parameter (field) type.
542
type OpParam = (String, Q Type, Q Exp)
543

    
544
-- * Python code generation
545

    
546
-- | Converts Haskell values into Python values
547
--
548
-- This is necessary for the default values of opcode parameters and
549
-- return values.  For example, if a default value or return type is a
550
-- Data.Map, then it must be shown as a Python dictioanry.
551
class Show a => PyValue a where
552
  showValue :: a -> String
553
  showValue = show
554

    
555
-- | Encapsulates Python default values
556
data PyValueEx = forall a. PyValue a => PyValueEx a
557

    
558
-- | Transfers opcode data between the opcode description (through
559
-- @genOpCode@) and the Python code generation functions.
560
type OpCodeDescriptor =
561
  (String, String, String, [String],
562
   [String], [Maybe PyValueEx], [String], String)
563

    
564
-- | Strips out the module name
565
--
566
-- @
567
-- pyBaseName "Data.Map" = "Map"
568
-- @
569
pyBaseName :: String -> String
570
pyBaseName str =
571
  case span (/= '.') str of
572
    (x, []) -> x
573
    (_, _:x) -> pyBaseName x
574

    
575
-- | Converts a Haskell type name into a Python type name.
576
--
577
-- @
578
-- pyTypename "Bool" = "ht.TBool"
579
-- @
580
pyTypeName :: Show a => a -> String
581
pyTypeName name =
582
  "ht.T" ++ (case pyBaseName (show name) of
583
                "()" -> "None"
584
                "Map" -> "DictOf"
585
                "Set" -> "SetOf"
586
                "ListSet" -> "SetOf"
587
                "Either" -> "Or"
588
                "GenericContainer" -> "DictOf"
589
                "JSValue" -> "Any"
590
                "JSObject" -> "Object"
591
                str -> str)
592

    
593
-- | Converts a Haskell type into a Python type.
594
--
595
-- @
596
-- pyType [Int] = "ht.TListOf(ht.TInt)"
597
-- @
598
pyType :: Type -> Q String
599
pyType (AppT typ1 typ2) =
600
  do t <- pyCall typ1 typ2
601
     return $ t ++ ")"
602

    
603
pyType (ConT name) = return (pyTypeName name)
604
pyType ListT = return "ht.TListOf"
605
pyType (TupleT 0) = return "ht.TNone"
606
pyType (TupleT _) = return "ht.TTupleOf"
607
pyType typ = error $ "unhandled case for type " ++ show typ
608
        
609
-- | Converts a Haskell type application into a Python type.
610
--
611
-- @
612
-- Maybe Int = "ht.TMaybe(ht.TInt)"
613
-- @
614
pyCall :: Type -> Type -> Q String
615
pyCall (AppT typ1 typ2) arg =
616
  do t <- pyCall typ1 typ2
617
     targ <- pyType arg
618
     return $ t ++ ", " ++ targ
619

    
620
pyCall typ1 typ2 =
621
  do t1 <- pyType typ1
622
     t2 <- pyType typ2
623
     return $ t1 ++ "(" ++ t2
624

    
625
-- | @pyType opt typ@ converts Haskell type @typ@ into a Python type,
626
-- where @opt@ determines if the converted type is optional (i.e.,
627
-- Maybe).
628
--
629
-- @
630
-- pyType False [Int] = "ht.TListOf(ht.TInt)" (mandatory)
631
-- pyType True [Int] = "ht.TMaybe(ht.TListOf(ht.TInt))" (optional)
632
-- @
633
pyOptionalType :: Bool -> Type -> Q String
634
pyOptionalType opt typ
635
  | opt = do t <- pyType typ
636
             return $ "ht.TMaybe(" ++ t ++ ")"
637
  | otherwise = pyType typ
638

    
639
-- | Optionally encapsulates default values in @PyValueEx@.
640
--
641
-- @maybeApp exp typ@ returns a quoted expression that encapsulates
642
-- the default value @exp@ of an opcode parameter cast to @typ@ in a
643
-- @PyValueEx@, if @exp@ is @Just@.  Otherwise, it returns a quoted
644
-- expression with @Nothing@.
645
maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
646
maybeApp Nothing _ =
647
  [| Nothing |]
648

    
649
maybeApp (Just expr) typ =
650
  [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]
651

    
652

    
653
-- | Generates a Python type according to whether the field is
654
-- optional
655
genPyType :: OptionalType -> Q Type -> Q ExpQ
656
genPyType opt typ =
657
  do t <- typ
658
     stringE <$> pyOptionalType (opt /= NotOptional) t
659

    
660
-- | Generates Python types from opcode parameters.
661
genPyTypes :: [Field] -> Q ExpQ
662
genPyTypes fs =
663
  listE <$> mapM (\f -> genPyType (fieldIsOptional f) (fieldType f)) fs
664

    
665
-- | Generates Python default values from opcode parameters.
666
genPyDefaults :: [Field] -> ExpQ
667
genPyDefaults fs =
668
  listE $ map (\f -> maybeApp (fieldDefault f) (fieldType f)) fs
669

    
670
-- | Generates a Haskell function call to "showPyClass" with the
671
-- necessary information on how to build the Python class string.
672
pyClass :: OpCodeConstructor -> ExpQ
673
pyClass (consName, consType, consDoc, consFields, consDscField) =
674
  do let pyClassVar = varNameE "showPyClass"
675
         consName' = stringE consName
676
     consType' <- genPyType NotOptional consType
677
     let consDoc' = stringE consDoc
678
         consFieldNames = listE $ map (stringE . fieldName) consFields
679
         consFieldDocs = listE $ map (stringE . fieldDoc) consFields
680
     consFieldTypes <- genPyTypes consFields
681
     let consFieldDefaults = genPyDefaults consFields
682
     [| ($consName',
683
         $consType',
684
         $consDoc',
685
         $consFieldNames,
686
         $consFieldTypes,
687
         $consFieldDefaults,
688
         $consFieldDocs,
689
         consDscField) |]
690

    
691
-- | Generates a function called "pyClasses" that holds the list of
692
-- all the opcode descriptors necessary for generating the Python
693
-- opcodes.
694
pyClasses :: [OpCodeConstructor] -> Q [Dec]
695
pyClasses cons =
696
  do let name = mkName "pyClasses"
697
         sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
698
     fn <- FunD name <$> (:[]) <$> declClause cons
699
     return [sig, fn]
700
  where declClause c =
701
          clause [] (normalB (ListE <$> mapM pyClass c)) []
702

    
703
-- | Converts from an opcode constructor to a Luxi constructor.
704
opcodeConsToLuxiCons :: (a, b, c, d, e) -> (a, d)
705
opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)
706

    
707
-- | Generates the OpCode data type.
708
--
709
-- This takes an opcode logical definition, and builds both the
710
-- datatype and the JSON serialisation out of it. We can't use a
711
-- generic serialisation since we need to be compatible with Ganeti's
712
-- own, so we have a few quirks to work around.
713
genOpCode :: String              -- ^ Type name to use
714
          -> [OpCodeConstructor] -- ^ Constructor name and parameters
715
          -> Q [Dec]
716
genOpCode name cons = do
717
  let tname = mkName name
718
  decl_d <- mapM (\(cname, _, _, fields, _) -> do
719
                    -- we only need the type of the field, without Q
720
                    fields' <- mapM (fieldTypeInfo "op") fields
721
                    return $ RecC (mkName cname) fields')
722
            cons
723
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
724
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
725
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
726
               (map opcodeConsToLuxiCons cons) saveConstructor True
727
  (loadsig, loadfn) <- genLoadOpCode cons
728
  pyDecls <- pyClasses cons
729
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs ++ pyDecls
730

    
731
-- | Generates the function pattern returning the list of fields for a
732
-- given constructor.
733
genOpConsFields :: OpCodeConstructor -> Clause
734
genOpConsFields (cname, _, _, fields, _) =
735
  let op_id = deCamelCase cname
736
      fvals = map (LitE . StringL) . sort . nub $
737
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
738
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
739

    
740
-- | Generates a list of all fields of an opcode constructor.
741
genAllOpFields  :: String              -- ^ Function name
742
                -> [OpCodeConstructor] -- ^ Object definition
743
                -> (Dec, Dec)
744
genAllOpFields sname opdefs =
745
  let cclauses = map genOpConsFields opdefs
746
      other = Clause [WildP] (NormalB (ListE [])) []
747
      fname = mkName sname
748
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
749
  in (SigD fname sigt, FunD fname (cclauses++[other]))
750

    
751
-- | Generates the \"save\" clause for an entire opcode constructor.
752
--
753
-- This matches the opcode with variables named the same as the
754
-- constructor fields (just so that the spliced in code looks nicer),
755
-- and passes those name plus the parameter definition to 'saveObjectField'.
756
saveConstructor :: LuxiConstructor -- ^ The constructor
757
                -> Q Clause        -- ^ Resulting clause
758
saveConstructor (sname, fields) = do
759
  let cname = mkName sname
760
  fnames <- mapM (newName . fieldVariable) fields
761
  let pat = conP cname (map varP fnames)
762
  let felems = map (uncurry saveObjectField) (zip fnames fields)
763
      -- now build the OP_ID serialisation
764
      opid = [| [( $(stringE "OP_ID"),
765
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
766
      flist = listE (opid:felems)
767
      -- and finally convert all this to a json object
768
      flist' = [| concat $flist |]
769
  clause [pat] (normalB flist') []
770

    
771
-- | Generates the main save opcode function.
772
--
773
-- This builds a per-constructor match clause that contains the
774
-- respective constructor-serialisation code.
775
genSaveOpCode :: Name                          -- ^ Object ype
776
              -> String                        -- ^ To 'JSValue' function name
777
              -> String                        -- ^ To 'JSObject' function name
778
              -> [LuxiConstructor]             -- ^ Object definition
779
              -> (LuxiConstructor -> Q Clause) -- ^ Constructor save fn
780
              -> Bool                          -- ^ Whether to generate
781
                                               -- obj or just a
782
                                               -- list\/tuple of values
783
              -> Q [Dec]
784
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
785
  tdclauses <- mapM fn opdefs
786
  let typecon = ConT tname
787
      jvalname = mkName jvalstr
788
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
789
      tdname = mkName tdstr
790
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
791
  jvalclause <- if gen_object
792
                  then [| $makeObjE . $(varE tdname) |]
793
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
794
  return [ SigD tdname tdsig
795
         , FunD tdname tdclauses
796
         , SigD jvalname jvalsig
797
         , ValD (VarP jvalname) (NormalB jvalclause) []]
798

    
799
-- | Generates load code for a single constructor of the opcode data type.
800
loadConstructor :: OpCodeConstructor -> Q Exp
801
loadConstructor (sname, _, _, fields, _) = do
802
  let name = mkName sname
803
  fbinds <- mapM loadObjectField fields
804
  let (fnames, fstmts) = unzip fbinds
805
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
806
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
807
  return $ DoE fstmts'
808

    
809
-- | Generates the loadOpCode function.
810
genLoadOpCode :: [OpCodeConstructor] -> Q (Dec, Dec)
811
genLoadOpCode opdefs = do
812
  let fname = mkName "loadOpCode"
813
      arg1 = mkName "v"
814
      objname = mkName "o"
815
      opid = mkName "op_id"
816
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
817
                                 (JSON.readJSON $(varE arg1)) |]
818
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
819
  -- the match results (per-constructor blocks)
820
  mexps <- mapM loadConstructor opdefs
821
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
822
  let mpats = map (\(me, (consName, _, _, _, _)) ->
823
                       let mp = LitP . StringL . deCamelCase $ consName
824
                       in Match mp (NormalB me) []
825
                  ) $ zip mexps opdefs
826
      defmatch = Match WildP (NormalB fails) []
827
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
828
      body = DoE [st1, st2, cst]
829
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
830
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
831

    
832
-- * Template code for luxi
833

    
834
-- | Constructor-to-string for LuxiOp.
835
genStrOfOp :: Name -> String -> Q [Dec]
836
genStrOfOp = genConstrToStr id
837

    
838
-- | Constructor-to-string for MsgKeys.
839
genStrOfKey :: Name -> String -> Q [Dec]
840
genStrOfKey = genConstrToStr ensureLower
841

    
842
-- | Generates the LuxiOp data type.
843
--
844
-- This takes a Luxi operation definition and builds both the
845
-- datatype and the function transforming the arguments to JSON.
846
-- We can't use anything less generic, because the way different
847
-- operations are serialized differs on both parameter- and top-level.
848
--
849
-- There are two things to be defined for each parameter:
850
--
851
-- * name
852
--
853
-- * type
854
--
855
genLuxiOp :: String -> [LuxiConstructor] -> Q [Dec]
856
genLuxiOp name cons = do
857
  let tname = mkName name
858
  decl_d <- mapM (\(cname, fields) -> do
859
                    -- we only need the type of the field, without Q
860
                    fields' <- mapM actualFieldType fields
861
                    let fields'' = zip (repeat NotStrict) fields'
862
                    return $ NormalC (mkName cname) fields'')
863
            cons
864
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
865
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
866
               cons saveLuxiConstructor False
867
  req_defs <- declareSADT "LuxiReq" .
868
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
869
                  cons
870
  return $ declD:save_decs ++ req_defs
871

    
872
-- | Generates the \"save\" clause for entire LuxiOp constructor.
873
saveLuxiConstructor :: LuxiConstructor -> Q Clause
874
saveLuxiConstructor (sname, fields) = do
875
  let cname = mkName sname
876
  fnames <- mapM (newName . fieldVariable) fields
877
  let pat = conP cname (map varP fnames)
878
  let felems = map (uncurry saveObjectField) (zip fnames fields)
879
      flist = [| concat $(listE felems) |]
880
  clause [pat] (normalB flist) []
881

    
882
-- * "Objects" functionality
883

    
884
-- | Extract the field's declaration from a Field structure.
885
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
886
fieldTypeInfo field_pfx fd = do
887
  t <- actualFieldType fd
888
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
889
  return (n, NotStrict, t)
890

    
891
-- | Build an object declaration.
892
buildObject :: String -> String -> [Field] -> Q [Dec]
893
buildObject sname field_pfx fields = do
894
  let name = mkName sname
895
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
896
  let decl_d = RecC name fields_d
897
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
898
  ser_decls <- buildObjectSerialisation sname fields
899
  return $ declD:ser_decls
900

    
901
-- | Generates an object definition: data type and its JSON instance.
902
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
903
buildObjectSerialisation sname fields = do
904
  let name = mkName sname
905
  savedecls <- genSaveObject saveObjectField sname fields
906
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
907
  shjson <- objectShowJSON sname
908
  rdjson <- objectReadJSON sname
909
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
910
                 [rdjson, shjson]
911
  return $ savedecls ++ [loadsig, loadfn, instdecl]
912

    
913
-- | The toDict function name for a given type.
914
toDictName :: String -> Name
915
toDictName sname = mkName ("toDict" ++ sname)
916

    
917
-- | Generates the save object functionality.
918
genSaveObject :: (Name -> Field -> Q Exp)
919
              -> String -> [Field] -> Q [Dec]
920
genSaveObject save_fn sname fields = do
921
  let name = mkName sname
922
  fnames <- mapM (newName . fieldVariable) fields
923
  let pat = conP name (map varP fnames)
924
  let tdname = toDictName sname
925
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
926

    
927
  let felems = map (uncurry save_fn) (zip fnames fields)
928
      flist = listE felems
929
      -- and finally convert all this to a json object
930
      tdlist = [| concat $flist |]
931
      iname = mkName "i"
932
  tclause <- clause [pat] (normalB tdlist) []
933
  cclause <- [| $makeObjE . $(varE tdname) |]
934
  let fname = mkName ("save" ++ sname)
935
  sigt <- [t| $(conT name) -> JSON.JSValue |]
936
  return [SigD tdname tdsigt, FunD tdname [tclause],
937
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
938

    
939
-- | Generates the code for saving an object's field, handling the
940
-- various types of fields that we have.
941
saveObjectField :: Name -> Field -> Q Exp
942
saveObjectField fvar field =
943
  case fieldIsOptional field of
944
    OptionalOmitNull -> [| case $(varE fvar) of
945
                             Nothing -> []
946
                             Just v  -> [( $nameE, JSON.showJSON v )]
947
                         |]
948
    OptionalSerializeNull -> [| case $(varE fvar) of
949
                                  Nothing -> [( $nameE, JSON.JSNull )]
950
                                  Just v  -> [( $nameE, JSON.showJSON v )]
951
                              |]
952
    NotOptional ->
953
      case fieldShow field of
954
        -- Note: the order of actual:extra is important, since for
955
        -- some serialisation types (e.g. Luxi), we use tuples
956
        -- (positional info) rather than object (name info)
957
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
958
        Just fn -> [| let (actual, extra) = $fn $fvarE
959
                      in ($nameE, JSON.showJSON actual):extra
960
                    |]
961
  where nameE = stringE (fieldName field)
962
        fvarE = varE fvar
963

    
964
-- | Generates the showJSON clause for a given object name.
965
objectShowJSON :: String -> Q Dec
966
objectShowJSON name = do
967
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
968
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
969

    
970
-- | Generates the load object functionality.
971
genLoadObject :: (Field -> Q (Name, Stmt))
972
              -> String -> [Field] -> Q (Dec, Dec)
973
genLoadObject load_fn sname fields = do
974
  let name = mkName sname
975
      funname = mkName $ "load" ++ sname
976
      arg1 = mkName $ if null fields then "_" else "v"
977
      objname = mkName "o"
978
      opid = mkName "op_id"
979
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
980
                                 (JSON.readJSON $(varE arg1)) |]
981
  fbinds <- mapM load_fn fields
982
  let (fnames, fstmts) = unzip fbinds
983
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
984
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
985
      -- FIXME: should we require an empty dict for an empty type?
986
      -- this allows any JSValue right now
987
      fstmts' = if null fields
988
                  then retstmt
989
                  else st1:fstmts ++ retstmt
990
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
991
  return $ (SigD funname sigt,
992
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
993

    
994
-- | Generates code for loading an object's field.
995
loadObjectField :: Field -> Q (Name, Stmt)
996
loadObjectField field = do
997
  let name = fieldVariable field
998
  fvar <- newName name
999
  -- these are used in all patterns below
1000
  let objvar = varNameE "o"
1001
      objfield = stringE (fieldName field)
1002
      loadexp =
1003
        if fieldIsOptional field /= NotOptional
1004
          -- we treat both optional types the same, since
1005
          -- 'maybeFromObj' can deal with both missing and null values
1006
          -- appropriately (the same)
1007
          then [| $(varE 'maybeFromObj) $objvar $objfield |]
1008
          else case fieldDefault field of
1009
                 Just defv ->
1010
                   [| $(varE 'fromObjWithDefault) $objvar
1011
                      $objfield $defv |]
1012
                 Nothing -> [| $fromObjE $objvar $objfield |]
1013
  bexp <- loadFn field loadexp objvar
1014

    
1015
  return (fvar, BindS (VarP fvar) bexp)
1016

    
1017
-- | Builds the readJSON instance for a given object name.
1018
objectReadJSON :: String -> Q Dec
1019
objectReadJSON name = do
1020
  let s = mkName "s"
1021
  body <- [| case JSON.readJSON $(varE s) of
1022
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
1023
               JSON.Error e ->
1024
                 JSON.Error $ "Can't parse value for type " ++
1025
                       $(stringE name) ++ ": " ++ e
1026
           |]
1027
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
1028

    
1029
-- * Inheritable parameter tables implementation
1030

    
1031
-- | Compute parameter type names.
1032
paramTypeNames :: String -> (String, String)
1033
paramTypeNames root = ("Filled"  ++ root ++ "Params",
1034
                       "Partial" ++ root ++ "Params")
1035

    
1036
-- | Compute information about the type of a parameter field.
1037
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
1038
paramFieldTypeInfo field_pfx fd = do
1039
  t <- actualFieldType fd
1040
  let n = mkName . (++ "P") . (field_pfx ++) .
1041
          fieldRecordName $ fd
1042
  return (n, NotStrict, AppT (ConT ''Maybe) t)
1043

    
1044
-- | Build a parameter declaration.
1045
--
1046
-- This function builds two different data structures: a /filled/ one,
1047
-- in which all fields are required, and a /partial/ one, in which all
1048
-- fields are optional. Due to the current record syntax issues, the
1049
-- fields need to be named differrently for the two structures, so the
1050
-- partial ones get a /P/ suffix.
1051
buildParam :: String -> String -> [Field] -> Q [Dec]
1052
buildParam sname field_pfx fields = do
1053
  let (sname_f, sname_p) = paramTypeNames sname
1054
      name_f = mkName sname_f
1055
      name_p = mkName sname_p
1056
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
1057
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
1058
  let decl_f = RecC name_f fields_f
1059
      decl_p = RecC name_p fields_p
1060
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
1061
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
1062
  ser_decls_f <- buildObjectSerialisation sname_f fields
1063
  ser_decls_p <- buildPParamSerialisation sname_p fields
1064
  fill_decls <- fillParam sname field_pfx fields
1065
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
1066
           buildParamAllFields sname fields ++
1067
           buildDictObjectInst name_f sname_f
1068

    
1069
-- | Builds a list of all fields of a parameter.
1070
buildParamAllFields :: String -> [Field] -> [Dec]
1071
buildParamAllFields sname fields =
1072
  let vname = mkName ("all" ++ sname ++ "ParamFields")
1073
      sig = SigD vname (AppT ListT (ConT ''String))
1074
      val = ListE $ map (LitE . StringL . fieldName) fields
1075
  in [sig, ValD (VarP vname) (NormalB val) []]
1076

    
1077
-- | Builds the 'DictObject' instance for a filled parameter.
1078
buildDictObjectInst :: Name -> String -> [Dec]
1079
buildDictObjectInst name sname =
1080
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
1081
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
1082

    
1083
-- | Generates the serialisation for a partial parameter.
1084
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
1085
buildPParamSerialisation sname fields = do
1086
  let name = mkName sname
1087
  savedecls <- genSaveObject savePParamField sname fields
1088
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
1089
  shjson <- objectShowJSON sname
1090
  rdjson <- objectReadJSON sname
1091
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
1092
                 [rdjson, shjson]
1093
  return $ savedecls ++ [loadsig, loadfn, instdecl]
1094

    
1095
-- | Generates code to save an optional parameter field.
1096
savePParamField :: Name -> Field -> Q Exp
1097
savePParamField fvar field = do
1098
  checkNonOptDef field
1099
  let actualVal = mkName "v"
1100
  normalexpr <- saveObjectField actualVal field
1101
  -- we have to construct the block here manually, because we can't
1102
  -- splice-in-splice
1103
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
1104
                                       (NormalB (ConE '[])) []
1105
                             , Match (ConP 'Just [VarP actualVal])
1106
                                       (NormalB normalexpr) []
1107
                             ]
1108

    
1109
-- | Generates code to load an optional parameter field.
1110
loadPParamField :: Field -> Q (Name, Stmt)
1111
loadPParamField field = do
1112
  checkNonOptDef field
1113
  let name = fieldName field
1114
  fvar <- newName name
1115
  -- these are used in all patterns below
1116
  let objvar = varNameE "o"
1117
      objfield = stringE name
1118
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
1119
  bexp <- loadFn field loadexp objvar
1120
  return (fvar, BindS (VarP fvar) bexp)
1121

    
1122
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
1123
buildFromMaybe :: String -> Q Dec
1124
buildFromMaybe fname =
1125
  valD (varP (mkName $ "n_" ++ fname))
1126
         (normalB [| $(varE 'fromMaybe)
1127
                        $(varNameE $ "f_" ++ fname)
1128
                        $(varNameE $ "p_" ++ fname) |]) []
1129

    
1130
-- | Builds a function that executes the filling of partial parameter
1131
-- from a full copy (similar to Python's fillDict).
1132
fillParam :: String -> String -> [Field] -> Q [Dec]
1133
fillParam sname field_pfx fields = do
1134
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
1135
      (sname_f, sname_p) = paramTypeNames sname
1136
      oname_f = "fobj"
1137
      oname_p = "pobj"
1138
      name_f = mkName sname_f
1139
      name_p = mkName sname_p
1140
      fun_name = mkName $ "fill" ++ sname ++ "Params"
1141
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
1142
                (NormalB . VarE . mkName $ oname_f) []
1143
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
1144
                (NormalB . VarE . mkName $ oname_p) []
1145
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
1146
                $ map (mkName . ("n_" ++)) fnames
1147
  le_new <- mapM buildFromMaybe fnames
1148
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
1149
  let sig = SigD fun_name funt
1150
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
1151
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
1152
      fun = FunD fun_name [fclause]
1153
  return [sig, fun]
1154

    
1155
-- * Template code for exceptions
1156

    
1157
-- | Exception simple error message field.
1158
excErrMsg :: (String, Q Type)
1159
excErrMsg = ("errMsg", [t| String |])
1160

    
1161
-- | Builds an exception type definition.
1162
genException :: String                  -- ^ Name of new type
1163
             -> SimpleObject -- ^ Constructor name and parameters
1164
             -> Q [Dec]
1165
genException name cons = do
1166
  let tname = mkName name
1167
  declD <- buildSimpleCons tname cons
1168
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
1169
                         uncurry saveExcCons
1170
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
1171
  return [declD, loadsig, loadfn, savesig, savefn]
1172

    
1173
-- | Generates the \"save\" clause for an entire exception constructor.
1174
--
1175
-- This matches the exception with variables named the same as the
1176
-- constructor fields (just so that the spliced in code looks nicer),
1177
-- and calls showJSON on it.
1178
saveExcCons :: String        -- ^ The constructor name
1179
            -> [SimpleField] -- ^ The parameter definitions for this
1180
                             -- constructor
1181
            -> Q Clause      -- ^ Resulting clause
1182
saveExcCons sname fields = do
1183
  let cname = mkName sname
1184
  fnames <- mapM (newName . fst) fields
1185
  let pat = conP cname (map varP fnames)
1186
      felems = if null fnames
1187
                 then conE '() -- otherwise, empty list has no type
1188
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
1189
  let tup = tupE [ litE (stringL sname), felems ]
1190
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
1191

    
1192
-- | Generates load code for a single constructor of an exception.
1193
--
1194
-- Generates the code (if there's only one argument, we will use a
1195
-- list, not a tuple:
1196
--
1197
-- @
1198
-- do
1199
--  (x1, x2, ...) <- readJSON args
1200
--  return $ Cons x1 x2 ...
1201
-- @
1202
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
1203
loadExcConstructor inname sname fields = do
1204
  let name = mkName sname
1205
  f_names <- mapM (newName . fst) fields
1206
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
1207
  let binds = case f_names of
1208
                [x] -> BindS (ListP [VarP x])
1209
                _   -> BindS (TupP (map VarP f_names))
1210
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
1211
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
1212

    
1213
{-| Generates the loadException function.
1214

    
1215
This generates a quite complicated function, along the lines of:
1216

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