Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH.hs @ 8aab74e9

History | View | Annotate | Download (47.6 kB)

1
{-# LANGUAGE 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, 2013 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
                  , OpCodeField(..)
44
                  , OpCodeDescriptor(..)
45
                  , genOpCode
46
                  , genStrOfOp
47
                  , genStrOfKey
48
                  , genLuxiOp
49
                  , Field (..)
50
                  , simpleField
51
                  , andRestArguments
52
                  , specialNumericalField
53
                  , withDoc
54
                  , defaultField
55
                  , optionalField
56
                  , optionalNullSerField
57
                  , renameField
58
                  , customField
59
                  , timeStampFields
60
                  , uuidFields
61
                  , serialFields
62
                  , tagsFields
63
                  , TagSet
64
                  , buildObject
65
                  , buildObjectSerialisation
66
                  , buildParam
67
                  , DictObject(..)
68
                  , genException
69
                  , excErrMsg
70
                  ) where
71

    
72
import Control.Applicative
73
import Control.Monad
74
import Data.Char
75
import Data.List
76
import Data.Maybe
77
import qualified Data.Map as M
78
import qualified Data.Set as Set
79
import Language.Haskell.TH
80

    
81
import qualified Text.JSON as JSON
82
import Text.JSON.Pretty (pp_value)
83

    
84
import Ganeti.JSON
85
import Ganeti.PyValue
86
import Ganeti.THH.PyType
87

    
88

    
89
-- * Exported types
90

    
91
-- | Class of objects that can be converted to 'JSObject'
92
-- lists-format.
93
class DictObject a where
94
  toDict :: a -> [(String, JSON.JSValue)]
95

    
96
-- | Optional field information.
97
data OptionalType
98
  = NotOptional           -- ^ Field is not optional
99
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
100
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
101
  | AndRestArguments      -- ^ Special field capturing all the remaining fields
102
                          -- as plain JSON values
103
  deriving (Show, Eq)
104

    
105
-- | Serialised field data type.
106
data Field = Field { fieldName        :: String
107
                   , fieldType        :: Q Type
108
                   , fieldRead        :: Maybe (Q Exp)
109
                   , fieldShow        :: Maybe (Q Exp)
110
                   , fieldExtraKeys   :: [String]
111
                   , fieldDefault     :: Maybe (Q Exp)
112
                   , fieldConstr      :: Maybe String
113
                   , fieldIsOptional  :: OptionalType
114
                   , fieldDoc         :: String
115
                   }
116

    
117
-- | Generates a simple field.
118
simpleField :: String -> Q Type -> Field
119
simpleField fname ftype =
120
  Field { fieldName        = fname
121
        , fieldType        = ftype
122
        , fieldRead        = Nothing
123
        , fieldShow        = Nothing
124
        , fieldExtraKeys   = []
125
        , fieldDefault     = Nothing
126
        , fieldConstr      = Nothing
127
        , fieldIsOptional  = NotOptional
128
        , fieldDoc         = ""
129
        }
130

    
131
-- | Generate an AndRestArguments catch-all field.
132
andRestArguments :: String -> Field
133
andRestArguments fname =
134
  Field { fieldName        = fname
135
        , fieldType        = [t| M.Map String JSON.JSValue |]
136
        , fieldRead        = Nothing
137
        , fieldShow        = Nothing
138
        , fieldExtraKeys   = []
139
        , fieldDefault     = Nothing
140
        , fieldConstr      = Nothing
141
        , fieldIsOptional  = AndRestArguments
142
        , fieldDoc         = ""
143
        }
144

    
145
withDoc :: String -> Field -> Field
146
withDoc doc field =
147
  field { fieldDoc = doc }
148

    
149
-- | Sets the renamed constructor field.
150
renameField :: String -> Field -> Field
151
renameField constrName field = field { fieldConstr = Just constrName }
152

    
153
-- | Sets the default value on a field (makes it optional with a
154
-- default value).
155
defaultField :: Q Exp -> Field -> Field
156
defaultField defval field = field { fieldDefault = Just defval }
157

    
158
-- | Marks a field optional (turning its base type into a Maybe).
159
optionalField :: Field -> Field
160
optionalField field = field { fieldIsOptional = OptionalOmitNull }
161

    
162
-- | Marks a field optional (turning its base type into a Maybe), but
163
-- with 'Nothing' serialised explicitly as /null/.
164
optionalNullSerField :: Field -> Field
165
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
166

    
167
-- | Wrapper around a special parse function, suitable as field-parsing
168
-- function.
169
numericalReadFn :: JSON.JSON a => (String -> JSON.Result a)
170
                   -> [(String, JSON.JSValue)] -> JSON.JSValue -> JSON.Result a
171
numericalReadFn _ _ v@(JSON.JSRational _ _) = JSON.readJSON v
172
numericalReadFn f _ (JSON.JSString x) = f $ JSON.fromJSString x
173
numericalReadFn _ _ _ = JSON.Error "A numerical field has to be a number or\ 
174
                                   \ a string."
175

    
176
-- | Wrapper to lift a read function to optional values
177
makeReadOptional :: ([(String, JSON.JSValue)] -> JSON.JSValue -> JSON.Result a)
178
                    -> [(String, JSON.JSValue)]
179
                    -> Maybe JSON.JSValue -> JSON.Result (Maybe a)
