THH.hs 30.2 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}

{-| TemplateHaskell helper for HTools.

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

-}

{-

Copyright (C) 2011 Google Inc.

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

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

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

-}

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

57
import Control.Arrow
58
import Control.Monad (liftM, liftM2)
59
import Data.Char
60
import Data.List
61
import qualified Data.Map as M
62
63
64
65
import Language.Haskell.TH

import qualified Text.JSON as JSON

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
-- * Exported types

type Container = M.Map String

-- | Serialised field data type.
data Field = Field { fieldName        :: String
                   , fieldType        :: Q Type
                   , fieldRead        :: Maybe (Q Exp)
                   , fieldShow        :: Maybe (Q Exp)
                   , fieldDefault     :: Maybe (Q Exp)
                   , fieldConstr      :: Maybe String
                   , fieldIsContainer :: Bool
                   , fieldIsOptional  :: Bool
                   }

-- | Generates a simple field.
simpleField :: String -> Q Type -> Field
simpleField fname ftype =
  Field { fieldName        = fname
        , fieldType        = ftype
        , fieldRead        = Nothing
        , fieldShow        = Nothing
        , fieldDefault     = Nothing
        , fieldConstr      = Nothing
        , fieldIsContainer = False
        , fieldIsOptional  = False
        }

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

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

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

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

-- | Sets custom functions on a field.
customField :: Q Exp -> Q Exp -> Field -> Field
customField readfn showfn field =
  field { fieldRead = Just readfn, fieldShow = Just showfn }

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

fieldVariable :: Field -> String
fieldVariable = map toLower . fieldRecordName

actualFieldType :: Field -> Q Type
actualFieldType f | fieldIsContainer f = [t| Container $t |]
                  | fieldIsOptional f  = [t| Maybe $t     |]
                  | otherwise = t
                  where t = fieldType f

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

loadFn :: Field -> Q Exp -> Q Exp
loadFn (Field { fieldIsContainer = True }) expr = [| $expr >>= readContainer |]
loadFn (Field { fieldRead = Just readfn }) expr = [| $expr >>= $readfn |]
loadFn _ expr = expr

saveFn :: Field -> Q Exp -> Q Exp
saveFn (Field { fieldIsContainer = True }) expr = [| showContainer $expr |]
saveFn (Field { fieldRead = Just readfn }) expr = [| $readfn $expr |]
saveFn _ expr = expr

-- * Common field declarations

timeStampFields :: [Field]
timeStampFields =
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
    ]

serialFields :: [Field]
serialFields =
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]

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

Iustin Pop's avatar
Iustin Pop committed
161
162
-- * Helper functions

163
164
165
-- | Ensure first letter is lowercase.
--
-- Used to convert type name to function prefix, e.g. in @data Aa ->
166
-- aaToRaw@.
167
168
169
170
ensureLower :: String -> String
ensureLower [] = []
ensureLower (x:xs) = toLower x:xs

171
172
173
174
175
176
177
-- | Ensure first letter is uppercase.
--
-- Used to convert constructor name to component
ensureUpper :: String -> String
ensureUpper [] = []
ensureUpper (x:xs) = toUpper x:xs

Iustin Pop's avatar
Iustin Pop committed
178
179
180
181
182
183
184
185
-- | Helper for quoted expressions.
varNameE :: String -> Q Exp
varNameE = varE . mkName

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

186
187
188
-- | ToRaw function name.
toRawName :: String -> Name
toRawName = mkName . (++ "ToRaw") . ensureLower
189

190
191
192
-- | FromRaw function name.
fromRawName :: String -> Name
fromRawName = mkName . (++ "FromRaw") . ensureLower
193

194
195
196
-- | Converts a name to it's varE/litE representations.
--
reprE :: Either String Name -> Q Exp
Iustin Pop's avatar
Iustin Pop committed
197
198
reprE = either stringE varE

199
200
201
202
203
204
205
206
-- | Smarter function application.
--
-- This does simply f x, except that if is 'id', it will skip it, in
-- order to generate more readable code when using -ddump-splices.
appFn :: Exp -> Exp -> Exp
appFn f x | f == VarE 'id = x
          | otherwise = AppE f x

207
208
209
210
211
212
213
214
-- | Container loader
readContainer :: (Monad m) => JSON.JSObject a -> m (Container a)
readContainer = return . M.fromList . JSON.fromJSObject

