Statistics
| Branch: | Tag: | Revision:

root / src / Ganeti / THH.hs @ 54c7dff7

History | View | Annotate | Download (40.5 kB)

1
{-# LANGUAGE TemplateHaskell #-}
2

    
3
{-| TemplateHaskell helper for Ganeti Haskell code.
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
                  , genAllConstr
37
                  , genAllOpIDs
38
                  , genOpCode
39
                  , genStrOfOp
40
                  , genStrOfKey
41
                  , genLuxiOp
42
                  , Field
43
                  , simpleField
44
                  , defaultField
45
                  , optionalField
46
                  , optionalNullSerField
47
                  , renameField
48
                  , customField
49
                  , timeStampFields
50
                  , uuidFields
51
                  , serialFields
52
                  , tagsFields
53
                  , TagSet
54
                  , buildObject
55
                  , buildObjectSerialisation
56
                  , buildParam
57
                  , DictObject(..)
58
                  , genException
59
                  , excErrMsg
60
                  ) where
61

    
62
import Control.Monad (liftM)
63
import Data.Char
64
import Data.List
65
import Data.Maybe (fromMaybe)
66
import qualified Data.Set as Set
67
import Language.Haskell.TH
68

    
69
import qualified Text.JSON as JSON
70
import Text.JSON.Pretty (pp_value)
71

    
72
import Ganeti.JSON
73

    
74
-- * Exported types
75

    
76
-- | Class of objects that can be converted to 'JSObject'
77
-- lists-format.
78
class DictObject a where
79
  toDict :: a -> [(String, JSON.JSValue)]
80

    
81
-- | Optional field information.
82
data OptionalType
83
  = NotOptional           -- ^ Field is not optional
84
  | OptionalOmitNull      -- ^ Field is optional, null is not serialised
85
  | OptionalSerializeNull -- ^ Field is optional, null is serialised
86
  deriving (Show, Eq)
87

    
88
-- | Serialised field data type.
89
data Field = Field { fieldName        :: String
90
                   , fieldType        :: Q Type
91
                   , fieldRead        :: Maybe (Q Exp)
92
                   , fieldShow        :: Maybe (Q Exp)
93
                   , fieldExtraKeys   :: [String]
94
                   , fieldDefault     :: Maybe (Q Exp)
95
                   , fieldConstr      :: Maybe String
96
                   , fieldIsOptional  :: OptionalType
97
                   }
98

    
99
-- | Generates a simple field.
100
simpleField :: String -> Q Type -> Field
101
simpleField fname ftype =
102
  Field { fieldName        = fname
103
        , fieldType        = ftype
104
        , fieldRead        = Nothing
105
        , fieldShow        = Nothing
106
        , fieldExtraKeys   = []
107
        , fieldDefault     = Nothing
108
        , fieldConstr      = Nothing
109
        , fieldIsOptional  = NotOptional
110
        }
111

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

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

    
121
-- | Marks a field optional (turning its base type into a Maybe).
122
optionalField :: Field -> Field
123
optionalField field = field { fieldIsOptional = OptionalOmitNull }
124

    
125
-- | Marks a field optional (turning its base type into a Maybe), but
126
-- with 'Nothing' serialised explicitly as /null/.
127
optionalNullSerField :: Field -> Field
128
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
129

    
130
-- | Sets custom functions on a field.
131
customField :: Name      -- ^ The name of the read function
132
            -> Name      -- ^ The name of the show function
133
            -> [String]  -- ^ The name of extra field keys
134
            -> Field     -- ^ The original field
135
            -> Field     -- ^ Updated field
136
customField readfn showfn extra field =
137
  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
138
        , fieldExtraKeys = extra }
139

    
140
-- | Computes the record name for a given field, based on either the
141
-- string value in the JSON serialisation or the custom named if any
142
-- exists.
143
fieldRecordName :: Field -> String
144
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
145
  fromMaybe (camelCase name) alias
146

    
147
-- | Computes the preferred variable name to use for the value of this
148
-- field. If the field has a specific constructor name, then we use a
149
-- first-letter-lowercased version of that; otherwise, we simply use
150
-- the field name. See also 'fieldRecordName'.
151
fieldVariable :: Field -> String
152
fieldVariable f =
153
  case (fieldConstr f) of
154
    Just name -> ensureLower name
155
    _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
156

    
157
-- | Compute the actual field type (taking into account possible
158
-- optional status).
159
actualFieldType :: Field -> Q Type
160
actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
161
                  | otherwise = t
162
                  where t = fieldType f
163

    
164
-- | Checks that a given field is not optional (for object types or
165
-- fields which should not allow this case).
166
checkNonOptDef :: (Monad m) => Field -> m ()
167
checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
168
                      , fieldName = name }) =
169
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
170
checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
171
                      , fieldName = name }) =
