THH.hs 29.3 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
-- * 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.
Iustin Pop's avatar
Iustin Pop committed
113
114
115
116
customField :: Name    -- ^ The name of the read function
            -> Name    -- ^ The name of the show function
            -> Field   -- ^ The original field
            -> Field   -- ^ Updated field
117
customField readfn showfn field =
Iustin Pop's avatar
Iustin Pop committed
118
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }
119
120
121
122
123

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

124
125
126
127
-- | 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'.
128
fieldVariable :: Field -> String
129
130
131
132
fieldVariable f =
  case (fieldConstr f) of
    Just name -> ensureLower name
    _ -> fieldName f
133
134
135
136
137
138
139
140
141
142
143
144
145
146

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 ()

147
148
149
150
151
152
153
154
155
156
157
158
-- | Produces the expression that will de-serialise a given
-- field. Since some custom parsing functions might need to use the
-- entire object, we do take and pass the object to any custom read
-- functions.
loadFn :: Field   -- ^ The field definition
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
       -> Q Exp   -- ^ The entire object in JSON object format
       -> Q Exp   -- ^ Resulting expression
loadFn (Field { fieldIsContainer = True }) expr _ =
  [| $expr >>= readContainer |]
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
loadFn _ expr _ = expr
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174

-- * 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
175
176
-- * Helper functions

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

185
186
187
188
189
190
191
-- | 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
192
193
194
195
196
197
198
199
-- | Helper for quoted expressions.
varNameE :: String -> Q Exp
varNameE = varE . mkName

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

200
201
202
-- | ToRaw function name.
toRawName :: String -> Name
toRawName = mkName . (++ "ToRaw") . ensureLower
203

204
205
206
-- | FromRaw function name.
fromRawName :: String -> Name
fromRawName = mkName . (++ "FromRaw") . ensureLower
207

208
209
210
-- | Converts a name to it's varE/litE representations.
--
reprE :: Either String Name -> Q Exp
Iustin Pop's avatar
Iustin Pop committed
211
212
reprE = either stringE varE

213
214
215
216
217
218
219
220
-- | 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

221
-- | Container loader
222
223
224
225
226
227
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
228
229
230
231
232

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

233
-- * Template code for simple raw type-equivalent ADTs
234

235
236
237
238
239
-- | Generates a data type declaration.
--
-- The type will have a fixed list of instances.
strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
240
241
242
  DataD [] name []
          (map (flip NormalC [] . mkName) constructors)
          [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
243

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

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

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

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

declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT = declareADT ''String
327
328
329
330
331
332

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

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

-- | Generates a JSON instance for a given type.
--
367
-- This assumes that the /name/ToRaw and /name/FromRaw functions
368
369
370
371
372
373
-- 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
374
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
375

Iustin Pop's avatar
Iustin Pop committed
376
377
-- * Template code for opcodes

378
379
380
381
382
-- | Transforms a CamelCase string into an_underscore_based_one.
deCamelCase :: String -> String
deCamelCase =
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)

383
384
385
386
387
-- | Transform an underscore_name into a CamelCase one.
camelCase :: String -> String
camelCase = concatMap (ensureUpper . drop 1) .
            groupBy (\_ b -> b /= '_') . ('_':)

388
-- | Computes the name of a given constructor.
389
390
391
392
393
constructorName :: Con -> Q Name
constructorName (NormalC name _) = return name
constructorName (RecC name _)    = return name
constructorName x                = fail $ "Unhandled constructor " ++ show x

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

412
413
414
-- | Constructor-to-string for OpCode.
genOpID :: Name -> String -> Q [Dec]
genOpID = genConstrToStr deCamelCase
415

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

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

-- | Generates the main save opcode function.
--
-- This builds a per-constructor match clause that contains the
-- respective constructor-serialisation code.
474
genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
475
476
477
478
479
480
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)

481
loadConstructor :: String -> [Field] -> Q Exp
482
483
loadConstructor sname fields = do
  let name = mkName sname
484
  fbinds <- mapM loadObjectField fields
485
486
487
488
489
  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'

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

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

557
-- | Generates the \"save\" expression for a single luxi parameter.
558
559
560
saveLuxiField :: Name -> LuxiParam -> Q Exp
saveLuxiField fvar (_, qt, fn) =
    [| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |]
561

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

-- | Generates the main save LuxiOp function.
575
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
576
577
578
579
580
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)
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596

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

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

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 |]
688
  bexp <- loadFn field loadexp objvar
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

  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
734
735
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
736
737
738
739
740
741
742
743
744
745
746
747
748
  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))
749
                 [rdjson, shjson]
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
  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 |]
773
  bexp <- loadFn field loadexp objvar
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
  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]