-- | Container dumper
showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue
showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList

215
-- * Template code for simple raw type-equivalent ADTs
216

217
218
219
220
221
-- | Generates a data type declaration.
--
-- The type will have a fixed list of instances.
strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
222
223
224
  DataD [] name []
          (map (flip NormalC [] . mkName) constructors)
          [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
225

226
-- | Generates a toRaw function.
227
228
229
230
--
-- This generates a simple function of the form:
--
-- @
231
232
233
-- nameToRaw :: Name -> /traw/
-- nameToRaw Cons1 = var1
-- nameToRaw Cons2 = \"value2\"
234
-- @
235
236
237
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genToRaw traw fname tname constructors = do
  sigt <- [t| $(conT tname) -> $(conT traw) |]
238
  -- the body clauses, matching on the constructor and returning the
239
  -- raw value
240
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
241
                             (normalB (reprE v)) []) constructors
242
243
  return [SigD fname sigt, FunD fname clauses]

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

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

304
305
306
307
308
declareIADT :: String -> [(String, Name)] -> Q [Dec]
declareIADT = declareADT ''Int

declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT = declareADT ''String
309
310
311
312
313
314

-- | Creates the showJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
315
-- showJSON = showJSON . /name/ToRaw
316
317
318
319
-- @
--
-- in an instance JSON /name/ declaration
genShowJSON :: String -> Q [Dec]
320
genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toRawName name)) |]
321
322
323
324
325
326
327

-- | Creates the readJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
-- readJSON s = case readJSON s of
328
--                Ok s' -> /name/FromRaw s'
329
330
331
332
333
334
335
336
--                Error e -> Error /description/
-- @
--
-- in an instance JSON /name/ declaration
genReadJSON :: String -> Q Dec
genReadJSON name = do
  let s = mkName "s"
  body <- [| case JSON.readJSON $(varE s) of
337
               JSON.Ok s' -> $(varE (fromRawName name)) s'
338
               JSON.Error e ->
339
                   JSON.Error $ "Can't parse raw value for type " ++
Iustin Pop's avatar
Iustin Pop committed
340
                           $(stringE name) ++ ": " ++ e
341
342
343
344
345
           |]
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]

-- | Generates a JSON instance for a given type.
--
346
-- This assumes that the /name/ToRaw and /name/FromRaw functions
347
348
349
350
351
352
353
-- have been defined as by the 'declareSADT' function.
makeJSONInstance :: Name -> Q [Dec]
makeJSONInstance name = do
  let base = nameBase name
  showJ <- genShowJSON base
  readJ <- genReadJSON base
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
354

Iustin Pop's avatar
Iustin Pop committed
355
356
-- * Template code for opcodes

357
358
359
360
361
-- | Transforms a CamelCase string into an_underscore_based_one.
deCamelCase :: String -> String
deCamelCase =
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)

362
363
364
365
366
-- | Transform an underscore_name into a CamelCase one.
camelCase :: String -> String
camelCase = concatMap (ensureUpper . drop 1) .
            groupBy (\_ b -> b /= '_') . ('_':)

367
-- | Computes the name of a given constructor.
368
369
370
371
372
constructorName :: Con -> Q Name
constructorName (NormalC name _) = return name
constructorName (RecC name _)    = return name
constructorName x                = fail $ "Unhandled constructor " ++ show x

373
-- | Builds the generic constructor-to-string function.
374
375
376
377
--
-- This generates a simple function of the following form:
--
-- @
378
379
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
380
381
382
-- @
--
-- This builds a custom list of name/string pairs and then uses
383
-- 'genToRaw' to actually generate the function
384
385
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
genConstrToStr trans_fun name fname = do
386
387
  TyConI (DataD _ _ _ cons _) <- reify name
  cnames <- mapM (liftM nameBase . constructorName) cons
388
  let svalues = map (Left . trans_fun) cnames
389
  genToRaw ''String (mkName fname) name $ zip cnames svalues
390

391
392
393
-- | Constructor-to-string for OpCode.
genOpID :: Name -> String -> Q [Dec]
genOpID = genConstrToStr deCamelCase
394

395
-- | OpCode parameter (field) type.
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
type OpParam = (String, Q Type, Q Exp)

