Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / THH.hs @ 9924d61e

History | View | Annotate | Download (31.6 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| TemplateHaskell helper for HTools.
4

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

    
9
-}
10

    
11
{-
12

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

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

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

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

    
30
-}
31

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

    
58
import Control.Monad (liftM)
59
import Data.Char
60
import Data.List
61
import Data.Maybe (fromMaybe)
62
import qualified Data.Set as Set
63
import Language.Haskell.TH
64

    
65
import qualified Text.JSON as JSON
66

    
67
-- * Exported types
68

    
69
-- | Class of objects that can be converted to 'JSObject'
70
-- lists-format.
71
class DictObject a where
72
  toDict :: a -> [(String, JSON.JSValue)]
73

    
74
-- | Serialised field data type.
75
data Field = Field { fieldName        :: String
76
                   , fieldType        :: Q Type
77
                   , fieldRead        :: Maybe (Q Exp)
78
                   , fieldShow        :: Maybe (Q Exp)
79
                   , fieldDefault     :: Maybe (Q Exp)
80
                   , fieldConstr      :: Maybe String
81
                   , fieldIsOptional  :: Bool
82
                   }
83

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

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

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

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

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

    
117
-- | Computes the record name for a given field, based on either the
118
-- string value in the JSON serialisation or the custom named if any
119
-- exists.
120
fieldRecordName :: Field -> String
121
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
122
  fromMaybe (camelCase name) alias
123

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

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

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

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

    
157
-- * Common field declarations
158

    
159
-- | Timestamp fields description.
160
timeStampFields :: [Field]
161
timeStampFields =
162
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
163
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
164
    ]
165

    
166
-- | Serial number fields description.
167
serialFields :: [Field]
168
serialFields =
169
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
170

    
171
-- | UUID fields description.
172
uuidFields :: [Field]
173
uuidFields = [ simpleField "uuid" [t| String |] ]
174

    
175
-- | Tag set type alias.
176
type TagSet = Set.Set String
177

    
178
-- | Tag field description.
179
tagsFields :: [Field]
180
tagsFields = [ defaultField [| Set.empty |] $
181
               simpleField "tags" [t| TagSet |] ]
182

    
183
-- * Helper functions
184

    
185
-- | Ensure first letter is lowercase.
186
--
187
-- Used to convert type name to function prefix, e.g. in @data Aa ->
188
-- aaToRaw@.
189
ensureLower :: String -> String
190
ensureLower [] = []
191
ensureLower (x:xs) = toLower x:xs
192

    
193
-- | Ensure first letter is uppercase.
194
--
195
-- Used to convert constructor name to component
196
ensureUpper :: String -> String
197
ensureUpper [] = []
198
ensureUpper (x:xs) = toUpper x:xs
199

    
200
-- | Helper for quoted expressions.
201
varNameE :: String -> Q Exp
202
varNameE = varE . mkName
203

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

    
208
-- | ToRaw function name.
209
toRawName :: String -> Name
210
toRawName = mkName . (++ "ToRaw") . ensureLower
211

    
212
-- | FromRaw function name.
213
fromRawName :: String -> Name
214
fromRawName = mkName . (++ "FromRaw") . ensureLower
215

    
216
-- | Converts a name to it's varE\/litE representations.
217
reprE :: Either String Name -> Q Exp
218
reprE = either stringE varE
219

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

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

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

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

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

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

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

    
320
declareSADT :: String -> [(String, Name)] -> Q [Dec]
321
declareSADT = declareADT ''String
322

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

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

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

    
371
-- * Template code for opcodes
372

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

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

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

    
389
-- | Extract all constructor names from a given type.
390
reifyConsNames :: Name -> Q [String]
391
reifyConsNames name = do
392
  reify_result <- reify name
393
  case reify_result of
394
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
395
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
396
                \ type constructor but got '" ++ show o ++ "'"
397

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

    
415
-- | Constructor-to-string for OpCode.
416
genOpID :: Name -> String -> Q [Dec]
417
genOpID = genConstrToStr deCamelCase
418

    
419
-- | Builds a list with all defined constructor names for a type.
420
--
421
-- @
422
-- vstr :: String
423
-- vstr = [...]
424
-- @
425
--
426
-- Where the actual values of the string are the constructor names
427
-- mapped via @trans_fun@.
428
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
429
genAllConstr trans_fun name vstr = do
430
  cnames <- reifyConsNames name
431
  let svalues = sort $ map trans_fun cnames
432
      vname = mkName vstr
