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)
74 -- | Class of objects that can be converted to 'JSObject'
76 class DictObject a where
77 toDict :: a -> [(String, JSON.JSValue)]
79 -- | Optional field information.
81 = NotOptional -- ^ Field is not optional
82 | OptionalOmitNull -- ^ Field is optional, null is not serialised
83 | OptionalSerializeNull -- ^ Field is optional, null is serialised
86 -- | Serialised field data type.
87 data Field = Field { fieldName :: String
89 , fieldRead :: Maybe (Q Exp)
90 , fieldShow :: Maybe (Q Exp)
91 , fieldDefault :: Maybe (Q Exp)
92 , fieldConstr :: Maybe String
93 , fieldIsOptional :: OptionalType
96 -- | Generates a simple field.
97 simpleField :: String -> Q Type -> Field
98 simpleField fname ftype =
99 Field { fieldName = fname
101 , fieldRead = Nothing
102 , fieldShow = Nothing
103 , fieldDefault = Nothing
104 , fieldConstr = Nothing
105 , fieldIsOptional = NotOptional
108 -- | Sets the renamed constructor field.
109 renameField :: String -> Field -> Field
110 renameField constrName field = field { fieldConstr = Just constrName }
112 -- | Sets the default value on a field (makes it optional with a
114 defaultField :: Q Exp -> Field -> Field
115 defaultField defval field = field { fieldDefault = Just defval }
117 -- | Marks a field optional (turning its base type into a Maybe).
118 optionalField :: Field -> Field
119 optionalField field = field { fieldIsOptional = OptionalOmitNull }
121 -- | Marks a field optional (turning its base type into a Maybe), but
122 -- with 'Nothing' serialised explicitly as /null/.
123 optionalNullSerField :: Field -> Field
124 optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
126 -- | Sets custom functions on a field.
127 customField :: Name -- ^ The name of the read function
128 -> Name -- ^ The name of the show function
129 -> Field -- ^ The original field
130 -> Field -- ^ Updated field
131 customField readfn showfn field =
132 field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }
134 -- | Computes the record name for a given field, based on either the
135 -- string value in the JSON serialisation or the custom named if any
137 fieldRecordName :: Field -> String
138 fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
139 fromMaybe (camelCase name) alias
141 -- | Computes the preferred variable name to use for the value of this
142 -- field. If the field has a specific constructor name, then we use a
143 -- first-letter-lowercased version of that; otherwise, we simply use
144 -- the field name. See also 'fieldRecordName'.
145 fieldVariable :: Field -> String
147 case (fieldConstr f) of
148 Just name -> ensureLower name
149 _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
151 -- | Compute the actual field type (taking into account possible
153 actualFieldType :: Field -> Q Type
154 actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |]
156 where t = fieldType f
158 -- | Checks that a given field is not optional (for object types or
159 -- fields which should not allow this case).
160 checkNonOptDef :: (Monad m) => Field -> m ()
161 checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
162 , fieldName = name }) =
163 fail $ "Optional field " ++ name ++ " used in parameter declaration"
164 checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
165 , fieldName = name }) =
166 fail $ "Optional field " ++ name ++ " used in parameter declaration"
167 checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
168 fail $ "Default field " ++ name ++ " used in parameter declaration"
169 checkNonOptDef _ = return ()
171 -- | Produces the expression that will de-serialise a given
172 -- field. Since some custom parsing functions might need to use the
173 -- entire object, we do take and pass the object to any custom read
175 loadFn :: Field -- ^ The field definition
176 -> Q Exp -- ^ The value of the field as existing in the JSON message
177 -> Q Exp -- ^ The entire object in JSON object format
178 -> Q Exp -- ^ Resulting expression
179 loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
180 loadFn _ expr _ = expr
182 -- * Common field declarations
184 -- | Timestamp fields description.
185 timeStampFields :: [Field]
187 [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |]
188 , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |]
191 -- | Serial number fields description.
192 serialFields :: [Field]
194 [ renameField "Serial" $ simpleField "serial_no" [t| Int |] ]
196 -- | UUID fields description.
197 uuidFields :: [Field]
198 uuidFields = [ simpleField "uuid" [t| String |] ]
200 -- | Tag set type alias.
201 type TagSet = Set.Set String
203 -- | Tag field description.
204 tagsFields :: [Field]
205 tagsFields = [ defaultField [| Set.empty |] $
206 simpleField "tags" [t| TagSet |] ]
210 -- | A simple field, in constrast to the customisable 'Field' type.
211 type SimpleField = (String, Q Type)
213 -- | A definition for a single constructor for a simple object.
214 type SimpleConstructor = (String, [SimpleField])
216 -- | A definition for ADTs with simple fields.
217 type SimpleObject = [SimpleConstructor]
219 -- * Helper functions
221 -- | Ensure first letter is lowercase.
223 -- Used to convert type name to function prefix, e.g. in @data Aa ->
225 ensureLower :: String -> String
227 ensureLower (x:xs) = toLower x:xs
229 -- | Ensure first letter is uppercase.
231 -- Used to convert constructor name to component
232 ensureUpper :: String -> String
234 ensureUpper (x:xs) = toUpper x:xs
236 -- | Helper for quoted expressions.
237 varNameE :: String -> Q Exp
238 varNameE = varE . mkName
240 -- | showJSON as an expression, for reuse.
242 showJSONE = varNameE "showJSON"
244 -- | ToRaw function name.
245 toRawName :: String -> Name
246 toRawName = mkName . (++ "ToRaw") . ensureLower
248 -- | FromRaw function name.
249 fromRawName :: String -> Name
250 fromRawName = mkName . (++ "FromRaw") . ensureLower
252 -- | Converts a name to it's varE\/litE representations.
253 reprE :: Either String Name -> Q Exp
254 reprE = either stringE varE
256 -- | Smarter function application.
258 -- This does simply f x, except that if is 'id', it will skip it, in
259 -- order to generate more readable code when using -ddump-splices.
260 appFn :: Exp -> Exp -> Exp
261 appFn f x | f == VarE 'id = x
262 | otherwise = AppE f x
264 -- | Builds a field for a normal constructor.
265 buildConsField :: Q Type -> StrictTypeQ
266 buildConsField ftype = do
268 return (NotStrict, ftype')
270 -- | Builds a constructor based on a simple definition (not field-based).
271 buildSimpleCons :: Name -> SimpleObject -> Q Dec
272 buildSimpleCons tname cons = do
273 decl_d <- mapM (\(cname, fields) -> do
274 fields' <- mapM (buildConsField . snd) fields
275 return $ NormalC (mkName cname) fields') cons
276 return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
278 -- | Generate the save function for a given type.
279 genSaveSimpleObj :: Name -- ^ Object type
280 -> String -- ^ Function name
281 -> SimpleObject -- ^ Object definition
282 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
284 genSaveSimpleObj tname sname opdefs fn = do
285 let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
287 cclauses <- mapM fn opdefs
288 return $ (SigD fname sigt, FunD fname cclauses)
290 -- * Template code for simple raw type-equivalent ADTs
292 -- | Generates a data type declaration.
294 -- The type will have a fixed list of instances.
295 strADTDecl :: Name -> [String] -> Dec
296 strADTDecl name constructors =
298 (map (flip NormalC [] . mkName) constructors)
299 [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
301 -- | Generates a toRaw function.
303 -- This generates a simple function of the form:
306 -- nameToRaw :: Name -> /traw/
307 -- nameToRaw Cons1 = var1
308 -- nameToRaw Cons2 = \"value2\"
310 genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
311 genToRaw traw fname tname constructors = do
312 let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
313 -- the body clauses, matching on the constructor and returning the
315 clauses <- mapM (\(c, v) -> clause [recP (mkName c) []]
316 (normalB (reprE v)) []) constructors
317 return [SigD fname sigt, FunD fname clauses]
319 -- | Generates a fromRaw function.
321 -- The function generated is monadic and can fail parsing the
322 -- raw value. It is of the form:
325 -- nameFromRaw :: (Monad m) => /traw/ -> m Name
326 -- nameFromRaw s | s == var1 = Cons1
327 -- | s == \"value2\" = Cons2
328 -- | otherwise = fail /.../
330 genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
331 genFromRaw traw fname tname constructors = do
332 -- signature of form (Monad m) => String -> m $name
333 sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
334 -- clauses for a guarded pattern
335 let varp = mkName "s"
337 clauses <- mapM (\(c, v) -> do
338 -- the clause match condition
339 g <- normalG [| $varpe == $(varE v) |]
341 r <- [| return $(conE (mkName c)) |]
342 return (g, r)) constructors
343 -- the otherwise clause (fallback)
345 g <- normalG [| otherwise |]
346 r <- [|fail ("Invalid string value for type " ++
347 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
349 let fun = FunD fname [Clause [VarP varp]
350 (GuardedB (clauses++[oth_clause])) []]
351 return [SigD fname sigt, fun]
353 -- | Generates a data type from a given raw format.
355 -- The format is expected to multiline. The first line contains the
356 -- type name, and the rest of the lines must contain two words: the
357 -- constructor name and then the string representation of the
358 -- respective constructor.
360 -- The function will generate the data type declaration, and then two
363 -- * /name/ToRaw, which converts the type to a raw type
365 -- * /name/FromRaw, which (monadically) converts from a raw type to the type
367 -- Note that this is basically just a custom show\/read instance,
369 declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
370 declareADT traw sname cons = do
371 let name = mkName sname
372 ddecl = strADTDecl name (map fst cons)
373 -- process cons in the format expected by genToRaw
374 cons' = map (\(a, b) -> (a, Right b)) cons
375 toraw <- genToRaw traw (toRawName sname) name cons'
376 fromraw <- genFromRaw traw (fromRawName sname) name cons
377 return $ ddecl:toraw ++ fromraw
379 declareIADT :: String -> [(String, Name)] -> Q [Dec]
380 declareIADT = declareADT ''Int
382 declareSADT :: String -> [(String, Name)] -> Q [Dec]
383 declareSADT = declareADT ''String
385 -- | Creates the showJSON member of a JSON instance declaration.
387 -- This will create what is the equivalent of:
390 -- showJSON = showJSON . /name/ToRaw
393 -- in an instance JSON /name/ declaration
394 genShowJSON :: String -> Q Dec
395 genShowJSON name = do
396 body <- [| JSON.showJSON . $(varE (toRawName name)) |]
397 return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
399 -- | Creates the readJSON member of a JSON instance declaration.
401 -- This will create what is the equivalent of:
404 -- readJSON s = case readJSON s of
405 -- Ok s' -> /name/FromRaw s'
406 -- Error e -> Error /description/
409 -- in an instance JSON /name/ declaration
410 genReadJSON :: String -> Q Dec
411 genReadJSON name = do
413 body <- [| case JSON.readJSON $(varE s) of
414 JSON.Ok s' -> $(varE (fromRawName name)) s'
416 JSON.Error $ "Can't parse raw value for type " ++
417 $(stringE name) ++ ": " ++ e ++ " from " ++
420 return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
422 -- | Generates a JSON instance for a given type.
424 -- This assumes that the /name/ToRaw and /name/FromRaw functions
425 -- have been defined as by the 'declareSADT' function.
426 makeJSONInstance :: Name -> Q [Dec]
427 makeJSONInstance name = do
428 let base = nameBase name
429 showJ <- genShowJSON base
430 readJ <- genReadJSON base
431 return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
433 -- * Template code for opcodes
435 -- | Transforms a CamelCase string into an_underscore_based_one.
436 deCamelCase :: String -> String
438 intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
440 -- | Transform an underscore_name into a CamelCase one.
441 camelCase :: String -> String
442 camelCase = concatMap (ensureUpper . drop 1) .
443 groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
445 -- | Computes the name of a given constructor.
446 constructorName :: Con -> Q Name
447 constructorName (NormalC name _) = return name
448 constructorName (RecC name _) = return name
449 constructorName x = fail $ "Unhandled constructor " ++ show x
451 -- | Extract all constructor names from a given type.
452 reifyConsNames :: Name -> Q [String]
453 reifyConsNames name = do
454 reify_result <- reify name
456 TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
457 o -> fail $ "Unhandled name passed to reifyConsNames, expected\
458 \ type constructor but got '" ++ show o ++ "'"
460 -- | Builds the generic constructor-to-string function.
462 -- This generates a simple function of the following form:
465 -- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
466 -- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
469 -- This builds a custom list of name\/string pairs and then uses
470 -- 'genToRaw' to actually generate the function.
471 genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
472 genConstrToStr trans_fun name fname = do
473 cnames <- reifyConsNames name
474 let svalues = map (Left . trans_fun) cnames
475 genToRaw ''String (mkName fname) name $ zip cnames svalues
477 -- | Constructor-to-string for OpCode.
478 genOpID :: Name -> String -> Q [Dec]
479 genOpID = genConstrToStr deCamelCase
481 -- | Builds a list with all defined constructor names for a type.
488 -- Where the actual values of the string are the constructor names
489 -- mapped via @trans_fun@.
490 genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
491 genAllConstr trans_fun name vstr = do
492 cnames <- reifyConsNames name
493 let svalues = sort $ map trans_fun cnames
495 sig = SigD vname (AppT ListT (ConT ''String))
496 body = NormalB (ListE (map (LitE . StringL) svalues))
497 return $ [sig, ValD (VarP vname) body []]
499 -- | Generates a list of all defined opcode IDs.
500 genAllOpIDs :: Name -> String -> Q [Dec]
501 genAllOpIDs = genAllConstr deCamelCase
503 -- | OpCode parameter (field) type.
504 type OpParam = (String, Q Type, Q Exp)
506 -- | Generates the OpCode data type.
508 -- This takes an opcode logical definition, and builds both the
509 -- datatype and the JSON serialisation out of it. We can't use a
510 -- generic serialisation since we need to be compatible with Ganeti's
511 -- own, so we have a few quirks to work around.
512 genOpCode :: String -- ^ Type name to use
513 -> [(String, [Field])] -- ^ Constructor name and parameters
515 genOpCode name cons = do
516 decl_d <- mapM (\(cname, fields) -> do
517 -- we only need the type of the field, without Q
518 fields' <- mapM actualFieldType fields
519 let fields'' = zip (repeat NotStrict) fields'
520 return $ NormalC (mkName cname) fields'')
522 let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
524 (savesig, savefn) <- genSaveOpCode cons
525 (loadsig, loadfn) <- genLoadOpCode cons
526 return [declD, loadsig, loadfn, savesig, savefn]
528 -- | Generates the \"save\" clause for an entire opcode constructor.
530 -- This matches the opcode with variables named the same as the
531 -- constructor fields (just so that the spliced in code looks nicer),
532 -- and passes those name plus the parameter definition to 'saveObjectField'.
533 saveConstructor :: String -- ^ The constructor name
534 -> [Field] -- ^ The parameter definitions for this
536 -> Q Clause -- ^ Resulting clause
537 saveConstructor sname fields = do
538 let cname = mkName sname
539 fnames <- mapM (newName . fieldVariable) fields
540 let pat = conP cname (map varP fnames)
541 let felems = map (uncurry saveObjectField) (zip fnames fields)
542 -- now build the OP_ID serialisation
543 opid = [| [( $(stringE "OP_ID"),
544 JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
545 flist = listE (opid:felems)
546 -- and finally convert all this to a json object
547 flist' = [| $(varNameE "makeObj") (concat $flist) |]
548 clause [pat] (normalB flist') []
550 -- | Generates the main save opcode function.
552 -- This builds a per-constructor match clause that contains the
553 -- respective constructor-serialisation code.
554 genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
555 genSaveOpCode opdefs = do
556 cclauses <- mapM (uncurry saveConstructor) opdefs
557 let fname = mkName "saveOpCode"
558 sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
559 return $ (SigD fname sigt, FunD fname cclauses)
561 -- | Generates load code for a single constructor of the opcode data type.
562 loadConstructor :: String -> [Field] -> Q Exp
563 loadConstructor sname fields = do
564 let name = mkName sname
565 fbinds <- mapM loadObjectField fields
566 let (fnames, fstmts) = unzip fbinds
567 let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
568 fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
571 -- | Generates the loadOpCode function.
572 genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
573 genLoadOpCode opdefs = do
574 let fname = mkName "loadOpCode"
577 opid = mkName "op_id"
578 st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
579 (JSON.readJSON $(varE arg1)) |]
580 st2 <- bindS (varP opid) [| $(varNameE "fromObj")
581 $(varE objname) $(stringE "OP_ID") |]
582 -- the match results (per-constructor blocks)
583 mexps <- mapM (uncurry loadConstructor) opdefs
584 fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
585 let mpats = map (\(me, c) ->
586 let mp = LitP . StringL . deCamelCase . fst $ c
587 in Match mp (NormalB me) []
589 defmatch = Match WildP (NormalB fails) []
590 cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
591 body = DoE [st1, st2, cst]
592 sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
593 return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
595 -- * Template code for luxi
597 -- | Constructor-to-string for LuxiOp.
598 genStrOfOp :: Name -> String -> Q [Dec]
599 genStrOfOp = genConstrToStr id
601 -- | Constructor-to-string for MsgKeys.
602 genStrOfKey :: Name -> String -> Q [Dec]
603 genStrOfKey = genConstrToStr ensureLower
605 -- | Generates the LuxiOp data type.
607 -- This takes a Luxi operation definition and builds both the
608 -- datatype and the function trnasforming the arguments to JSON.
609 -- We can't use anything less generic, because the way different
610 -- operations are serialized differs on both parameter- and top-level.
612 -- There are two things to be defined for each parameter:
618 genLuxiOp :: String -> SimpleObject -> Q [Dec]
619 genLuxiOp name cons = do
620 let tname = mkName name
621 declD <- buildSimpleCons tname cons
622 (savesig, savefn) <- genSaveSimpleObj tname "opToArgs"
623 cons saveLuxiConstructor
624 req_defs <- declareSADT "LuxiReq" .
625 map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
627 return $ [declD, savesig, savefn] ++ req_defs
629 -- | Generates the \"save\" expression for a single luxi parameter.
630 saveLuxiField :: Name -> SimpleField -> Q Exp
631 saveLuxiField fvar (_, qt) =
632 [| JSON.showJSON $(varE fvar) |]
634 -- | Generates the \"save\" clause for entire LuxiOp constructor.
635 saveLuxiConstructor :: SimpleConstructor -> Q Clause
636 saveLuxiConstructor (sname, fields) = do
637 let cname = mkName sname
638 fnames = map (mkName . fst) fields
639 pat = conP cname (map varP fnames)
640 flist = map (uncurry saveLuxiField) (zip fnames fields)
641 finval = if null flist
642 then [| JSON.showJSON () |]
643 else [| JSON.showJSON $(listE flist) |]
644 clause [pat] (normalB finval) []
646 -- * "Objects" functionality
648 -- | Extract the field's declaration from a Field structure.
649 fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
650 fieldTypeInfo field_pfx fd = do
651 t <- actualFieldType fd
652 let n = mkName . (field_pfx ++) . fieldRecordName $ fd
653 return (n, NotStrict, t)
655 -- | Build an object declaration.
656 buildObject :: String -> String -> [Field] -> Q [Dec]
657 buildObject sname field_pfx fields = do
658 let name = mkName sname
659 fields_d <- mapM (fieldTypeInfo field_pfx) fields
660 let decl_d = RecC name fields_d
661 let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq]
662 ser_decls <- buildObjectSerialisation sname fields
663 return $ declD:ser_decls
665 -- | Generates an object definition: data type and its JSON instance.
666 buildObjectSerialisation :: String -> [Field] -> Q [Dec]
667 buildObjectSerialisation sname fields = do
668 let name = mkName sname
669 savedecls <- genSaveObject saveObjectField sname fields
670 (loadsig, loadfn) <- genLoadObject loadObjectField sname fields
671 shjson <- objectShowJSON sname
672 rdjson <- objectReadJSON sname
673 let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
675 return $ savedecls ++ [loadsig, loadfn, instdecl]
677 -- | The toDict function name for a given type.
678 toDictName :: String -> Name
679 toDictName sname = mkName ("toDict" ++ sname)
681 -- | Generates the save object functionality.
682 genSaveObject :: (Name -> Field -> Q Exp)
683 -> String -> [Field] -> Q [Dec]
684 genSaveObject save_fn sname fields = do
685 let name = mkName sname
686 fnames <- mapM (newName . fieldVariable) fields
687 let pat = conP name (map varP fnames)
688 let tdname = toDictName sname
689 tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
691 let felems = map (uncurry save_fn) (zip fnames fields)
693 -- and finally convert all this to a json object
694 tdlist = [| concat $flist |]
696 tclause <- clause [pat] (normalB tdlist) []
697 cclause <- [| $(varNameE "makeObj") . $(varE tdname) |]
698 let fname = mkName ("save" ++ sname)
699 sigt <- [t| $(conT name) -> JSON.JSValue |]
700 return [SigD tdname tdsigt, FunD tdname [tclause],
701 SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
703 -- | Generates the code for saving an object's field, handling the
704 -- various types of fields that we have.
705 saveObjectField :: Name -> Field -> Q Exp
706 saveObjectField fvar field =
707 case fieldIsOptional field of
708 OptionalOmitNull -> [| case $(varE fvar) of
710 Just v -> [( $nameE, JSON.showJSON v )]
712 OptionalSerializeNull -> [| case $(varE fvar) of
713 Nothing -> [( $nameE, JSON.JSNull )]
714 Just v -> [( $nameE, JSON.showJSON v )]
717 case fieldShow field of
718 Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
719 Just fn -> [| let (actual, extra) = $fn $fvarE
720 in extra ++ [( $nameE, JSON.showJSON actual)]
722 where nameE = stringE (fieldName field)
725 -- | Generates the showJSON clause for a given object name.
726 objectShowJSON :: String -> Q Dec
727 objectShowJSON name = do
728 body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
729 return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
731 -- | Generates the load object functionality.
732 genLoadObject :: (Field -> Q (Name, Stmt))
733 -> String -> [Field] -> Q (Dec, Dec)
734 genLoadObject load_fn sname fields = do
735 let name = mkName sname
736 funname = mkName $ "load" ++ sname
739 opid = mkName "op_id"
740 st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
741 (JSON.readJSON $(varE arg1)) |]
742 fbinds <- mapM load_fn fields
743 let (fnames, fstmts) = unzip fbinds
744 let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
745 fstmts' = st1:fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
746 sigt <- [t| JSON.JSValue -> JSON.Result $(conT name) |]
747 return $ (SigD funname sigt,
748 FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])
750 -- | Generates code for loading an object's field.
751 loadObjectField :: Field -> Q (Name, Stmt)
752 loadObjectField field = do
753 let name = fieldVariable field
755 -- these are used in all patterns below
756 let objvar = varNameE "o"
757 objfield = stringE (fieldName field)
759 if fieldIsOptional field /= NotOptional
760 -- we treat both optional types the same, since
761 -- 'maybeFromObj' can deal with both missing and null values
762 -- appropriately (the same)
763 then [| $(varNameE "maybeFromObj") $objvar $objfield |]
764 else case fieldDefault field of
766 [| $(varNameE "fromObjWithDefault") $objvar
768 Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
769 bexp <- loadFn field loadexp objvar
771 return (fvar, BindS (VarP fvar) bexp)
773 -- | Builds the readJSON instance for a given object name.
774 objectReadJSON :: String -> Q Dec
775 objectReadJSON name = do
777 body <- [| case JSON.readJSON $(varE s) of
778 JSON.Ok s' -> $(varE .mkName $ "load" ++ name) s'
780 JSON.Error $ "Can't parse value for type " ++
781 $(stringE name) ++ ": " ++ e
783 return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
785 -- * Inheritable parameter tables implementation
787 -- | Compute parameter type names.
788 paramTypeNames :: String -> (String, String)
789 paramTypeNames root = ("Filled" ++ root ++ "Params",
790 "Partial" ++ root ++ "Params")
792 -- | Compute information about the type of a parameter field.
793 paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
794 paramFieldTypeInfo field_pfx fd = do
795 t <- actualFieldType fd
796 let n = mkName . (++ "P") . (field_pfx ++) .
798 return (n, NotStrict, AppT (ConT ''Maybe) t)
800 -- | Build a parameter declaration.
802 -- This function builds two different data structures: a /filled/ one,
803 -- in which all fields are required, and a /partial/ one, in which all
804 -- fields are optional. Due to the current record syntax issues, the
805 -- fields need to be named differrently for the two structures, so the
806 -- partial ones get a /P/ suffix.
807 buildParam :: String -> String -> [Field] -> Q [Dec]
808 buildParam sname field_pfx fields = do
809 let (sname_f, sname_p) = paramTypeNames sname
810 name_f = mkName sname_f
811 name_p = mkName sname_p
812 fields_f <- mapM (fieldTypeInfo field_pfx) fields
813 fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
814 let decl_f = RecC name_f fields_f
815 decl_p = RecC name_p fields_p
816 let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
817 declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
818 ser_decls_f <- buildObjectSerialisation sname_f fields
819 ser_decls_p <- buildPParamSerialisation sname_p fields
820 fill_decls <- fillParam sname field_pfx fields
821 return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
822 buildParamAllFields sname fields ++
823 buildDictObjectInst name_f sname_f
825 -- | Builds a list of all fields of a parameter.
826 buildParamAllFields :: String -> [Field] -> [Dec]
827 buildParamAllFields sname fields =
828 let vname = mkName ("all" ++ sname ++ "ParamFields")
829 sig = SigD vname (AppT ListT (ConT ''String))
830 val = ListE $ map (LitE . StringL . fieldName) fields
831 in [sig, ValD (VarP vname) (NormalB val) []]
833 -- | Builds the 'DictObject' instance for a filled parameter.
834 buildDictObjectInst :: Name -> String -> [Dec]
835 buildDictObjectInst name sname =
836 [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
837 [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
839 -- | Generates the serialisation for a partial parameter.
840 buildPParamSerialisation :: String -> [Field] -> Q [Dec]
841 buildPParamSerialisation sname fields = do
842 let name = mkName sname
843 savedecls <- genSaveObject savePParamField sname fields
844 (loadsig, loadfn) <- genLoadObject loadPParamField sname fields
845 shjson <- objectShowJSON sname
846 rdjson <- objectReadJSON sname
847 let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
849 return $ savedecls ++ [loadsig, loadfn, instdecl]
851 -- | Generates code to save an optional parameter field.
852 savePParamField :: Name -> Field -> Q Exp
853 savePParamField fvar field = do
855 let actualVal = mkName "v"
856 normalexpr <- saveObjectField actualVal field
857 -- we have to construct the block here manually, because we can't
859 return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
860 (NormalB (ConE '[])) []
861 , Match (ConP 'Just [VarP actualVal])
862 (NormalB normalexpr) []
865 -- | Generates code to load an optional parameter field.
866 loadPParamField :: Field -> Q (Name, Stmt)
867 loadPParamField field = do
869 let name = fieldName field
871 -- these are used in all patterns below
872 let objvar = varNameE "o"
873 objfield = stringE name
874 loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
875 bexp <- loadFn field loadexp objvar
876 return (fvar, BindS (VarP fvar) bexp)
878 -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
879 buildFromMaybe :: String -> Q Dec
880 buildFromMaybe fname =
881 valD (varP (mkName $ "n_" ++ fname))
882 (normalB [| $(varNameE "fromMaybe")
883 $(varNameE $ "f_" ++ fname)
884 $(varNameE $ "p_" ++ fname) |]) []
886 -- | Builds a function that executes the filling of partial parameter
887 -- from a full copy (similar to Python's fillDict).
888 fillParam :: String -> String -> [Field] -> Q [Dec]
889 fillParam sname field_pfx fields = do
890 let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
891 (sname_f, sname_p) = paramTypeNames sname
894 name_f = mkName sname_f
895 name_p = mkName sname_p
896 fun_name = mkName $ "fill" ++ sname ++ "Params"
897 le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
898 (NormalB . VarE . mkName $ oname_f) []
899 le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
900 (NormalB . VarE . mkName $ oname_p) []
901 obj_new = foldl (\accu vname -> AppE accu (VarE vname)) (ConE name_f)
902 $ map (mkName . ("n_" ++)) fnames
903 le_new <- mapM buildFromMaybe fnames
904 funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
905 let sig = SigD fun_name funt
906 fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
907 (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
908 fun = FunD fun_name [fclause]
911 -- * Template code for exceptions
913 -- | Exception simple error message field.
914 excErrMsg :: (String, Q Type)
915 excErrMsg = ("errMsg", [t| String |])
917 -- | Builds an exception type definition.
918 genException :: String -- ^ Name of new type
919 -> SimpleObject -- ^ Constructor name and parameters
921 genException name cons = do
922 let tname = mkName name
923 declD <- buildSimpleCons tname cons
924 (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
926 (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
927 return [declD, loadsig, loadfn, savesig, savefn]
929 -- | Generates the \"save\" clause for an entire exception constructor.
931 -- This matches the exception with variables named the same as the
932 -- constructor fields (just so that the spliced in code looks nicer),
933 -- and calls showJSON on it.
934 saveExcCons :: String -- ^ The constructor name
935 -> [SimpleField] -- ^ The parameter definitions for this
937 -> Q Clause -- ^ Resulting clause
938 saveExcCons sname fields = do
939 let cname = mkName sname
940 fnames <- mapM (newName . fst) fields
941 let pat = conP cname (map varP fnames)
942 felems = if null fnames
943 then conE '() -- otherwise, empty list has no type
944 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
945 let tup = tupE [ litE (stringL sname), felems ]
946 clause [pat] (normalB [| JSON.showJSON $tup |]) []
948 -- | Generates load code for a single constructor of an exception.
950 -- Generates the code (if there's only one argument, we will use a
951 -- list, not a tuple:
955 -- (x1, x2, ...) <- readJSON args
956 -- return $ Cons x1 x2 ...
958 loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
959 loadExcConstructor inname sname fields = do
960 let name = mkName sname
961 f_names <- mapM (newName . fst) fields
962 let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
963 let binds = case f_names of
964 [x] -> BindS (ListP [VarP x])
965 _ -> BindS (TupP (map VarP f_names))
966 cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
967 return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
969 {-| Generates the loadException function.
971 This generates a quite complicated function, along the lines of:
974 loadFn (JSArray [JSString name, args]) = case name of
976 (x1, x2, ...) <- readJSON args
977 return $ A1 x1 x2 ...
979 s -> fail $ "Unknown exception" ++ s
980 loadFn v = fail $ "Expected array but got " ++ show v
983 genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
984 genLoadExc tname sname opdefs = do
985 let fname = mkName sname
986 exc_name <- newName "name"
987 exc_args <- newName "args"
988 exc_else <- newName "s"
989 arg_else <- newName "v"
990 fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
991 -- default match for unknown exception name
992 let defmatch = Match (VarP exc_else) (NormalB fails) []
993 -- the match results (per-constructor blocks)
995 mapM (\(s, params) -> do
996 body_exp <- loadExcConstructor exc_args s params
997 return $ Match (LitP (StringL s)) (NormalB body_exp) [])
999 -- the first function clause; we can't use [| |] due to TH
1000 -- limitations, so we have to build the AST by hand
1001 let clause1 = Clause [ConP 'JSON.JSArray
1002 [ListP [ConP 'JSON.JSString [VarP exc_name],
1004 (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
1006 (str_matches ++ [defmatch]))) []
1007 -- the fail expression for the second function clause
1008 fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
1009 " but got " ++ show (pp_value $(varE arg_else)) ++ "'"
1011 -- the second function clause
1012 let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
1013 sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
1014 return $ (SigD fname sigt, FunD fname [clause1, clause2])