Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH.hs @ 0b7bf465

History | View | Annotate | Download (46.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, 2014 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
                  , specialNumericalField
52
                  , withDoc
53
                  , defaultField
54
                  , optionalField
55
                  , optionalNullSerField
56
                  , renameField
57
                  , customField
58
                  , timeStampFields
59
                  , uuidFields
60
                  , serialFields
61
                  , tagsFields
62
                  , TagSet
63
                  , buildObject
64
                  , buildObjectSerialisation
65
                  , buildParam
66
                  , DictObject(..)
67
                  , genException
68
                  , excErrMsg
69
                  ) where
70

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

    
79
import qualified Text.JSON as JSON
80
import Text.JSON.Pretty (pp_value)
81

    
82
import Ganeti.JSON
83
import Ganeti.PyValue
84
import Ganeti.THH.PyType
85

    
86

    
87
-- * Exported types
88

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

    
94
-- | Optional field information.
95
data OptionalType
96
  = NotOptional           -- ^ Field is not optional
97
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
98
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
99
  deriving (Show, Eq)
100

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

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

    
127
withDoc :: String -> Field -> Field
128
withDoc doc field =
129
  field { fieldDoc = doc }
130

    
131
-- | Sets the renamed constructor field.
132
renameField :: String -> Field -> Field
133
renameField constrName field = field { fieldConstr = Just constrName }
134

    
135
-- | Sets the default value on a field (makes it optional with a
136
-- default value).
137
defaultField :: Q Exp -> Field -> Field
138
defaultField defval field = field { fieldDefault = Just defval }
139

    
140
-- | Marks a field optional (turning its base type into a Maybe).
141
optionalField :: Field -> Field
142
optionalField field = field { fieldIsOptional = OptionalOmitNull }
143

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

    
149
-- | Wrapper around a special parse function, suitable as field-parsing
150
-- function.
151
numericalReadFn :: JSON.JSON a => (String -> JSON.Result a)
152
                   -> [(String, JSON.JSValue)] -> JSON.JSValue -> JSON.Result a
153
numericalReadFn _ _ v@(JSON.JSRational _ _) = JSON.readJSON v
154
numericalReadFn f _ (JSON.JSString x) = f $ JSON.fromJSString x
155
numericalReadFn _ _ _ = JSON.Error "A numerical field has to be a number or\ 
156
                                   \ a string."
157

    
158
-- | Sets the read function to also accept string parsable by the given
159
-- function.
160
specialNumericalField :: Name -> Field -> Field
161
specialNumericalField f field =
162
     field { fieldRead = Just (appE (varE 'numericalReadFn) (varE f)) }
163

    
164
-- | Sets custom functions on a field.
165
customField :: Name      -- ^ The name of the read function
166
            -> Name      -- ^ The name of the show function
167
            -> [String]  -- ^ The name of extra field keys
168
            -> Field     -- ^ The original field
169
            -> Field     -- ^ Updated field
170
customField readfn showfn extra field =
171
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
172
        , fieldExtraKeys = extra }
173

    
174
-- | Computes the record name for a given field, based on either the
175
-- string value in the JSON serialisation or the custom named if any
176
-- exists.
177
fieldRecordName :: Field -> String
178
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
179
  fromMaybe (camelCase name) alias
180

    
181
-- | Computes the preferred variable name to use for the value of this
182
-- field. If the field has a specific constructor name, then we use a
183
-- first-letter-lowercased version of that; otherwise, we simply use
184
-- the field name. See also 'fieldRecordName'.
185
fieldVariable :: Field -> String
186
fieldVariable f =
187
  case (fieldConstr f) of
188
    Just name -> ensureLower name
189
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
190

    
191
-- | Compute the actual field type (taking into account possible
192
-- optional status).
193
actualFieldType :: Field -> Q Type
194
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
195
                  | otherwise = t
196
                  where t = fieldType f
197

    
198
-- | Checks that a given field is not optional (for object types or
199
-- fields which should not allow this case).
200
checkNonOptDef :: (Monad m) => Field -> m ()
201
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
202
                      , fieldName = name }) =
203
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
204
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
205
                      , fieldName = name }) =
206
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
207
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
208
  fail $ "Default field " ++ name ++ " used in parameter declaration"
209
checkNonOptDef _ = return ()
210

    
211
-- | Construct a function that parses a field value. If the field has
212
-- a custom 'fieldRead', it's applied to @o@ and used. Otherwise
213
-- @JSON.readJSON@ is used.
214
parseFn :: Field   -- ^ The field definition
215
        -> Q Exp   -- ^ The entire object in JSON object format