433
      sig = SigD vname (AppT ListT (ConT ''String))
434
      body = NormalB (ListE (map (LitE . StringL) svalues))
435
  return $ [sig, ValD (VarP vname) body []]
436

    
437
-- | Generates a list of all defined opcode IDs.
438
genAllOpIDs :: Name -> String -> Q [Dec]
439
genAllOpIDs = genAllConstr deCamelCase
440

    
441
-- | OpCode parameter (field) type.
442
type OpParam = (String, Q Type, Q Exp)
443

    
444
-- | Generates the OpCode data type.
445
--
446
-- This takes an opcode logical definition, and builds both the
447
-- datatype and the JSON serialisation out of it. We can't use a
448
-- generic serialisation since we need to be compatible with Ganeti's
449
-- own, so we have a few quirks to work around.
450
genOpCode :: String                -- ^ Type name to use
451
          -> [(String, [Field])]   -- ^ Constructor name and parameters
452
          -> Q [Dec]
453
genOpCode name cons = do
454
  decl_d <- mapM (\(cname, fields) -> do
455
                    -- we only need the type of the field, without Q
456
                    fields' <- mapM actualFieldType fields
457
                    let fields'' = zip (repeat NotStrict) fields'
458
                    return $ NormalC (mkName cname) fields'')
459
            cons
460
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
461

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

    
466
-- | Checks whether a given parameter is options.
467
--
468
-- This requires that it's a 'Maybe'.
469
isOptional :: Type -> Bool
470
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
471
isOptional _ = False
472

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

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

    
506
-- | Generates load code for a single constructor of the opcode data type.
507
loadConstructor :: String -> [Field] -> Q Exp
508
loadConstructor sname fields = do
509
  let name = mkName sname
510
  fbinds <- mapM loadObjectField fields
511
  let (fnames, fstmts) = unzip fbinds
512
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
513
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
514
  return $ DoE fstmts'
515

    
516
-- | Generates the loadOpCode function.
517
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
518
genLoadOpCode opdefs = do
519
  let fname = mkName "loadOpCode"
520
      arg1 = mkName "v"
521
      objname = mkName "o"
522
      opid = mkName "op_id"
523
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
524
                                 (JSON.readJSON $(varE arg1)) |]
525
  st2 <- bindS (varP opid) [| $(varNameE "fromObj")
526
                              $(varE objname) $(stringE "OP_ID") |]
527
  -- the match results (per-constructor blocks)
528
  mexps <- mapM (uncurry loadConstructor) opdefs
529
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
530
  let mpats = map (\(me, c) ->
531
                       let mp = LitP . StringL . deCamelCase . fst $ c
532
                       in Match mp (NormalB me) []
533
                  ) $ zip mexps opdefs
534
      defmatch = Match WildP (NormalB fails) []
535
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
536
      body = DoE [st1, st2, cst]
537
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
538
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
539

    
540
-- * Template code for luxi
541

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

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

    
550
-- | LuxiOp parameter type.
551
type LuxiParam = (String, Q Type)
552

    
553
-- | Generates the LuxiOp data type.
554
--
555
-- This takes a Luxi operation definition and builds both the
556
-- datatype and the function trnasforming the arguments to JSON.
557
-- We can't use anything less generic, because the way different
558
-- operations are serialized differs on both parameter- and top-level.
559
--
560
-- There are two things to be defined for each parameter:
561
--
562
-- * name
563
--
564
-- * type
565
--
566
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
567
genLuxiOp name cons = do
568
  decl_d <- mapM (\(cname, fields) -> do
569
                    fields' <- mapM (\(_, qt) ->
570
                                         qt >>= \t -> return (NotStrict, t))
571
                               fields
572
                    return $ NormalC (mkName cname) fields')
573
            cons
574
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
575
  (savesig, savefn) <- genSaveLuxiOp cons
576
  req_defs <- declareSADT "LuxiReq" .
577
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
578
                  cons
579
  return $ [declD, savesig, savefn] ++ req_defs
580

    
581
-- | Generates the \"save\" expression for a single luxi parameter.
582
saveLuxiField :: Name -> LuxiParam -> Q Exp
583
saveLuxiField fvar (_, qt) =
584
    [| JSON.showJSON $(varE fvar) |]
585

    
586
-- | Generates the \"save\" clause for entire LuxiOp constructor.
587
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
588
saveLuxiConstructor (sname, fields) = do
589
  let cname = mkName sname
590
      fnames = map (mkName . fst) fields
591
      pat = conP cname (map varP fnames)
