Statistics
| Branch: | Tag: | Revision:

root / htools / Ganeti / THH.hs @ ef3ad027

History | View | Annotate | Download (36.6 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
                  , 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
                  , genException
57
                  , excErrMsg
58
                  ) where
59

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

    
67
import qualified Text.JSON as JSON
68
import Text.JSON.Pretty (pp_value)
69

    
70
-- * Exported types
71

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

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

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

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

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

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

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

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

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

    
137
actualFieldType :: Field -> Q Type
138
actualFieldType f | fieldIsOptional f  = [t| Maybe $t     |]
139
                  | otherwise = t
140
                  where t = fieldType f
141

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

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

    
160
-- * Common field declarations
161

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

    
169
-- | Serial number fields description.
170
serialFields :: [Field]
171
serialFields =
172
    [ renameField  "Serial" $ simpleField "serial_no" [t| Int |] ]
173

    
174
-- | UUID fields description.
175
uuidFields :: [Field]
176
uuidFields = [ simpleField "uuid" [t| String |] ]
177

    
178
-- | Tag set type alias.
179
type TagSet = Set.Set String
180

    
181
-- | Tag field description.
182
tagsFields :: [Field]
183
tagsFields = [ defaultField [| Set.empty |] $
184
               simpleField "tags" [t| TagSet |] ]
185

    
186
-- * Internal types
187

    
188
-- | A simple field, in constrast to the customisable 'Field' type.
189
type SimpleField = (String, Q Type)
190

    
191
-- | A definition for a single constructor for a simple object.
192
type SimpleConstructor = (String, [SimpleField])
193

    
194
-- | A definition for ADTs with simple fields.
195
type SimpleObject = [SimpleConstructor]
196

    
197
-- * Helper functions
198

    
199
-- | Ensure first letter is lowercase.
200
--
201
-- Used to convert type name to function prefix, e.g. in @data Aa ->
202
-- aaToRaw@.
203
ensureLower :: String -> String
204
ensureLower [] = []
205
ensureLower (x:xs) = toLower x:xs
206

    
207
-- | Ensure first letter is uppercase.
208
--
209
-- Used to convert constructor name to component
210
ensureUpper :: String -> String
211
ensureUpper [] = []
212
ensureUpper (x:xs) = toUpper x:xs
213

    
214
-- | Helper for quoted expressions.
215
varNameE :: String -> Q Exp
216
varNameE = varE . mkName
217

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

    
222
-- | ToRaw function name.
223
toRawName :: String -> Name
224
toRawName = mkName . (++ "ToRaw") . ensureLower
225

    
226
-- | FromRaw function name.
227
fromRawName :: String -> Name
228
fromRawName = mkName . (++ "FromRaw") . ensureLower
229

    
230
-- | Converts a name to it's varE\/litE representations.
231
reprE :: Either String Name -> Q Exp
232
reprE = either stringE varE
233

    
234
-- | Smarter function application.
235
--
236
-- This does simply f x, except that if is 'id', it will skip it, in
237
-- order to generate more readable code when using -ddump-splices.
238
appFn :: Exp -> Exp -> Exp
239
appFn f x | f == VarE 'id = x
240
          | otherwise = AppE f x
241

    
242
-- | Builds a field for a normal constructor.
243
buildConsField :: Q Type -> StrictTypeQ
244
buildConsField ftype = do
245
  ftype' <- ftype