216
        -> Q Exp   -- ^ The resulting function that parses a JSON message
217
parseFn field o = maybe [| JSON.readJSON |] (`appE` o) (fieldRead field)
218

    
219
-- | Produces the expression that will de-serialise a given
220
-- field. Since some custom parsing functions might need to use the
221
-- entire object, we do take and pass the object to any custom read
222
-- functions.
223
loadFn :: Field   -- ^ The field definition
224
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
225
       -> Q Exp   -- ^ The entire object in JSON object format
226
       -> Q Exp   -- ^ Resulting expression
227
loadFn field expr o = [| $expr >>= $(parseFn field o) |]
228

    
229
-- | Just as 'loadFn', but for optional fields.
230
loadFnOpt :: Field   -- ^ The field definition
231
          -> Q Exp   -- ^ The value of the field as existing in the JSON message
232
                     -- as Maybe
233
          -> Q Exp   -- ^ The entire object in JSON object format
234
          -> Q Exp   -- ^ Resulting expression
235
loadFnOpt field@(Field { fieldDefault = Just def }) expr o
236
  = [| $expr >>= maybe (return $def) $(parseFn field o) |]
237
loadFnOpt field expr o
238
  = [| $expr >>= maybe (return Nothing) (liftM Just . $(parseFn field o)) |]
239

    
240
-- * Common field declarations
241

    
242
-- | Timestamp fields description.
243
timeStampFields :: [Field]
244
timeStampFields =
245
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
246
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
247
    ]
248

    
249
-- | Serial number fields description.
250
serialFields :: [Field]
251
serialFields =
252
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
253

    
254
-- | UUID fields description.
255
uuidFields :: [Field]
256
uuidFields = [ simpleField "uuid" [t| String |] ]
257

    
258
-- | Tag set type alias.
259
type TagSet = Set.Set String
260

    
261
-- | Tag field description.
262
tagsFields :: [Field]
263
tagsFields = [ defaultField [| Set.empty |] $
264
               simpleField "tags" [t| TagSet |] ]
265

    
266
-- * Internal types
267

    
268
-- | A simple field, in constrast to the customisable 'Field' type.
269
type SimpleField = (String, Q Type)
270

    
271
-- | A definition for a single constructor for a simple object.
272
type SimpleConstructor = (String, [SimpleField])
273

    
274
-- | A definition for ADTs with simple fields.
275
type SimpleObject = [SimpleConstructor]
276

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

    
280
-- | A type alias for a Luxi constructor of a regular object.
281
type LuxiConstructor = (String, [Field])
282

    
283
-- * Helper functions
284

    
285
-- | Ensure first letter is lowercase.
286
--
287
-- Used to convert type name to function prefix, e.g. in @data Aa ->
288
-- aaToRaw@.
289
ensureLower :: String -> String
290
ensureLower [] = []
291
ensureLower (x:xs) = toLower x:xs
292

    
293
-- | Ensure first letter is uppercase.
294
--
295
-- Used to convert constructor name to component
296
ensureUpper :: String -> String
297
ensureUpper [] = []
298
ensureUpper (x:xs) = toUpper x:xs
299

    
300
-- | Helper for quoted expressions.
301
varNameE :: String -> Q Exp
302
varNameE = varE . mkName
303

    
304
-- | showJSON as an expression, for reuse.
305
showJSONE :: Q Exp
306
showJSONE = varE 'JSON.showJSON
307

    
308
-- | makeObj as an expression, for reuse.
309
makeObjE :: Q Exp
310
makeObjE = varE 'JSON.makeObj
311

    
312
-- | fromObj (Ganeti specific) as an expression, for reuse.
313
fromObjE :: Q Exp
314
fromObjE = varE 'fromObj
315

    
316
-- | ToRaw function name.
317
toRawName :: String -> Name
318
toRawName = mkName . (++ "ToRaw") . ensureLower
319

    
320
-- | FromRaw function name.
321
fromRawName :: String -> Name
322
fromRawName = mkName . (++ "FromRaw") . ensureLower
323

    
324
-- | Converts a name to it's varE\/litE representations.
325
reprE :: Either String Name -> Q Exp
326
reprE = either stringE varE
327

    
328
-- | Smarter function application.
329
--
330
-- This does simply f x, except that if is 'id', it will skip it, in
331
-- order to generate more readable code when using -ddump-splices.
332
appFn :: Exp -> Exp -> Exp
333
appFn f x | f == VarE 'id = x
334
          | otherwise = AppE f x