-- | Generates the OpCode data type.
--
-- This takes an opcode logical definition, and builds both the
-- datatype and the JSON serialisation out of it. We can't use a
-- generic serialisation since we need to be compatible with Ganeti's
-- own, so we have a few quirks to work around.
--
-- There are three things to be defined for each parameter:
--
-- * name
--
-- * type; if this is 'Maybe', will only be serialised if it's a
--   'Just' value
--
-- * default; if missing, won't raise an exception, but will instead
--   use the default
--
genOpCode :: String                -- ^ Type name to use
          -> [(String, [OpParam])] -- ^ Constructor name and parameters
          -> Q [Dec]
genOpCode name cons = do
  decl_d <- mapM (\(cname, fields) -> do
                    -- we only need the type of the field, without Q
                    fields' <- mapM (\(_, qt, _) ->
                                         qt >>= \t -> return (NotStrict, t))
                               fields
                    return $ NormalC (mkName cname) fields')
            cons
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]

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

432
-- | Checks whether a given parameter is options.
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
--
-- This requires that it's a 'Maybe'.
isOptional :: Type -> Bool
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
isOptional _ = False

-- | Generates the \"save\" expression for a single opcode parameter.
--
-- There is only one special handling mode: if the parameter is of
-- 'Maybe' type, then we only save it if it's a 'Just' value,
-- otherwise we skip it.
saveField :: Name    -- ^ The name of variable that contains the value
          -> OpParam -- ^ Parameter definition
          -> Q Exp
saveField fvar (fname, qt, _) = do
  t <- qt
Iustin Pop's avatar
Iustin Pop committed
449
  let fnexp = stringE fname
450
451
452
      fvare = varE fvar
  (if isOptional t
   then [| case $fvare of
Iustin Pop's avatar
Iustin Pop committed
453
             Just v' -> [( $fnexp, $showJSONE v')]
454
455
             Nothing -> []
         |]
Iustin Pop's avatar
Iustin Pop committed
456
   else [| [( $fnexp, $showJSONE $fvare )] |])
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472

-- | Generates the \"save\" clause for an entire opcode constructor.
--
-- This matches the opcode with variables named the same as the
-- constructor fields (just so that the spliced in code looks nicer),
-- and passes those name plus the parameter definition to 'saveField'.
saveConstructor :: String    -- ^ The constructor name
                -> [OpParam] -- ^ The parameter definitions for this
                             -- constructor
                -> Q Clause  -- ^ Resulting clause
saveConstructor sname fields = do
  let cname = mkName sname
  let fnames = map (\(n, _, _) -> mkName n) fields
  let pat = conP cname (map varP fnames)
  let felems = map (uncurry saveField) (zip fnames fields)
      -- now build the OP_ID serialisation
Iustin Pop's avatar
Iustin Pop committed
473
474
      opid = [| [( $(stringE "OP_ID"),
                   $showJSONE $(stringE . deCamelCase $ sname) )] |]
475
476
      flist = listE (opid:felems)
      -- and finally convert all this to a json object
Iustin Pop's avatar
Iustin Pop committed
477
      flist' = [| $(varNameE "makeObj") (concat $flist) |]
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
  clause [pat] (normalB flist') []

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

-- | Generates the \"load\" field for a single parameter.
--
-- There is custom handling, depending on how the parameter is
-- specified. For a 'Maybe' type parameter, we allow that it is not
-- present (via 'Utils.maybeFromObj'). Otherwise, if there is a
-- default value, we allow the parameter to be abset, and finally if
-- there is no default value, we require its presence.
loadField :: OpParam -> Q (Name, Stmt)
loadField (fname, qt, qdefa) = do
  let fvar = mkName fname
  t <- qt
  defa <- qdefa
  -- these are used in all patterns below
Iustin Pop's avatar
Iustin Pop committed
504
505
  let objvar = varNameE "o"
      objfield = stringE fname
506
  bexp <- if isOptional t
Iustin Pop's avatar
Iustin Pop committed
507
          then [| $((varNameE "maybeFromObj")) $objvar $objfield |]
508
509
510
          else case defa of
                 AppE (ConE dt) defval | dt == 'Just ->
                   -- but has a default value
Iustin Pop's avatar
Iustin Pop committed
511
                   [| $(varNameE "fromObjWithDefault")
512
513
                      $objvar $objfield $(return defval) |]
                 ConE dt | dt == 'Nothing ->
Iustin Pop's avatar
Iustin Pop committed
514
                     [| $(varNameE "fromObj") $objvar $objfield |]
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
                 s -> fail $ "Invalid default value " ++ show s ++
                      ", expecting either 'Nothing' or a 'Just defval'"
  return (fvar, BindS (VarP fvar) bexp)

loadConstructor :: String -> [OpParam] -> Q Exp
loadConstructor sname fields = do
  let name = mkName sname
  fbinds <- mapM loadField fields
  let (fnames, fstmts) = unzip fbinds
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
  return $ DoE fstmts'

genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec)
genLoadOpCode opdefs = do
  let fname = mkName "loadOpCode"
      arg1 = mkName "v"
      objname = mkName "o"
      opid = mkName "op_id"
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
                                 (JSON.readJSON $(varE arg1)) |]