180
makeReadOptional _ _ Nothing = JSON.Ok Nothing
181
makeReadOptional f o (Just x) = fmap Just $ f o x
182

    
183
-- | Sets the read function to also accept string parsable by the given
184
-- function.
185
specialNumericalField :: Name -> Field -> Field
186
specialNumericalField f field =
187
  if (fieldIsOptional field == NotOptional)
188
     then field { fieldRead = Just (appE (varE 'numericalReadFn) (varE f)) }
189
     else field { fieldRead = Just (appE (varE 'makeReadOptional)
190
                                         (appE (varE 'numericalReadFn)
191
                                               (varE f))) }
192

    
193
-- | Sets custom functions on a field.
194
customField :: Name      -- ^ The name of the read function
195
            -> Name      -- ^ The name of the show function
196
            -> [String]  -- ^ The name of extra field keys
197
            -> Field     -- ^ The original field
198
            -> Field     -- ^ Updated field
199
customField readfn showfn extra field =
200
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
201
        , fieldExtraKeys = extra }
202

    
203
-- | Computes the record name for a given field, based on either the
204
-- string value in the JSON serialisation or the custom named if any
205
-- exists.
206
fieldRecordName :: Field -> String
207
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
208
  fromMaybe (camelCase name) alias
209

    
210
-- | Computes the preferred variable name to use for the value of this
211
-- field. If the field has a specific constructor name, then we use a
212
-- first-letter-lowercased version of that; otherwise, we simply use
213
-- the field name. See also 'fieldRecordName'.
214
fieldVariable :: Field -> String
215
fieldVariable f =
216
  case (fieldConstr f) of
217
    Just name -> ensureLower name
218
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
219

    
220
-- | Compute the actual field type (taking into account possible
221
-- optional status).
222
actualFieldType :: Field -> Q Type
223
actualFieldType f | fieldIsOptional f `elem` [NotOptional, AndRestArguments] = t
224
                  | otherwise =  [t| Maybe $t |]
225
                  where t = fieldType f
226

    
227
-- | Checks that a given field is not optional (for object types or
228
-- fields which should not allow this case).
229
checkNonOptDef :: (Monad m) => Field -> m ()
230
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
231
                      , fieldName = name }) =
232
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
233
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
234
                      , fieldName = name }) =
235
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
236
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
237
  fail $ "Default field " ++ name ++ " used in parameter declaration"
238
checkNonOptDef _ = return ()
239

    
240
-- | Produces the expression that will de-serialise a given
241
-- field. Since some custom parsing functions might need to use the
242
-- entire object, we do take and pass the object to any custom read
243
-- functions.
244
loadFn :: Field   -- ^ The field definition
245
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
246
       -> Q Exp   -- ^ The entire object in JSON object format
247
       -> Q Exp   -- ^ Resulting expression
248
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
249
loadFn _ expr _ = expr
250

    
251
-- * Common field declarations
252

    
253
-- | Timestamp fields description.
254
timeStampFields :: [Field]
255
timeStampFields =
256
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
257
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
258
    ]
259

    
260
-- | Serial number fields description.
261
serialFields :: [Field]
262
serialFields =
263
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
264

    
265
-- | UUID fields description.
266
uuidFields :: [Field]
267
uuidFields = [ simpleField "uuid" [t| String |] ]
268

    
269
-- | Tag set type alias.
270
type TagSet = Set.Set String
271

    
272
-- | Tag field description.
273
tagsFields :: [Field]
274
tagsFields = [ defaultField [| Set.empty |] $
275
               simpleField "tags" [t| TagSet |] ]
276

    
277
-- * Internal types
278

    
279
-- | A simple field, in constrast to the customisable 'Field' type.
280
type SimpleField = (String, Q Type)
281

    
282
-- | A definition for a single constructor for a simple object.
283
type SimpleConstructor = (String, [SimpleField])
284

    
285
-- | A definition for ADTs with simple fields.
286
type SimpleObject = [SimpleConstructor]
287

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

    
291
-- | A type alias for a Luxi constructor of a regular object.
292
type LuxiConstructor = (String, [Field])
293

    
294
-- * Helper functions
295

    
296
-- | Ensure first letter is lowercase.
297
--
298
-- Used to convert type name to function prefix, e.g. in @data Aa ->
299
-- aaToRaw@.
300
ensureLower :: String -> String
301
ensureLower [] = []
302
ensureLower (x:xs) = toLower x:xs
303

    
304
-- | Ensure first letter is uppercase.
305
--
306
-- Used to convert constructor name to component
307
ensureUpper :: String -> String
308
ensureUpper [] = []
309
ensureUpper (x:xs) = toUpper x:xs
310

    
311
-- | Helper for quoted expressions.
312
varNameE :: String -> Q Exp
313
varNameE = varE . mkName
314

    
315
-- | showJSON as an expression, for reuse.
316
showJSONE :: Q Exp
317
showJSONE = varE 'JSON.showJSON
318

    
319
-- | makeObj as an expression, for reuse.
320
makeObjE :: Q Exp
321
makeObjE = varE 'JSON.makeObj
322

    
323
-- | fromObj (Ganeti specific) as an expression, for reuse.
324
fromObjE :: Q Exp
325
fromObjE = varE 'fromObj
326

    
327
-- | ToRaw function name.
328
toRawName :: String -> Name
329
toRawName = mkName . (++ "ToRaw") . ensureLower
330

    
331
-- | FromRaw function name.
332
fromRawName :: String -> Name
333
fromRawName = mkName . (++ "FromRaw") . ensureLower
334

    
335
-- | Converts a name to it's varE\/litE representations.
336
reprE :: Either String Name -> Q Exp
337
reprE = either stringE varE
338

    
339
-- | Smarter function application.
340
--
341
-- This does simply f x, except that if is 'id', it will skip it, in
342
-- order to generate more readable code when using -ddump-splices.
343
appFn :: Exp -> Exp -> Exp
344
appFn f x | f == VarE 'id = x
345
          | otherwise = AppE f x