172
  fail $ "Optional field " ++ name ++ " used in parameter declaration"
173
checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
174
  fail $ "Default field " ++ name ++ " used in parameter declaration"
175
checkNonOptDef _ = return ()
176

    
177
-- | Produces the expression that will de-serialise a given
178
-- field. Since some custom parsing functions might need to use the
179
-- entire object, we do take and pass the object to any custom read
180
-- functions.
181
loadFn :: Field   -- ^ The field definition
182
       -> Q Exp   -- ^ The value of the field as existing in the JSON message
183
       -> Q Exp   -- ^ The entire object in JSON object format
184
       -> Q Exp   -- ^ Resulting expression
185
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
186
loadFn _ expr _ = expr
187

    
188
-- * Common field declarations
189

    
190
-- | Timestamp fields description.
191
timeStampFields :: [Field]
192
timeStampFields =
193
    [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
194
    , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
195
    ]
196

    
197
-- | Serial number fields description.
198
serialFields :: [Field]
199
serialFields =
200
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
201

    
202
-- | UUID fields description.
203
uuidFields :: [Field]
204
uuidFields = [ simpleField "uuid" [t| String |] ]
205

    
206
-- | Tag set type alias.
207
type TagSet = Set.Set String
208

    
209
-- | Tag field description.
210
tagsFields :: [Field]
211
tagsFields = [ defaultField [| Set.empty |] $
212
               simpleField "tags" [t| TagSet |] ]
213

    
214
-- * Internal types
215

    
216
-- | A simple field, in constrast to the customisable 'Field' type.
217
type SimpleField = (String, Q Type)
218

    
219
-- | A definition for a single constructor for a simple object.
220
type SimpleConstructor = (String, [SimpleField])
221

    
222
-- | A definition for ADTs with simple fields.
223
type SimpleObject = [SimpleConstructor]
224

    
225
-- | A type alias for a constructor of a regular object.
226
type Constructor = (String, [Field])
227

    
228
-- * Helper functions
229

    
230
-- | Ensure first letter is lowercase.
231
--
232
-- Used to convert type name to function prefix, e.g. in @data Aa ->
233
-- aaToRaw@.
234
ensureLower :: String -> String
235
ensureLower [] = []
236
ensureLower (x:xs) = toLower x:xs
237

    
238
-- | Ensure first letter is uppercase.
239
--
240
-- Used to convert constructor name to component
241
ensureUpper :: String -> String
242
ensureUpper [] = []
243
ensureUpper (x:xs) = toUpper x:xs
244

    
245
-- | Helper for quoted expressions.
246
varNameE :: String -> Q Exp
247
varNameE = varE . mkName
248

    
249
-- | showJSON as an expression, for reuse.
250
showJSONE :: Q Exp
251
showJSONE = varE 'JSON.showJSON
252

    
253
-- | makeObj as an expression, for reuse.
254
makeObjE :: Q Exp
255
makeObjE = varE 'JSON.makeObj
256

    
257
-- | fromObj (Ganeti specific) as an expression, for reuse.
258
fromObjE :: Q Exp
259
fromObjE = varE 'fromObj
260

    
261
-- | ToRaw function name.
262
toRawName :: String -> Name
263
toRawName = mkName . (++ "ToRaw") . ensureLower
264

    
265
-- | FromRaw function name.
266
fromRawName :: String -> Name
267
fromRawName = mkName . (++ "FromRaw") . ensureLower
268

    
269
-- | Converts a name to it's varE\/litE representations.
270
reprE :: Either String Name -> Q Exp
271
reprE = either stringE varE
272

    
273
-- | Smarter function application.
274
--
275
-- This does simply f x, except that if is 'id', it will skip it, in
276
-- order to generate more readable code when using -ddump-splices.
277
appFn :: Exp -> Exp -> Exp
278
appFn f x | f == VarE 'id = x
279
          | otherwise = AppE f x
280

    
281
-- | Builds a field for a normal constructor.
282
buildConsField :: Q Type -> StrictTypeQ
283
buildConsField ftype = do
284
  ftype' <- ftype
