Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / THH.hs @ 84835174

History | View | Annotate | Download (29 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| TemplateHaskell helper for HTools.
4

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

    
9
-}
10

    
11
{-
12

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

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

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

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

    
30
-}
31

    
32
module Ganeti.THH ( declareSADT
33
                  , declareIADT
34
                  , makeJSONInstance
35
                  , genOpID
36
                  , genOpCode
37
                  , genStrOfOp
38
                  , genStrOfKey
39
                  , genLuxiOp
40
                  , Field
41
                  , simpleField
42
                  , defaultField
43
                  , optionalField
44
                  , renameField
45
                  , containerField
46
                  , customField
47
                  , timeStampFields
48
                  , uuidFields
49
                  , serialFields
50
                  , tagsFields
51
                  , buildObject
52
                  , buildObjectSerialisation
53
                  , buildParam
54
                  , Container
55
                  ) where
56

    
57
import Control.Monad (liftM, liftM2)
58
import Data.Char
59
import Data.List
60
import qualified Data.Set as Set
61
import Language.Haskell.TH
62

    
63
import qualified Text.JSON as JSON
64

    
65
import Ganeti.HTools.JSON
66

    
67
-- * Exported types
68

    
69
-- | Serialised field data type.
70
data Field = Field { fieldName        :: String
71
                   , fieldType        :: Q Type
72
                   , fieldRead        :: Maybe (Q Exp)
73
                   , fieldShow        :: Maybe (Q Exp)
74
                   , fieldDefault     :: Maybe (Q Exp)
75
                   , fieldConstr      :: Maybe String
76
                   , fieldIsContainer :: Bool
77
                   , fieldIsOptional  :: Bool
78
                   }
79

    
80
-- | Generates a simple field.
81
simpleField :: String -> Q Type -> Field
82
simpleField fname ftype =
83
  Field { fieldName        = fname
84
        , fieldType        = ftype
85
        , fieldRead        = Nothing
86
        , fieldShow        = Nothing
87
        , fieldDefault     = Nothing
88
        , fieldConstr      = Nothing
89
        , fieldIsContainer = False
90
        , fieldIsOptional  = False
91
        }
92

    
93
-- | Sets the renamed constructor field.
94
renameField :: String -> Field -> Field
95
renameField constrName field = field { fieldConstr = Just constrName }
96

    
97
-- | Sets the default value on a field (makes it optional with a
98
-- default value).
99
defaultField :: Q Exp -> Field -> Field
100
defaultField defval field = field { fieldDefault = Just defval }
101

    
102
-- | Marks a field optional (turning its base type into a Maybe).
103
optionalField :: Field -> Field
104
optionalField field = field { fieldIsOptional = True }
105

    
106
-- | Marks a field as a container.
107
containerField :: Field -> Field
108
containerField field = field { fieldIsContainer = True }
109

    
110
-- | Sets custom functions on a field.
111
customField :: Name    -- ^ The name of the read function
112
            -> Name    -- ^ The name of the show function
113
            -> Field   -- ^ The original field
114
            -> Field   -- ^ Updated field
115
customField readfn showfn field =
116
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }
117

    
118
fieldRecordName :: Field -> String
119
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
120
  maybe (camelCase name) id alias
121

    
122
-- | Computes the preferred variable name to use for the value of this
123
-- field. If the field has a specific constructor name, then we use a
124
-- first-letter-lowercased version of that; otherwise, we simply use
125
-- the field name. See also 'fieldRecordName'.
126
fieldVariable :: Field -> String
127
fieldVariable f =
128
  case (fieldConstr f) of
129
    Just name -> ensureLower name
130
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
131

    
132
actualFieldType :: Field -> Q Type
133
actualFieldType f | fieldIsContainer f = [t| Container $t |]
134
                  | fieldIsOptional f  = [t| Maybe $t     |]
135
                  | otherwise = t
136
                  where t = fieldType f
137

    
138
checkNonOptDef :: (Monad m) => Field -> m ()
139
checkNonOptDef (Field { fieldIsOptional = True, fieldName = name }) =
140
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
141
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
142
  fail $ "Default field " ++ name ++ " used in parameter declaration"