346

    
347
-- | Builds a field for a normal constructor.
348
buildConsField :: Q Type -> StrictTypeQ
349
buildConsField ftype = do
350
  ftype' <- ftype
351
  return (NotStrict, ftype')
352

    
353
-- | Builds a constructor based on a simple definition (not field-based).
354
buildSimpleCons :: Name -> SimpleObject -> Q Dec
355
buildSimpleCons tname cons = do
356
  decl_d <- mapM (\(cname, fields) -> do
357
                    fields' <- mapM (buildConsField . snd) fields
358
                    return $ NormalC (mkName cname) fields') cons
359
  return $ DataD [] tname [] decl_d [''Show, ''Eq]
360

    
361
-- | Generate the save function for a given type.
362
genSaveSimpleObj :: Name                            -- ^ Object type
363
                 -> String                          -- ^ Function name
364
                 -> SimpleObject                    -- ^ Object definition
365
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
366
                 -> Q (Dec, Dec)
367
genSaveSimpleObj tname sname opdefs fn = do
368
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
369
      fname = mkName sname
370
  cclauses <- mapM fn opdefs
371
  return $ (SigD fname sigt, FunD fname cclauses)
372

    
373
-- * Template code for simple raw type-equivalent ADTs
374

    
375
-- | Generates a data type declaration.
376
--
377
-- The type will have a fixed list of instances.
378
strADTDecl :: Name -> [String] -> Dec
379
strADTDecl name constructors =
380
  DataD [] name []
381
          (map (flip NormalC [] . mkName) constructors)
382
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
383

    
384
-- | Generates a toRaw function.
385
--
386
-- This generates a simple function of the form:
387
--
388
-- @
389
-- nameToRaw :: Name -> /traw/
390
-- nameToRaw Cons1 = var1
391
-- nameToRaw Cons2 = \"value2\"
392
-- @
393
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
394
genToRaw traw fname tname constructors = do
395
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
396
  -- the body clauses, matching on the constructor and returning the
397
  -- raw value
398
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
399
                             (normalB (reprE v)) []) constructors
400
  return [SigD fname sigt, FunD fname clauses]
401

    
402
-- | Generates a fromRaw function.
403
--
404
-- The function generated is monadic and can fail parsing the
405
-- raw value. It is of the form:
406
--
407
-- @
408
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
409
-- nameFromRaw s | s == var1       = Cons1
410
--               | s == \"value2\" = Cons2
411
--               | otherwise = fail /.../
412
-- @
413
genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
414
genFromRaw traw fname tname constructors = do
415
  -- signature of form (Monad m) => String -> m $name
416
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
417
  -- clauses for a guarded pattern
418
  let varp = mkName "s"
419
      varpe = varE varp
420
  clauses <- mapM (\(c, v) -> do
421
                     -- the clause match condition
422
                     g <- normalG [| $varpe == $(reprE v) |]
423
                     -- the clause result
424
                     r <- [| return $(conE (mkName c)) |]
425
                     return (g, r)) constructors
426
  -- the otherwise clause (fallback)
427
  oth_clause <- do
428
    g <- normalG [| otherwise |]
429
    r <- [|fail ("Invalid string value for type " ++
430
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
431
    return (g, r)
432
  let fun = FunD fname [Clause [VarP varp]
433
                        (GuardedB (clauses++[oth_clause])) []]
434
  return [SigD fname sigt, fun]
435

    
436
-- | Generates a data type from a given raw format.
437
--
438
-- The format is expected to multiline. The first line contains the
439
-- type name, and the rest of the lines must contain two words: the
440
-- constructor name and then the string representation of the
441
-- respective constructor.
442
--
443
-- The function will generate the data type declaration, and then two
444
-- functions:
445
--
446
-- * /name/ToRaw, which converts the type to a raw type
447
--
448
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
449
--
450
-- Note that this is basically just a custom show\/read instance,
451
-- nothing else.
452
declareADT
453
  :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
454
declareADT fn traw sname cons = do
455
  let name = mkName sname
456
      ddecl = strADTDecl name (map fst cons)
457
      -- process cons in the format expected by genToRaw
458
      cons' = map (\(a, b) -> (a, fn b)) cons
459
  toraw <- genToRaw traw (toRawName sname) name cons'
460
  fromraw <- genFromRaw traw (fromRawName sname) name cons'
461
  return $ ddecl:toraw ++ fromraw
462

    
463
declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
464
declareLADT = declareADT Left
465

    
466
declareILADT :: String -> [(String, Int)] -> Q [Dec]
467
declareILADT sname cons = do
468
  consNames <- sequence [ newName ('_':n) | (n, _) <- cons ]
469
  consFns <- concat <$> sequence
470
             [ do sig <- sigD n [t| Int |]
471
                  let expr = litE (IntegerL (toInteger i))
472
                  fn <- funD n [clause [] (normalB expr) []]
473
                  return [sig, fn]
474
             | n <- consNames
475
             | (_, i) <- cons ]
476
  let cons' = [ (n, n') | (n, _) <- cons | n' <- consNames ]
477
  (consFns ++) <$> declareADT Right ''Int sname cons'
478

    
479
declareIADT :: String -> [(String, Name)] -> Q [Dec]
480
declareIADT = declareADT Right ''Int
481

    
482
declareSADT :: String -> [(String, Name)] -> Q [Dec]
483
declareSADT = declareADT Right ''String
484

    
485
-- | Creates the showJSON member of a JSON instance declaration.
486
--
487
-- This will create what is the equivalent of:
488
--
489
-- @
490
-- showJSON = showJSON . /name/ToRaw
491
-- @
492
--
493
-- in an instance JSON /name/ declaration
494
genShowJSON :: String -> Q Dec
495
genShowJSON name = do
496
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
497
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
498

    
499
-- | Creates the readJSON member of a JSON instance declaration.
500
--
501
-- This will create what is the equivalent of:
502
--
503
-- @
504
-- readJSON s = case readJSON s of
505
--                Ok s' -> /name/FromRaw s'
506
--                Error e -> Error /description/
507
-- @
508
--
509
-- in an instance JSON /name/ declaration
510
genReadJSON :: String -> Q Dec
511
genReadJSON name = do
512
  let s = mkName "s"
513
  body <- [| case JSON.readJSON $(varE s) of
514
               JSON.Ok s' -> $(varE (fromRawName name)) s'
515
               JSON.Error e ->
516
                   JSON.Error $ "Can't parse raw value for type " ++
517
                           $(stringE name) ++ ": " ++ e ++ " from " ++
518
                           show $(varE s)
519
           |]
520
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
521

    
522
-- | Generates a JSON instance for a given type.
523
--
524
-- This assumes that the /name/ToRaw and /name/FromRaw functions
525
-- have been defined as by the 'declareSADT' function.
526
makeJSONInstance :: Name -> Q [Dec]
527
makeJSONInstance name = do
528
  let base = nameBase name
529
  showJ <- genShowJSON base
530
  readJ <- genReadJSON base
531
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
532

    
533
-- * Template code for opcodes
534

    
535
-- | Transforms a CamelCase string into an_underscore_based_one.
536
deCamelCase :: String -> String
537
deCamelCase =
538
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
539

    
540
-- | Transform an underscore_name into a CamelCase one.
541
camelCase :: String -> String
542
camelCase = concatMap (ensureUpper . drop 1) .
543
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
544

    
545
-- | Computes the name of a given constructor.
546
constructorName :: Con -> Q Name
547
constructorName (NormalC name _) = return name
548
constructorName (RecC name _)    = return name
549
constructorName x                = fail $ "Unhandled constructor " ++ show x
550

    
551
-- | Extract all constructor names from a given type.
552
reifyConsNames :: Name -> Q [String]
553
reifyConsNames name = do
554
  reify_result <- reify name
555
  case reify_result of
556
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
557
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
558
                \ type constructor but got '" ++ show o ++ "'"
559

    
560
-- | Builds the generic constructor-to-string function.
561
--
562
-- This generates a simple function of the following form:
563
--
564
-- @
565
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
566
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
567
-- @
568
--
569
-- This builds a custom list of name\/string pairs and then uses
570
-- 'genToRaw' to actually generate the function.
571
genConstrToStr :: (String -> Q String) -> Name -> String -> Q [Dec]
572
genConstrToStr trans_fun name fname = do
573
  cnames <- reifyConsNames name
574
  svalues <- mapM (liftM Left . trans_fun) cnames
575
  genToRaw ''String (mkName fname) name $ zip cnames svalues
576

    
577
-- | Constructor-to-string for OpCode.
578
genOpID :: Name -> String -> Q [Dec]
579
genOpID = genConstrToStr (return . deCamelCase)
580

    
581
-- | Builds a list with all defined constructor names for a type.
582
--
583
-- @
584
-- vstr :: String
585
-- vstr = [...]
586
-- @
587
--
588
-- Where the actual values of the string are the constructor names
589
-- mapped via @trans_fun@.
590
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
591
genAllConstr trans_fun name vstr = do
592
  cnames <- reifyConsNames name
593
  let svalues = sort $ map trans_fun cnames
594
      vname = mkName vstr
595
      sig = SigD vname (AppT ListT (ConT ''String))
596
      body = NormalB (ListE (map (LitE . StringL) svalues))
597
  return $ [sig, ValD (VarP vname) body []]
598

    
599
-- | Generates a list of all defined opcode IDs.
600
genAllOpIDs :: Name -> String -> Q [Dec]
601
genAllOpIDs = genAllConstr deCamelCase
602

    
603
-- | OpCode parameter (field) type.
604
type OpParam = (String, Q Type, Q Exp)
605

    
606
-- * Python code generation
607

    
608
data OpCodeField = OpCodeField { ocfName :: String
609
                               , ocfType :: PyType
610
                               , ocfDefl :: Maybe PyValueEx
611
                               , ocfDoc  :: String
612
                               }
613

    
614
-- | Transfers opcode data between the opcode description (through
615
-- @genOpCode@) and the Python code generation functions.
616
data OpCodeDescriptor = OpCodeDescriptor { ocdName   :: String
617
                                         , ocdType   :: PyType
618
                                         , ocdDoc    :: String
619
                                         , ocdFields :: [OpCodeField]
620
                                         , ocdDescr  :: String
621
                                         }
622

    
623
-- | Optionally encapsulates default values in @PyValueEx@.
624
--
625
-- @maybeApp exp typ@ returns a quoted expression that encapsulates
626
-- the default value @exp@ of an opcode parameter cast to @typ@ in a
627
-- @PyValueEx@, if @exp@ is @Just@.  Otherwise, it returns a quoted
628
-- expression with @Nothing@.
629
maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
630
maybeApp Nothing _ =
631
  [| Nothing |]
632

    
633
maybeApp (Just expr) typ =
634
  [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]
635

    
636
-- | Generates a Python type according to whether the field is
637
-- optional.
638
--
639
-- The type of created expression is PyType.
640
genPyType' :: OptionalType -> Q Type -> Q PyType
641
genPyType' opt typ = typ >>= pyOptionalType (opt /= NotOptional)
642

    
643
-- | Generates Python types from opcode parameters.
644
genPyType :: Field -> Q PyType
645
genPyType f = genPyType' (fieldIsOptional f) (fieldType f)
646

    
647
-- | Generates Python default values from opcode parameters.
648
genPyDefault :: Field -> Q Exp
649
genPyDefault f = maybeApp (fieldDefault f) (fieldType f)
650

    
651
pyField :: Field -> Q Exp
652
pyField f = genPyType f >>= \t ->
653
            [| OpCodeField $(stringE (fieldName f))
654
                           t
655
                           $(genPyDefault f)
656
                           $(stringE (fieldDoc f)) |]
657

    
658
-- | Generates a Haskell function call to "showPyClass" with the
659
-- necessary information on how to build the Python class string.
660
pyClass :: OpCodeConstructor -> Q Exp
661
pyClass (consName, consType, consDoc, consFields, consDscField) =
662
  do let pyClassVar = varNameE "showPyClass"
663
         consName' = stringE consName
664
     consType' <- genPyType' NotOptional consType
665
     let consDoc' = stringE consDoc
666
     [| OpCodeDescriptor $consName'
667
                         consType'
668
                         $consDoc'
669
                         $(listE $ map pyField consFields)
670
                         consDscField |]
671

    
672
-- | Generates a function called "pyClasses" that holds the list of
673
-- all the opcode descriptors necessary for generating the Python
674
-- opcodes.
675
pyClasses :: [OpCodeConstructor] -> Q [Dec]
676
pyClasses cons =
677
  do let name = mkName "pyClasses"
678
         sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
679
     fn <- FunD name <$> (:[]) <$> declClause cons
680
     return [sig, fn]
681
  where declClause c =
682
          clause [] (normalB (ListE <$> mapM pyClass c)) []
683

    
684
-- | Converts from an opcode constructor to a Luxi constructor.
685
opcodeConsToLuxiCons :: (a, b, c, d, e) -> (a, d)
686
opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)
687

    
688
-- | Generates the OpCode data type.
689
--
690
-- This takes an opcode logical definition, and builds both the
691
-- datatype and the JSON serialisation out of it. We can't use a
692
-- generic serialisation since we need to be compatible with Ganeti's
693
-- own, so we have a few quirks to work around.
694
genOpCode :: String              -- ^ Type name to use
695
          -> [OpCodeConstructor] -- ^ Constructor name and parameters
696
          -> Q [Dec]
697
genOpCode name cons = do
698
  let tname = mkName name
699
  decl_d <- mapM (\(cname, _, _, fields, _) -> do
700
                    -- we only need the type of the field, without Q
701
                    fields' <- mapM (fieldTypeInfo "op") fields
702
                    return $ RecC (mkName cname) fields')
703
            cons
704
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
705
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
706
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
707
               (map opcodeConsToLuxiCons cons) saveConstructor True
708
  (loadsig, loadfn) <- genLoadOpCode cons
709
  pyDecls <- pyClasses cons
710
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs ++ pyDecls
711

    
712
-- | Generates the function pattern returning the list of fields for a
713
-- given constructor.
714
genOpConsFields :: OpCodeConstructor -> Clause
715
genOpConsFields (cname, _, _, fields, _) =
716
  let op_id = deCamelCase cname
717
      fvals = map (LitE . StringL) . sort . nub $
718
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
719
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
720

    
721
-- | Generates a list of all fields of an opcode constructor.
722
genAllOpFields  :: String              -- ^ Function name
723
                -> [OpCodeConstructor] -- ^ Object definition
724
                -> (Dec, Dec)
725
genAllOpFields sname opdefs =
726
  let cclauses = map genOpConsFields opdefs
727
      other = Clause [WildP] (NormalB (ListE [])) []
728
      fname = mkName sname
729
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
730
  in (SigD fname sigt, FunD fname (cclauses++[other]))
731

    
732
-- | Generates the \"save\" clause for an entire opcode constructor.
733
--
734
-- This matches the opcode with variables named the same as the
735
-- constructor fields (just so that the spliced in code looks nicer),
736
-- and passes those name plus the parameter definition to 'saveObjectField'.
737
saveConstructor :: LuxiConstructor -- ^ The constructor
738
                -> Q Clause        -- ^ Resulting clause
739
saveConstructor (sname, fields) = do
740
  let cname = mkName sname
741
  fnames <- mapM (newName . fieldVariable) fields
742
  let pat = conP cname (map varP fnames)
743
  let felems = map (uncurry saveObjectField) (zip fnames fields)
744
      -- now build the OP_ID serialisation
745
      opid = [| [( $(stringE "OP_ID"),
746
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
747
      flist = listE (opid:felems)
748
      -- and finally convert all this to a json object
749
      flist' = [| concat $flist |]
750
  clause [pat] (normalB flist') []
751

    
752
-- | Generates the main save opcode function.
753
--
754
-- This builds a per-constructor match clause that contains the
755
-- respective constructor-serialisation code.
756
genSaveOpCode :: Name                          -- ^ Object ype
757
              -> String                        -- ^ To 'JSValue' function name
758
              -> String                        -- ^ To 'JSObject' function name
759
              -> [LuxiConstructor]             -- ^ Object definition
760
              -> (LuxiConstructor -> Q Clause) -- ^ Constructor save fn
761
              -> Bool                          -- ^ Whether to generate
762
                                               -- obj or just a
763
                                               -- list\/tuple of values
764
              -> Q [Dec]
765
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
766
  tdclauses <- mapM fn opdefs
767
  let typecon = ConT tname
768
      jvalname = mkName jvalstr
769
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
770
      tdname = mkName tdstr
771
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
772
  jvalclause <- if gen_object
773
                  then [| $makeObjE . $(varE tdname) |]
774
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
775
  return [ SigD tdname tdsig
776
         , FunD tdname tdclauses
777
         , SigD jvalname jvalsig
778
         , ValD (VarP jvalname) (NormalB jvalclause) []]
779

    
780
-- | Generates load code for a single constructor of the opcode data type.
781
loadConstructor :: OpCodeConstructor -> Q Exp
782
loadConstructor (sname, _, _, fields, _) = do
783
  let name = mkName sname
784
  fbinds <- mapM (loadObjectField fields) fields
785
  let (fnames, fstmts) = unzip fbinds
786
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
787
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
788
  return $ DoE fstmts'
789

    
790
-- | Generates the loadOpCode function.
791
genLoadOpCode :: [OpCodeConstructor] -> Q (Dec, Dec)
792
genLoadOpCode opdefs = do
793
  let fname = mkName "loadOpCode"
794
      arg1 = mkName "v"
795
      objname = mkName "o"
796
      opid = mkName "op_id"
797
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
798
                                 (JSON.readJSON $(varE arg1)) |]
799
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
800
  -- the match results (per-constructor blocks)
801
  mexps <- mapM loadConstructor opdefs
802
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
803
  let mpats = map (\(me, (consName, _, _, _, _)) ->
804
                       let mp = LitP . StringL . deCamelCase $ consName
805
                       in Match mp (NormalB me) []
806
                  ) $ zip mexps opdefs
807
      defmatch = Match WildP (NormalB fails) []
808
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
809
      body = DoE [st1, st2, cst]
810
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
811
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
812

    
813
-- * Template code for luxi
814

    
815
-- | Constructor-to-string for LuxiOp.
816
genStrOfOp :: Name -> String -> Q [Dec]
817
genStrOfOp = genConstrToStr return
818

    
819
-- | Constructor-to-string for MsgKeys.
820
genStrOfKey :: Name -> String -> Q [Dec]
821
genStrOfKey = genConstrToStr (return . ensureLower)
822

    
823
-- | Generates the LuxiOp data type.
824
--
825
-- This takes a Luxi operation definition and builds both the
826
-- datatype and the function transforming the arguments to JSON.
827
-- We can't use anything less generic, because the way different
828
-- operations are serialized differs on both parameter- and top-level.
829
--
830
-- There are two things to be defined for each parameter:
831
--
832
-- * name
833
--
834
-- * type
835
--
836
genLuxiOp :: String -> [LuxiConstructor] -> Q [Dec]
837
genLuxiOp name cons = do
838
  let tname = mkName name
839
  decl_d <- mapM (\(cname, fields) -> do
840
                    -- we only need the type of the field, without Q
841
                    fields' <- mapM actualFieldType fields
842
                    let fields'' = zip (repeat NotStrict) fields'
843
                    return $ NormalC (mkName cname) fields'')
844
            cons
845
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
846
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
847
               cons saveLuxiConstructor False
848
  req_defs <- declareSADT "LuxiReq" .
849
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
850
                  cons
851
  return $ declD:save_decs ++ req_defs
852

    
853
-- | Generates the \"save\" clause for entire LuxiOp constructor.
854
saveLuxiConstructor :: LuxiConstructor -> Q Clause
855
saveLuxiConstructor (sname, fields) = do
856
  let cname = mkName sname
857
  fnames <- mapM (newName . fieldVariable) fields
858
  let pat = conP cname (map varP fnames)
859
  let felems = map (uncurry saveObjectField) (zip fnames fields)
860
      flist = [| concat $(listE felems) |]
861
  clause [pat] (normalB flist) []
862

    
863
-- * "Objects" functionality
864

    
865
-- | Extract the field's declaration from a Field structure.
866
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
867
fieldTypeInfo field_pfx fd = do
868
  t <- actualFieldType fd
869
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
870
  return (n, NotStrict, t)
871

    
872
-- | Build an object declaration.
873
buildObject :: String -> String -> [Field] -> Q [Dec]
874
buildObject sname field_pfx fields = do
875
  let name = mkName sname
876
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
877
  let decl_d = RecC name fields_d
878
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
879
  ser_decls <- buildObjectSerialisation sname fields
880
  return $ declD:ser_decls
881

    
882
-- | Generates an object definition: data type and its JSON instance.
883
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
884
buildObjectSerialisation sname fields = do
885
  let name = mkName sname
886
  savedecls <- genSaveObject saveObjectField sname fields
887
  (loadsig, loadfn) <- genLoadObject (loadObjectField fields) sname fields
888
  shjson <- objectShowJSON sname
889
  rdjson <- objectReadJSON sname
890
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
891
                 [rdjson, shjson]
892
  return $ savedecls ++ [loadsig, loadfn, instdecl]
893

    
894
-- | The toDict function name for a given type.
895
toDictName :: String -> Name
896
toDictName sname = mkName ("toDict" ++ sname)
897

    
898
-- | Generates the save object functionality.
899
genSaveObject :: (Name -> Field -> Q Exp)
900
              -> String -> [Field] -> Q [Dec]
901
genSaveObject save_fn sname fields = do
902
  let name = mkName sname
903
  fnames <- mapM (newName . fieldVariable) fields
904
  let pat = conP name (map varP fnames)
905
  let tdname = toDictName sname
906
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
907

    
908
  let felems = map (uncurry save_fn) (zip fnames fields)
909
      flist = listE felems
910
      -- and finally convert all this to a json object
911
      tdlist = [| concat $flist |]
912
      iname = mkName "i"
913
  tclause <- clause [pat] (normalB tdlist) []
914
  cclause <- [| $makeObjE . $(varE tdname) |]
915
  let fname = mkName ("save" ++ sname)
916
  sigt <- [t| $(conT name) -> JSON.JSValue |]
917
  return [SigD tdname tdsigt, FunD tdname [tclause],
918
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
919

    
920
-- | Generates the code for saving an object's field, handling the
921
-- various types of fields that we have.
922
saveObjectField :: Name -> Field -> Q Exp
923
saveObjectField fvar field =
924
  case fieldIsOptional field of
925
    OptionalOmitNull -> [| case $(varE fvar) of
926
                             Nothing -> []
927
                             Just v  -> [( $nameE, JSON.showJSON v )]
928
                         |]
929
    OptionalSerializeNull -> [| case $(varE fvar) of
930
                                  Nothing -> [( $nameE, JSON.JSNull )]
931
                                  Just v  -> [( $nameE, JSON.showJSON v )]
932
                              |]
933
    NotOptional ->
934
      case fieldShow field of
935
        -- Note: the order of actual:extra is important, since for
936
        -- some serialisation types (e.g. Luxi), we use tuples
937
        -- (positional info) rather than object (name info)
938
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
939
        Just fn -> [| let (actual, extra) = $fn $fvarE
940
                      in ($nameE, JSON.showJSON actual):extra
941
                    |]
942
    AndRestArguments -> [| M.toList $(varE fvar) |]
943
  where nameE = stringE (fieldName field)
944
        fvarE = varE fvar
945

    
946
-- | Generates the showJSON clause for a given object name.
947
objectShowJSON :: String -> Q Dec
948
objectShowJSON name = do
949
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
950
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
951

    
952
-- | Generates the load object functionality.
953
genLoadObject :: (Field -> Q (Name, Stmt))
954
              -> String -> [Field] -> Q (Dec, Dec)
955
genLoadObject load_fn sname fields = do
956
  let name = mkName sname
957
      funname = mkName $ "load" ++ sname
958
      arg1 = mkName $ if null fields then "_" else "v"
959
      objname = mkName "o"
960
      opid = mkName "op_id"
961
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
962
                                 (JSON.readJSON $(varE arg1)) |]
963
  fbinds <- mapM load_fn fields
964
  let (fnames, fstmts) = unzip fbinds
965
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
966
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
967
      -- FIXME: should we require an empty dict for an empty type?
968
      -- this allows any JSValue right now
969
      fstmts' = if null fields
970
                  then retstmt
971
                  else st1:fstmts ++ retstmt
972
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
973
  return $ (SigD funname sigt,
974
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
975

    
976
-- | Generates code for loading an object's field.
977
loadObjectField :: [Field] -> Field -> Q (Name, Stmt)
978
loadObjectField allFields field = do
979
  let name = fieldVariable field
980
      names = map fieldVariable allFields
981
      otherNames = listE . map stringE $ names \\ [name]
982
  fvar <- newName name
983
  -- these are used in all patterns below
984
  let objvar = varNameE "o"
985
      objfield = stringE (fieldName field)
986
      loadexp =
987
        case fieldIsOptional field of
988
          NotOptional ->
989
            case fieldDefault field of
990
                 Just defv ->
991
                   [| $(varE 'fromObjWithDefault) $objvar
992
                      $objfield $defv |]
993
                 Nothing -> [| $fromObjE $objvar $objfield |]
994
          AndRestArguments -> [| return . M.fromList
995
                                   $ filter (not . (`elem` $otherNames) . fst)
996
                                            $objvar |]
997
          _ -> [| $(varE 'maybeFromObj) $objvar $objfield |]
998
          -- we treat both optional types the same, since
999
          -- 'maybeFromObj' can deal with both missing and null values
1000
          -- appropriately (the same)
1001
  bexp <- loadFn field loadexp objvar
1002

    
1003
  return (fvar, BindS (VarP fvar) bexp)
1004

    
1005
-- | Builds the readJSON instance for a given object name.
1006
objectReadJSON :: String -> Q Dec
1007
objectReadJSON name = do
1008
  let s = mkName "s"
1009
  body <- [| case JSON.readJSON $(varE s) of
1010
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
1011
               JSON.Error e ->
1012
                 JSON.Error $ "Can't parse value for type " ++
1013
                       $(stringE name) ++ ": " ++ e
1014
           |]
1015
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
1016

    
1017
-- * Inheritable parameter tables implementation
1018

    
1019
-- | Compute parameter type names.
1020
paramTypeNames :: String -> (String, String)
1021
paramTypeNames root = ("Filled"  ++ root ++ "Params",
1022
                       "Partial" ++ root ++ "Params")
1023

    
1024
-- | Compute information about the type of a parameter field.
1025
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
1026
paramFieldTypeInfo field_pfx fd = do
1027
  t <- actualFieldType fd
1028
  let n = mkName . (++ "P") . (field_pfx ++) .
1029
          fieldRecordName $ fd
1030
  return (n, NotStrict, AppT (ConT ''Maybe) t)
1031

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

    
1057
-- | Builds a list of all fields of a parameter.
1058
buildParamAllFields :: String -> [Field] -> [Dec]
1059
buildParamAllFields sname fields =
1060
  let vname = mkName ("all" ++ sname ++ "ParamFields")
1061
      sig = SigD vname (AppT ListT (ConT ''String))
1062
      val = ListE $ map (LitE . StringL . fieldName) fields
1063
  in [sig, ValD (VarP vname) (NormalB val) []]
1064

    
1065
-- | Builds the 'DictObject' instance for a filled parameter.
1066
buildDictObjectInst :: Name -> String -> [Dec]
1067
buildDictObjectInst name sname =
1068
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
1069
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
1070

    
1071
-- | Generates the serialisation for a partial parameter.
1072
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
1073
buildPParamSerialisation sname fields = do
1074
  let name = mkName sname
1075
  savedecls <- genSaveObject savePParamField sname fields
1076
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
1077
  shjson <- objectShowJSON sname
1078
  rdjson <- objectReadJSON sname
1079
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
1080
                 [rdjson, shjson]
1081
  return $ savedecls ++ [loadsig, loadfn, instdecl]
1082

    
1083
-- | Generates code to save an optional parameter field.
1084
savePParamField :: Name -> Field -> Q Exp
1085
savePParamField fvar field = do
1086
  checkNonOptDef field
1087
  let actualVal = mkName "v"
1088
  normalexpr <- saveObjectField actualVal field
1089
  -- we have to construct the block here manually, because we can't
1090
  -- splice-in-splice
1091
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
1092
                                       (NormalB (ConE '[])) []
1093
                             , Match (ConP 'Just [VarP actualVal])
1094
                                       (NormalB normalexpr) []
1095
                             ]
1096

    
1097
-- | Generates code to load an optional parameter field.
1098
loadPParamField :: Field -> Q (Name, Stmt)
1099
loadPParamField field = do
1100
  checkNonOptDef field
1101
  let name = fieldName field
1102
  fvar <- newName name
1103
  -- these are used in all patterns below
1104
  let objvar = varNameE "o"
1105
      objfield = stringE name
1106
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
1107
      field' = field {fieldRead=fmap (appE (varE 'makeReadOptional))
1108
                                  $ fieldRead field}
1109
  bexp <- loadFn field' loadexp objvar
1110
  return (fvar, BindS (VarP fvar) bexp)
1111

    
1112
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
1113
buildFromMaybe :: String -> Q Dec
1114
buildFromMaybe fname =
1115
  valD (varP (mkName $ "n_" ++ fname))
1116
         (normalB [| $(varE 'fromMaybe)
1117
                        $(varNameE $ "f_" ++ fname)
1118
                        $(varNameE $ "p_" ++ fname) |]) []
1119

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

    
1145
-- * Template code for exceptions
1146

    
1147
-- | Exception simple error message field.
1148
excErrMsg :: (String, Q Type)
1149
excErrMsg = ("errMsg", [t| String |])
1150

    
1151
-- | Builds an exception type definition.
1152
genException :: String                  -- ^ Name of new type
1153
             -> SimpleObject -- ^ Constructor name and parameters
1154
             -> Q [Dec]
1155
genException name cons = do
1156
  let tname = mkName name
1157
  declD <- buildSimpleCons tname cons
1158
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
1159
                         uncurry saveExcCons
1160
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
1161
  return [declD, loadsig, loadfn, savesig, savefn]
1162

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

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

    
1203
{-| Generates the loadException function.
1204

    
1205
This generates a quite complicated function, along the lines of:
1206

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