1 {-# LANGUAGE TemplateHaskell #-}
3 {-| TemplateHaskell helper for Ganeti Haskell code.
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).
13 Copyright (C) 2011, 2012 Google Inc.
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.
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.
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
32 module Ganeti.THH ( declareSADT
46 , optionalNullSerField
55 , buildObjectSerialisation
62 import Control.Monad (liftM)
65 import Data.Maybe (fromMaybe)
66 import qualified Data.Set as Set
67 import Language.Haskell.TH
69 import qualified Text.JSON as JSON
70 import Text.JSON.Pretty (pp_value)
76 -- | Class of objects that can be converted to 'JSObject'
78 class DictObject a where
79 toDict :: a -> [(String, JSON.JSValue)]
81 -- | Optional field information.
83 = NotOptional -- ^ Field is not optional
84 | OptionalOmitNull -- ^ Field is optional, null is not serialised
85 | OptionalSerializeNull -- ^ Field is optional, null is serialised
88 -- | Serialised field data type.
89 data Field = Field { fieldName :: String
91 , fieldRead :: Maybe (Q Exp)
92 , fieldShow :: Maybe (Q Exp)
93 , fieldDefault :: Maybe (Q Exp)
94 , fieldConstr :: Maybe String
95 , fieldIsOptional :: OptionalType
98 -- | Generates a simple field.
99 simpleField :: String -> Q Type -> Field
100 simpleField fname ftype =
101 Field { fieldName = fname
103 , fieldRead = Nothing
104 , fieldShow = Nothing
105 , fieldDefault = Nothing
106 , fieldConstr = Nothing
107 , fieldIsOptional = NotOptional
110 -- | Sets the renamed constructor field.
111 renameField :: String -> Field -> Field
112 renameField constrName field = field { fieldConstr = Just constrName }
114 -- | Sets the default value on a field (makes it optional with a
116 defaultField :: Q Exp -> Field -> Field
117 defaultField defval field = field { fieldDefault = Just defval }
119 -- | Marks a field optional (turning its base type into a Maybe).
120 optionalField :: Field -> Field
121 optionalField field = field { fieldIsOptional = OptionalOmitNull }
123 -- | Marks a field optional (turning its base type into a Maybe), but
124 -- with 'Nothing' serialised explicitly as /null/.
125 optionalNullSerField :: Field -> Field
126 optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
128 -- | Sets custom functions on a field.
129 customField :: Name -- ^ The name of the read function
130 -> Name -- ^ The name of the show function
131 -> Field -- ^ The original field
132 -> Field -- ^ Updated field
133 customField readfn showfn field =
134 field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }
136 -- | Computes the record name for a given field, based on either the
137 -- string value in the JSON serialisation or the custom named if any
139 fieldRecordName :: Field -> String
140 fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
141 fromMaybe (camelCase name) alias
143 -- | Computes the preferred variable name to use for the value of this
144 -- field. If the field has a specific constructor name, then we use a
145 -- first-letter-lowercased version of that; otherwise, we simply use
146 -- the field name. See also 'fieldRecordName'.
147 fieldVariable :: Field -> String
149 case (fieldConstr f) of
150 Just name -> ensureLower name
151 _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
153 -- | Compute the actual field type (taking into account possible
155 actualFieldType :: Field -> Q Type
156 actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
158 where t = fieldType f
160 -- | Checks that a given field is not optional (for object types or
161 -- fields which should not allow this case).
162 checkNonOptDef :: (Monad m) => Field -> m ()
163 checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
164 , fieldName = name }) =
165 fail $ "Optional field " ++ name ++ " used in parameter declaration"
166 checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
167 , fieldName = name }) =
168 fail $ "Optional field " ++ name ++ " used in parameter declaration"
169 checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
170 fail $ "Default field " ++ name ++ " used in parameter declaration"
171 checkNonOptDef _ = return ()
173 -- | Produces the expression that will de-serialise a given
174 -- field. Since some custom parsing functions might need to use the
175 -- entire object, we do take and pass the object to any custom read
177 loadFn :: Field -- ^ The field definition
178 -> Q Exp -- ^ The value of the field as existing in the JSON message
179 -> Q Exp -- ^ The entire object in JSON object format
180 -> Q Exp -- ^ Resulting expression
181 loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
182 loadFn _ expr _ = expr
184 -- * Common field declarations
186 -- | Timestamp fields description.
187 timeStampFields :: [Field]
189 [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
190 , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
193 -- | Serial number fields description.
194 serialFields :: [Field]
196 [ renameField "Serial" $ simpleField "serial_no" [t| Int |] ]
198 -- | UUID fields description.
199 uuidFields :: [Field]
200 uuidFields = [ simpleField "uuid" [t| String |] ]
202 -- | Tag set type alias.
203 type TagSet = Set.Set String
205 -- | Tag field description.
206 tagsFields :: [Field]
207 tagsFields = [ defaultField [| Set.empty |] $
208 simpleField "tags" [t| TagSet |] ]
212 -- | A simple field, in constrast to the customisable 'Field' type.
213 type SimpleField = (String, Q Type)
215 -- | A definition for a single constructor for a simple object.
216 type SimpleConstructor = (String, [SimpleField])
218 -- | A definition for ADTs with simple fields.
219 type SimpleObject = [SimpleConstructor]
221 -- * Helper functions
223 -- | Ensure first letter is lowercase.
225 -- Used to convert type name to function prefix, e.g. in @data Aa ->
227 ensureLower :: String -> String
229 ensureLower (x:xs) = toLower x:xs
231 -- | Ensure first letter is uppercase.
233 -- Used to convert constructor name to component
234 ensureUpper :: String -> String
236 ensureUpper (x:xs) = toUpper x:xs
238 -- | Helper for quoted expressions.
239 varNameE :: String -> Q Exp
240 varNameE = varE . mkName
242 -- | showJSON as an expression, for reuse.
244 showJSONE = varE 'JSON.showJSON
246 -- | makeObj as an expression, for reuse.
248 makeObjE = varE 'JSON.makeObj
250 -- | fromObj (Ganeti specific) as an expression, for reuse.
252 fromObjE = varE 'fromObj
254 -- | ToRaw function name.
255 toRawName :: String -> Name
256 toRawName = mkName . (++ "ToRaw") . ensureLower
258 -- | FromRaw function name.
259 fromRawName :: String -> Name
260 fromRawName = mkName . (++ "FromRaw") . ensureLower
262 -- | Converts a name to it's varE\/litE representations.
263 reprE :: Either String Name -> Q Exp
264 reprE = either stringE varE
266 -- | Smarter function application.
268 -- This does simply f x, except that if is 'id', it will skip it, in
269 -- order to generate more readable code when using -ddump-splices.
270 appFn :: Exp -> Exp -> Exp
271 appFn f x | f == VarE 'id = x
272 | otherwise = AppE f x
274 -- | Builds a field for a normal constructor.
275 buildConsField :: Q Type -> StrictTypeQ
276 buildConsField ftype = do
278 return (NotStrict, ftype')
280 -- | Builds a constructor based on a simple definition (not field-based).
281 buildSimpleCons :: Name -> SimpleObject -> Q Dec
282 buildSimpleCons tname cons = do
283 decl_d <- mapM (\(cname, fields) -> do
284 fields' <- mapM (buildConsField . snd) fields
285 return $ NormalC (mkName cname) fields') cons
286 return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
288 -- | Generate the save function for a given type.
289 genSaveSimpleObj :: Name -- ^ Object type
290 -> String -- ^ Function name
291 -> SimpleObject -- ^ Object definition
292 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
294 genSaveSimpleObj tname sname opdefs fn = do
295 let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
297 cclauses <- mapM fn opdefs
298 return $ (SigD fname sigt, FunD fname cclauses)
300 -- * Template code for simple raw type-equivalent ADTs
302 -- | Generates a data type declaration.
304 -- The type will have a fixed list of instances.
305 strADTDecl :: Name -> [String] -> Dec
306 strADTDecl name constructors =
308 (map (flip NormalC [] . mkName) constructors)
309 [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
311 -- | Generates a toRaw function.
313 -- This generates a simple function of the form:
316 -- nameToRaw :: Name -> /traw/
317 -- nameToRaw Cons1 = var1
318 -- nameToRaw Cons2 = \"value2\"
320 genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
321 genToRaw traw fname tname constructors = do
322 let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
323 -- the body clauses, matching on the constructor and returning the
325 clauses <- mapM (\(c, v) -> clause [recP (mkName c) []]
326 (normalB (reprE v)) []) constructors
327 return [SigD fname sigt, FunD fname clauses]
329 -- | Generates a fromRaw function.
331 -- The function generated is monadic and can fail parsing the
332 -- raw value. It is of the form:
335 -- nameFromRaw :: (Monad m) => /traw/ -> m Name
336 -- nameFromRaw s | s == var1 = Cons1
337 -- | s == \"value2\" = Cons2
338 -- | otherwise = fail /.../
340 genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
341 genFromRaw traw fname tname constructors = do
342 -- signature of form (Monad m) => String -> m $name
343 sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
344 -- clauses for a guarded pattern
345 let varp = mkName "s"
347 clauses <- mapM (\(c, v) -> do
348 -- the clause match condition
349 g <- normalG [| $varpe == $(varE v) |]
351 r <- [| return $(conE (mkName c)) |]
352 return (g, r)) constructors
353 -- the otherwise clause (fallback)
355 g <- normalG [| otherwise |]
356 r <- [|fail ("Invalid string value for type " ++
357 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
359 let fun = FunD fname [Clause [VarP varp]
360 (GuardedB (clauses++[oth_clause])) []]
361 return [SigD fname sigt, fun]
363 -- | Generates a data type from a given raw format.
365 -- The format is expected to multiline. The first line contains the
366 -- type name, and the rest of the lines must contain two words: the
367 -- constructor name and then the string representation of the
368 -- respective constructor.
370 -- The function will generate the data type declaration, and then two
373 -- * /name/ToRaw, which converts the type to a raw type
375 -- * /name/FromRaw, which (monadically) converts from a raw type to the type
377 -- Note that this is basically just a custom show\/read instance,
379 declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
380 declareADT traw sname cons = do
381 let name = mkName sname
382 ddecl = strADTDecl name (map fst cons)
383 -- process cons in the format expected by genToRaw
384 cons' = map (\(a, b) -> (a, Right b)) cons
385 toraw <- genToRaw traw (toRawName sname) name cons'
386 fromraw <- genFromRaw traw (fromRawName sname) name cons
387 return $ ddecl:toraw ++ fromraw
389 declareIADT :: String -> [(String, Name)] -> Q [Dec]
390 declareIADT = declareADT ''Int
392 declareSADT :: String -> [(String, Name)] -> Q [Dec]
393 declareSADT = declareADT ''String
395 -- | Creates the showJSON member of a JSON instance declaration.
397 -- This will create what is the equivalent of:
400 -- showJSON = showJSON . /name/ToRaw
403 -- in an instance JSON /name/ declaration
404 genShowJSON :: String -> Q Dec
405 genShowJSON name = do
406 body <- [| JSON.showJSON . $(varE (toRawName name)) |]
407 return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
409 -- | Creates the readJSON member of a JSON instance declaration.
411 -- This will create what is the equivalent of:
414 -- readJSON s = case readJSON s of
415 -- Ok s' -> /name/FromRaw s'
416 -- Error e -> Error /description/
419 -- in an instance JSON /name/ declaration
420 genReadJSON :: String -> Q Dec
421 genReadJSON name = do
423 body <- [| case JSON.readJSON $(varE s) of
424 JSON.Ok s' -> $(varE (fromRawName name)) s'
426 JSON.Error $ "Can't parse raw value for type " ++
427 $(stringE name) ++ ": " ++ e ++ " from " ++
430 return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
432 -- | Generates a JSON instance for a given type.
434 -- This assumes that the /name/ToRaw and /name/FromRaw functions
435 -- have been defined as by the 'declareSADT' function.
436 makeJSONInstance :: Name -> Q [Dec]
437 makeJSONInstance name = do
438 let base = nameBase name
439 showJ <- genShowJSON base
440 readJ <- genReadJSON base
441 return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
443 -- * Template code for opcodes
445 -- | Transforms a CamelCase string into an_underscore_based_one.
446 deCamelCase :: String -> String
448 intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
450 -- | Transform an underscore_name into a CamelCase one.
451 camelCase :: String -> String
452 camelCase = concatMap (ensureUpper . drop 1) .
453 groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
455 -- | Computes the name of a given constructor.
456 constructorName :: Con -> Q Name
457 constructorName (NormalC name _) = return name
458 constructorName (RecC name _) = return name
459 constructorName x = fail $ "Unhandled constructor " ++ show x
461 -- | Extract all constructor names from a given type.
462 reifyConsNames :: Name -> Q [String]
463 reifyConsNames name = do
464 reify_result <- reify name
466 TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
467 o -> fail $ "Unhandled name passed to reifyConsNames, expected\
468 \ type constructor but got '" ++ show o ++ "'"
470 -- | Builds the generic constructor-to-string function.
472 -- This generates a simple function of the following form:
475 -- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
476 -- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
479 -- This builds a custom list of name\/string pairs and then uses
480 -- 'genToRaw' to actually generate the function.
481 genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
482 genConstrToStr trans_fun name fname = do
483 cnames <- reifyConsNames name
484 let svalues = map (Left . trans_fun) cnames
485 genToRaw ''String (mkName fname) name $ zip cnames svalues
487 -- | Constructor-to-string for OpCode.
488 genOpID :: Name -> String -> Q [Dec]
489 genOpID = genConstrToStr deCamelCase
491 -- | Builds a list with all defined constructor names for a type.
498 -- Where the actual values of the string are the constructor names
499 -- mapped via @trans_fun@.
500 genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
501 genAllConstr trans_fun name vstr = do
502 cnames <- reifyConsNames name
503 let svalues = sort $ map trans_fun cnames
505 sig = SigD vname (AppT ListT (ConT ''String))
506 body = NormalB (ListE (map (LitE . StringL) svalues))
507 return $ [sig, ValD (VarP vname) body []]
509 -- | Generates a list of all defined opcode IDs.
510 genAllOpIDs :: Name -> String -> Q [Dec]
511 genAllOpIDs = genAllConstr deCamelCase
513 -- | OpCode parameter (field) type.
514 type OpParam = (String, Q Type, Q Exp)
516 -- | Generates the OpCode data type.
518 -- This takes an opcode logical definition, and builds both the
519 -- datatype and the JSON serialisation out of it. We can't use a
520 -- generic serialisation since we need to be compatible with Ganeti's
521 -- own, so we have a few quirks to work around.
522 genOpCode :: String -- ^ Type name to use
523 -> [(String, [Field])] -- ^ Constructor name and parameters
525 genOpCode name cons = do
526 let tname = mkName name
527 decl_d <- mapM (\(cname, fields) -> do
528 -- we only need the type of the field, without Q
529 fields' <- mapM (fieldTypeInfo "op") fields
530 return $ RecC (mkName cname) fields')
532 let declD = DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
534 (savesig, savefn) <- genSaveOpCode tname "saveOpCode" cons
535 (uncurry saveConstructor)
536 (loadsig, loadfn) <- genLoadOpCode cons
537 return [declD, loadsig, loadfn, savesig, savefn]
539 -- | Generates the \"save\" clause for an entire opcode constructor.
541 -- This matches the opcode with variables named the same as the
542 -- constructor fields (just so that the spliced in code looks nicer),
543 -- and passes those name plus the parameter definition to 'saveObjectField'.
544 saveConstructor :: String -- ^ The constructor name
545 -> [Field] -- ^ The parameter definitions for this
547 -> Q Clause -- ^ Resulting clause
548 saveConstructor sname fields = do
549 let cname = mkName sname
550 fnames <- mapM (newName . fieldVariable) fields
551 let pat = conP cname (map varP fnames)
552 let felems = map (uncurry saveObjectField) (zip fnames fields)
553 -- now build the OP_ID serialisation
554 opid = [| [( $(stringE "OP_ID"),
555 JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
556 flist = listE (opid:felems)
557 -- and finally convert all this to a json object
558 flist' = [| $makeObjE (concat $flist) |]
559 clause [pat] (normalB flist') []
561 -- | Generates the main save opcode function.
563 -- This builds a per-constructor match clause that contains the
564 -- respective constructor-serialisation code.
565 genSaveOpCode :: Name -- ^ Object ype
566 -> String -- ^ Function name
567 -> [(String, [Field])] -- ^ Object definition
568 -> ((String, [Field]) -> Q Clause) -- ^ Constructor save fn
570 genSaveOpCode tname sname opdefs fn = do
571 cclauses <- mapM fn opdefs
572 let fname = mkName sname
573 sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
574 return $ (SigD fname sigt, FunD fname cclauses)
576 -- | Generates load code for a single constructor of the opcode data type.
577 loadConstructor :: String -> [Field] -> Q Exp
578 loadConstructor sname fields = do
579 let name = mkName sname
580 fbinds <- mapM loadObjectField fields
581 let (fnames, fstmts) = unzip fbinds
582 let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
583 fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
586 -- | Generates the loadOpCode function.
587 genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
588 genLoadOpCode opdefs = do
589 let fname = mkName "loadOpCode"
592 opid = mkName "op_id"
593 st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
594 (JSON.readJSON $(varE arg1)) |]
595 st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
596 -- the match results (per-constructor blocks)
597 mexps <- mapM (uncurry loadConstructor) opdefs
598 fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
599 let mpats = map (\(me, c) ->
600 let mp = LitP . StringL . deCamelCase . fst $ c
601 in Match mp (NormalB me) []
603 defmatch = Match WildP (NormalB fails) []
604 cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
605 body = DoE [st1, st2, cst]
606 sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
607 return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
609 -- * Template code for luxi
611 -- | Constructor-to-string for LuxiOp.
612 genStrOfOp :: Name -> String -> Q [Dec]
613 genStrOfOp = genConstrToStr id
615 -- | Constructor-to-string for MsgKeys.
616 genStrOfKey :: Name -> String -> Q [Dec]
617 genStrOfKey = genConstrToStr ensureLower
619 -- | Generates the LuxiOp data type.
621 -- This takes a Luxi operation definition and builds both the
622 -- datatype and the function trnasforming the arguments to JSON.
623 -- We can't use anything less generic, because the way different
624 -- operations are serialized differs on both parameter- and top-level.
626 -- There are two things to be defined for each parameter:
632 genLuxiOp :: String -> [(String, [Field])] -> Q [Dec]
633 genLuxiOp name cons = do
634 let tname = mkName name
635 decl_d <- mapM (\(cname, fields) -> do
636 -- we only need the type of the field, without Q
637 fields' <- mapM actualFieldType fields
638 let fields'' = zip (repeat NotStrict) fields'
639 return $ NormalC (mkName cname) fields'')
641 let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
642 (savesig, savefn) <- genSaveOpCode tname "opToArgs"
643 cons saveLuxiConstructor
644 req_defs <- declareSADT "LuxiReq" .
645 map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
647 return $ [declD, savesig, savefn] ++ req_defs
649 -- | Generates the \"save\" expression for a single luxi parameter.
650 saveLuxiField :: Name -> SimpleField -> Q Exp
651 saveLuxiField fvar (_, qt) =
652 [| JSON.showJSON $(varE fvar) |]
654 -- | Generates the \"save\" clause for entire LuxiOp constructor.
655 saveLuxiConstructor :: (String, [Field]) -> Q Clause
656 saveLuxiConstructor (sname, fields) = do
657 let cname = mkName sname
658 fnames <- mapM (newName . fieldVariable) fields
659 let pat = conP cname (map varP fnames)
660 let felems = map (uncurry saveObjectField) (zip fnames fields)
661 flist = if null felems
662 then [| JSON.showJSON () |]
663 else [| JSON.showJSON (map snd $ concat $(listE felems)) |]
664 clause [pat] (normalB flist) []
666 -- * "Objects" functionality
668 -- | Extract the field's declaration from a Field structure.
669 fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
670 fieldTypeInfo field_pfx fd = do
671 t <- actualFieldType fd
672 let n = mkName . (field_pfx ++) . fieldRecordName $ fd
673 return (n, NotStrict, t)
675 -- | Build an object declaration.
676 buildObject :: String -> String -> [Field] -> Q [Dec]
677 buildObject sname field_pfx fields = do
678 let name = mkName sname
679 fields_d <- mapM (fieldTypeInfo field_pfx) fields
680 let decl_d = RecC name fields_d
681 let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
682 ser_decls <- buildObjectSerialisation sname fields
683 return $ declD:ser_decls
685 -- | Generates an object definition: data type and its JSON instance.
686 buildObjectSerialisation :: String -> [Field] -> Q [Dec]
687 buildObjectSerialisation sname fields = do
688 let name = mkName sname
689 savedecls <- genSaveObject saveObjectField sname fields
690 (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
691 shjson <- objectShowJSON sname
692 rdjson <- objectReadJSON sname
693 let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
695 return $ savedecls ++ [loadsig, loadfn, instdecl]
697 -- | The toDict function name for a given type.
698 toDictName :: String -> Name
699 toDictName sname = mkName ("toDict" ++ sname)
701 -- | Generates the save object functionality.
702 genSaveObject :: (Name -> Field -> Q Exp)
703 -> String -> [Field] -> Q [Dec]
704 genSaveObject save_fn sname fields = do
705 let name = mkName sname
706 fnames <- mapM (newName . fieldVariable) fields
707 let pat = conP name (map varP fnames)
708 let tdname = toDictName sname
709 tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
711 let felems = map (uncurry save_fn) (zip fnames fields)
713 -- and finally convert all this to a json object
714 tdlist = [| concat $flist |]
716 tclause <- clause [pat] (normalB tdlist) []
717 cclause <- [| $makeObjE . $(varE tdname) |]
718 let fname = mkName ("save" ++ sname)
719 sigt <- [t| $(conT name) -> JSON.JSValue |]
720 return [SigD tdname tdsigt, FunD tdname [tclause],
721 SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
723 -- | Generates the code for saving an object's field, handling the
724 -- various types of fields that we have.
725 saveObjectField :: Name -> Field -> Q Exp
726 saveObjectField fvar field =
727 case fieldIsOptional field of
728 OptionalOmitNull -> [| case $(varE fvar) of
730 Just v -> [( $nameE, JSON.showJSON v )]
732 OptionalSerializeNull -> [| case $(varE fvar) of
733 Nothing -> [( $nameE, JSON.JSNull )]
734 Just v -> [( $nameE, JSON.showJSON v )]
737 case fieldShow field of
738 -- Note: the order of actual:extra is important, since for
739 -- some serialisation types (e.g. Luxi), we use tuples
740 -- (positional info) rather than object (name info)
741 Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
742 Just fn -> [| let (actual, extra) = $fn $fvarE
743 in ($nameE, JSON.showJSON actual):extra
745 where nameE = stringE (fieldName field)
748 -- | Generates the showJSON clause for a given object name.
749 objectShowJSON :: String -> Q Dec
750 objectShowJSON name = do
751 body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
752 return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
754 -- | Generates the load object functionality.
755 genLoadObject :: (Field -> Q (Name, Stmt))
756 -> String -> [Field] -> Q (Dec, Dec)
757 genLoadObject load_fn sname fields = do
758 let name = mkName sname
759 funname = mkName $ "load" ++ sname
762 opid = mkName "op_id"
763 st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
764 (JSON.readJSON $(varE arg1)) |]
765 fbinds <- mapM load_fn fields
766 let (fnames, fstmts) = unzip fbinds
767 let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
768 fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
769 sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
770 return $ (SigD funname sigt,
771 FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
773 -- | Generates code for loading an object's field.
774 loadObjectField :: Field -> Q (Name, Stmt)
775 loadObjectField field = do
776 let name = fieldVariable field
778 -- these are used in all patterns below
779 let objvar = varNameE "o"
780 objfield = stringE (fieldName field)
782 if fieldIsOptional field /= NotOptional
783 -- we treat both optional types the same, since
784 -- 'maybeFromObj' can deal with both missing and null values
785 -- appropriately (the same)
786 then [| $(varE 'maybeFromObj) $objvar $objfield |]
787 else case fieldDefault field of
789 [| $(varE 'fromObjWithDefault) $objvar
791 Nothing -> [| $fromObjE $objvar $objfield |]
792 bexp <- loadFn field loadexp objvar
794 return (fvar, BindS (VarP fvar) bexp)
796 -- | Builds the readJSON instance for a given object name.
797 objectReadJSON :: String -> Q Dec
798 objectReadJSON name = do
800 body <- [| case JSON.readJSON $(varE s) of
801 JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
803 JSON.Error $ "Can't parse value for type " ++
804 $(stringE name) ++ ": " ++ e
806 return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
808 -- * Inheritable parameter tables implementation
810 -- | Compute parameter type names.
811 paramTypeNames :: String -> (String, String)
812 paramTypeNames root = ("Filled" ++ root ++ "Params",
813 "Partial" ++ root ++ "Params")
815 -- | Compute information about the type of a parameter field.
816 paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
817 paramFieldTypeInfo field_pfx fd = do
818 t <- actualFieldType fd
819 let n = mkName . (++ "P") . (field_pfx ++) .
821 return (n, NotStrict, AppT (ConT ''Maybe) t)
823 -- | Build a parameter declaration.
825 -- This function builds two different data structures: a /filled/ one,
826 -- in which all fields are required, and a /partial/ one, in which all
827 -- fields are optional. Due to the current record syntax issues, the
828 -- fields need to be named differrently for the two structures, so the
829 -- partial ones get a /P/ suffix.
830 buildParam :: String -> String -> [Field] -> Q [Dec]
831 buildParam sname field_pfx fields = do
832 let (sname_f, sname_p) = paramTypeNames sname
833 name_f = mkName sname_f
834 name_p = mkName sname_p
835 fields_f <- mapM (fieldTypeInfo field_pfx) fields
836 fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
837 let decl_f = RecC name_f fields_f
838 decl_p = RecC name_p fields_p
839 let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
840 declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
841 ser_decls_f <- buildObjectSerialisation sname_f fields
842 ser_decls_p <- buildPParamSerialisation sname_p fields
843 fill_decls <- fillParam sname field_pfx fields
844 return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
845 buildParamAllFields sname fields ++
846 buildDictObjectInst name_f sname_f
848 -- | Builds a list of all fields of a parameter.
849 buildParamAllFields :: String -> [Field] -> [Dec]
850 buildParamAllFields sname fields =
851 let vname = mkName ("all" ++ sname ++ "ParamFields")
852 sig = SigD vname (AppT ListT (ConT ''String))
853 val = ListE $ map (LitE . StringL . fieldName) fields
854 in [sig, ValD (VarP vname) (NormalB val) []]
856 -- | Builds the 'DictObject' instance for a filled parameter.
857 buildDictObjectInst :: Name -> String -> [Dec]
858 buildDictObjectInst name sname =
859 [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
860 [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
862 -- | Generates the serialisation for a partial parameter.
863 buildPParamSerialisation :: String -> [Field] -> Q [Dec]
864 buildPParamSerialisation sname fields = do
865 let name = mkName sname
866 savedecls <- genSaveObject savePParamField sname fields
867 (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
868 shjson <- objectShowJSON sname
869 rdjson <- objectReadJSON sname
870 let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
872 return $ savedecls ++ [loadsig, loadfn, instdecl]
874 -- | Generates code to save an optional parameter field.
875 savePParamField :: Name -> Field -> Q Exp
876 savePParamField fvar field = do
878 let actualVal = mkName "v"
879 normalexpr <- saveObjectField actualVal field
880 -- we have to construct the block here manually, because we can't
882 return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
883 (NormalB (ConE '[])) []
884 , Match (ConP 'Just [VarP actualVal])
885 (NormalB normalexpr) []
888 -- | Generates code to load an optional parameter field.
889 loadPParamField :: Field -> Q (Name, Stmt)
890 loadPParamField field = do
892 let name = fieldName field
894 -- these are used in all patterns below
895 let objvar = varNameE "o"
896 objfield = stringE name
897 loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
898 bexp <- loadFn field loadexp objvar
899 return (fvar, BindS (VarP fvar) bexp)
901 -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
902 buildFromMaybe :: String -> Q Dec
903 buildFromMaybe fname =
904 valD (varP (mkName $ "n_" ++ fname))
905 (normalB [| $(varE 'fromMaybe)
906 $(varNameE $ "f_" ++ fname)
907 $(varNameE $ "p_" ++ fname) |]) []
909 -- | Builds a function that executes the filling of partial parameter
910 -- from a full copy (similar to Python's fillDict).
911 fillParam :: String -> String -> [Field] -> Q [Dec]
912 fillParam sname field_pfx fields = do
913 let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
914 (sname_f, sname_p) = paramTypeNames sname
917 name_f = mkName sname_f
918 name_p = mkName sname_p
919 fun_name = mkName $ "fill" ++ sname ++ "Params"
920 le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
921 (NormalB . VarE . mkName $ oname_f) []
922 le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
923 (NormalB . VarE . mkName $ oname_p) []
924 obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
925 $ map (mkName . ("n_" ++)) fnames
926 le_new <- mapM buildFromMaybe fnames
927 funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
928 let sig = SigD fun_name funt
929 fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
930 (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
931 fun = FunD fun_name [fclause]
934 -- * Template code for exceptions
936 -- | Exception simple error message field.
937 excErrMsg :: (String, Q Type)
938 excErrMsg = ("errMsg", [t| String |])
940 -- | Builds an exception type definition.
941 genException :: String -- ^ Name of new type
942 -> SimpleObject -- ^ Constructor name and parameters
944 genException name cons = do
945 let tname = mkName name
946 declD <- buildSimpleCons tname cons
947 (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
949 (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
950 return [declD, loadsig, loadfn, savesig, savefn]
952 -- | Generates the \"save\" clause for an entire exception constructor.
954 -- This matches the exception with variables named the same as the
955 -- constructor fields (just so that the spliced in code looks nicer),
956 -- and calls showJSON on it.
957 saveExcCons :: String -- ^ The constructor name
958 -> [SimpleField] -- ^ The parameter definitions for this
960 -> Q Clause -- ^ Resulting clause
961 saveExcCons sname fields = do
962 let cname = mkName sname
963 fnames <- mapM (newName . fst) fields
964 let pat = conP cname (map varP fnames)
965 felems = if null fnames
966 then conE '() -- otherwise, empty list has no type
967 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
968 let tup = tupE [ litE (stringL sname), felems ]
969 clause [pat] (normalB [| JSON.showJSON $tup |]) []
971 -- | Generates load code for a single constructor of an exception.
973 -- Generates the code (if there's only one argument, we will use a
974 -- list, not a tuple:
978 -- (x1, x2, ...) <- readJSON args
979 -- return $ Cons x1 x2 ...
981 loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
982 loadExcConstructor inname sname fields = do
983 let name = mkName sname
984 f_names <- mapM (newName . fst) fields
985 let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
986 let binds = case f_names of
987 [x] -> BindS (ListP [VarP x])
988 _ -> BindS (TupP (map VarP f_names))
989 cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
990 return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
992 {-| Generates the loadException function.
994 This generates a quite complicated function, along the lines of:
997 loadFn (JSArray [JSString name, args]) = case name of
999 (x1, x2, ...) <- readJSON args
1000 return $ A1 x1 x2 ...
1002 s -> fail $ "Unknown exception" ++ s
1003 loadFn v = fail $ "Expected array but got " ++ show v
1006 genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
1007 genLoadExc tname sname opdefs = do
1008 let fname = mkName sname
1009 exc_name <- newName "name"
1010 exc_args <- newName "args"
1011 exc_else <- newName "s"
1012 arg_else <- newName "v"
1013 fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
1014 -- default match for unknown exception name
1015 let defmatch = Match (VarP exc_else) (NormalB fails) []
1016 -- the match results (per-constructor blocks)
1018 mapM (\(s, params) -> do
1019 body_exp <- loadExcConstructor exc_args s params
1020 return $ Match (LitP (StringL s)) (NormalB body_exp) [])
1022 -- the first function clause; we can't use [| |] due to TH
1023 -- limitations, so we have to build the AST by hand
1024 let clause1 = Clause [ConP 'JSON.JSArray
1025 [ListP [ConP 'JSON.JSString [VarP exc_name],
1027 (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
1029 (str_matches ++ [defmatch]))) []
1030 -- the fail expression for the second function clause
1031 fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
1032 " but got " ++ show (pp_value $(varE arg_else)) ++ "'"
1034 -- the second function clause
1035 let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
1036 sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
1037 return $ (SigD fname sigt, FunD fname [clause1, clause2])