335

    
336
-- | Builds a field for a normal constructor.
337
buildConsField :: Q Type -> StrictTypeQ
338
buildConsField ftype = do
339
  ftype' <- ftype
340
  return (NotStrict, ftype')
341

    
342
-- | Builds a constructor based on a simple definition (not field-based).
343
buildSimpleCons :: Name -> SimpleObject -> Q Dec
344
buildSimpleCons tname cons = do
345
  decl_d <- mapM (\(cname, fields) -> do
346
                    fields' <- mapM (buildConsField . snd) fields
347
                    return $ NormalC (mkName cname) fields') cons
348
  return $ DataD [] tname [] decl_d [''Show, ''Eq]
349

    
350
-- | Generate the save function for a given type.
351
genSaveSimpleObj :: Name                            -- ^ Object type
352
                 -> String                          -- ^ Function name
353
                 -> SimpleObject                    -- ^ Object definition
354
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
355
                 -> Q (Dec, Dec)
356
genSaveSimpleObj tname sname opdefs fn = do
357
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
358
      fname = mkName sname
359
  cclauses <- mapM fn opdefs
360
  return $ (SigD fname sigt, FunD fname cclauses)
361

    
362
-- * Template code for simple raw type-equivalent ADTs
363

    
364
-- | Generates a data type declaration.
365
--
366
-- The type will have a fixed list of instances.
367
strADTDecl :: Name -> [String] -> Dec
368
strADTDecl name constructors =
369
  DataD [] name []
370
          (map (flip NormalC [] . mkName) constructors)
371
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
372

    
373
-- | Generates a toRaw function.
374
--
375
-- This generates a simple function of the form:
376
--
377
-- @
378
-- nameToRaw :: Name -> /traw/
379
-- nameToRaw Cons1 = var1
380
-- nameToRaw Cons2 = \"value2\"
381
-- @
382
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
383
genToRaw traw fname tname constructors = do
384
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
385
  -- the body clauses, matching on the constructor and returning the
386
  -- raw value
387
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
388
                             (normalB (reprE v)) []) constructors
389
  return [SigD fname sigt, FunD fname clauses]
390

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

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

    
452
declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
453
declareLADT = declareADT Left
454

    
455
declareILADT :: String -> [(String, Int)] -> Q [Dec]
456
declareILADT sname cons = do
457
  consNames <- sequence [ newName ('_':n) | (n, _) <- cons ]
458
  consFns <- concat <$> sequence
459
             [ do sig <- sigD n [t| Int |]
460
                  let expr = litE (IntegerL (toInteger i))
461
                  fn <- funD n [clause [] (normalB expr) []]
462
                  return [sig, fn]
463
             | n <- consNames
464
             | (_, i) <- cons ]
465
  let cons' = [ (n, n') | (n, _) <- cons | n' <- consNames ]
466
  (consFns ++) <$> declareADT Right ''Int sname cons'
467

    
468
declareIADT :: String -> [(String, Name)] -> Q [Dec]
469
declareIADT = declareADT Right ''Int
470

    
471
declareSADT :: String -> [(String, Name)] -> Q [Dec]
472
declareSADT = declareADT Right ''String
473

    
474
-- | Creates the showJSON member of a JSON instance declaration.
475
--
476
-- This will create what is the equivalent of:
477
--
478
-- @
479
-- showJSON = showJSON . /name/ToRaw
480
-- @
481
--
482
-- in an instance JSON /name/ declaration
483
genShowJSON :: String -> Q Dec
484
genShowJSON name = do
485
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
486
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
487

    
488
-- | Creates the readJSON member of a JSON instance declaration.
489
--
490
-- This will create what is the equivalent of:
491
--
492
-- @
493
-- readJSON s = case readJSON s of
494
--                Ok s' -> /name/FromRaw s'
495
--                Error e -> Error /description/
496
-- @
497
--
498
-- in an instance JSON /name/ declaration
499
genReadJSON :: String -> Q Dec
500
genReadJSON name = do
501
  let s = mkName "s"
502
  body <- [| case JSON.readJSON $(varE s) of
503
               JSON.Ok s' -> $(varE (fromRawName name)) s'
504
               JSON.Error e ->
505
                   JSON.Error $ "Can't parse raw value for type " ++
506
                           $(stringE name) ++ ": " ++ e ++ " from " ++
507
                           show $(varE s)
508
           |]
509
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
510

    
511
-- | Generates a JSON instance for a given type.
512
--
513
-- This assumes that the /name/ToRaw and /name/FromRaw functions
514
-- have been defined as by the 'declareSADT' function.
515
makeJSONInstance :: Name -> Q [Dec]
516
makeJSONInstance name = do
517
  let base = nameBase name