592
      flist = map (uncurry saveLuxiField) (zip fnames fields)
593
      finval = if null flist
594
               then [| JSON.showJSON ()    |]
595
               else [| JSON.showJSON $(listE flist) |]
596
  clause [pat] (normalB finval) []
597

    
598
-- | Generates the main save LuxiOp function.
599
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec)
600
genSaveLuxiOp opdefs = do
601
  sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
602
  let fname = mkName "opToArgs"
603
  cclauses <- mapM saveLuxiConstructor opdefs
604
  return $ (SigD fname sigt, FunD fname cclauses)
605

    
606
-- * "Objects" functionality
607

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

    
615
-- | Build an object declaration.
616
buildObject :: String -> String -> [Field] -> Q [Dec]
617
buildObject sname field_pfx fields = do
618
  let name = mkName sname
619
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
620
  let decl_d = RecC name fields_d
621
  let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
622
  ser_decls <- buildObjectSerialisation sname fields
623
  return $ declD:ser_decls
624

    
625
-- | Generates an object definition: data type and its JSON instance.
626
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
627
buildObjectSerialisation sname fields = do
628
  let name = mkName sname
629
  savedecls <- genSaveObject saveObjectField sname fields
630
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
631
  shjson <- objectShowJSON sname
632
  rdjson <- objectReadJSON sname
633
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
634
                 [rdjson, shjson]
635
  return $ savedecls ++ [loadsig, loadfn, instdecl]
636

    
637
-- | The toDict function name for a given type.
638
toDictName :: String -> Name
639
toDictName sname = mkName ("toDict" ++ sname)
640

    
641
-- | Generates the save object functionality.
642
genSaveObject :: (Name -> Field -> Q Exp)
643
              -> String -> [Field] -> Q [Dec]
644
genSaveObject save_fn sname fields = do
645
  let name = mkName sname
646
  fnames <- mapM (newName . fieldVariable) fields
647
  let pat = conP name (map varP fnames)
648
  let tdname = toDictName sname
649
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
650

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

    
663
-- | Generates the code for saving an object's field, handling the
664
-- various types of fields that we have.
665
saveObjectField :: Name -> Field -> Q Exp
666
saveObjectField fvar field
667
  | fisOptional = [| case $(varE fvar) of
668
                      Nothing -> []
669
                      Just v -> [( $nameE, JSON.showJSON v)]
670
                  |]
671
  | otherwise = case fieldShow field of
672
      Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
673
      Just fn -> [| let (actual, extra) = $fn $fvarE
674
                    in extra ++ [( $nameE, JSON.showJSON actual)]
675
                  |]
676
  where fisOptional  = fieldIsOptional field
677
        nameE = stringE (fieldName field)
678
        fvarE = varE fvar
679

    
680
-- | Generates the showJSON clause for a given object name.
681
objectShowJSON :: String -> Q Dec
682
objectShowJSON name = do
683
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
684
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
685

    
686
-- | Generates the load object functionality.
687
genLoadObject :: (Field -> Q (Name, Stmt))
688
              -> String -> [Field] -> Q (Dec, Dec)
689
genLoadObject load_fn sname fields = do
690
  let name = mkName sname
691
      funname = mkName $ "load" ++ sname
692
      arg1 = mkName "v"
693
      objname = mkName "o"
694
      opid = mkName "op_id"
695
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
696
                                 (JSON.readJSON $(varE arg1)) |]
697
  fbinds <- mapM load_fn fields
698
  let (fnames, fstmts) = unzip fbinds
699
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
700
      fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