143
checkNonOptDef _ = return ()
144

    
145
-- | Produces the expression that will de-serialise a given
146
-- field. Since some custom parsing functions might need to use the
147
-- entire object, we do take and pass the object to any custom read
148
-- functions.
149
loadFn :: Field   -- ^ The field definition
150
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
151
       -> Q Exp   -- ^ The entire object in JSON object format
152
       -> Q Exp   -- ^ Resulting expression
153
loadFn (Field { fieldIsContainer = True }) expr _ =
154
  [| $expr |]
155
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
156
loadFn _ expr _ = expr
157

    
158
-- * Common field declarations
159

    
160
timeStampFields :: [Field]
161
timeStampFields =
162
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
163
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
164
    ]
165

    
166
serialFields :: [Field]
167
serialFields =
168
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
169

    
170
uuidFields :: [Field]
171
uuidFields = [ simpleField "uuid" [t| String |] ]
172

    
173
-- | Tag field description.
174
tagsFields :: [Field]
175
tagsFields = [ defaultField [| Set.empty |] $
176
               simpleField "tags" [t| Set.Set String |] ]
177

    
178
-- * Helper functions
179

    
180
-- | Ensure first letter is lowercase.
181
--
182
-- Used to convert type name to function prefix, e.g. in @data Aa ->
183
-- aaToRaw@.
184
ensureLower :: String -> String
185
ensureLower [] = []
186
ensureLower (x:xs) = toLower x:xs
187

    
188
-- | Ensure first letter is uppercase.
189
--
190
-- Used to convert constructor name to component
191
ensureUpper :: String -> String
192
ensureUpper [] = []
193
ensureUpper (x:xs) = toUpper x:xs
194

    
195
-- | Helper for quoted expressions.
196
varNameE :: String -> Q Exp
197
varNameE = varE . mkName
198

    
199
-- | showJSON as an expression, for reuse.
200
showJSONE :: Q Exp
201
showJSONE = varNameE "showJSON"
202

    
203
-- | ToRaw function name.
204
toRawName :: String -> Name
205
toRawName = mkName . (++ "ToRaw") . ensureLower
206

    
207
-- | FromRaw function name.
208
fromRawName :: String -> Name
209
fromRawName = mkName . (++ "FromRaw") . ensureLower
210

    
211
-- | Converts a name to it's varE/litE representations.
212
--
213
reprE :: Either String Name -> Q Exp
214
reprE = either stringE varE
215

    
216
-- | Smarter function application.
217
--
218
-- This does simply f x, except that if is 'id', it will skip it, in
219
-- order to generate more readable code when using -ddump-splices.
220
appFn :: Exp -> Exp -> Exp
221
appFn f x | f == VarE 'id = x
222
          | otherwise = AppE f x
223

    
224
-- * Template code for simple raw type-equivalent ADTs
225

    
226
-- | Generates a data type declaration.
227
--
228
-- The type will have a fixed list of instances.
229
strADTDecl :: Name -> [String] -> Dec
230
strADTDecl name constructors =
231
  DataD [] name []
232
          (map (flip NormalC [] . mkName) constructors)
233
          [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
234

    
235
-- | Generates a toRaw function.
236
--
237
-- This generates a simple function of the form:
238
--
239
-- @
240
-- nameToRaw :: Name -> /traw/
241
-- nameToRaw Cons1 = var1
242
-- nameToRaw Cons2 = \"value2\"
243
-- @
244
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
245
genToRaw traw fname tname constructors = do
246
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
247
  -- the body clauses, matching on the constructor and returning the
248
  -- raw value
249
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
250
                             (normalB (reprE v)) []) constructors
251
  return [SigD fname sigt, FunD fname clauses]
252

    
253
-- | Generates a fromRaw function.
254
--
255
-- The function generated is monadic and can fail parsing the
256
-- raw value. It is of the form:
257
--
258
-- @
259
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
260
-- nameFromRaw s | s == var1       = Cons1
261
--               | s == \"value2\" = Cons2
262
--               | otherwise = fail /.../
263
-- @
264
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
265
genFromRaw traw fname tname constructors = do
266
  -- signature of form (Monad m) => String -> m $name