518
  showJ <- genShowJSON base
519
  readJ <- genReadJSON base
520
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
521

    
522
-- * Template code for opcodes
523

    
524
-- | Transforms a CamelCase string into an_underscore_based_one.
525
deCamelCase :: String -> String
526
deCamelCase =
527
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
528

    
529
-- | Transform an underscore_name into a CamelCase one.
530
camelCase :: String -> String
531
camelCase = concatMap (ensureUpper . drop 1) .
532
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
533

    
534
-- | Computes the name of a given constructor.
535
constructorName :: Con -> Q Name
536
constructorName (NormalC name _) = return name
537
constructorName (RecC name _)    = return name
538
constructorName x                = fail $ "Unhandled constructor " ++ show x
539

    
540
-- | Extract all constructor names from a given type.
541
reifyConsNames :: Name -> Q [String]
542
reifyConsNames name = do
543
  reify_result <- reify name
544
  case reify_result of
545
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
546
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
547
                \ type constructor but got '" ++ show o ++ "'"
548

    
549
-- | Builds the generic constructor-to-string function.
550
--
551
-- This generates a simple function of the following form:
552
--
553
-- @
554
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
555
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
556
-- @
557
--
558
-- This builds a custom list of name\/string pairs and then uses
559
-- 'genToRaw' to actually generate the function.
560
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
561
genConstrToStr trans_fun name fname = do
562
  cnames <- reifyConsNames name
563
  let svalues = map (Left . trans_fun) cnames
564
  genToRaw ''String (mkName fname) name $ zip cnames svalues
565

    
566
-- | Constructor-to-string for OpCode.
567
genOpID :: Name -> String -> Q [Dec]
568
genOpID = genConstrToStr deCamelCase
569

    
570
-- | Builds a list with all defined constructor names for a type.
571
--
572
-- @
573
-- vstr :: String
574
-- vstr = [...]
575
-- @
576
--
577
-- Where the actual values of the string are the constructor names
578
-- mapped via @trans_fun@.
579
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
580
genAllConstr trans_fun name vstr = do
581
  cnames <- reifyConsNames name
582
  let svalues = sort $ map trans_fun cnames
583
      vname = mkName vstr
584
      sig = SigD vname (AppT ListT (ConT ''String))
585
      body = NormalB (ListE (map (LitE . StringL) svalues))
586
  return $ [sig, ValD (VarP vname) body []]
587

    
588
-- | Generates a list of all defined opcode IDs.
589
genAllOpIDs :: Name -> String -> Q [Dec]
590
genAllOpIDs = genAllConstr deCamelCase
591

    
592
-- | OpCode parameter (field) type.
593
type OpParam = (String, Q Type, Q Exp)
594

    
595
-- * Python code generation
596

    
597
data OpCodeField = OpCodeField { ocfName :: String
598
                               , ocfType :: PyType
599
                               , ocfDefl :: Maybe PyValueEx
600
                               , ocfDoc  :: String
601
                               }
602

    
603
-- | Transfers opcode data between the opcode description (through
604
-- @genOpCode@) and the Python code generation functions.
605
data OpCodeDescriptor = OpCodeDescriptor { ocdName   :: String
606
                                         , ocdType   :: PyType
607
                                         , ocdDoc    :: String
608
                                         , ocdFields :: [OpCodeField]
609
                                         , ocdDescr  :: String
610
                                         }
611

    
612
-- | Optionally encapsulates default values in @PyValueEx@.
613
--
614
-- @maybeApp exp typ@ returns a quoted expression that encapsulates
615
-- the default value @exp@ of an opcode parameter cast to @typ@ in a
616
-- @PyValueEx@, if @exp@ is @Just@.  Otherwise, it returns a quoted
617
-- expression with @Nothing@.
618
maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
619
maybeApp Nothing _ =
620
  [| Nothing |]
621

    
622
maybeApp (Just expr) typ =
623
  [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]
624

    
625
-- | Generates a Python type according to whether the field is
626
-- optional.
627
--
628
-- The type of created expression is PyType.
629
genPyType' :: OptionalType -> Q Type -> Q PyType
630
genPyType' opt typ = typ >>= pyOptionalType (opt /= NotOptional)
631

    
632
-- | Generates Python types from opcode parameters.
633
genPyType :: Field -> Q PyType
634
genPyType f = genPyType' (fieldIsOptional f) (fieldType f)
635

    
636
-- | Generates Python default values from opcode parameters.
637
genPyDefault :: Field -> Q Exp
638
genPyDefault f = maybeApp (fieldDefault f) (fieldType f)
639

    
640
pyField :: Field -> Q Exp
641
pyField f = genPyType f >>= \t ->
642
            [| OpCodeField $(stringE (fieldName f))
643
                           t
644
                           $(genPyDefault f)
645
                           $(stringE (fieldDoc f)) |]