Iustin Pop's avatar
Iustin Pop committed
536
537
  st2 <- bindS (varP opid) [| $(varNameE "fromObj")
                              $(varE objname) $(stringE "OP_ID") |]
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
  -- the match results (per-constructor blocks)
  mexps <- mapM (uncurry loadConstructor) opdefs
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
  let mpats = map (\(me, c) ->
                       let mp = LitP . StringL . deCamelCase . fst $ c
                       in Match mp (NormalB me) []
                  ) $ zip mexps opdefs
      defmatch = Match WildP (NormalB fails) []
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
      body = DoE [st1, st2, cst]
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])

-- | No default type.
noDefault :: Q Exp
noDefault = conE 'Nothing
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583

-- * Template code for luxi

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

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

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

-- | Generates the LuxiOp data type.
--
-- This takes a Luxi operation definition and builds both the
-- datatype and the function trnasforming the arguments to JSON.
-- We can't use anything less generic, because the way different
-- operations are serialized differs on both parameter- and top-level.
--
-- There are three things to be defined for each parameter:
--
-- * name
--
-- * type
--
-- * operation; this is the operation performed on the parameter before
--   serialization
--
584
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
585
genLuxiOp name cons = do
586
  decl_d <- mapM (\(cname, fields) -> do
587
588
589
590
591
592
593
594
595
                    fields' <- mapM (\(_, qt, _) ->
                                         qt >>= \t -> return (NotStrict, t))
                               fields
                    return $ NormalC (mkName cname) fields')
            cons
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]
  (savesig, savefn) <- genSaveLuxiOp cons
  return [declD, savesig, savefn]

596
-- | Generates the \"save\" expression for a single luxi parameter.
597
598
599
saveLuxiField :: Name -> LuxiParam -> Q Exp
saveLuxiField fvar (_, qt, fn) =
    [| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |]
600

601
-- | Generates the \"save\" clause for entire LuxiOp constructor.
602
603
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
saveLuxiConstructor (sname, fields) = do
604
605
606
  let cname = mkName sname
      fnames = map (\(nm, _, _) -> mkName nm) fields
      pat = conP cname (map varP fnames)
607
608
609
610
      flist = map (uncurry saveLuxiField) (zip fnames fields)
      finval = if null flist
               then [| JSON.showJSON ()    |]
               else [| JSON.showJSON $(listE flist) |]
611
  clause [pat] (normalB finval) []
612
613

-- | Generates the main save LuxiOp function.
614
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
615
616
617
618
619
genSaveLuxiOp opdefs = do
  sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
  let fname = mkName "opToArgs"
  cclauses <- mapM saveLuxiConstructor opdefs
  return $ (SigD fname sigt, FunD fname cclauses)
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841

-- * "Objects" functionality

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

-- | Build an object declaration.
buildObject :: String -> String -> [Field] -> Q [Dec]
buildObject sname field_pfx fields = do
  let name = mkName sname
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
  let decl_d = RecC name fields_d
  let declD = DataD [] name [] [decl_d] [''Show, ''Read]
  ser_decls <- buildObjectSerialisation sname fields
  return $ declD:ser_decls

buildObjectSerialisation :: String -> [Field] -> Q [Dec]
buildObjectSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject saveObjectField sname fields
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
                 (rdjson:shjson)
  return $ savedecls ++ [loadsig, loadfn, instdecl]

genSaveObject :: (Name -> Field -> Q Exp)
              -> String -> [Field] -> Q [Dec]