267
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
268
  -- clauses for a guarded pattern
269
  let varp = mkName "s"
270
      varpe = varE varp
271
  clauses <- mapM (\(c, v) -> do
272
                     -- the clause match condition
273
                     g <- normalG [| $varpe == $(varE v) |]
274
                     -- the clause result
275
                     r <- [| return $(conE (mkName c)) |]
276
                     return (g, r)) constructors
277
  -- the otherwise clause (fallback)
278
  oth_clause <- do
279
    g <- normalG [| otherwise |]
280
    r <- [|fail ("Invalid string value for type " ++
281
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
282
    return (g, r)
283
  let fun = FunD fname [Clause [VarP varp]
284
                        (GuardedB (clauses++[oth_clause])) []]
285
  return [SigD fname sigt, fun]
286

    
287
-- | Generates a data type from a given raw format.
288
--
289
-- The format is expected to multiline. The first line contains the
290
-- type name, and the rest of the lines must contain two words: the
291
-- constructor name and then the string representation of the
292
-- respective constructor.
293
--
294
-- The function will generate the data type declaration, and then two
295
-- functions:
296
--
297
-- * /name/ToRaw, which converts the type to a raw type
298
--
299
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
300
--
301
-- Note that this is basically just a custom show/read instance,
302
-- nothing else.
303
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
304
declareADT traw sname cons = do
305
  let name = mkName sname
306
      ddecl = strADTDecl name (map fst cons)
307
      -- process cons in the format expected by genToRaw
308
      cons' = map (\(a, b) -> (a, Right b)) cons
309
  toraw <- genToRaw traw (toRawName sname) name cons'
310
  fromraw <- genFromRaw traw (fromRawName sname) name cons
311
  return $ ddecl:toraw ++ fromraw
312

    
313
declareIADT :: String -> [(String, Name)] -> Q [Dec]
314
declareIADT = declareADT ''Int
315

    
316
declareSADT :: String -> [(String, Name)] -> Q [Dec]
317
declareSADT = declareADT ''String
318

    
319
-- | Creates the showJSON member of a JSON instance declaration.
320
--
321
-- This will create what is the equivalent of:
322
--
323
-- @
324
-- showJSON = showJSON . /name/ToRaw
325
-- @
326
--
327
-- in an instance JSON /name/ declaration
328
genShowJSON :: String -> Q Dec
329
genShowJSON name = do
330
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
331
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
332

    
333
-- | Creates the readJSON member of a JSON instance declaration.
334
--
335
-- This will create what is the equivalent of:
336
--
337
-- @
338
-- readJSON s = case readJSON s of
339
--                Ok s' -> /name/FromRaw s'
340
--                Error e -> Error /description/
341
-- @
342
--
343
-- in an instance JSON /name/ declaration
344
genReadJSON :: String -> Q Dec
345
genReadJSON name = do
346
  let s = mkName "s"
347
  body <- [| case JSON.readJSON $(varE s) of
348
               JSON.Ok s' -> $(varE (fromRawName name)) s'
349
               JSON.Error e ->
350
                   JSON.Error $ "Can't parse raw value for type " ++
351
                           $(stringE name) ++ ": " ++ e ++ " from " ++
352
                           show $(varE s)
353
           |]
354
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
355

    
356
-- | Generates a JSON instance for a given type.
357
--
358
-- This assumes that the /name/ToRaw and /name/FromRaw functions
359
-- have been defined as by the 'declareSADT' function.
360
makeJSONInstance :: Name -> Q [Dec]
361
makeJSONInstance name = do
362
  let base = nameBase name
363
  showJ <- genShowJSON base
364
  readJ <- genReadJSON base
365
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
366

    
367
-- * Template code for opcodes
368

    
369
-- | Transforms a CamelCase string into an_underscore_based_one.
370
deCamelCase :: String -> String
371
deCamelCase =
372
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
373

    
374
-- | Transform an underscore_name into a CamelCase one.
375
camelCase :: String -> String
376
camelCase = concatMap (ensureUpper . drop 1) .
377
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
378

    
379
-- | Computes the name of a given constructor.
380
constructorName :: Con -> Q Name
381
constructorName (NormalC name _) = return name
382
constructorName (RecC name _)    = return name
383
constructorName x                = fail $ "Unhandled constructor " ++ show x
384

    
385
-- | Builds the generic constructor-to-string function.
386
--
387
-- This generates a simple function of the following form:
388
--
389
-- @
390
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
391
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
392
-- @
393
--
394
-- This builds a custom list of name/string pairs and then uses
395
-- 'genToRaw' to actually generate the function
396
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
397
genConstrToStr trans_fun name fname = do
398
  TyConI (DataD _ _ _ cons _) <- reify name
399
  cnames <- mapM (liftM nameBase . constructorName) cons
400
  let svalues = map (Left . trans_fun) cnames
401
  genToRaw ''String (mkName fname) name $ zip cnames svalues
402

    
403
-- | Constructor-to-string for OpCode.
404
genOpID :: Name -> String -> Q [Dec]
405
genOpID = genConstrToStr deCamelCase
406

    
407
-- | OpCode parameter (field) type.
408
type OpParam = (String, Q Type, Q Exp)
409

    
410
-- | Generates the OpCode data type.
411
--
412
-- This takes an opcode logical definition, and builds both the
413
-- datatype and the JSON serialisation out of it. We can't use a
414
-- generic serialisation since we need to be compatible with Ganeti's
415
-- own, so we have a few quirks to work around.
416
genOpCode :: String                -- ^ Type name to use
417
          -> [(String, [Field])]   -- ^ Constructor name and parameters
418
          -> Q [Dec]
419
genOpCode name cons = do
420
  decl_d <- mapM (\(cname, fields) -> do
421
                    -- we only need the type of the field, without Q
422
                    fields' <- mapM actualFieldType fields
423
                    let fields'' = zip (repeat NotStrict) fields'
424
                    return $ NormalC (mkName cname) fields'')
425
            cons
426
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
427

    
428
  (savesig, savefn) <- genSaveOpCode cons
429
  (loadsig, loadfn) <- genLoadOpCode cons
430
  return [declD, loadsig, loadfn, savesig, savefn]
431

    
432
-- | Checks whether a given parameter is options.
433
--
434
-- This requires that it's a 'Maybe'.
435
isOptional :: Type -> Bool
436
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
437
isOptional _ = False
438

    
439
-- | Generates the \"save\" clause for an entire opcode constructor.
440
--
441
-- This matches the opcode with variables named the same as the
442
-- constructor fields (just so that the spliced in code looks nicer),
443
-- and passes those name plus the parameter definition to 'saveObjectField'.
444
saveConstructor :: String    -- ^ The constructor name
445
                -> [Field]   -- ^ The parameter definitions for this
446
                             -- constructor
447
                -> Q Clause  -- ^ Resulting clause
448
saveConstructor sname fields = do
449
  let cname = mkName sname
450
  fnames <- mapM (newName . fieldVariable) fields
451
  let pat = conP cname (map varP fnames)
452
  let felems = map (uncurry saveObjectField) (zip fnames fields)
453
      -- now build the OP_ID serialisation
454
      opid = [| [( $(stringE "OP_ID"),
455
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
456
      flist = listE (opid:felems)
457
      -- and finally convert all this to a json object
458
      flist' = [| $(varNameE "makeObj") (concat $flist) |]
459
  clause [pat] (normalB flist') []
460

    
461
-- | Generates the main save opcode function.
462
--
463
-- This builds a per-constructor match clause that contains the
464
-- respective constructor-serialisation code.
465
genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
466
genSaveOpCode opdefs = do
467
  cclauses <- mapM (uncurry saveConstructor) opdefs
468
  let fname = mkName "saveOpCode"
469
  sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
470
  return $ (SigD fname sigt, FunD fname cclauses)
471

    
472
loadConstructor :: String -> [Field] -> Q Exp
473
loadConstructor sname fields = do
474
  let name = mkName sname
475
  fbinds <- mapM loadObjectField fields
476
  let (fnames, fstmts) = unzip fbinds
477
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
478
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
479
  return $ DoE fstmts'
480

    
481
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
482
genLoadOpCode opdefs = do
483
  let fname = mkName "loadOpCode"
484
      arg1 = mkName "v"
485
      objname = mkName "o"
486
      opid = mkName "op_id"
487
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
488
                                 (JSON.readJSON $(varE arg1)) |]
489
  st2 <- bindS (varP opid) [| $(varNameE "fromObj")
490
                              $(varE objname) $(stringE "OP_ID") |]
491
  -- the match results (per-constructor blocks)
492
  mexps <- mapM (uncurry loadConstructor) opdefs
493
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
494
  let mpats = map (\(me, c) ->
495
                       let mp = LitP . StringL . deCamelCase . fst $ c
496
                       in Match mp (NormalB me) []
497
                  ) $ zip mexps opdefs
498
      defmatch = Match WildP (NormalB fails) []
499
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
500
      body = DoE [st1, st2, cst]
501
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
502
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
503

    
504
-- * Template code for luxi
505

    
506
-- | Constructor-to-string for LuxiOp.
507
genStrOfOp :: Name -> String -> Q [Dec]
508
genStrOfOp = genConstrToStr id
509

    
510
-- | Constructor-to-string for MsgKeys.
511
genStrOfKey :: Name -> String -> Q [Dec]
512
genStrOfKey = genConstrToStr ensureLower
513

    
514
-- | LuxiOp parameter type.
515
type LuxiParam = (String, Q Type, Q Exp)
516

    
517
-- | Generates the LuxiOp data type.
518
--
519
-- This takes a Luxi operation definition and builds both the
520
-- datatype and the function trnasforming the arguments to JSON.
521
-- We can't use anything less generic, because the way different
522
-- operations are serialized differs on both parameter- and top-level.
523
--
524
-- There are three things to be defined for each parameter:
525
--
526
-- * name
527
--
528
-- * type
529
--
530
-- * operation; this is the operation performed on the parameter before
531
--   serialization
532
--
533
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
534
genLuxiOp name cons = do
535
  decl_d <- mapM (\(cname, fields) -> do
536
                    fields' <- mapM (\(_, qt, _) ->
537
                                         qt >>= \t -> return (NotStrict, t))
538
                               fields
539
                    return $ NormalC (mkName cname) fields')
540
            cons
541
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
542
  (savesig, savefn) <- genSaveLuxiOp cons
543
  req_defs <- declareSADT "LuxiReq" .
544
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
545
                  cons
546
  return $ [declD, savesig, savefn] ++ req_defs
547

    
548
-- | Generates the \"save\" expression for a single luxi parameter.
549
saveLuxiField :: Name -> LuxiParam -> Q Exp
550
saveLuxiField fvar (_, qt, fn) =
551
    [| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |]
552

    
553
-- | Generates the \"save\" clause for entire LuxiOp constructor.
554
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
555
saveLuxiConstructor (sname, fields) = do
556
  let cname = mkName sname
557
      fnames = map (\(nm, _, _) -> mkName nm) fields
558
      pat = conP cname (map varP fnames)
559
      flist = map (uncurry saveLuxiField) (zip fnames fields)
560
      finval = if null flist
561
               then [| JSON.showJSON ()    |]
562
               else [| JSON.showJSON $(listE flist) |]
563
  clause [pat] (normalB finval) []
564

    
565
-- | Generates the main save LuxiOp function.
566
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
567
genSaveLuxiOp opdefs = do
568
  sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
569
  let fname = mkName "opToArgs"
570
  cclauses <- mapM saveLuxiConstructor opdefs
571
  return $ (SigD fname sigt, FunD fname cclauses)
572

    
573
-- * "Objects" functionality
574

    
575
-- | Extract the field's declaration from a Field structure.
576
fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
577
fieldTypeInfo field_pfx fd = do
578
  t <- actualFieldType fd
579
  let n = mkName . (field_pfx ++) . fieldRecordName $ fd
580
  return (n, NotStrict, t)
581

    
582
-- | Build an object declaration.
583
buildObject :: String -> String -> [Field] -> Q [Dec]
584
buildObject sname field_pfx fields = do
585
  let name = mkName sname
586
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
587
  let decl_d = RecC name fields_d
588
  let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
589
  ser_decls <- buildObjectSerialisation sname fields
590
  return $ declD:ser_decls
591

    
592
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
593
buildObjectSerialisation sname fields = do
594
  let name = mkName sname
595
  savedecls <- genSaveObject saveObjectField sname fields
596
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
597
  shjson <- objectShowJSON sname
598
  rdjson <- objectReadJSON sname
599
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
600
                 [rdjson, shjson]
601
  return $ savedecls ++ [loadsig, loadfn, instdecl]
602

    
603
genSaveObject :: (Name -> Field -> Q Exp)
604
              -> String -> [Field] -> Q [Dec]
605
genSaveObject save_fn sname fields = do
606
  let name = mkName sname
607
  fnames <- mapM (newName . fieldVariable) fields
608
  let pat = conP name (map varP fnames)
609
  let tdname = mkName ("toDict" ++ sname)
610
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
611

    
612
  let felems = map (uncurry save_fn) (zip fnames fields)
613
      flist = listE felems
614
      -- and finally convert all this to a json object
615
      tdlist = [| concat $flist |]
616
      iname = mkName "i"
617
  tclause <- clause [pat] (normalB tdlist) []
618
  cclause <- [| $(varNameE "makeObj") . $(varE tdname) |]
619
  let fname = mkName ("save" ++ sname)
620
  sigt <- [t| $(conT name) -> JSON.JSValue |]
621
  return [SigD tdname tdsigt, FunD tdname [tclause],
622
          SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
623

    
624
saveObjectField :: Name -> Field -> Q Exp
625
saveObjectField fvar field
626
  | isContainer = [| [( $nameE , JSON.showJSON $fvarE)] |]
627
  | fisOptional = [| case $(varE fvar) of
628
                      Nothing -> []
629
                      Just v -> [( $nameE, JSON.showJSON v)]
630
                  |]
631
  | otherwise = case fieldShow field of
632
      Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
633
      Just fn -> [| let (actual, extra) = $fn $fvarE
634
                    in extra ++ [( $nameE, JSON.showJSON actual)]
635
                  |]
636
  where isContainer = fieldIsContainer field
637
        fisOptional  = fieldIsOptional field
638
        nameE = stringE (fieldName field)
639
        fvarE = varE fvar
640

    
641
objectShowJSON :: String -> Q Dec
642
objectShowJSON name = do
643
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
644
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
645

    
646
genLoadObject :: (Field -> Q (Name, Stmt))
647
              -> String -> [Field] -> Q (Dec, Dec)
648
genLoadObject load_fn sname fields = do
649
  let name = mkName sname
650
      funname = mkName $ "load" ++ sname
651
      arg1 = mkName "v"
652
      objname = mkName "o"
653
      opid = mkName "op_id"
654
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
655
                                 (JSON.readJSON $(varE arg1)) |]
656
  fbinds <- mapM load_fn fields
657
  let (fnames, fstmts) = unzip fbinds
658
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
659
      fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
660
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
661
  return $ (SigD funname sigt,
662
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
663

    
664
loadObjectField :: Field -> Q (Name, Stmt)
665
loadObjectField field = do
666
  let name = fieldVariable field
667
  fvar <- newName name
668
  -- these are used in all patterns below
669
  let objvar = varNameE "o"
670
      objfield = stringE (fieldName field)
671
      loadexp =
672
        if fieldIsOptional field
673
          then [| $(varNameE "maybeFromObj") $objvar $objfield |]
674
          else case fieldDefault field of
675
                 Just defv ->
676
                   [| $(varNameE "fromObjWithDefault") $objvar
677
                      $objfield $defv |]
678
                 Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
679
  bexp <- loadFn field loadexp objvar
680

    
681
  return (fvar, BindS (VarP fvar) bexp)
682

    
683
objectReadJSON :: String -> Q Dec
684
objectReadJSON name = do
685
  let s = mkName "s"
686
  body <- [| case JSON.readJSON $(varE s) of
687
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
688
               JSON.Error e ->
689
                 JSON.Error $ "Can't parse value for type " ++
690
                       $(stringE name) ++ ": " ++ e
691
           |]
692
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
693

    
694
-- * Inheritable parameter tables implementation
695

    
696
-- | Compute parameter type names.
697
paramTypeNames :: String -> (String, String)
698
paramTypeNames root = ("Filled"  ++ root ++ "Params",
699
                       "Partial" ++ root ++ "Params")
700

    
701
-- | Compute information about the type of a parameter field.
702
paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
703
paramFieldTypeInfo field_pfx fd = do
704
  t <- actualFieldType fd
705
  let n = mkName . (++ "P") . (field_pfx ++) .
706
          fieldRecordName $ fd
707
  return (n, NotStrict, AppT (ConT ''Maybe) t)
708

    
709
-- | Build a parameter declaration.
710
--
711
-- This function builds two different data structures: a /filled/ one,
712
-- in which all fields are required, and a /partial/ one, in which all
713
-- fields are optional. Due to the current record syntax issues, the
714
-- fields need to be named differrently for the two structures, so the
715
-- partial ones get a /P/ suffix.
716
buildParam :: String -> String -> [Field] -> Q [Dec]
717
buildParam sname field_pfx fields = do
718
  let (sname_f, sname_p) = paramTypeNames sname
719
      name_f = mkName sname_f
720
      name_p = mkName sname_p
721
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
722
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
723
  let decl_f = RecC name_f fields_f
724
      decl_p = RecC name_p fields_p
725
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
726
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
727
  ser_decls_f <- buildObjectSerialisation sname_f fields
728
  ser_decls_p <- buildPParamSerialisation sname_p fields
729
  fill_decls <- fillParam sname field_pfx fields
730
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls
731

    
732
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
733
buildPParamSerialisation sname fields = do
734
  let name = mkName sname
735
  savedecls <- genSaveObject savePParamField sname fields
736
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
737
  shjson <- objectShowJSON sname
738
  rdjson <- objectReadJSON sname
739
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
740
                 [rdjson, shjson]
741
  return $ savedecls ++ [loadsig, loadfn, instdecl]
742

    
743
savePParamField :: Name -> Field -> Q Exp
744
savePParamField fvar field = do
745
  checkNonOptDef field
746
  let actualVal = mkName "v"
747
  normalexpr <- saveObjectField actualVal field
748
  -- we have to construct the block here manually, because we can't
749
  -- splice-in-splice
750
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
751
                                       (NormalB (ConE '[])) []
752
                             , Match (ConP 'Just [VarP actualVal])
753
                                       (NormalB normalexpr) []
754
                             ]
755
loadPParamField :: Field -> Q (Name, Stmt)
756
loadPParamField field = do
757
  checkNonOptDef field
758
  let name = fieldName field
759
  fvar <- newName name
760
  -- these are used in all patterns below
761
  let objvar = varNameE "o"
762
      objfield = stringE name
763
      loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
764
  bexp <- loadFn field loadexp objvar
765
  return (fvar, BindS (VarP fvar) bexp)
766

    
767
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
768
buildFromMaybe :: String -> Q Dec
769
buildFromMaybe fname =
770
  valD (varP (mkName $ "n_" ++ fname))
771
         (normalB [| $(varNameE "fromMaybe")
772
                        $(varNameE $ "f_" ++ fname)
773
                        $(varNameE $ "p_" ++ fname) |]) []
774

    
775
fillParam :: String -> String -> [Field] -> Q [Dec]
776
fillParam sname field_pfx fields = do
777
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
778
      (sname_f, sname_p) = paramTypeNames sname
779
      oname_f = "fobj"
780
      oname_p = "pobj"
781
      name_f = mkName sname_f
782
      name_p = mkName sname_p
783
      fun_name = mkName $ "fill" ++ sname ++ "Params"
784
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
785
                (NormalB . VarE . mkName $ oname_f) []
786
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
787
                (NormalB . VarE . mkName $ oname_p) []
788
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
789
                $ map (mkName . ("n_" ++)) fnames
790
  le_new <- mapM buildFromMaybe fnames
791
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
792
  let sig = SigD fun_name funt
793
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
794
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
795
      fun = FunD fun_name [fclause]
796
  return [sig, fun]