646

    
647
-- | Generates a Haskell function call to "showPyClass" with the
648
-- necessary information on how to build the Python class string.
649
pyClass :: OpCodeConstructor -> Q Exp
650
pyClass (consName, consType, consDoc, consFields, consDscField) =
651
  do let pyClassVar = varNameE "showPyClass"
652
         consName' = stringE consName
653
     consType' <- genPyType' NotOptional consType
654
     let consDoc' = stringE consDoc
655
     [| OpCodeDescriptor $consName'
656
                         consType'
657
                         $consDoc'
658
                         $(listE $ map pyField consFields)
659
                         consDscField |]
660

    
661
-- | Generates a function called "pyClasses" that holds the list of
662
-- all the opcode descriptors necessary for generating the Python
663
-- opcodes.
664
pyClasses :: [OpCodeConstructor] -> Q [Dec]
665
pyClasses cons =
666
  do let name = mkName "pyClasses"
667
         sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
668
     fn <- FunD name <$> (:[]) <$> declClause cons
669
     return [sig, fn]
670
  where declClause c =
671
          clause [] (normalB (ListE <$> mapM pyClass c)) []
672

    
673
-- | Converts from an opcode constructor to a Luxi constructor.
674
opcodeConsToLuxiCons :: (a, b, c, d, e) -> (a, d)
675
opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)
676

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

    
701
-- | Generates the function pattern returning the list of fields for a
702
-- given constructor.
703
genOpConsFields :: OpCodeConstructor -> Clause
704
genOpConsFields (cname, _, _, fields, _) =
705
  let op_id = deCamelCase cname
706
      fvals = map (LitE . StringL) . sort . nub $
707
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
708
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
709

    
710
-- | Generates a list of all fields of an opcode constructor.
711
genAllOpFields  :: String              -- ^ Function name
712
                -> [OpCodeConstructor] -- ^ Object definition
713
                -> (Dec, Dec)
714
genAllOpFields sname opdefs =
715
  let cclauses = map genOpConsFields opdefs
716
      other = Clause [WildP] (NormalB (ListE [])) []
717
      fname = mkName sname
718
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
719
  in (SigD fname sigt, FunD fname (cclauses++[other]))
720

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

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

    
769
-- | Generates load code for a single constructor of the opcode data type.
770
loadConstructor :: OpCodeConstructor -> Q Exp
771
loadConstructor (sname, _, _, fields, _) = do
772
  let name = mkName sname
773
  fbinds <- mapM loadObjectField fields
774
  let (fnames, fstmts) = unzip fbinds
775
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
776
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
777
  return $ DoE fstmts'
778

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

    
802
-- * Template code for luxi
803

    
804
-- | Constructor-to-string for LuxiOp.
805
genStrOfOp :: Name -> String -> Q [Dec]
806
genStrOfOp = genConstrToStr id
807

    
808
-- | Constructor-to-string for MsgKeys.
809
genStrOfKey :: Name -> String -> Q [Dec]
810
genStrOfKey = genConstrToStr ensureLower
811

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

    
842
-- | Generates the \"save\" clause for entire LuxiOp constructor.
843
saveLuxiConstructor :: LuxiConstructor -> Q Clause
844
saveLuxiConstructor (sname, fields) = do
845
  let cname = mkName sname
846
  fnames <- mapM (newName . fieldVariable) fields
847
  let pat = conP cname (map varP fnames)
848
  let felems = map (uncurry saveObjectField) (zip fnames fields)
849
      flist = [| concat $(listE felems) |]
850
  clause [pat] (normalB flist) []
851

    
852
-- * "Objects" functionality
853

    
854
-- | Extract the field's declaration from a Field structure.
855
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
856
fieldTypeInfo field_pfx fd = do
857
  t <- actualFieldType fd
858
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
859
  return (n, NotStrict, t)
860

    
861
-- | Build an object declaration.
862
buildObject :: String -> String -> [Field] -> Q [Dec]
863
buildObject sname field_pfx fields = do
864
  let name = mkName sname
865
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
866
  let decl_d = RecC name fields_d
867
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
868
  ser_decls <- buildObjectSerialisation sname fields
