THH.hs 28.9 KB
Newer Older
1
{-# LANGUAGE TemplateHaskell #-}
2
3
4
5
6
7
8
9
10
11
12

{-| 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).

-}

{-

13
Copyright (C) 2011, 2012 Google Inc.
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

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
                  , genOpCode
37
38
39
                  , genStrOfOp
                  , genStrOfKey
                  , genLuxiOp
40
41
42
43
44
45
46
47
48
49
50
51
52
53
                  , Field
                  , simpleField
                  , defaultField
                  , optionalField
                  , renameField
                  , containerField
                  , customField
                  , timeStampFields
                  , uuidFields
                  , serialFields
                  , buildObject
                  , buildObjectSerialisation
                  , buildParam
                  , Container
54
55
                  ) where

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

import qualified Text.JSON as JSON

65
66
import Ganeti.HTools.JSON

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
-- * 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

121
122
123
124
-- | Computes the preferred variable name to use for the value of this
-- field. If the field has a specific constructor name, then we use a
-- first-letter-lowercased version of that; otherwise, we simply use
-- the field name. See also 'fieldRecordName'.
125
fieldVariable :: Field -> String
126
127
128
129
fieldVariable f =
  case (fieldConstr f) of
    Just name -> ensureLower name
    _ -> fieldName f
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
161
162
163
164
165
166
167
168

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
169
170
-- * Helper functions

171
172
173
-- | Ensure first letter is lowercase.
--
-- Used to convert type name to function prefix, e.g. in @data Aa ->
174
-- aaToRaw@.
175
176
177
178
ensureLower :: String -> String
ensureLower [] = []
ensureLower (x:xs) = toLower x:xs

179
180
181
182
183
184
185
-- | 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
186
187
188
189
190
191
192
193
-- | Helper for quoted expressions.
varNameE :: String -> Q Exp
varNameE = varE . mkName

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

194
195
196
-- | ToRaw function name.
toRawName :: String -> Name
toRawName = mkName . (++ "ToRaw") . ensureLower
197

198
199
200
-- | FromRaw function name.
fromRawName :: String -> Name
fromRawName = mkName . (++ "FromRaw") . ensureLower
201

202
203
204
-- | Converts a name to it's varE/litE representations.
--
reprE :: Either String Name -> Q Exp
Iustin Pop's avatar
Iustin Pop committed
205
206
reprE = either stringE varE

207
208
209
210
211
212
213
214
-- | 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

215
-- | Container loader
216
217
218
219
220
221
readContainer :: (Monad m, JSON.JSON a) =>
                 JSON.JSObject JSON.JSValue -> m (Container a)
readContainer obj = do
  let kjvlist = JSON.fromJSObject obj
  kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
  return $ M.fromList kalist
222
223
224
225
226

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

227
-- * Template code for simple raw type-equivalent ADTs
228

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

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

256
-- | Generates a fromRaw function.
257
258
--
-- The function generated is monadic and can fail parsing the
259
-- raw value. It is of the form:
260
261
--
-- @
262
263
264
265
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
-- nameFromRaw s | s == var1       = Cons1
--               | s == \"value2\" = Cons2
--               | otherwise = fail /.../
266
-- @
267
268
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
genFromRaw traw fname tname constructors = do
269
  -- signature of form (Monad m) => String -> m $name
270
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
271
272
273
274
275
276
277
278
279
280
281
282
283
  -- 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 " ++
284
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
285
286
287
288
289
    return (g, r)
  let fun = FunD fname [Clause [VarP varp]
                        (GuardedB (clauses++[oth_clause])) []]
  return [SigD fname sigt, fun]

290
-- | Generates a data type from a given raw format.
291
292
293
294
295
296
297
298
299
--
-- 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:
--
300
-- * /name/ToRaw, which converts the type to a raw type
301
--
302
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
303
304
305
--
-- Note that this is basically just a custom show/read instance,
-- nothing else.
306
307
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
declareADT traw sname cons = do
308
309
  let name = mkName sname
      ddecl = strADTDecl name (map fst cons)
310
      -- process cons in the format expected by genToRaw
311
      cons' = map (\(a, b) -> (a, Right b)) cons
312
313
314
  toraw <- genToRaw traw (toRawName sname) name cons'
  fromraw <- genFromRaw traw (fromRawName sname) name cons
  return $ ddecl:toraw ++ fromraw
315

316
317
318
319
320
declareIADT :: String -> [(String, Name)] -> Q [Dec]
declareIADT = declareADT ''Int

declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT = declareADT ''String
321
322
323
324
325
326

-- | Creates the showJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
327
-- showJSON = showJSON . /name/ToRaw
328
329
330
-- @
--
-- in an instance JSON /name/ declaration
331
332
333
334
genShowJSON :: String -> Q Dec
genShowJSON name = do
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
335
336
337
338
339
340
341