246
  return (NotStrict, ftype')
247

    
248
-- | Builds a constructor based on a simple definition (not field-based).
249
buildSimpleCons :: Name -> SimpleObject -> Q Dec
250
buildSimpleCons tname cons = do
251
  decl_d <- mapM (\(cname, fields) -> do
252
                    fields' <- mapM (buildConsField . snd) fields
253
                    return $ NormalC (mkName cname) fields') cons
254
  return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
255

    
256
-- | Generate the save function for a given type.
257
genSaveSimpleObj :: Name                            -- ^ Object type
258
                 -> String                          -- ^ Function name
259
                 -> SimpleObject                    -- ^ Object definition
260
                 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
261
                 -> Q (Dec, Dec)
262
genSaveSimpleObj tname sname opdefs fn = do
263
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
264
      fname = mkName sname
265
  cclauses <- mapM fn opdefs
266
  return $ (SigD fname sigt, FunD fname cclauses)
267

    
268
-- * Template code for simple raw type-equivalent ADTs
269

    
270
-- | Generates a data type declaration.
271
--
272
-- The type will have a fixed list of instances.
273
strADTDecl :: Name -> [String] -> Dec
274
strADTDecl name constructors =
275
  DataD [] name []
276
          (map (flip NormalC [] . mkName) constructors)
277
          [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
278

    
279
-- | Generates a toRaw function.
280
--
281
-- This generates a simple function of the form:
282
--
283
-- @
284
-- nameToRaw :: Name -> /traw/
285
-- nameToRaw Cons1 = var1
286
-- nameToRaw Cons2 = \"value2\"
287
-- @
288
genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
289
genToRaw traw fname tname constructors = do
290
  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
291
  -- the body clauses, matching on the constructor and returning the
292
  -- raw value
293
  clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
294
                             (normalB (reprE v)) []) constructors
295
  return [SigD fname sigt, FunD fname clauses]
296

    
297
-- | Generates a fromRaw function.
298
--
299
-- The function generated is monadic and can fail parsing the
300
-- raw value. It is of the form:
301
--
302
-- @
303
-- nameFromRaw :: (Monad m) => /traw/ -> m Name
304
-- nameFromRaw s | s == var1       = Cons1
305
--               | s == \"value2\" = Cons2
306
--               | otherwise = fail /.../
307
-- @
308
genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
309
genFromRaw traw fname tname constructors = do
310
  -- signature of form (Monad m) => String -> m $name
311
  sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
312
  -- clauses for a guarded pattern
313
  let varp = mkName "s"
314
      varpe = varE varp
315
  clauses <- mapM (\(c, v) -> do
316
                     -- the clause match condition
317
                     g <- normalG [| $varpe == $(varE v) |]
318
                     -- the clause result
319
                     r <- [| return $(conE (mkName c)) |]
320
                     return (g, r)) constructors
321
  -- the otherwise clause (fallback)
322
  oth_clause <- do
323
    g <- normalG [| otherwise |]
324
    r <- [|fail ("Invalid string value for type " ++
325
                 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
326
    return (g, r)
327
  let fun = FunD fname [Clause [VarP varp]
328
                        (GuardedB (clauses++[oth_clause])) []]
329
  return [SigD fname sigt, fun]
330

    
331
-- | Generates a data type from a given raw format.
332
--
333
-- The format is expected to multiline. The first line contains the
334
-- type name, and the rest of the lines must contain two words: the
335
-- constructor name and then the string representation of the
336
-- respective constructor.
337
--
338
-- The function will generate the data type declaration, and then two
339
-- functions:
340
--
341
-- * /name/ToRaw, which converts the type to a raw type
342
--
343
-- * /name/FromRaw, which (monadically) converts from a raw type to the type
344
--
345
-- Note that this is basically just a custom show\/read instance,
346
-- nothing else.
347
declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
348
declareADT traw sname cons = do
349
  let name = mkName sname
350
      ddecl = strADTDecl name (map fst cons)
351
      -- process cons in the format expected by genToRaw
352
      cons' = map (\(a, b) -> (a, Right b)) cons
353
  toraw <- genToRaw traw (toRawName sname) name cons'
354
  fromraw <- genFromRaw traw (fromRawName sname) name cons
355
  return $ ddecl:toraw ++ fromraw
356

    
357
declareIADT :: String -> [(String, Name)] -> Q [Dec]
358
declareIADT = declareADT ''Int
359

    
360
declareSADT :: String -> [(String, Name)] -> Q [Dec]
361
declareSADT = declareADT ''String
362

    
363
-- | Creates the showJSON member of a JSON instance declaration.
364
--
365
-- This will create what is the equivalent of:
366
--
367
-- @
368
-- showJSON = showJSON . /name/ToRaw
369
-- @
370
--
371
-- in an instance JSON /name/ declaration
372
genShowJSON :: String -> Q Dec
373
genShowJSON name = do
374
  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
375
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
376

    
377
-- | Creates the readJSON member of a JSON instance declaration.
378
--
379
-- This will create what is the equivalent of:
380
--
381
-- @
382
-- readJSON s = case readJSON s of
383
--                Ok s' -> /name/FromRaw s'
384
--                Error e -> Error /description/
385
-- @
386
--
387
-- in an instance JSON /name/ declaration
388
genReadJSON :: String -> Q Dec
389
genReadJSON name = do
390
  let s = mkName "s"
391
  body <- [| case JSON.readJSON $(varE s) of
392
               JSON.Ok s' -> $(varE (fromRawName name)) s'
393
               JSON.Error e ->
394
                   JSON.Error $ "Can't parse raw value for type " ++
395
                           $(stringE name) ++ ": " ++ e ++ " from " ++
396
                           show $(varE s)
397
           |]
398
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
399

    
400
-- | Generates a JSON instance for a given type.
401
--
402
-- This assumes that the /name/ToRaw and /name/FromRaw functions
403
-- have been defined as by the 'declareSADT' function.
404
makeJSONInstance :: Name -> Q [Dec]
405
makeJSONInstance name = do
406
  let base = nameBase name
407
  showJ <- genShowJSON base
408
  readJ <- genReadJSON base
409
  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
410

    
411
-- * Template code for opcodes
412

    
413
-- | Transforms a CamelCase string into an_underscore_based_one.
414
deCamelCase :: String -> String
415
deCamelCase =
416
    intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
417

    
418
-- | Transform an underscore_name into a CamelCase one.
419
camelCase :: String -> String
420
camelCase = concatMap (ensureUpper . drop 1) .
421
            groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
422

    
423
-- | Computes the name of a given constructor.
424
constructorName :: Con -> Q Name
425
constructorName (NormalC name _) = return name
426
constructorName (RecC name _)    = return name
427
constructorName x                = fail $ "Unhandled constructor " ++ show x
428

    
429
-- | Extract all constructor names from a given type.
430
reifyConsNames :: Name -> Q [String]
431
reifyConsNames name = do
432
  reify_result <- reify name
433
  case reify_result of
434
    TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
435
    o -> fail $ "Unhandled name passed to reifyConsNames, expected\
436
                \ type constructor but got '" ++ show o ++ "'"
437

    
438
-- | Builds the generic constructor-to-string function.
439
--
440
-- This generates a simple function of the following form:
441
--
442
-- @
443
-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
444
-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
445
-- @
446
--
447
-- This builds a custom list of name\/string pairs and then uses
448
-- 'genToRaw' to actually generate the function.
449
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
450
genConstrToStr trans_fun name fname = do
451
  cnames <- reifyConsNames name
452
  let svalues = map (Left . trans_fun) cnames
453
  genToRaw ''String (mkName fname) name $ zip cnames svalues
454

    
455
-- | Constructor-to-string for OpCode.
456
genOpID :: Name -> String -> Q [Dec]
457
genOpID = genConstrToStr deCamelCase
458

    
459
-- | Builds a list with all defined constructor names for a type.
460
--
461
-- @
462
-- vstr :: String
463
-- vstr = [...]
464
-- @
465
--
466
-- Where the actual values of the string are the constructor names
467
-- mapped via @trans_fun@.
468
genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
469
genAllConstr trans_fun name vstr = do
470
  cnames <- reifyConsNames name
471
  let svalues = sort $ map trans_fun cnames
472
      vname = mkName vstr
473
      sig = SigD vname (AppT ListT (ConT ''String))
474
      body = NormalB (ListE (map (LitE . StringL) svalues))
475
  return $ [sig, ValD (VarP vname) body []]
476

    
477
-- | Generates a list of all defined opcode IDs.
478
genAllOpIDs :: Name -> String -> Q [Dec]
479
genAllOpIDs = genAllConstr deCamelCase
480

    
481
-- | OpCode parameter (field) type.
482
type OpParam = (String, Q Type, Q Exp)
483

    
484
-- | Generates the OpCode data type.
485
--
486
-- This takes an opcode logical definition, and builds both the
487
-- datatype and the JSON serialisation out of it. We can't use a
488
-- generic serialisation since we need to be compatible with Ganeti's
489
-- own, so we have a few quirks to work around.
490
genOpCode :: String                -- ^ Type name to use
491
          -> [(String, [Field])]   -- ^ Constructor name and parameters
492
          -> Q [Dec]
493
genOpCode name cons = do
494
  decl_d <- mapM (\(cname, fields) -> do
495
                    -- we only need the type of the field, without Q
496
                    fields' <- mapM actualFieldType fields
497
                    let fields'' = zip (repeat NotStrict) fields'
498
                    return $ NormalC (mkName cname) fields'')
499
            cons
500
  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
501

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

    
506
-- | Checks whether a given parameter is options.
507
--
508
-- This requires that it's a 'Maybe'.
509
isOptional :: Type -> Bool
510
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
511
isOptional _ = False
512

    
513
-- | Generates the \"save\" clause for an entire opcode constructor.
514
--
515
-- This matches the opcode with variables named the same as the
516
-- constructor fields (just so that the spliced in code looks nicer),
517
-- and passes those name plus the parameter definition to 'saveObjectField'.
518
saveConstructor :: String    -- ^ The constructor name
519
                -> [Field]   -- ^ The parameter definitions for this
520
                             -- constructor
521
                -> Q Clause  -- ^ Resulting clause
522
saveConstructor sname fields = do
523
  let cname = mkName sname
524
  fnames <- mapM (newName . fieldVariable) fields
525
  let pat = conP cname (map varP fnames)
526
  let felems = map (uncurry saveObjectField) (zip fnames fields)
527
      -- now build the OP_ID serialisation
528
      opid = [| [( $(stringE "OP_ID"),
529
                   JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
530
      flist = listE (opid:felems)
531
      -- and finally convert all this to a json object
532
      flist' = [| $(varNameE "makeObj") (concat $flist) |]
533
  clause [pat] (normalB flist') []
534

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

    
546
-- | Generates load code for a single constructor of the opcode data type.
547
loadConstructor :: String -> [Field] -> Q Exp
548
loadConstructor sname fields = do
549
  let name = mkName sname
550
  fbinds <- mapM loadObjectField fields
551
  let (fnames, fstmts) = unzip fbinds
552
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
553
      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
554
  return $ DoE fstmts'
555

    
556
-- | Generates the loadOpCode function.
557
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
558
genLoadOpCode opdefs = do
559
  let fname = mkName "loadOpCode"
560
      arg1 = mkName "v"
561
      objname = mkName "o"
562
      opid = mkName "op_id"
563
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
564
                                 (JSON.readJSON $(varE arg1)) |]
565
  st2 <- bindS (varP opid) [| $(varNameE "fromObj")
566
                              $(varE objname) $(stringE "OP_ID") |]
567
  -- the match results (per-constructor blocks)
568
  mexps <- mapM (uncurry loadConstructor) opdefs
569
  fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
570
  let mpats = map (\(me, c) ->
571
                       let mp = LitP . StringL . deCamelCase . fst $ c
572
                       in Match mp (NormalB me) []
573
                  ) $ zip mexps opdefs
574
      defmatch = Match WildP (NormalB fails) []
575
      cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
576
      body = DoE [st1, st2, cst]
577
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
578
  return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
579

    
580
-- * Template code for luxi
581

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

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

    
590
-- | Generates the LuxiOp data type.
591
--
592
-- This takes a Luxi operation definition and builds both the
593
-- datatype and the function trnasforming the arguments to JSON.
594
-- We can't use anything less generic, because the way different
595
-- operations are serialized differs on both parameter- and top-level.
596
--
597
-- There are two things to be defined for each parameter:
598
--
599
-- * name
600
--
601
-- * type
602
--
603
genLuxiOp :: String -> SimpleObject -> Q [Dec]
604
genLuxiOp name cons = do
605
  let tname = mkName name
606
  declD <- buildSimpleCons tname cons
607
  (savesig, savefn) <- genSaveSimpleObj tname "opToArgs"
608
                         cons saveLuxiConstructor
609
  req_defs <- declareSADT "LuxiReq" .
610
              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
611
                  cons
612
  return $ [declD, savesig, savefn] ++ req_defs
613

    
614
-- | Generates the \"save\" expression for a single luxi parameter.
615
saveLuxiField :: Name -> SimpleField -> Q Exp
616
saveLuxiField fvar (_, qt) =
617
    [| JSON.showJSON $(varE fvar) |]
618

    
619
-- | Generates the \"save\" clause for entire LuxiOp constructor.
620
saveLuxiConstructor :: SimpleConstructor -> Q Clause
621
saveLuxiConstructor (sname, fields) = do
622
  let cname = mkName sname
623
      fnames = map (mkName . fst) fields
624
      pat = conP cname (map varP fnames)
625
      flist = map (uncurry saveLuxiField) (zip fnames fields)
626
      finval = if null flist
627
               then [| JSON.showJSON ()    |]
628
               else [| JSON.showJSON $(listE flist) |]
629
  clause [pat] (normalB finval) []
630

    
631
-- * "Objects" functionality
632

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

    
640
-- | Build an object declaration.
641
buildObject :: String -> String -> [Field] -> Q [Dec]
642
buildObject sname field_pfx fields = do
643
  let name = mkName sname
644
  fields_d <- mapM (fieldTypeInfo field_pfx) fields
645
  let decl_d = RecC name fields_d
646
  let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
647
  ser_decls <- buildObjectSerialisation sname fields
648
  return $ declD:ser_decls
649

    
650
-- | Generates an object definition: data type and its JSON instance.
651
buildObjectSerialisation :: String -> [Field] -> Q [Dec]
652
buildObjectSerialisation sname fields = do
653
  let name = mkName sname
654
  savedecls <- genSaveObject saveObjectField sname fields
655
  (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
656
  shjson <- objectShowJSON sname
657
  rdjson <- objectReadJSON sname
658
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
659
                 [rdjson, shjson]
660
  return $ savedecls ++ [loadsig, loadfn, instdecl]
661

    
662
-- | The toDict function name for a given type.
663
toDictName :: String -> Name
664
toDictName sname = mkName ("toDict" ++ sname)
665

    
666
-- | Generates the save object functionality.
667
genSaveObject :: (Name -> Field -> Q Exp)
668
              -> String -> [Field] -> Q [Dec]
669
genSaveObject save_fn sname fields = do
670
  let name = mkName sname
671
  fnames <- mapM (newName . fieldVariable) fields
672
  let pat = conP name (map varP fnames)
673
  let tdname = toDictName sname
674
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
675

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

    
688
-- | Generates the code for saving an object's field, handling the
689
-- various types of fields that we have.
690
saveObjectField :: Name -> Field -> Q Exp
691
saveObjectField fvar field
692
  | fisOptional = [| case $(varE fvar) of
693
                      Nothing -> []
694
                      Just v -> [( $nameE, JSON.showJSON v)]
695
                  |]
696
  | otherwise = case fieldShow field of
697
      Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
698
      Just fn -> [| let (actual, extra) = $fn $fvarE
699
                    in extra ++ [( $nameE, JSON.showJSON actual)]
700
                  |]
701
  where fisOptional  = fieldIsOptional field
702
        nameE = stringE (fieldName field)
703
        fvarE = varE fvar
704

    
705
-- | Generates the showJSON clause for a given object name.
706
objectShowJSON :: String -> Q Dec
707
objectShowJSON name = do
708
  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
709
  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
710

    
711
-- | Generates the load object functionality.
712
genLoadObject :: (Field -> Q (Name, Stmt))
713
              -> String -> [Field] -> Q (Dec, Dec)
714
genLoadObject load_fn sname fields = do
715
  let name = mkName sname
716
      funname = mkName $ "load" ++ sname
717
      arg1 = mkName "v"
718
      objname = mkName "o"
719
      opid = mkName "op_id"
720
  st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
721
                                 (JSON.readJSON $(varE arg1)) |]
722
  fbinds <- mapM load_fn fields
723
  let (fnames, fstmts) = unzip fbinds
724
  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
725
      fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
726
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
727
  return $ (SigD funname sigt,
728
            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
729

    
730
-- | Generates code for loading an object's field.
731
loadObjectField :: Field -> Q (Name, Stmt)
732
loadObjectField field = do
733
  let name = fieldVariable field
734
  fvar <- newName name
735
  -- these are used in all patterns below
736
  let objvar = varNameE "o"
737
      objfield = stringE (fieldName field)
738
      loadexp =
739
        if fieldIsOptional field
740
          then [| $(varNameE "maybeFromObj") $objvar $objfield |]
741
          else case fieldDefault field of
742
                 Just defv ->
743
                   [| $(varNameE "fromObjWithDefault") $objvar
744
                      $objfield $defv |]
745
                 Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
746
  bexp <- loadFn field loadexp objvar
747

    
748
  return (fvar, BindS (VarP fvar) bexp)
749

    
750
-- | Builds the readJSON instance for a given object name.
751
objectReadJSON :: String -> Q Dec
752
objectReadJSON name = do
753
  let s = mkName "s"
754
  body <- [| case JSON.readJSON $(varE s) of
755
               JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
756
               JSON.Error e ->
757
                 JSON.Error $ "Can't parse value for type " ++
758
                       $(stringE name) ++ ": " ++ e
759
           |]
760
  return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
761

    
762
-- * Inheritable parameter tables implementation
763

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

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

    
777
-- | Build a parameter declaration.
778
--
779
-- This function builds two different data structures: a /filled/ one,
780
-- in which all fields are required, and a /partial/ one, in which all
781
-- fields are optional. Due to the current record syntax issues, the
782
-- fields need to be named differrently for the two structures, so the
783
-- partial ones get a /P/ suffix.
784
buildParam :: String -> String -> [Field] -> Q [Dec]
785
buildParam sname field_pfx fields = do
786
  let (sname_f, sname_p) = paramTypeNames sname
787
      name_f = mkName sname_f
788
      name_p = mkName sname_p
789
  fields_f <- mapM (fieldTypeInfo field_pfx) fields
790
  fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
791
  let decl_f = RecC name_f fields_f
792
      decl_p = RecC name_p fields_p
793
  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
794
      declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
795
  ser_decls_f <- buildObjectSerialisation sname_f fields
796
  ser_decls_p <- buildPParamSerialisation sname_p fields
797
  fill_decls <- fillParam sname field_pfx fields
798
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
799
           buildParamAllFields sname fields ++
800
           buildDictObjectInst name_f sname_f
801

    
802
-- | Builds a list of all fields of a parameter.
803
buildParamAllFields :: String -> [Field] -> [Dec]
804
buildParamAllFields sname fields =
805
  let vname = mkName ("all" ++ sname ++ "ParamFields")
806
      sig = SigD vname (AppT ListT (ConT ''String))
807
      val = ListE $ map (LitE . StringL . fieldName) fields
808
  in [sig, ValD (VarP vname) (NormalB val) []]
809

    
810
-- | Builds the 'DictObject' instance for a filled parameter.
811
buildDictObjectInst :: Name -> String -> [Dec]
812
buildDictObjectInst name sname =
813
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
814
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
815

    
816
-- | Generates the serialisation for a partial parameter.
817
buildPParamSerialisation :: String -> [Field] -> Q [Dec]
818
buildPParamSerialisation sname fields = do
819
  let name = mkName sname
820
  savedecls <- genSaveObject savePParamField sname fields
821
  (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
822
  shjson <- objectShowJSON sname
823
  rdjson <- objectReadJSON sname
824
  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
825
                 [rdjson, shjson]
826
  return $ savedecls ++ [loadsig, loadfn, instdecl]
827

    
828
-- | Generates code to save an optional parameter field.
829
savePParamField :: Name -> Field -> Q Exp
830
savePParamField fvar field = do
831
  checkNonOptDef field
832
  let actualVal = mkName "v"
833
  normalexpr <- saveObjectField actualVal field
834
  -- we have to construct the block here manually, because we can't
835
  -- splice-in-splice
836
  return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
837
                                       (NormalB (ConE '[])) []
838
                             , Match (ConP 'Just [VarP actualVal])
839
                                       (NormalB normalexpr) []
840
                             ]
841

    
842
-- | Generates code to load an optional parameter field.
843
loadPParamField :: Field -> Q (Name, Stmt)
844
loadPParamField field = do
845
  checkNonOptDef field
846
  let name = fieldName field
847
  fvar <- newName name
848
  -- these are used in all patterns below
849
  let objvar = varNameE "o"
850
      objfield = stringE name
851
      loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
852
  bexp <- loadFn field loadexp objvar
853
  return (fvar, BindS (VarP fvar) bexp)
854

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

    
863
-- | Builds a function that executes the filling of partial parameter
864
-- from a full copy (similar to Python's fillDict).
865
fillParam :: String -> String -> [Field] -> Q [Dec]
866
fillParam sname field_pfx fields = do
867
  let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
868
      (sname_f, sname_p) = paramTypeNames sname
869
      oname_f = "fobj"
870
      oname_p = "pobj"
871
      name_f = mkName sname_f
872
      name_p = mkName sname_p
873
      fun_name = mkName $ "fill" ++ sname ++ "Params"
874
      le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
875
                (NormalB . VarE . mkName $ oname_f) []
876
      le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
877
                (NormalB . VarE . mkName $ oname_p) []
878
      obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
879
                $ map (mkName . ("n_" ++)) fnames
880
  le_new <- mapM buildFromMaybe fnames
881
  funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
882
  let sig = SigD fun_name funt
883
      fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
884
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
885
      fun = FunD fun_name [fclause]
886
  return [sig, fun]
887

    
888
-- * Template code for exceptions
889

    
890
-- | Exception simple error message field.
891
excErrMsg :: (String, Q Type)
892
excErrMsg = ("errMsg", [t| String |])
893

    
894
-- | Builds an exception type definition.
895
genException :: String                  -- ^ Name of new type
896
             -> SimpleObject -- ^ Constructor name and parameters
897
             -> Q [Dec]
898
genException name cons = do
899
  let tname = mkName name
900
  declD <- buildSimpleCons tname cons
901
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
902
                         uncurry saveExcCons
903
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
904
  return [declD, loadsig, loadfn, savesig, savefn]
905

    
906
-- | Generates the \"save\" clause for an entire exception constructor.
907
--
908
-- This matches the exception with variables named the same as the
909
-- constructor fields (just so that the spliced in code looks nicer),
910
-- and calls showJSON on it.
911
saveExcCons :: String        -- ^ The constructor name
912
            -> [SimpleField] -- ^ The parameter definitions for this
913
                             -- constructor
914
            -> Q Clause      -- ^ Resulting clause
915
saveExcCons sname fields = do
916
  let cname = mkName sname
917
  fnames <- mapM (newName . fst) fields
918
  let pat = conP cname (map varP fnames)
919
      felems = if null fnames
920
                 then conE '() -- otherwise, empty list has no type
921
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
922
  let tup = tupE [ litE (stringL sname), felems ]
923
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
924

    
925
-- | Generates load code for a single constructor of an exception.
926
--
927
-- Generates the code (if there's only one argument, we will use a
928
-- list, not a tuple:
929
--
930
-- @
931
-- do
932
--  (x1, x2, ...) <- readJSON args
933
--  return $ Cons x1 x2 ...
934
-- @
935
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
936
loadExcConstructor inname sname fields = do
937
  let name = mkName sname
938
  f_names <- mapM (newName . fst) fields
939
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
940
  let binds = case f_names of
941
                [x] -> BindS (ListP [VarP x])
942
                _   -> BindS (TupP (map VarP f_names))
943
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
944
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
945

    
946
{-| Generates the loadException function.
947

    
948
This generates a quite complicated function, along the lines of:
949

    
950
@
951
loadFn (JSArray [JSString name, args]) = case name of
952
   "A1" -> do
953
     (x1, x2, ...) <- readJSON args
954
     return $ A1 x1 x2 ...
955
   "a2" -> ...
956
   s -> fail $ "Unknown exception" ++ s
957
loadFn v = fail $ "Expected array but got " ++ show v
958
@
959
-}
960
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
961
genLoadExc tname sname opdefs = do
962
  let fname = mkName sname
963
  exc_name <- newName "name"
964
  exc_args <- newName "args"
965
  exc_else <- newName "s"
966
  arg_else <- newName "v"
967
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
968
  -- default match for unknown exception name
969
  let defmatch = Match (VarP exc_else) (NormalB fails) []
970
  -- the match results (per-constructor blocks)
971
  str_matches <-
972
    mapM (\(s, params) -> do
973
            body_exp <- loadExcConstructor exc_args s params
974
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
975
    opdefs
976
  -- the first function clause; we can't use [| |] due to TH
977
  -- limitations, so we have to build the AST by hand
978
  let clause1 = Clause [ConP 'JSON.JSArray
979
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
980
                                            VarP exc_args]]]
981
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
982
                                        (VarE exc_name))
983
                          (str_matches ++ [defmatch]))) []
984
  -- the fail expression for the second function clause
985
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
986
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
987
                |]
988
  -- the second function clause
989
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
990
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
991
  return $ (SigD fname sigt, FunD fname [clause1, clause2])