869
  return $ declD:ser_decls
870

    
871
-- | Generates an object definition: data type and its JSON instance.
872
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
873
buildObjectSerialisation sname fields = do
874
  let name = mkName sname
875
  savedecls <- genSaveObject saveObjectField sname fields
876
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
877
  shjson <- objectShowJSON sname
878
  rdjson <- objectReadJSON sname
879
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
880
                 [rdjson, shjson]
881
  return $ savedecls ++ [loadsig, loadfn, instdecl]
882

    
883
-- | The toDict function name for a given type.
884
toDictName :: String -> Name
885
toDictName sname = mkName ("toDict" ++ sname)
886

    
887
-- | Generates the save object functionality.
888
genSaveObject :: (Name -> Field -> Q Exp)
889
              -> String -> [Field] -> Q [Dec]
890
genSaveObject save_fn sname fields = do
891
  let name = mkName sname
892
  fnames <- mapM (newName . fieldVariable) fields
893
  let pat = conP name (map varP fnames)
894
  let tdname = toDictName sname
895
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
896

    
897
  let felems = map (uncurry save_fn) (zip fnames fields)
898
      flist = listE felems
899
      -- and finally convert all this to a json object
900
      tdlist = [| concat $flist |]
901
      iname = mkName "i"
902
  tclause <- clause [pat] (normalB tdlist) []
903
  cclause <- [| $makeObjE . $(varE tdname) |]
904
  let fname = mkName ("save" ++ sname)
905
  sigt <- [t| $(conT name) -> JSON.JSValue |]