-- | Creates the readJSON member of a JSON instance declaration.
--
-- This will create what is the equivalent of:
--
-- @
-- readJSON s = case readJSON s of
342
--                Ok s' -> /name/FromRaw s'
343
344
345
346
347
348
349
350
--                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
351
               JSON.Ok s' -> $(varE (fromRawName name)) s'
352
               JSON.Error e ->
353
                   JSON.Error $ "Can't parse raw value for type " ++
354
355
                           $(stringE name) ++ ": " ++ e ++ " from " ++
                           show $(varE s)
356
357
358
359
360
           |]
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]

-- | Generates a JSON instance for a given type.
--
361
-- This assumes that the /name/ToRaw and /name/FromRaw functions
362
363
364
365
366
367
-- 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
368
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
369

Iustin Pop's avatar
Iustin Pop committed
370
371
-- * Template code for opcodes

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

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

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

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

406
407
408
-- | Constructor-to-string for OpCode.
genOpID :: Name -> String -> Q [Dec]
genOpID = genConstrToStr deCamelCase
409

410
-- | OpCode parameter (field) type.
411
412
413
414
415
416
417
418
419
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.
genOpCode :: String                -- ^ Type name to use
420
          -> [(String, [Field])]   -- ^ Constructor name and parameters
421
422
423
424
          -> Q [Dec]
genOpCode name cons = do
  decl_d <- mapM (\(cname, fields) -> do
                    -- we only need the type of the field, without Q
425
426
427
                    fields' <- mapM actualFieldType fields
                    let fields'' = zip (repeat NotStrict) fields'
                    return $ NormalC (mkName cname) fields'')
428
429
430
431
432
433
434
            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]

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

-- | 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),
446
-- and passes those name plus the parameter definition to 'saveObjectField'.
447
saveConstructor :: String    -- ^ The constructor name
448
                -> [Field]   -- ^ The parameter definitions for this
449
450
451
452
                             -- constructor
                -> Q Clause  -- ^ Resulting clause
saveConstructor sname fields = do
  let cname = mkName sname
453
  let fnames = map (mkName . fieldVariable) fields
454
  let pat = conP cname (map varP fnames)
455
  let felems = map (uncurry saveObjectField) (zip fnames fields)
456
      -- now build the OP_ID serialisation
Iustin Pop's avatar
Iustin Pop committed
457
      opid = [| [( $(stringE "OP_ID"),
458
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
459
460
      flist = listE (opid:felems)
      -- and finally convert all this to a json object
Iustin Pop's avatar
Iustin Pop committed
461
      flist' = [| $(varNameE "makeObj") (concat $flist) |]
462
463
464
465
466
467
  clause [pat] (normalB flist') []

-- | Generates the main save opcode function.
--
-- This builds a per-constructor match clause that contains the
-- respective constructor-serialisation code.
468
genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
469
470
471
472
473
474
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)

475
loadConstructor :: String -> [Field] -> Q Exp
476
477
loadConstructor sname fields = do
  let name = mkName sname
478
  fbinds <- mapM loadObjectField fields
479
480
481
482
483
  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'

484
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
485
486
487
488
489
490
491
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
492
493
  st2 <- bindS (varP opid) [| $(varNameE "fromObj")
                              $(varE objname) $(stringE "OP_ID") |]
494
495
496
497
498
499
500
501
502
503
504
505
506
  -- 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) []])

507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
-- * 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
--
536
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
537
genLuxiOp name cons = do
538
  decl_d <- mapM (\(cname, fields) -> do
539
540
541
542
543
                    fields' <- mapM (\(_, qt, _) ->
                                         qt >>= \t -> return (NotStrict, t))
                               fields
                    return $ NormalC (mkName cname) fields')
            cons
544
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
545
  (savesig, savefn) <- genSaveLuxiOp cons
Iustin Pop's avatar
Iustin Pop committed
546
547
548
549
  req_defs <- declareSADT "LuxiReq" .
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
                  cons
  return $ [declD, savesig, savefn] ++ req_defs
550

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

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

-- | Generates the main save LuxiOp function.
569
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
570
571
572
573
574
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)
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590

-- * "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
591
  let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
592
593
594
595
596
597
598
599
600
601
602
  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))
603
                 [rdjson, shjson]
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
  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
629
  | isContainer = [| [( $nameE , JSON.showJSON . showContainer $ $fvarE)] |]
630
631
  | fisOptional = [| case $(varE fvar) of
                      Nothing -> []
632
                      Just v -> [( $nameE, JSON.showJSON v)]
633
634
                  |]
  | otherwise = case fieldShow field of
635
636
      Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
      Just fn -> [| [( $nameE, JSON.showJSON . $fn $ $fvarE)] |]
637
638
639
640
641
  where isContainer = fieldIsContainer field
        fisOptional  = fieldIsOptional field
        nameE = stringE (fieldName field)
        fvarE = varE fvar

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

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
726
727
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
728
729
730
731
732
733
734
735
736
737
738
739
740
  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))
741
                 [rdjson, shjson]
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
  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]