285
  return (NotStrict, ftype')
286

    
287
-- | Builds a constructor based on a simple definition (not field-based).
288
buildSimpleCons :: Name -> SimpleObject -> Q Dec
289
buildSimpleCons tname cons = do
290
  decl_d <- mapM (\(cname, fields) -> do
291
                    fields' <- mapM (buildConsField . snd) fields
292
                    return $ NormalC (mkName cname) fields') cons
293
  return $ DataD [] tname [] decl_d [''Show, ''Eq]
294

    
295
-- | Generate the save function for a given type.
296
genSaveSimpleObj :: Name                            -- ^ Object type
297
                 -> String                          -- ^ Function name
298
                 -> SimpleObject                    -- ^ Object definition
299
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
300
                 -> Q (Dec, Dec)
301
genSaveSimpleObj tname sname opdefs fn = do
302
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
303
      fname = mkName sname
304
  cclauses <- mapM fn opdefs
305
  return $ (SigD fname sigt, FunD fname cclauses)
306

    
307
-- * Template code for simple raw type-equivalent ADTs
308

    
309
-- | Generates a data type declaration.
310
--
311
-- The type will have a fixed list of instances.
312
strADTDecl :: Name -> [String] -> Dec
313
strADTDecl name constructors =
314
  DataD [] name []
315
          (map (flip NormalC [] . mkName) constructors)
316
          [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
317

    
318
-- | Generates a toRaw function.
319
--
320
-- This generates a simple function of the form:
321
--
322
-- @
323
-- nameToRaw :: Name -> /traw/
324
-- nameToRaw Cons1 = var1
325
-- nameToRaw Cons2 = \"value2\"
326
-- @
327
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
328
genToRaw traw fname tname constructors = do
329
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
330
  -- the body clauses, matching on the constructor and returning the
331
  -- raw value
332
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
333
                             (normalB (reprE v)) []) constructors
334
  return [SigD fname sigt, FunD fname clauses]
335

    
336
-- | Generates a fromRaw function.
337
--
338
-- The function generated is monadic and can fail parsing the
339
-- raw value. It is of the form:
340
--
341
-- @
342
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
343
-- nameFromRaw s | s == var1       = Cons1
344
--               | s == \"value2\" = Cons2
345
--               | otherwise = fail /.../
346
-- @
347
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
348
genFromRaw traw fname tname constructors = do
349
  -- signature of form (Monad m) => String -> m $name
350
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
351
  -- clauses for a guarded pattern
352
  let varp = mkName "s"
353
      varpe = varE varp
354
  clauses <- mapM (\(c, v) -> do
355
                     -- the clause match condition
356
                     g <- normalG [| $varpe == $(varE v) |]
357
                     -- the clause result
358
                     r <- [| return $(conE (mkName c)) |]
359
                     return (g, r)) constructors
360
  -- the otherwise clause (fallback)
361
  oth_clause <- do
362
    g <- normalG [| otherwise |]
363
    r <- [|fail ("Invalid string value for type " ++
364
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
365
    return (g, r)
366
  let fun = FunD fname [Clause [VarP varp]
367
                        (GuardedB (clauses++[oth_clause])) []]
368
  return [SigD fname sigt, fun]
369

    
370
-- | Generates a data type from a given raw format.
371
--
372
-- The format is expected to multiline. The first line contains the
373
-- type name, and the rest of the lines must contain two words: the
374
-- constructor name and then the string representation of the
375
-- respective constructor.
376
--
377
-- The function will generate the data type declaration, and then two
378
-- functions:
379
--
380
-- * /name/ToRaw, which converts the type to a raw type
381
--
382
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
383
--
384
-- Note that this is basically just a custom show\/read instance,
385
-- nothing else.
386
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
387
declareADT traw sname cons = do
388
  let name = mkName sname
389
      ddecl = strADTDecl name (map fst cons)
390
      -- process cons in the format expected by genToRaw
391
      cons' = map (\(a, b) -> (a, Right b)) cons
392
  toraw <- genToRaw traw (toRawName sname) name cons'
393
  fromraw <- genFromRaw traw (fromRawName sname) name cons
394
  return $ ddecl:toraw ++ fromraw
395

    
396
declareIADT :: String -> [(String, Name)] -> Q [Dec]
397
declareIADT = declareADT ''Int
398

    
399
declareSADT :: String -> [(String, Name)] -> Q [Dec]
400
declareSADT = declareADT ''String
401

    
402
-- | Creates the showJSON member of a JSON instance declaration.
403
--
404
-- This will create what is the equivalent of:
405
--
406
-- @
407
-- showJSON = showJSON . /name/ToRaw
408
-- @
409
--
410
-- in an instance JSON /name/ declaration
411
genShowJSON :: String -> Q Dec
412
genShowJSON name = do
413
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
414
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
415

    
416
-- | Creates the readJSON member of a JSON instance declaration.
417
--
418
-- This will create what is the equivalent of:
419
--
420
-- @
421
-- readJSON s = case readJSON s of
422
--                Ok s' -> /name/FromRaw s'
423
--                Error e -> Error /description/
424
-- @
425
--
426
-- in an instance JSON /name/ declaration
427
genReadJSON :: String -> Q Dec
428
genReadJSON name = do
429
  let s = mkName "s"
430
  body <- [| case JSON.readJSON $(varE s) of
431
               JSON.Ok s' -> $(varE (fromRawName name)) s'
432
               JSON.Error e ->
433
                   JSON.Error $ "Can't parse raw value for type " ++
434
                           $(stringE name) ++ ": " ++ e ++ " from " ++
435
                           show $(varE s)
436
           |]
437
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
438

    
439
-- | Generates a JSON instance for a given type.
440
--
441
-- This assumes that the /name/ToRaw and /name/FromRaw functions
442
-- have been defined as by the 'declareSADT' function.
443
makeJSONInstance :: Name -> Q [Dec]
444
makeJSONInstance name = do
445
  let base = nameBase name
446
  showJ <- genShowJSON base
447
  readJ <- genReadJSON base
448
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
449

    
450
-- * Template code for opcodes
451

    
452
-- | Transforms a CamelCase string into an_underscore_based_one.
453
deCamelCase :: String -> String
454
deCamelCase =
455
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
456

    
457
-- | Transform an underscore_name into a CamelCase one.
458
camelCase :: String -> String
459
camelCase = concatMap (ensureUpper . drop 1) .
460
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
461

    
462
-- | Computes the name of a given constructor.
463
constructorName :: Con -> Q Name
464
constructorName (NormalC name _) = return name
465
constructorName (RecC name _)    = return name
466
constructorName x                = fail $ "Unhandled constructor " ++ show x
467

    
468
-- | Extract all constructor names from a given type.
469
reifyConsNames :: Name -> Q [String]
470
reifyConsNames name = do
471
  reify_result <- reify name
472
  case reify_result of
473
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
474
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
475
                \ type constructor but got '" ++ show o ++ "'"
476

    
477
-- | Builds the generic constructor-to-string function.
478
--
479
-- This generates a simple function of the following form:
480
--
481
-- @
482
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
483
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
484
-- @
485
--
486
-- This builds a custom list of name\/string pairs and then uses
487
-- 'genToRaw' to actually generate the function.
488
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
489
genConstrToStr trans_fun name fname = do
490
  cnames <- reifyConsNames name
491
  let svalues = map (Left . trans_fun) cnames
492
  genToRaw ''String (mkName fname) name $ zip cnames svalues
493

    
494
-- | Constructor-to-string for OpCode.
495
genOpID :: Name -> String -> Q [Dec]
496
genOpID = genConstrToStr deCamelCase
497

    
498
-- | Builds a list with all defined constructor names for a type.
499
--
500
-- @
501
-- vstr :: String
502
-- vstr = [...]
503
-- @
504
--
505
-- Where the actual values of the string are the constructor names
506
-- mapped via @trans_fun@.
507
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
508
genAllConstr trans_fun name vstr = do
509
  cnames <- reifyConsNames name
510
  let svalues = sort $ map trans_fun cnames
511
      vname = mkName vstr
512
      sig = SigD vname (AppT ListT (ConT ''String))
513
      body = NormalB (ListE (map (LitE . StringL) svalues))
514
  return $ [sig, ValD (VarP vname) body []]
515

    
516
-- | Generates a list of all defined opcode IDs.
517
genAllOpIDs :: Name -> String -> Q [Dec]
518
genAllOpIDs = genAllConstr deCamelCase
519

    
520
-- | OpCode parameter (field) type.
521
type OpParam = (String, Q Type, Q Exp)
522

    
523
-- | Generates the OpCode data type.
524
--
525
-- This takes an opcode logical definition, and builds both the
526
-- datatype and the JSON serialisation out of it. We can't use a
527
-- generic serialisation since we need to be compatible with Ganeti's
528
-- own, so we have a few quirks to work around.
529
genOpCode :: String        -- ^ Type name to use
530
          -> [Constructor] -- ^ Constructor name and parameters
531
          -> Q [Dec]
532
genOpCode name cons = do
533
  let tname = mkName name
534
  decl_d <- mapM (\(cname, fields) -> do
535
                    -- we only need the type of the field, without Q
536
                    fields' <- mapM (fieldTypeInfo "op") fields
537
                    return $ RecC (mkName cname) fields')
538
            cons
539
  let declD = DataD [] tname [] decl_d [''Show, ''Eq]
540

    
541
  let (allfsig, allffn) = genAllOpFields "allOpFields" cons
542
  save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
543
               cons (uncurry saveConstructor) True
544
  (loadsig, loadfn) <- genLoadOpCode cons
545
  return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs
546

    
547
-- | Generates the function pattern returning the list of fields for a
548
-- given constructor.
549
genOpConsFields :: Constructor -> Clause
550
genOpConsFields (cname, fields) =
551
  let op_id = deCamelCase cname
552
      fvals = map (LitE . StringL) . sort . nub $
553
              concatMap (\f -> fieldName f:fieldExtraKeys f) fields
554
  in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
555

    
556
-- | Generates a list of all fields of an opcode constructor.
557
genAllOpFields  :: String        -- ^ Function name
558
                -> [Constructor] -- ^ Object definition
559
                -> (Dec, Dec)
560
genAllOpFields sname opdefs =
561
  let cclauses = map genOpConsFields opdefs
562
      other = Clause [WildP] (NormalB (ListE [])) []
563
      fname = mkName sname
564
      sigt = AppT  (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
565
  in (SigD fname sigt, FunD fname (cclauses++[other]))
566

    
567
-- | Generates the \"save\" clause for an entire opcode constructor.
568
--
569
-- This matches the opcode with variables named the same as the
570
-- constructor fields (just so that the spliced in code looks nicer),
571
-- and passes those name plus the parameter definition to 'saveObjectField'.
572
saveConstructor :: String    -- ^ The constructor name
573
                -> [Field]   -- ^ The parameter definitions for this
574
                             -- constructor
575
                -> Q Clause  -- ^ Resulting clause
576
saveConstructor sname fields = do
577
  let cname = mkName sname
578
  fnames <- mapM (newName . fieldVariable) fields
579
  let pat = conP cname (map varP fnames)
580
  let felems = map (uncurry saveObjectField) (zip fnames fields)
581
      -- now build the OP_ID serialisation
582
      opid = [| [( $(stringE "OP_ID"),
583
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
584
      flist = listE (opid:felems)
585
      -- and finally convert all this to a json object
586
      flist' = [| concat $flist |]
587
  clause [pat] (normalB flist') []
588

    
589
-- | Generates the main save opcode function.
590
--
591
-- This builds a per-constructor match clause that contains the
592
-- respective constructor-serialisation code.
593
genSaveOpCode :: Name                      -- ^ Object ype
594
              -> String                    -- ^ To 'JSValue' function name
595
              -> String                    -- ^ To 'JSObject' function name
596
              -> [Constructor]             -- ^ Object definition
597
              -> (Constructor -> Q Clause) -- ^ Constructor save fn
598
              -> Bool                      -- ^ Whether to generate
599
                                           -- obj or just a
600
                                           -- list\/tuple of values
601
              -> Q [Dec]
602
genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
603
  tdclauses <- mapM fn opdefs
604
  let typecon = ConT tname
605
      jvalname = mkName jvalstr
606
      jvalsig = AppT  (AppT ArrowT typecon) (ConT ''JSON.JSValue)
607
      tdname = mkName tdstr
608
  tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
609
  jvalclause <- if gen_object
610
                  then [| $makeObjE . $(varE tdname) |]
611
                  else [| JSON.showJSON . map snd . $(varE tdname) |]
612
  return [ SigD tdname tdsig
613
         , FunD tdname tdclauses
614
         , SigD jvalname jvalsig
615
         , ValD (VarP jvalname) (NormalB jvalclause) []]
616

    
617
-- | Generates load code for a single constructor of the opcode data type.
618
loadConstructor :: String -> [Field] -> Q Exp
619
loadConstructor sname fields = do
620
  let name = mkName sname
621
  fbinds <- mapM loadObjectField fields
622
  let (fnames, fstmts) = unzip fbinds
623
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
624
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
625
  return $ DoE fstmts'
626

    
627
-- | Generates the loadOpCode function.
628
genLoadOpCode :: [Constructor] -> Q (Dec, Dec)
629
genLoadOpCode opdefs = do
630
  let fname = mkName "loadOpCode"
631
      arg1 = mkName "v"
632
      objname = mkName "o"
633
      opid = mkName "op_id"
634
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
635
                                 (JSON.readJSON $(varE arg1)) |]
636
  st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
637
  -- the match results (per-constructor blocks)
638
  mexps <- mapM (uncurry loadConstructor) opdefs
639
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
640
  let mpats = map (\(me, c) ->
641
                       let mp = LitP . StringL . deCamelCase . fst $ c
642
                       in Match mp (NormalB me) []
643
                  ) $ zip mexps opdefs
644
      defmatch = Match WildP (NormalB fails) []
645
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
646
      body = DoE [st1, st2, cst]
647
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
648
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
649

    
650
-- * Template code for luxi
651

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

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

    
660
-- | Generates the LuxiOp data type.
661
--
662
-- This takes a Luxi operation definition and builds both the
663
-- datatype and the function trnasforming the arguments to JSON.
664
-- We can't use anything less generic, because the way different
665
-- operations are serialized differs on both parameter- and top-level.
666
--
667
-- There are two things to be defined for each parameter:
668
--
669
-- * name
670
--
671
-- * type
672
--
673
genLuxiOp :: String -> [Constructor] -> Q [Dec]
674
genLuxiOp name cons = do
675
  let tname = mkName name
676
  decl_d <- mapM (\(cname, fields) -> do
677
                    -- we only need the type of the field, without Q
678
                    fields' <- mapM actualFieldType fields
679
                    let fields'' = zip (repeat NotStrict) fields'
680
                    return $ NormalC (mkName cname) fields'')
681
            cons
682
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
683
  save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
684
               cons saveLuxiConstructor False
685
  req_defs <- declareSADT "LuxiReq" .
686
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
687
                  cons
688
  return $ declD:save_decs ++ req_defs
689

    
690
-- | Generates the \"save\" clause for entire LuxiOp constructor.
691
saveLuxiConstructor :: Constructor -> Q Clause
692
saveLuxiConstructor (sname, fields) = do
693
  let cname = mkName sname
694
  fnames <- mapM (newName . fieldVariable) fields
695
  let pat = conP cname (map varP fnames)
696
  let felems = map (uncurry saveObjectField) (zip fnames fields)
697
      flist = [| concat $(listE felems) |]
698
  clause [pat] (normalB flist) []
699

    
700
-- * "Objects" functionality
701

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

    
709
-- | Build an object declaration.
710
buildObject :: String -> String -> [Field] -> Q [Dec]
711
buildObject sname field_pfx fields = do
712
  let name = mkName sname
713
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
714
  let decl_d = RecC name fields_d
715
  let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
716
  ser_decls <- buildObjectSerialisation sname fields
717
  return $ declD:ser_decls
718

    
719
-- | Generates an object definition: data type and its JSON instance.
720
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
721
buildObjectSerialisation sname fields = do
722
  let name = mkName sname
723
  savedecls <- genSaveObject saveObjectField sname fields
724
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
725
  shjson <- objectShowJSON sname
726
  rdjson <- objectReadJSON sname
727
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
728
                 [rdjson, shjson]
729
  return $ savedecls ++ [loadsig, loadfn, instdecl]
730

    
731
-- | The toDict function name for a given type.
732
toDictName :: String -> Name
733
toDictName sname = mkName ("toDict" ++ sname)
734

    
735
-- | Generates the save object functionality.
736
genSaveObject :: (Name -> Field -> Q Exp)
737
              -> String -> [Field] -> Q [Dec]
738
genSaveObject save_fn sname fields = do
739
  let name = mkName sname
740
  fnames <- mapM (newName . fieldVariable) fields
741
  let pat = conP name (map varP fnames)
742
  let tdname = toDictName sname
743
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
744

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

    
757
-- | Generates the code for saving an object's field, handling the
758
-- various types of fields that we have.
759
saveObjectField :: Name -> Field -> Q Exp
760
saveObjectField fvar field =
761
  case fieldIsOptional field of
762
    OptionalOmitNull -> [| case $(varE fvar) of
763
                             Nothing -> []
764
                             Just v  -> [( $nameE, JSON.showJSON v )]
765
                         |]
766
    OptionalSerializeNull -> [| case $(varE fvar) of
767
                                  Nothing -> [( $nameE, JSON.JSNull )]
768
                                  Just v  -> [( $nameE, JSON.showJSON v )]
769
                              |]
770
    NotOptional ->
771
      case fieldShow field of
772
        -- Note: the order of actual:extra is important, since for
773
        -- some serialisation types (e.g. Luxi), we use tuples
774
        -- (positional info) rather than object (name info)
775
        Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
776
        Just fn -> [| let (actual, extra) = $fn $fvarE
777
                      in ($nameE, JSON.showJSON actual):extra
778
                    |]
779
  where nameE = stringE (fieldName field)
780
        fvarE = varE fvar
781

    
782
-- | Generates the showJSON clause for a given object name.
783
objectShowJSON :: String -> Q Dec
784
objectShowJSON name = do
785
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
786
  return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
787

    
788
-- | Generates the load object functionality.
789
genLoadObject :: (Field -> Q (Name, Stmt))
790
              -> String -> [Field] -> Q (Dec, Dec)
791
genLoadObject load_fn sname fields = do
792
  let name = mkName sname
793
      funname = mkName $ "load" ++ sname
794
      arg1 = mkName $ if null fields then "_" else "v"
795
      objname = mkName "o"
796
      opid = mkName "op_id"
797
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
798
                                 (JSON.readJSON $(varE arg1)) |]
799
  fbinds <- mapM load_fn fields
800
  let (fnames, fstmts) = unzip fbinds
801
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
802
      retstmt = [NoBindS (AppE (VarE 'return) cval)]
803
      -- FIXME: should we require an empty dict for an empty type?
804
      -- this allows any JSValue right now
805
      fstmts' = if null fields
806
                  then retstmt
807
                  else st1:fstmts ++ retstmt
808
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
809
  return $ (SigD funname sigt,
810
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
811

    
812
-- | Generates code for loading an object's field.
813
loadObjectField :: Field -> Q (Name, Stmt)
814
loadObjectField field = do
815
  let name = fieldVariable field
816
  fvar <- newName name
817
  -- these are used in all patterns below
818
  let objvar = varNameE "o"
819
      objfield = stringE (fieldName field)
820
      loadexp =
821
        if fieldIsOptional field /= NotOptional
822
          -- we treat both optional types the same, since
823
          -- 'maybeFromObj' can deal with both missing and null values
824
          -- appropriately (the same)
825
          then [| $(varE 'maybeFromObj) $objvar $objfield |]
826
          else case fieldDefault field of
827
                 Just defv ->
828
                   [| $(varE 'fromObjWithDefault) $objvar
829
                      $objfield $defv |]
830
                 Nothing -> [| $fromObjE $objvar $objfield |]
831
  bexp <- loadFn field loadexp objvar
832

    
833
  return (fvar, BindS (VarP fvar) bexp)
834

    
835
-- | Builds the readJSON instance for a given object name.
836
objectReadJSON :: String -> Q Dec
837
objectReadJSON name = do
838
  let s = mkName "s"
839
  body <- [| case JSON.readJSON $(varE s) of
840
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
841
               JSON.Error e ->
842
                 JSON.Error $ "Can't parse value for type " ++
843
                       $(stringE name) ++ ": " ++ e
844
           |]
845
  return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
846

    
847
-- * Inheritable parameter tables implementation
848

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

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

    
862
-- | Build a parameter declaration.
863
--
864
-- This function builds two different data structures: a /filled/ one,
865
-- in which all fields are required, and a /partial/ one, in which all
866
-- fields are optional. Due to the current record syntax issues, the
867
-- fields need to be named differrently for the two structures, so the
868
-- partial ones get a /P/ suffix.
869
buildParam :: String -> String -> [Field] -> Q [Dec]
870
buildParam sname field_pfx fields = do
871
  let (sname_f, sname_p) = paramTypeNames sname
872
      name_f = mkName sname_f
873
      name_p = mkName sname_p
874
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
875
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
876
  let decl_f = RecC name_f fields_f
877
      decl_p = RecC name_p fields_p
878
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
879
      declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
880
  ser_decls_f <- buildObjectSerialisation sname_f fields
881
  ser_decls_p <- buildPParamSerialisation sname_p fields
882
  fill_decls <- fillParam sname field_pfx fields
883
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
884
           buildParamAllFields sname fields ++
885
           buildDictObjectInst name_f sname_f
886

    
887
-- | Builds a list of all fields of a parameter.
888
buildParamAllFields :: String -> [Field] -> [Dec]
889
buildParamAllFields sname fields =
890
  let vname = mkName ("all" ++ sname ++ "ParamFields")
891
      sig = SigD vname (AppT ListT (ConT ''String))
892
      val = ListE $ map (LitE . StringL . fieldName) fields
893
  in [sig, ValD (VarP vname) (NormalB val) []]
894

    
895
-- | Builds the 'DictObject' instance for a filled parameter.
896
buildDictObjectInst :: Name -> String -> [Dec]
897
buildDictObjectInst name sname =
898
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
899
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
900

    
901
-- | Generates the serialisation for a partial parameter.
902
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
903
buildPParamSerialisation sname fields = do
904
  let name = mkName sname
905
  savedecls <- genSaveObject savePParamField sname fields
906
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
907
  shjson <- objectShowJSON sname
908
  rdjson <- objectReadJSON sname
909
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
910
                 [rdjson, shjson]
911
  return $ savedecls ++ [loadsig, loadfn, instdecl]
912

    
913
-- | Generates code to save an optional parameter field.
914
savePParamField :: Name -> Field -> Q Exp
915
savePParamField fvar field = do
916
  checkNonOptDef field
917
  let actualVal = mkName "v"
918
  normalexpr <- saveObjectField actualVal field
919
  -- we have to construct the block here manually, because we can't
920
  -- splice-in-splice
921
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
922
                                       (NormalB (ConE '[])) []
923
                             , Match (ConP 'Just [VarP actualVal])
924
                                       (NormalB normalexpr) []
925
                             ]
926

    
927
-- | Generates code to load an optional parameter field.
928
loadPParamField :: Field -> Q (Name, Stmt)
929
loadPParamField field = do
930
  checkNonOptDef field
931
  let name = fieldName field
932
  fvar <- newName name
933
  -- these are used in all patterns below
934
  let objvar = varNameE "o"
935
      objfield = stringE name
936
      loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
937
  bexp <- loadFn field loadexp objvar
938
  return (fvar, BindS (VarP fvar) bexp)
939

    
940
-- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
941
buildFromMaybe :: String -> Q Dec
942
buildFromMaybe fname =
943
  valD (varP (mkName $ "n_" ++ fname))
944
         (normalB [| $(varE 'fromMaybe)
945
                        $(varNameE $ "f_" ++ fname)
946
                        $(varNameE $ "p_" ++ fname) |]) []
947

    
948
-- | Builds a function that executes the filling of partial parameter
949
-- from a full copy (similar to Python's fillDict).
950
fillParam :: String -> String -> [Field] -> Q [Dec]
951
fillParam sname field_pfx fields = do
952
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
953
      (sname_f, sname_p) = paramTypeNames sname
954
      oname_f = "fobj"
955
      oname_p = "pobj"
956
      name_f = mkName sname_f
957
      name_p = mkName sname_p
958
      fun_name = mkName $ "fill" ++ sname ++ "Params"
959
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
960
                (NormalB . VarE . mkName $ oname_f) []
961
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
962
                (NormalB . VarE . mkName $ oname_p) []
963
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
964
                $ map (mkName . ("n_" ++)) fnames
965
  le_new <- mapM buildFromMaybe fnames
966
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
967
  let sig = SigD fun_name funt
968
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
969
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
970
      fun = FunD fun_name [fclause]
971
  return [sig, fun]
972

    
973
-- * Template code for exceptions
974

    
975
-- | Exception simple error message field.
976
excErrMsg :: (String, Q Type)
977
excErrMsg = ("errMsg", [t| String |])
978

    
979
-- | Builds an exception type definition.
980
genException :: String                  -- ^ Name of new type
981
             -> SimpleObject -- ^ Constructor name and parameters
982
             -> Q [Dec]
983
genException name cons = do
984
  let tname = mkName name
985
  declD <- buildSimpleCons tname cons
986
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
987
                         uncurry saveExcCons
988
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
989
  return [declD, loadsig, loadfn, savesig, savefn]
990

    
991
-- | Generates the \"save\" clause for an entire exception constructor.
992
--
993
-- This matches the exception with variables named the same as the
994
-- constructor fields (just so that the spliced in code looks nicer),
995
-- and calls showJSON on it.
996
saveExcCons :: String        -- ^ The constructor name
997
            -> [SimpleField] -- ^ The parameter definitions for this
998
                             -- constructor
999
            -> Q Clause      -- ^ Resulting clause
1000
saveExcCons sname fields = do
1001
  let cname = mkName sname
1002
  fnames <- mapM (newName . fst) fields
1003
  let pat = conP cname (map varP fnames)
1004
      felems = if null fnames
1005
                 then conE '() -- otherwise, empty list has no type
1006
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
1007
  let tup = tupE [ litE (stringL sname), felems ]
1008
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
1009

    
1010
-- | Generates load code for a single constructor of an exception.
1011
--
1012
-- Generates the code (if there's only one argument, we will use a
1013
-- list, not a tuple:
1014
--
1015
-- @
1016
-- do
1017
--  (x1, x2, ...) <- readJSON args
1018
--  return $ Cons x1 x2 ...
1019
-- @
1020
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
1021
loadExcConstructor inname sname fields = do
1022
  let name = mkName sname
1023
  f_names <- mapM (newName . fst) fields
1024
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
1025
  let binds = case f_names of
1026
                [x] -> BindS (ListP [VarP x])
1027
                _   -> BindS (TupP (map VarP f_names))
1028
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
1029
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
1030

    
1031
{-| Generates the loadException function.
1032

    
1033
This generates a quite complicated function, along the lines of:
1034

    
1035
@
1036
loadFn (JSArray [JSString name, args]) = case name of
1037
   "A1" -> do
1038
     (x1, x2, ...) <- readJSON args
1039
     return $ A1 x1 x2 ...
1040
   "a2" -> ...
1041
   s -> fail $ "Unknown exception" ++ s
1042
loadFn v = fail $ "Expected array but got " ++ show v
1043
@
1044
-}
1045
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
1046
genLoadExc tname sname opdefs = do
1047
  let fname = mkName sname
1048
  exc_name <- newName "name"
1049
  exc_args <- newName "args"
1050
  exc_else <- newName "s"
1051
  arg_else <- newName "v"
1052
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
1053
  -- default match for unknown exception name
1054
  let defmatch = Match (VarP exc_else) (NormalB fails) []
1055
  -- the match results (per-constructor blocks)
1056
  str_matches <-
1057
    mapM (\(s, params) -> do
1058
            body_exp <- loadExcConstructor exc_args s params
1059
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
1060
    opdefs
1061
  -- the first function clause; we can't use [| |] due to TH
1062
  -- limitations, so we have to build the AST by hand
1063
  let clause1 = Clause [ConP 'JSON.JSArray
1064
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
1065
                                            VarP exc_args]]]
1066
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
1067
                                        (VarE exc_name))
1068
                          (str_matches ++ [defmatch]))) []
1069
  -- the fail expression for the second function clause
1070
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
1071
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
1072
                |]
1073
  -- the second function clause
1074
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
1075
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
1076
  return $ (SigD fname sigt, FunD fname [clause1, clause2])