genSaveObject save_fn sname fields = do
  let name = mkName sname
  let fnames = map (mkName . fieldVariable) fields
  let pat = conP name (map varP fnames)
  let tdname = mkName ("toDict" ++ sname)
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]

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

saveObjectField :: Name -> Field -> Q Exp
saveObjectField fvar field
  | isContainer = [| [( $nameE , $showJSONE . showContainer $ $fvarE)] |]
  | fisOptional = [| case $(varE fvar) of
                      Nothing -> []
                      Just v -> [( $nameE, $showJSONE v)]
                  |]
  | otherwise = case fieldShow field of
      Nothing -> [| [( $nameE, $showJSONE $fvarE)] |]
      Just fn -> [| [( $nameE, $showJSONE . $fn $ $fvarE)] |]
  where isContainer = fieldIsContainer field
        fisOptional  = fieldIsOptional field
        nameE = stringE (fieldName field)
        fvarE = varE fvar

objectShowJSON :: String -> Q [Dec]
objectShowJSON name =
  [d| showJSON = JSON.showJSON . $(varE . mkName $ "save" ++ name) |]

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

loadObjectField :: Field -> Q (Name, Stmt)
loadObjectField field = do
  let name = fieldVariable field
      fvar = mkName name
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE (fieldName field)
      loadexp =
        if fieldIsOptional field
          then [| $(varNameE "maybeFromObj") $objvar $objfield |]
          else case fieldDefault field of
                 Just defv ->
                   [| $(varNameE "fromObjWithDefault") $objvar
                      $objfield $defv |]
                 Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
  bexp <- loadFn field loadexp

  return (fvar, BindS (VarP fvar) bexp)

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

-- * Inheritable parameter tables implementation

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

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

-- | Build a parameter declaration.
--
-- This function builds two different data structures: a /filled/ one,
-- in which all fields are required, and a /partial/ one, in which all
-- fields are optional. Due to the current record syntax issues, the
-- fields need to be named differrently for the two structures, so the
-- partial ones get a /P/ suffix.
buildParam :: String -> String -> [Field] -> Q [Dec]
buildParam sname field_pfx fields = do
  let (sname_f, sname_p) = paramTypeNames sname
      name_f = mkName sname_f
      name_p = mkName sname_p
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
  let decl_f = RecC name_f fields_f
      decl_p = RecC name_p fields_p
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read]
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read]
  ser_decls_f <- buildObjectSerialisation sname_f fields
  ser_decls_p <- buildPParamSerialisation sname_p fields
  fill_decls <- fillParam sname field_pfx fields
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls

buildPParamSerialisation :: String -> [Field] -> Q [Dec]
buildPParamSerialisation sname fields = do
  let name = mkName sname
  savedecls <- genSaveObject savePParamField sname fields
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
  shjson <- objectShowJSON sname
  rdjson <- objectReadJSON sname
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
                 (rdjson:shjson)
  return $ savedecls ++ [loadsig, loadfn, instdecl]

savePParamField :: Name -> Field -> Q Exp
savePParamField fvar field = do
  checkNonOptDef field
  let actualVal = mkName "v"
  normalexpr <- saveObjectField actualVal field
  -- we have to construct the block here manually, because we can't
  -- splice-in-splice
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
                                       (NormalB (ConE '[])) []
                             , Match (ConP 'Just [VarP actualVal])
                                       (NormalB normalexpr) []
                             ]
loadPParamField :: Field -> Q (Name, Stmt)
loadPParamField field = do
  checkNonOptDef field
  let name = fieldName field
      fvar = mkName name
  -- these are used in all patterns below
  let objvar = varNameE "o"
      objfield = stringE name
      loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
  bexp <- loadFn field loadexp
  return (fvar, BindS (VarP fvar) bexp)

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

fillParam :: String -> String -> [Field] -> Q [Dec]
fillParam sname field_pfx fields = do
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
      (sname_f, sname_p) = paramTypeNames sname
      oname_f = "fobj"
      oname_p = "pobj"
      name_f = mkName sname_f
      name_p = mkName sname_p
      fun_name = mkName $ "fill" ++ sname ++ "Params"
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_f) []
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
                (NormalB . VarE . mkName $ oname_p) []
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
                $ map (mkName . ("n_" ++)) fnames
  le_new <- mapM buildFromMaybe fnames
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
  let sig = SigD fun_name funt
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
      fun = FunD fun_name [fclause]
  return [sig, fun]