701
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
702
  return $ (SigD funname sigt,
703
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
704

    
705
-- | Generates code for loading an object's field.
706
loadObjectField :: Field -> Q (Name, Stmt)
707
loadObjectField field = do
708
  let name = fieldVariable field
709
  fvar <- newName name
710
  -- these are used in all patterns below
711
  let objvar = varNameE "o"
712
      objfield = stringE (fieldName field)
713
      loadexp =
714
        if fieldIsOptional field
715
          then [| $(varNameE "maybeFromObj") $objvar $objfield |]
716
          else case fieldDefault field of
717
                 Just defv ->
718
                   [| $(varNameE "fromObjWithDefault") $objvar
719
                      $objfield $defv |]
720
                 Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
721
  bexp <- loadFn field loadexp objvar
722

    
723
  return (fvar, BindS (VarP fvar) bexp)
724

    
725
-- | Builds the readJSON instance for a given object name.
726
objectReadJSON :: String -> Q Dec
727
objectReadJSON name = do
728
  let s = mkName "s"
729
  body <- [| case JSON.readJSON $(varE s) of
730
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
731
               JSON.Error e ->
732
                 JSON.Error $ "Can't parse value for type " ++
733
                       $(stringE name) ++ ": " ++ e
734
           |]
735
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
736

    
737
-- * Inheritable parameter tables implementation
738

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

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

    
752
-- | Build a parameter declaration.
753
--
754
-- This function builds two different data structures: a /filled/ one,
755
-- in which all fields are required, and a /partial/ one, in which all
756
-- fields are optional. Due to the current record syntax issues, the
757
-- fields need to be named differrently for the two structures, so the
758
-- partial ones get a /P/ suffix.
759
buildParam :: String -> String -> [Field] -> Q [Dec]
760
buildParam sname field_pfx fields = do
761
  let (sname_f, sname_p) = paramTypeNames sname
762
      name_f = mkName sname_f
763
      name_p = mkName sname_p
764
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
765
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
766
  let decl_f = RecC name_f fields_f
767
      decl_p = RecC name_p fields_p
768
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
769
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
770
  ser_decls_f <- buildObjectSerialisation sname_f fields
771
  ser_decls_p <- buildPParamSerialisation sname_p fields
772
  fill_decls <- fillParam sname field_pfx fields
773
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
774
           buildParamAllFields sname fields ++
775
           buildDictObjectInst name_f sname_f
776

    
777
-- | Builds a list of all fields of a parameter.
778
buildParamAllFields :: String -> [Field] -> [Dec]
779
buildParamAllFields sname fields =
780
  let vname = mkName ("all" ++ sname ++ "ParamFields")
781
      sig = SigD vname (AppT ListT (ConT ''String))
782
      val = ListE $ map (LitE . StringL . fieldName) fields
783
  in [sig, ValD (VarP vname) (NormalB val) []]
784

    
785
-- | Builds the 'DictObject' instance for a filled parameter.
786
buildDictObjectInst :: Name -> String -> [Dec]
787
buildDictObjectInst name sname =
788
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
789
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
790

    
791
-- | Generates the serialisation for a partial parameter.
792
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
793
buildPParamSerialisation sname fields = do
794
  let name = mkName sname
795
  savedecls <- genSaveObject savePParamField sname fields
796
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
797
  shjson <- objectShowJSON sname
798
  rdjson <- objectReadJSON sname
799
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
800
                 [rdjson, shjson]
801
  return $ savedecls ++ [loadsig, loadfn, instdecl]
802

    
803
-- | Generates code to save an optional parameter field.
804
savePParamField :: Name -> Field -> Q Exp
805
savePParamField fvar field = do
806
  checkNonOptDef field
807
  let actualVal = mkName "v"
808
  normalexpr <- saveObjectField actualVal field
809
  -- we have to construct the block here manually, because we can't
810
  -- splice-in-splice
811
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
812
                                       (NormalB (ConE '[])) []
813
                             , Match (ConP 'Just [VarP actualVal])
814
                                       (NormalB normalexpr) []
815
                             ]
816

    
817
-- | Generates code to load an optional parameter field.
818
loadPParamField :: Field -> Q (Name, Stmt)
819
loadPParamField field = do
820
  checkNonOptDef field
821
  let name = fieldName field
822
  fvar <- newName name
823
  -- these are used in all patterns below
824
  let objvar = varNameE "o"
825
      objfield = stringE name
826
      loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
827
  bexp <- loadFn field loadexp objvar
828
  return (fvar, BindS (VarP fvar) bexp)
829

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

    
838
-- | Builds a function that executes the filling of partial parameter
839
-- from a full copy (similar to Python's fillDict).
840
fillParam :: String -> String -> [Field] -> Q [Dec]
841
fillParam sname field_pfx fields = do
842
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
843
      (sname_f, sname_p) = paramTypeNames sname
844
      oname_f = "fobj"
845
      oname_p = "pobj"
846
      name_f = mkName sname_f
847
      name_p = mkName sname_p
848
      fun_name = mkName $ "fill" ++ sname ++ "Params"
849
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
850
                (NormalB . VarE . mkName $ oname_f) []
851
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
852
                (NormalB . VarE . mkName $ oname_p) []
853
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
854
                $ map (mkName . ("n_" ++)) fnames
855
  le_new <- mapM buildFromMaybe fnames
856
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
857
  let sig = SigD fun_name funt
858
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
859
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
860
      fun = FunD fun_name [fclause]
861
  return [sig, fun]