906
  return [SigD tdname tdsigt, FunD tdname [tclause],
907
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
908

    
909
-- | Generates the code for saving an object's field, handling the
910
-- various types of fields that we have.
911
saveObjectField :: Name -> Field -> Q Exp
912
saveObjectField fvar field =
913
  case fieldIsOptional field of
914
    OptionalOmitNull -> [| case $(varE fvar) of
915
                             Nothing -> []
916
                             Just v  -> [( $nameE, JSON.showJSON v )]
917
                         |]
918
    OptionalSerializeNull -> [| case $(varE fvar) of
919
                                  Nothing -> [( $nameE, JSON.JSNull )]
920
                                  Just v  -> [( $nameE, JSON.showJSON v )]
921
                              |]
922
    NotOptional ->
923
      case fieldShow field of
924
        -- Note: the order of actual:extra is important, since for
925
        -- some serialisation types (e.g. Luxi), we use tuples
926
        -- (positional info) rather than object (name info)
927
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
928
        Just fn -> [| let (actual, extra) = $fn $fvarE
929
                      in ($nameE, JSON.showJSON actual):extra
930
                    |]
931
  where nameE = stringE (fieldName field)
932
        fvarE = varE fvar
933

    
934
-- | Generates the showJSON clause for a given object name.
935
objectShowJSON :: String -> Q Dec
936
objectShowJSON name = do
937
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
938
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
939

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

    
964
-- | Generates code for loading an object's field.
965
loadObjectField :: Field -> Q (Name, Stmt)
966
loadObjectField field = do
967
  let name = fieldVariable field
968
  fvar <- newName name
969
  -- these are used in all patterns below
970
  let objvar = varNameE "o"
971
      objfield = stringE (fieldName field)
972
  bexp <- case fieldDefault field of
973
            -- Only non-optional fields without defaults must have a value;
974
            -- we treat both optional types the same, since
975
            -- 'maybeFromObj' can deal with both missing and null values
976
            -- appropriately (the same)
977
            Nothing | fieldIsOptional field == NotOptional ->
978
                 loadFn field [| fromObj $objvar $objfield |] objvar
979
            _ -> loadFnOpt field [| maybeFromObj $objvar $objfield |] objvar
980

    
981
  return (fvar, BindS (VarP fvar) bexp)
982

    
983
-- | Builds the readJSON instance for a given object name.
984
objectReadJSON :: String -> Q Dec
985
objectReadJSON name = do
986
  let s = mkName "s"
987
  body <- [| case JSON.readJSON $(varE s) of
988
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
989
               JSON.Error e ->
990
                 JSON.Error $ "Can't parse value for type " ++
991
                       $(stringE name) ++ ": " ++ e
992
           |]
993
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
994

    
995
-- * Inheritable parameter tables implementation
996

    
997
-- | Compute parameter type names.
998
paramTypeNames :: String -> (String, String)
999
paramTypeNames root = ("Filled"  ++ root ++ "Params",
1000
                       "Partial" ++ root ++ "Params")
1001

    
1002
-- | Compute information about the type of a parameter field.
1003
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
1004
paramFieldTypeInfo field_pfx fd = do
1005
  t <- actualFieldType fd
1006
  let n = mkName . (++ "P") . (field_pfx ++) .
1007
          fieldRecordName $ fd
1008
  return (n, NotStrict, AppT (ConT ''Maybe) t)
1009

    
1010
-- | Build a parameter declaration.
1011
--
1012
-- This function builds two different data structures: a /filled/ one,
1013
-- in which all fields are required, and a /partial/ one, in which all
1014
-- fields are optional. Due to the current record syntax issues, the
1015
-- fields need to be named differrently for the two structures, so the
1016
-- partial ones get a /P/ suffix.
1017
buildParam :: String -> String -> [Field] -> Q [Dec]
1018
buildParam sname field_pfx fields = do
1019
  let (sname_f, sname_p) = paramTypeNames sname
1020
      name_f = mkName sname_f
1021
      name_p = mkName sname_p
1022
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
1023
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
1024
  let decl_f = RecC name_f fields_f
1025
      decl_p = RecC name_p fields_p
1026
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
1027
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
1028
  ser_decls_f <- buildObjectSerialisation sname_f fields
1029
  ser_decls_p <- buildPParamSerialisation sname_p fields
1030
  fill_decls <- fillParam sname field_pfx fields
1031
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
1032
           buildParamAllFields sname fields ++
1033
           buildDictObjectInst name_f sname_f
1034

    
1035
-- | Builds a list of all fields of a parameter.
1036
buildParamAllFields :: String -> [Field] -> [Dec]
1037
buildParamAllFields sname fields =
1038
  let vname = mkName ("all" ++ sname ++ "ParamFields")
1039
      sig = SigD vname (AppT ListT (ConT ''String))
1040
      val = ListE $ map (LitE . StringL . fieldName) fields
1041
  in [sig, ValD (VarP vname) (NormalB val) []]
1042

    
1043
-- | Builds the 'DictObject' instance for a filled parameter.
1044
buildDictObjectInst :: Name -> String -> [Dec]
1045
buildDictObjectInst name sname =
1046
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
1047
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
1048

    
1049
-- | Generates the serialisation for a partial parameter.
1050
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
1051
buildPParamSerialisation sname fields = do
1052
  let name = mkName sname
1053
  savedecls <- genSaveObject savePParamField sname fields
1054
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
1055
  shjson <- objectShowJSON sname
1056
  rdjson <- objectReadJSON sname
1057
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
1058
                 [rdjson, shjson]
1059
  return $ savedecls ++ [loadsig, loadfn, instdecl]
1060

    
1061
-- | Generates code to save an optional parameter field.
1062
savePParamField :: Name -> Field -> Q Exp
1063
savePParamField fvar field = do
1064
  checkNonOptDef field
1065
  let actualVal = mkName "v"
1066
  normalexpr <- saveObjectField actualVal field
1067
  -- we have to construct the block here manually, because we can't
1068
  -- splice-in-splice
1069
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
1070
                                       (NormalB (ConE '[])) []
1071
                             , Match (ConP 'Just [VarP actualVal])
1072
                                       (NormalB normalexpr) []
1073
                             ]
1074

    
1075
-- | Generates code to load an optional parameter field.
1076
loadPParamField :: Field -> Q (Name, Stmt)
1077
loadPParamField field = do
1078
  checkNonOptDef field
1079
  let name = fieldName field
1080
  fvar <- newName name
1081
  -- these are used in all patterns below
1082
  let objvar = varNameE "o"
1083
      objfield = stringE name
1084
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
1085
  bexp <- loadFnOpt field loadexp objvar
1086
  return (fvar, BindS (VarP fvar) bexp)
1087

    
1088
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
1089
buildFromMaybe :: String -> Q Dec
1090
buildFromMaybe fname =
1091
  valD (varP (mkName $ "n_" ++ fname))
1092
         (normalB [| $(varE 'fromMaybe)
1093
                        $(varNameE $ "f_" ++ fname)
1094
                        $(varNameE $ "p_" ++ fname) |]) []
1095

    
1096
-- | Builds a function that executes the filling of partial parameter
1097
-- from a full copy (similar to Python's fillDict).
1098
fillParam :: String -> String -> [Field] -> Q [Dec]
1099
fillParam sname field_pfx fields = do
1100
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
1101
      (sname_f, sname_p) = paramTypeNames sname
1102
      oname_f = "fobj"
1103
      oname_p = "pobj"
1104
      name_f = mkName sname_f
1105
      name_p = mkName sname_p
1106
      fun_name = mkName $ "fill" ++ sname ++ "Params"
1107
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
1108
                (NormalB . VarE . mkName $ oname_f) []
1109
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
1110
                (NormalB . VarE . mkName $ oname_p) []
1111
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
1112
                $ map (mkName . ("n_" ++)) fnames
1113
  le_new <- mapM buildFromMaybe fnames
1114
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
1115
  let sig = SigD fun_name funt
1116
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
1117
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
1118
      fun = FunD fun_name [fclause]
1119
  return [sig, fun]
1120

    
1121
-- * Template code for exceptions
1122

    
1123
-- | Exception simple error message field.
1124
excErrMsg :: (String, Q Type)
1125
excErrMsg = ("errMsg", [t| String |])
1126

    
1127
-- | Builds an exception type definition.
1128
genException :: String                  -- ^ Name of new type
1129
             -> SimpleObject -- ^ Constructor name and parameters
1130
             -> Q [Dec]
1131
genException name cons = do
1132
  let tname = mkName name
1133
  declD <- buildSimpleCons tname cons
1134
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
1135
                         uncurry saveExcCons
1136
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
1137
  return [declD, loadsig, loadfn, savesig, savefn]
1138

    
1139
-- | Generates the \"save\" clause for an entire exception constructor.
1140
--
1141
-- This matches the exception with variables named the same as the
1142
-- constructor fields (just so that the spliced in code looks nicer),
1143
-- and calls showJSON on it.
1144
saveExcCons :: String        -- ^ The constructor name
1145
            -> [SimpleField] -- ^ The parameter definitions for this
1146
                             -- constructor
1147
            -> Q Clause      -- ^ Resulting clause
1148
saveExcCons sname fields = do
1149
  let cname = mkName sname
1150
  fnames <- mapM (newName . fst) fields
1151
  let pat = conP cname (map varP fnames)
1152
      felems = if null fnames
1153
                 then conE '() -- otherwise, empty list has no type
1154
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
1155
  let tup = tupE [ litE (stringL sname), felems ]
1156
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
1157

    
1158
-- | Generates load code for a single constructor of an exception.
1159
--
1160
-- Generates the code (if there's only one argument, we will use a
1161
-- list, not a tuple:
1162
--
1163
-- @
1164
-- do
1165
--  (x1, x2, ...) <- readJSON args
1166
--  return $ Cons x1 x2 ...
1167
-- @
1168
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
1169
loadExcConstructor inname sname fields = do
1170
  let name = mkName sname
1171
  f_names <- mapM (newName . fst) fields
1172
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
1173
  let binds = case f_names of
1174
                [x] -> BindS (ListP [VarP x])
1175
                _   -> BindS (TupP (map VarP f_names))
1176
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
1177
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
1178

    
1179
{-| Generates the loadException function.
1180

    
1181
This generates a quite complicated function, along the lines of:
1182

    
1183
@
1184
loadFn (JSArray [JSString name, args]) = case name of
1185
   "A1" -> do
1186
     (x1, x2, ...) <- readJSON args
1187
     return $ A1 x1 x2 ...
1188
   "a2" -> ...
1189
   s -> fail $ "Unknown exception" ++ s
1190
loadFn v = fail $ "Expected array but got " ++ show v
1191
@
1192
-}
1193
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
1194
genLoadExc tname sname opdefs = do
1195
  let fname = mkName sname
1196
  exc_name <- newName "name"
1197
  exc_args <- newName "args"
1198
  exc_else <- newName "s"
1199
  arg_else <- newName "v"
1200
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
1201
  -- default match for unknown exception name
1202
  let defmatch = Match (VarP exc_else) (NormalB fails) []
1203
  -- the match results (per-constructor blocks)
1204
  str_matches <-
1205
    mapM (\(s, params) -> do
1206
            body_exp <- loadExcConstructor exc_args s params
1207
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
1208
    opdefs
1209
  -- the first function clause; we can't use [| |] due to TH
1210
  -- limitations, so we have to build the AST by hand
1211
  let clause1 = Clause [ConP 'JSON.JSArray
1212
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
1213
                                            VarP exc_args]]]
1214
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
1215
                                        (VarE exc_name))
1216
                          (str_matches ++ [defmatch]))) []
1217
  -- the fail expression for the second function clause
1218
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
1219
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
1220
                |]
1221
  -- the second function clause
1222
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
1223
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
1224
  return $ (SigD fname sigt, FunD fname [clause1, clause2])