Merge branch 'stable-2.12' into stable-2.13
[ganeti-github.git] / src / Ganeti / THH.hs
1 {-# LANGUAGE ParallelListComp, 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, 2013, 2014 Google Inc.
14 All rights reserved.
15
16 Redistribution and use in source and binary forms, with or without
17 modification, are permitted provided that the following conditions are
18 met:
19
20 1. Redistributions of source code must retain the above copyright notice,
21 this list of conditions and the following disclaimer.
22
23 2. Redistributions in binary form must reproduce the above copyright
24 notice, this list of conditions and the following disclaimer in the
25 documentation and/or other materials provided with the distribution.
26
27 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
28 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
29 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
30 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
31 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
32 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
33 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
34 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
35 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
36 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
37 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
38
39 -}
40
41 module Ganeti.THH ( declareSADT
42 , declareLADT
43 , declareILADT
44 , declareIADT
45 , makeJSONInstance
46 , deCamelCase
47 , genOpID
48 , genOpLowerStrip
49 , genAllConstr
50 , genAllOpIDs
51 , PyValue(..)
52 , PyValueEx(..)
53 , OpCodeField(..)
54 , OpCodeDescriptor(..)
55 , genOpCode
56 , genStrOfOp
57 , genStrOfKey
58 , genLuxiOp
59 , Field (..)
60 , simpleField
61 , andRestArguments
62 , withDoc
63 , defaultField
64 , notSerializeDefaultField
65 , optionalField
66 , optionalNullSerField
67 , renameField
68 , customField
69 , buildObject
70 , buildObjectSerialisation
71 , buildParam
72 , genException
73 , excErrMsg
74 ) where
75
76 import Control.Arrow ((&&&))
77 import Control.Applicative
78 import Control.Monad
79 import Control.Monad.Base () -- Needed to prevent spurious GHC linking errors.
80 import Control.Monad.Writer (tell)
81 import qualified Control.Monad.Trans as MT
82 import Data.Attoparsec.Text ()
83 -- Needed to prevent spurious GHC 7.4 linking errors.
84 -- See issue #683 and https://ghc.haskell.org/trac/ghc/ticket/4899
85 import Data.Char
86 import Data.Function (on)
87 import Data.List
88 import Data.Maybe
89 import qualified Data.Map as M
90 import qualified Data.Set as S
91 import Language.Haskell.TH
92 import Language.Haskell.TH.Syntax (lift)
93
94 import qualified Text.JSON as JSON
95 import Text.JSON.Pretty (pp_value)
96
97 import Ganeti.JSON
98 import Ganeti.PyValue
99 import Ganeti.THH.PyType
100
101
102 -- * Exported types
103
104 -- | Optional field information.
105 data OptionalType
106 = NotOptional -- ^ Field is not optional
107 | OptionalOmitNull -- ^ Field is optional, null is not serialised
108 | OptionalSerializeNull -- ^ Field is optional, null is serialised
109 | AndRestArguments -- ^ Special field capturing all the remaining fields
110 -- as plain JSON values
111 deriving (Show, Eq)
112
113 -- | Serialised field data type describing how to generate code for the field.
114 -- Each field has a type, which isn't captured in the type of the data type,
115 -- but is saved in the 'Q' monad in 'fieldType'.
116 --
117 -- Let @t@ be a type we want to parametrize the field with. There are the
118 -- following possible types of fields:
119 --
120 -- [Mandatory with no default.] Then @fieldType@ holds @t@,
121 -- @fieldDefault = Nothing@ and @fieldIsOptional = NotOptional@.
122 --
123 -- [Field with a default value.] Then @fieldType@ holds @t@ and
124 -- @fieldDefault = Just exp@ where @exp@ is an expression of type @t@ and
125 -- @fieldIsOptional = NotOptional@.
126 --
127 -- [Optional, no default value.] Then @fieldType@ holds @Maybe t@,
128 -- @fieldDefault = Nothing@ and @fieldIsOptional@ is either
129 -- 'OptionalOmitNull' or 'OptionalSerializeNull'.
130 --
131 -- Optional fields with a default value are prohibited, as their main
132 -- intention is to represent the information that a request didn't contain
133 -- the field data.
134 --
135 -- /Custom (de)serialization:/
136 -- Field can have custom (de)serialization functions that are stored in
137 -- 'fieldRead' and 'fieldShow'. If they aren't provided, the default is to use
138 -- 'readJSON' and 'showJSON' for the field's type @t@. If they are provided,
139 -- the type of the contained deserializing expression must be
140 --
141 -- @
142 -- [(String, JSON.JSValue)] -> JSON.JSValue -> JSON.Result t
143 -- @
144 --
145 -- where the first argument carries the whole record in the case the
146 -- deserializing function needs to process additional information.
147 --
148 -- The type of the contained serializing experssion must be
149 --
150 -- @
151 -- t -> (JSON.JSValue, [(String, JSON.JSValue)])
152 -- @
153 --
154 -- where the result can provide extra JSON fields to include in the output
155 -- record (or just return @[]@ if they're not needed).
156 --
157 -- Note that for optional fields the type appearing in the custom functions
158 -- is still @t@. Therefore making a field optional doesn't change the
159 -- functions.
160 --
161 -- There is also a special type of optional field 'AndRestArguments' which
162 -- allows to parse any additional arguments not covered by other fields. There
163 -- can be at most one such special field and it's type must be
164 -- @Map String JSON.JSValue@. See also 'andRestArguments'.
165 data Field = Field { fieldName :: String
166 , fieldType :: Q Type
167 -- ^ the type of the field, @t@ for non-optional fields,
168 -- @Maybe t@ for optional ones.
169 , fieldRead :: Maybe (Q Exp)
170 -- ^ an optional custom deserialization function of type
171 -- @[(String, JSON.JSValue)] -> JSON.JSValue ->
172 -- JSON.Result t@
173 , fieldShow :: Maybe (Q Exp)
174 -- ^ an optional custom serialization function of type
175 -- @t -> (JSON.JSValue, [(String, JSON.JSValue)])@
176 , fieldExtraKeys :: [String]
177 -- ^ a list of extra keys added by 'fieldShow'
178 , fieldDefault :: Maybe (Q Exp)
179 -- ^ an optional default value of type @t@
180 , fieldSerializeDefault :: Bool
181 -- ^ whether not presented default value will be
182 -- serialized
183 , fieldConstr :: Maybe String
184 , fieldIsOptional :: OptionalType
185 -- ^ determines if a field is optional, and if yes,
186 -- how
187 , fieldDoc :: String
188 }
189
190 -- | Generates a simple field.
191 simpleField :: String -> Q Type -> Field
192 simpleField fname ftype =
193 Field { fieldName = fname
194 , fieldType = ftype
195 , fieldRead = Nothing
196 , fieldShow = Nothing
197 , fieldExtraKeys = []
198 , fieldDefault = Nothing
199 , fieldSerializeDefault = True
200 , fieldConstr = Nothing
201 , fieldIsOptional = NotOptional
202 , fieldDoc = ""
203 }
204
205 -- | Generate an AndRestArguments catch-all field.
206 andRestArguments :: String -> Field
207 andRestArguments fname =
208 Field { fieldName = fname
209 , fieldType = [t| M.Map String JSON.JSValue |]
210 , fieldRead = Nothing
211 , fieldShow = Nothing
212 , fieldExtraKeys = []
213 , fieldDefault = Nothing
214 , fieldSerializeDefault = True
215 , fieldConstr = Nothing
216 , fieldIsOptional = AndRestArguments
217 , fieldDoc = ""
218 }
219
220 withDoc :: String -> Field -> Field
221 withDoc doc field =
222 field { fieldDoc = doc }
223
224 -- | Sets the renamed constructor field.
225 renameField :: String -> Field -> Field
226 renameField constrName field = field { fieldConstr = Just constrName }
227
228 -- | Sets the default value on a field (makes it optional with a
229 -- default value).
230 defaultField :: Q Exp -> Field -> Field
231 defaultField defval field = field { fieldDefault = Just defval }
232
233 -- | A defaultField which will be serialized only if it's value differs from
234 -- a default value.
235 notSerializeDefaultField :: Q Exp -> Field -> Field
236 notSerializeDefaultField defval field =
237 field { fieldDefault = Just defval
238 , fieldSerializeDefault = False }
239
240 -- | Marks a field optional (turning its base type into a Maybe).
241 optionalField :: Field -> Field
242 optionalField field = field { fieldIsOptional = OptionalOmitNull }
243
244 -- | Marks a field optional (turning its base type into a Maybe), but
245 -- with 'Nothing' serialised explicitly as /null/.
246 optionalNullSerField :: Field -> Field
247 optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
248
249 -- | Sets custom functions on a field.
250 customField :: Name -- ^ The name of the read function
251 -> Name -- ^ The name of the show function
252 -> [String] -- ^ The name of extra field keys
253 -> Field -- ^ The original field
254 -> Field -- ^ Updated field
255 customField readfn showfn extra field =
256 field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
257 , fieldExtraKeys = extra }
258
259 -- | Computes the record name for a given field, based on either the
260 -- string value in the JSON serialisation or the custom named if any
261 -- exists.
262 fieldRecordName :: Field -> String
263 fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
264 fromMaybe (camelCase name) alias
265
266 -- | Computes the preferred variable name to use for the value of this
267 -- field. If the field has a specific constructor name, then we use a
268 -- first-letter-lowercased version of that; otherwise, we simply use
269 -- the field name. See also 'fieldRecordName'.
270 fieldVariable :: Field -> String
271 fieldVariable f =
272 case (fieldConstr f) of
273 Just name -> ensureLower name
274 _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f
275
276 -- | Compute the actual field type (taking into account possible
277 -- optional status).
278 actualFieldType :: Field -> Q Type
279 actualFieldType f | fieldIsOptional f `elem` [NotOptional, AndRestArguments] = t
280 | otherwise = [t| Maybe $t |]
281 where t = fieldType f
282
283 -- | Checks that a given field is not optional (for object types or
284 -- fields which should not allow this case).
285 checkNonOptDef :: (Monad m) => Field -> m ()
286 checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull
287 , fieldName = name }) =
288 fail $ "Optional field " ++ name ++ " used in parameter declaration"
289 checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull
290 , fieldName = name }) =
291 fail $ "Optional field " ++ name ++ " used in parameter declaration"
292 checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
293 fail $ "Default field " ++ name ++ " used in parameter declaration"
294 checkNonOptDef _ = return ()
295
296 -- | Construct a function that parses a field value. If the field has
297 -- a custom 'fieldRead', it's applied to @o@ and used. Otherwise
298 -- @JSON.readJSON@ is used.
299 parseFn :: Field -- ^ The field definition
300 -> Q Exp -- ^ The entire object in JSON object format
301 -> Q Exp -- ^ The resulting function that parses a JSON message
302 parseFn field o =
303 let fnType = [t| JSON.JSValue -> JSON.Result $(fieldType field) |]
304 expr = maybe [| readJSONWithDesc $(stringE $ fieldName field) False |]
305 (`appE` o) (fieldRead field)
306 in sigE expr fnType
307
308 -- | Produces the expression that will de-serialise a given
309 -- field. Since some custom parsing functions might need to use the
310 -- entire object, we do take and pass the object to any custom read
311 -- functions.
312 loadFn :: Field -- ^ The field definition
313 -> Q Exp -- ^ The value of the field as existing in the JSON message
314 -> Q Exp -- ^ The entire object in JSON object format
315 -> Q Exp -- ^ Resulting expression
316 loadFn field expr o = [| $expr >>= $(parseFn field o) |]
317
318 -- | Just as 'loadFn', but for optional fields.
319 loadFnOpt :: Field -- ^ The field definition
320 -> Q Exp -- ^ The value of the field as existing in the JSON message
321 -- as Maybe
322 -> Q Exp -- ^ The entire object in JSON object format
323 -> Q Exp -- ^ Resulting expression
324 loadFnOpt field@(Field { fieldDefault = Just def }) expr o
325 = case fieldIsOptional field of
326 NotOptional -> [| $expr >>= maybe (return $def) $(parseFn field o) |]
327 _ -> fail $ "Field " ++ fieldName field ++ ":\
328 \ A field can't be optional and\
329 \ have a default value at the same time."
330 loadFnOpt field expr o
331 = [| $expr >>= maybe (return Nothing) (liftM Just . $(parseFn field o)) |]
332
333 -- * Internal types
334
335 -- | A simple field, in constrast to the customisable 'Field' type.
336 type SimpleField = (String, Q Type)
337
338 -- | A definition for a single constructor for a simple object.
339 type SimpleConstructor = (String, [SimpleField])
340
341 -- | A definition for ADTs with simple fields.
342 type SimpleObject = [SimpleConstructor]
343
344 -- | A type alias for an opcode constructor of a regular object.
345 type OpCodeConstructor = (String, Q Type, String, [Field], String)
346
347 -- | A type alias for a Luxi constructor of a regular object.
348 type LuxiConstructor = (String, [Field])
349
350 -- * Helper functions
351
352 -- | Ensure first letter is lowercase.
353 --
354 -- Used to convert type name to function prefix, e.g. in @data Aa ->
355 -- aaToRaw@.
356 ensureLower :: String -> String
357 ensureLower [] = []
358 ensureLower (x:xs) = toLower x:xs
359
360 -- | Ensure first letter is uppercase.
361 --
362 -- Used to convert constructor name to component
363 ensureUpper :: String -> String
364 ensureUpper [] = []
365 ensureUpper (x:xs) = toUpper x:xs
366
367 -- | Helper for quoted expressions.
368 varNameE :: String -> Q Exp
369 varNameE = varE . mkName
370
371 -- | fromObj (Ganeti specific) as an expression, for reuse.
372 fromObjE :: Q Exp
373 fromObjE = varE 'fromObj
374
375 -- | ToRaw function name.
376 toRawName :: String -> Name
377 toRawName = mkName . (++ "ToRaw") . ensureLower
378
379 -- | FromRaw function name.
380 fromRawName :: String -> Name
381 fromRawName = mkName . (++ "FromRaw") . ensureLower
382
383 -- | Converts a name to it's varE\/litE representations.
384 reprE :: Either String Name -> Q Exp
385 reprE = either stringE varE
386
387 -- | Apply a constructor to a list of expressions
388 appCons :: Name -> [Exp] -> Exp
389 appCons cname = foldl AppE (ConE cname)
390
391 -- | Apply a constructor to a list of applicative expressions
392 appConsApp :: Name -> [Exp] -> Exp
393 appConsApp cname =
394 foldl (\accu e -> InfixE (Just accu) (VarE '(<*>)) (Just e))
395 (AppE (VarE 'pure) (ConE cname))
396
397 -- | Builds a field for a normal constructor.
398 buildConsField :: Q Type -> StrictTypeQ
399 buildConsField ftype = do
400 ftype' <- ftype
401 return (NotStrict, ftype')
402
403 -- | Builds a constructor based on a simple definition (not field-based).
404 buildSimpleCons :: Name -> SimpleObject -> Q Dec
405 buildSimpleCons tname cons = do
406 decl_d <- mapM (\(cname, fields) -> do
407 fields' <- mapM (buildConsField . snd) fields
408 return $ NormalC (mkName cname) fields') cons
409 return $ DataD [] tname [] decl_d [''Show, ''Eq]
410
411 -- | Generate the save function for a given type.
412 genSaveSimpleObj :: Name -- ^ Object type
413 -> String -- ^ Function name
414 -> SimpleObject -- ^ Object definition
415 -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
416 -> Q (Dec, Dec)
417 genSaveSimpleObj tname sname opdefs fn = do
418 let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
419 fname = mkName sname
420 cclauses <- mapM fn opdefs
421 return $ (SigD fname sigt, FunD fname cclauses)
422
423 -- * Template code for simple raw type-equivalent ADTs
424
425 -- | Generates a data type declaration.
426 --
427 -- The type will have a fixed list of instances.
428 strADTDecl :: Name -> [String] -> Dec
429 strADTDecl name constructors =
430 DataD [] name []
431 (map (flip NormalC [] . mkName) constructors)
432 [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
433
434 -- | Generates a toRaw function.
435 --
436 -- This generates a simple function of the form:
437 --
438 -- @
439 -- nameToRaw :: Name -> /traw/
440 -- nameToRaw Cons1 = var1
441 -- nameToRaw Cons2 = \"value2\"
442 -- @
443 genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
444 genToRaw traw fname tname constructors = do
445 let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)
446 -- the body clauses, matching on the constructor and returning the
447 -- raw value
448 clauses <- mapM (\(c, v) -> clause [recP (mkName c) []]
449 (normalB (reprE v)) []) constructors
450 return [SigD fname sigt, FunD fname clauses]
451
452 -- | Generates a fromRaw function.
453 --
454 -- The function generated is monadic and can fail parsing the
455 -- raw value. It is of the form:
456 --
457 -- @
458 -- nameFromRaw :: (Monad m) => /traw/ -> m Name
459 -- nameFromRaw s | s == var1 = Cons1
460 -- | s == \"value2\" = Cons2
461 -- | otherwise = fail /.../
462 -- @
463 genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
464 genFromRaw traw fname tname constructors = do
465 -- signature of form (Monad m) => String -> m $name
466 sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
467 -- clauses for a guarded pattern
468 let varp = mkName "s"
469 varpe = varE varp
470 clauses <- mapM (\(c, v) -> do
471 -- the clause match condition
472 g <- normalG [| $varpe == $(reprE v) |]
473 -- the clause result
474 r <- [| return $(conE (mkName c)) |]
475 return (g, r)) constructors
476 -- the otherwise clause (fallback)
477 oth_clause <- do
478 g <- normalG [| otherwise |]
479 r <- [|fail ("Invalid string value for type " ++
480 $(litE (stringL (nameBase tname))) ++ ": " ++ show $varpe) |]
481 return (g, r)
482 let fun = FunD fname [Clause [VarP varp]
483 (GuardedB (clauses++[oth_clause])) []]
484 return [SigD fname sigt, fun]
485
486 -- | Generates a data type from a given raw format.
487 --
488 -- The format is expected to multiline. The first line contains the
489 -- type name, and the rest of the lines must contain two words: the
490 -- constructor name and then the string representation of the
491 -- respective constructor.
492 --
493 -- The function will generate the data type declaration, and then two
494 -- functions:
495 --
496 -- * /name/ToRaw, which converts the type to a raw type
497 --
498 -- * /name/FromRaw, which (monadically) converts from a raw type to the type
499 --
500 -- Note that this is basically just a custom show\/read instance,
501 -- nothing else.
502 declareADT
503 :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
504 declareADT fn traw sname cons = do
505 let name = mkName sname
506 ddecl = strADTDecl name (map fst cons)
507 -- process cons in the format expected by genToRaw
508 cons' = map (\(a, b) -> (a, fn b)) cons
509 toraw <- genToRaw traw (toRawName sname) name cons'
510 fromraw <- genFromRaw traw (fromRawName sname) name cons'
511 return $ ddecl:toraw ++ fromraw
512
513 declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
514 declareLADT = declareADT Left
515
516 declareILADT :: String -> [(String, Int)] -> Q [Dec]
517 declareILADT sname cons = do
518 consNames <- sequence [ newName ('_':n) | (n, _) <- cons ]
519 consFns <- concat <$> sequence
520 [ do sig <- sigD n [t| Int |]
521 let expr = litE (IntegerL (toInteger i))
522 fn <- funD n [clause [] (normalB expr) []]
523 return [sig, fn]
524 | n <- consNames
525 | (_, i) <- cons ]
526 let cons' = [ (n, n') | (n, _) <- cons | n' <- consNames ]
527 (consFns ++) <$> declareADT Right ''Int sname cons'
528
529 declareIADT :: String -> [(String, Name)] -> Q [Dec]
530 declareIADT = declareADT Right ''Int
531
532 declareSADT :: String -> [(String, Name)] -> Q [Dec]
533 declareSADT = declareADT Right ''String
534
535 -- | Creates the showJSON member of a JSON instance declaration.
536 --
537 -- This will create what is the equivalent of:
538 --
539 -- @
540 -- showJSON = showJSON . /name/ToRaw
541 -- @
542 --
543 -- in an instance JSON /name/ declaration
544 genShowJSON :: String -> Q Dec
545 genShowJSON name = do
546 body <- [| JSON.showJSON . $(varE (toRawName name)) |]
547 return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
548
549 -- | Creates the readJSON member of a JSON instance declaration.
550 --
551 -- This will create what is the equivalent of:
552 --
553 -- @
554 -- readJSON s = case readJSON s of
555 -- Ok s' -> /name/FromRaw s'
556 -- Error e -> Error /description/
557 -- @
558 --
559 -- in an instance JSON /name/ declaration
560 genReadJSON :: String -> Q Dec
561 genReadJSON name = do
562 let s = mkName "s"
563 body <- [| $(varE (fromRawName name)) =<<
564 readJSONWithDesc $(stringE name) True $(varE s) |]
565 return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
566
567 -- | Generates a JSON instance for a given type.
568 --
569 -- This assumes that the /name/ToRaw and /name/FromRaw functions
570 -- have been defined as by the 'declareSADT' function.
571 makeJSONInstance :: Name -> Q [Dec]
572 makeJSONInstance name = do
573 let base = nameBase name
574 showJ <- genShowJSON base
575 readJ <- genReadJSON base
576 return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
577
578 -- * Template code for opcodes
579
580 -- | Transforms a CamelCase string into an_underscore_based_one.
581 deCamelCase :: String -> String
582 deCamelCase =
583 intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
584
585 -- | Transform an underscore_name into a CamelCase one.
586 camelCase :: String -> String
587 camelCase = concatMap (ensureUpper . drop 1) .
588 groupBy (\_ b -> b /= '_' && b /= '-') . ('_':)
589
590 -- | Computes the name of a given constructor.
591 constructorName :: Con -> Q Name
592 constructorName (NormalC name _) = return name
593 constructorName (RecC name _) = return name
594 constructorName x = fail $ "Unhandled constructor " ++ show x
595
596 -- | Extract all constructor names from a given type.
597 reifyConsNames :: Name -> Q [String]
598 reifyConsNames name = do
599 reify_result <- reify name
600 case reify_result of
601 TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
602 o -> fail $ "Unhandled name passed to reifyConsNames, expected\
603 \ type constructor but got '" ++ show o ++ "'"
604
605 -- | Builds the generic constructor-to-string function.
606 --
607 -- This generates a simple function of the following form:
608 --
609 -- @
610 -- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
611 -- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
612 -- @
613 --
614 -- This builds a custom list of name\/string pairs and then uses
615 -- 'genToRaw' to actually generate the function.
616 genConstrToStr :: (String -> Q String) -> Name -> String -> Q [Dec]
617 genConstrToStr trans_fun name fname = do
618 cnames <- reifyConsNames name
619 svalues <- mapM (liftM Left . trans_fun) cnames
620 genToRaw ''String (mkName fname) name $ zip cnames svalues
621
622 -- | Constructor-to-string for OpCode.
623 genOpID :: Name -> String -> Q [Dec]
624 genOpID = genConstrToStr (return . deCamelCase)
625
626 -- | Strips @Op@ from the constructor name, converts to lower-case
627 -- and adds a given prefix.
628 genOpLowerStrip :: String -> Name -> String -> Q [Dec]
629 genOpLowerStrip prefix =
630 genConstrToStr (liftM ((prefix ++) . map toLower . deCamelCase)
631 . stripPrefixM "Op")
632 where
633 stripPrefixM :: String -> String -> Q String
634 stripPrefixM pfx s = maybe (fail $ s ++ " doesn't start with " ++ pfx)
635 return
636 $ stripPrefix pfx s
637
638 -- | Builds a list with all defined constructor names for a type.
639 --
640 -- @
641 -- vstr :: String
642 -- vstr = [...]
643 -- @
644 --
645 -- Where the actual values of the string are the constructor names
646 -- mapped via @trans_fun@.
647 genAllConstr :: (String -> String) -> Name -> String -> Q [Dec]
648 genAllConstr trans_fun name vstr = do
649 cnames <- reifyConsNames name
650 let svalues = sort $ map trans_fun cnames
651 vname = mkName vstr
652 sig = SigD vname (AppT ListT (ConT ''String))
653 body = NormalB (ListE (map (LitE . StringL) svalues))
654 return $ [sig, ValD (VarP vname) body []]
655
656 -- | Generates a list of all defined opcode IDs.
657 genAllOpIDs :: Name -> String -> Q [Dec]
658 genAllOpIDs = genAllConstr deCamelCase
659
660 -- * Python code generation
661
662 data OpCodeField = OpCodeField { ocfName :: String
663 , ocfType :: PyType
664 , ocfDefl :: Maybe PyValueEx
665 , ocfDoc :: String
666 }
667
668 -- | Transfers opcode data between the opcode description (through
669 -- @genOpCode@) and the Python code generation functions.
670 data OpCodeDescriptor = OpCodeDescriptor { ocdName :: String
671 , ocdType :: PyType
672 , ocdDoc :: String
673 , ocdFields :: [OpCodeField]
674 , ocdDescr :: String
675 }
676
677 -- | Optionally encapsulates default values in @PyValueEx@.
678 --
679 -- @maybeApp exp typ@ returns a quoted expression that encapsulates
680 -- the default value @exp@ of an opcode parameter cast to @typ@ in a
681 -- @PyValueEx@, if @exp@ is @Just@. Otherwise, it returns a quoted
682 -- expression with @Nothing@.
683 maybeApp :: Maybe (Q Exp) -> Q Type -> Q Exp
684 maybeApp Nothing _ =
685 [| Nothing |]
686
687 maybeApp (Just expr) typ =
688 [| Just ($(conE (mkName "PyValueEx")) ($expr :: $typ)) |]
689
690 -- | Generates a Python type according to whether the field is
691 -- optional.
692 --
693 -- The type of created expression is PyType.
694 genPyType' :: OptionalType -> Q Type -> Q PyType
695 genPyType' opt typ = typ >>= pyOptionalType (opt /= NotOptional)
696
697 -- | Generates Python types from opcode parameters.
698 genPyType :: Field -> Q PyType
699 genPyType f = genPyType' (fieldIsOptional f) (fieldType f)
700
701 -- | Generates Python default values from opcode parameters.
702 genPyDefault :: Field -> Q Exp
703 genPyDefault f = maybeApp (fieldDefault f) (fieldType f)
704
705 pyField :: Field -> Q Exp
706 pyField f = genPyType f >>= \t ->
707 [| OpCodeField $(stringE (fieldName f))
708 t
709 $(genPyDefault f)
710 $(stringE (fieldDoc f)) |]
711
712 -- | Generates a Haskell function call to "showPyClass" with the
713 -- necessary information on how to build the Python class string.
714 pyClass :: OpCodeConstructor -> Q Exp
715 pyClass (consName, consType, consDoc, consFields, consDscField) =
716 do let consName' = stringE consName
717 consType' <- genPyType' NotOptional consType
718 let consDoc' = stringE consDoc
719 [| OpCodeDescriptor $consName'
720 consType'
721 $consDoc'
722 $(listE $ map pyField consFields)
723 consDscField |]
724
725 -- | Generates a function called "pyClasses" that holds the list of
726 -- all the opcode descriptors necessary for generating the Python
727 -- opcodes.
728 pyClasses :: [OpCodeConstructor] -> Q [Dec]
729 pyClasses cons =
730 do let name = mkName "pyClasses"
731 sig = SigD name (AppT ListT (ConT ''OpCodeDescriptor))
732 fn <- FunD name <$> (:[]) <$> declClause cons
733 return [sig, fn]
734 where declClause c =
735 clause [] (normalB (ListE <$> mapM pyClass c)) []
736
737 -- | Converts from an opcode constructor to a Luxi constructor.
738 opcodeConsToLuxiCons :: OpCodeConstructor -> LuxiConstructor
739 opcodeConsToLuxiCons (x, _, _, y, _) = (x, y)
740
741 -- | Generates 'DictObject' instance for an op-code.
742 genOpCodeDictObject :: Name -- ^ Type name to use
743 -> (LuxiConstructor -> Q Clause) -- ^ saving function
744 -> (LuxiConstructor -> Q Exp) -- ^ loading function
745 -> [LuxiConstructor] -- ^ Constructors
746 -> Q [Dec]
747 genOpCodeDictObject tname savefn loadfn cons = do
748 tdclauses <- genSaveOpCode cons savefn
749 fdclauses <- genLoadOpCode cons loadfn
750 return [ InstanceD [] (AppT (ConT ''DictObject) (ConT tname))
751 [ FunD 'toDict tdclauses
752 , FunD 'fromDictWKeys fdclauses
753 ]]
754
755 -- | Generates the OpCode data type.
756 --
757 -- This takes an opcode logical definition, and builds both the
758 -- datatype and the JSON serialisation out of it. We can't use a
759 -- generic serialisation since we need to be compatible with Ganeti's
760 -- own, so we have a few quirks to work around.
761 genOpCode :: String -- ^ Type name to use
762 -> [OpCodeConstructor] -- ^ Constructor name and parameters
763 -> Q [Dec]
764 genOpCode name cons = do
765 let tname = mkName name
766 decl_d <- mapM (\(cname, _, _, fields, _) -> do
767 -- we only need the type of the field, without Q
768 fields' <- mapM (fieldTypeInfo "op") fields
769 return $ RecC (mkName cname) fields')
770 cons
771 let declD = DataD [] tname [] decl_d [''Show, ''Eq]
772 let (allfsig, allffn) = genAllOpFields "allOpFields" cons
773 -- DictObject
774 let luxiCons = map opcodeConsToLuxiCons cons
775 dictObjInst <- genOpCodeDictObject tname saveConstructor loadOpConstructor
776 luxiCons
777 -- rest
778 pyDecls <- pyClasses cons
779 return $ [declD, allfsig, allffn] ++ dictObjInst ++ pyDecls
780
781 -- | Generates the function pattern returning the list of fields for a
782 -- given constructor.
783 genOpConsFields :: OpCodeConstructor -> Clause
784 genOpConsFields (cname, _, _, fields, _) =
785 let op_id = deCamelCase cname
786 fvals = map (LitE . StringL) . sort . nub $
787 concatMap (\f -> fieldName f:fieldExtraKeys f) fields
788 in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
789
790 -- | Generates a list of all fields of an opcode constructor.
791 genAllOpFields :: String -- ^ Function name
792 -> [OpCodeConstructor] -- ^ Object definition
793 -> (Dec, Dec)
794 genAllOpFields sname opdefs =
795 let cclauses = map genOpConsFields opdefs
796 other = Clause [WildP] (NormalB (ListE [])) []
797 fname = mkName sname
798 sigt = AppT (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
799 in (SigD fname sigt, FunD fname (cclauses++[other]))
800
801 -- | Generates the \"save\" clause for an entire opcode constructor.
802 --
803 -- This matches the opcode with variables named the same as the
804 -- constructor fields (just so that the spliced in code looks nicer),
805 -- and passes those name plus the parameter definition to 'saveObjectField'.
806 saveConstructor :: LuxiConstructor -- ^ The constructor
807 -> Q Clause -- ^ Resulting clause
808 saveConstructor (sname, fields) = do
809 let cname = mkName sname
810 fnames <- mapM (newName . fieldVariable) fields
811 let pat = conP cname (map varP fnames)
812 let felems = zipWith saveObjectField fnames fields
813 -- now build the OP_ID serialisation
814 opid = [| [( $(stringE "OP_ID"),
815 JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
816 flist = listE (opid:felems)
817 -- and finally convert all this to a json object
818 flist' = [| concat $flist |]
819 clause [pat] (normalB flist') []
820
821 -- | Generates the main save opcode function, serializing as a dictionary.
822 --
823 -- This builds a per-constructor match clause that contains the
824 -- respective constructor-serialisation code.
825 genSaveOpCode :: [LuxiConstructor] -- ^ Object definition
826 -> (LuxiConstructor -> Q Clause) -- ^ Constructor save fn
827 -> Q [Clause]
828 genSaveOpCode opdefs fn = mapM fn opdefs
829
830 -- | Generates load code for a single constructor of the opcode data type.
831 -- The type of the resulting expression is @WriterT UsedKeys J.Result a@.
832 loadConstructor :: Name -> (Field -> Q Exp) -> [Field] -> Q Exp
833 loadConstructor name loadfn fields =
834 [| MT.lift $(appConsApp name <$> mapM loadfn fields)
835 <* tell $(fieldsUsedKeysQ fields) |]
836
837 -- | Generates load code for a single constructor of the opcode data type.
838 loadOpConstructor :: LuxiConstructor -> Q Exp
839 loadOpConstructor (sname, fields) =
840 loadConstructor (mkName sname) (loadObjectField fields) fields
841
842 -- | Generates the loadOpCode function.
843 genLoadOpCode :: [LuxiConstructor]
844 -> (LuxiConstructor -> Q Exp) -- ^ Constructor load fn
845 -> Q [Clause]
846 genLoadOpCode opdefs fn = do
847 let objname = objVarName
848 opidKey = "OP_ID"
849 opid = mkName $ map toLower opidKey
850 st <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE opidKey) |]
851 -- the match results (per-constructor blocks)
852 mexps <- mapM fn opdefs
853 fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
854 let mpats = map (\(me, op) ->
855 let mp = LitP . StringL . deCamelCase . fst $ op
856 in Match mp (NormalB me) []
857 ) $ zip mexps opdefs
858 defmatch = Match WildP (NormalB fails) []
859 cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
860 body = DoE [st, cst]
861 -- include "OP_ID" to the list of used keys
862 bodyAndOpId <- [| $(return body)
863 <* tell (mkUsedKeys $ S.singleton opidKey) |]
864 return [Clause [VarP objname] (NormalB bodyAndOpId) []]
865
866 -- * Template code for luxi
867
868 -- | Constructor-to-string for LuxiOp.
869 genStrOfOp :: Name -> String -> Q [Dec]
870 genStrOfOp = genConstrToStr return
871
872 -- | Constructor-to-string for MsgKeys.
873 genStrOfKey :: Name -> String -> Q [Dec]
874 genStrOfKey = genConstrToStr (return . ensureLower)
875
876 -- | Generates the LuxiOp data type.
877 --
878 -- This takes a Luxi operation definition and builds both the
879 -- datatype and the function transforming the arguments to JSON.
880 -- We can't use anything less generic, because the way different
881 -- operations are serialized differs on both parameter- and top-level.
882 --
883 -- There are two things to be defined for each parameter:
884 --
885 -- * name
886 --
887 -- * type
888 --
889 genLuxiOp :: String -> [LuxiConstructor] -> Q [Dec]
890 genLuxiOp name cons = do
891 let tname = mkName name
892 decl_d <- mapM (\(cname, fields) -> do
893 -- we only need the type of the field, without Q
894 fields' <- mapM actualFieldType fields
895 let fields'' = zip (repeat NotStrict) fields'
896 return $ NormalC (mkName cname) fields'')
897 cons
898 let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
899 -- generate DictObject instance
900 dictObjInst <- genOpCodeDictObject tname saveLuxiConstructor
901 loadOpConstructor cons
902 -- .. and use it to construct 'opToArgs' of 'toDict'
903 -- (as we know that the output of 'toDict' is always in the proper order)
904 opToArgsType <- [t| $(conT tname) -> JSON.JSValue |]
905 opToArgsExp <- [| JSON.showJSON . map snd . toDict |]
906 let opToArgsName = mkName "opToArgs"
907 opToArgsDecs = [ SigD opToArgsName opToArgsType
908 , ValD (VarP opToArgsName) (NormalB opToArgsExp) []
909 ]
910 -- rest
911 req_defs <- declareSADT "LuxiReq" .
912 map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
913 cons
914 return $ [declD] ++ dictObjInst ++ opToArgsDecs ++ req_defs
915
916 -- | Generates the \"save\" clause for entire LuxiOp constructor.
917 saveLuxiConstructor :: LuxiConstructor -> Q Clause
918 saveLuxiConstructor (sname, fields) = do
919 let cname = mkName sname
920 fnames <- mapM (newName . fieldVariable) fields
921 let pat = conP cname (map varP fnames)
922 let felems = zipWith saveObjectField fnames fields
923 flist = [| concat $(listE felems) |]
924 clause [pat] (normalB flist) []
925
926 -- * "Objects" functionality
927
928 -- | Extract the field's declaration from a Field structure.
929 fieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
930 fieldTypeInfo field_pfx fd = do
931 t <- actualFieldType fd
932 let n = mkName . (field_pfx ++) . fieldRecordName $ fd
933 return (n, NotStrict, t)
934
935 -- | Build an object declaration.
936 buildObject :: String -> String -> [Field] -> Q [Dec]
937 buildObject sname field_pfx fields = do
938 when (any ((==) AndRestArguments . fieldIsOptional)
939 . drop 1 $ reverse fields)
940 $ fail "Objects may have only one AndRestArguments field,\
941 \ and it must be the last one."
942 let name = mkName sname
943 fields_d <- mapM (fieldTypeInfo field_pfx) fields
944 let decl_d = RecC name fields_d
945 let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
946 ser_decls <- buildObjectSerialisation sname fields
947 return $ declD:ser_decls
948
949 -- | Generates an object definition: data type and its JSON instance.
950 buildObjectSerialisation :: String -> [Field] -> Q [Dec]
951 buildObjectSerialisation sname fields = do
952 let name = mkName sname
953 dictdecls <- genDictObject saveObjectField
954 (loadObjectField fields) sname fields
955 savedecls <- genSaveObject sname
956 (loadsig, loadfn) <- genLoadObject sname
957 shjson <- objectShowJSON sname
958 rdjson <- objectReadJSON sname
959 let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
960 [rdjson, shjson]
961 return $ dictdecls ++ savedecls ++ [loadsig, loadfn, instdecl]
962
963 -- | An internal name used for naming variables that hold the entire
964 -- object of type @[(String,JSValue)]@.
965 objVarName :: Name
966 objVarName = mkName "_o"
967
968 -- | Provides a default 'toJSArray' for 'ArrayObject' instance using its
969 -- existing 'DictObject' instance. The keys are serialized in the order
970 -- they're declared. The list must contain all keys possibly generated by
971 -- 'toDict'.
972 defaultToJSArray :: (DictObject a) => [String] -> a -> [JSON.JSValue]
973 defaultToJSArray keys o =
974 let m = M.fromList $ toDict o
975 in map (fromMaybe JSON.JSNull . flip M.lookup m) keys
976
977 -- | Provides a default 'fromJSArray' for 'ArrayObject' instance using its
978 -- existing 'DictObject' instance. The fields are deserialized in the order
979 -- they're declared.
980 defaultFromJSArray :: (DictObject a)
981 => [String] -> [JSON.JSValue] -> JSON.Result a
982 defaultFromJSArray keys xs = do
983 let xslen = length xs
984 explen = length keys
985 unless (xslen == explen) (fail $ "Expected " ++ show explen
986 ++ " arguments, got " ++ show xslen)
987 fromDict $ zip keys xs
988
989 -- | Generates an additional 'ArrayObject' instance using its
990 -- existing 'DictObject' instance.
991 --
992 -- See 'defaultToJSArray' and 'defaultFromJSArray'.
993 genArrayObjectInstance :: Name -> [Field] -> Q Dec
994 genArrayObjectInstance name fields = do
995 let fnames = concatMap (liftA2 (:) fieldName fieldExtraKeys) fields
996 instanceD (return []) (appT (conT ''ArrayObject) (conT name))
997 [ valD (varP 'toJSArray) (normalB [| defaultToJSArray $(lift fnames) |]) []
998 , valD (varP 'fromJSArray) (normalB [| defaultFromJSArray fnames |]) []
999 ]
1000
1001 -- | Generates 'DictObject' instance.
1002 genDictObject :: (Name -> Field -> Q Exp) -- ^ a saving function
1003 -> (Field -> Q Exp) -- ^ a loading function
1004 -> String -- ^ an object name
1005 -> [Field] -- ^ a list of fields
1006 -> Q [Dec]
1007 genDictObject save_fn load_fn sname fields = do
1008 let name = mkName sname
1009 -- toDict
1010 fnames <- mapM (newName . fieldVariable) fields
1011 let pat = conP name (map varP fnames)
1012 tdexp = [| concat $(listE $ zipWith save_fn fnames fields) |]
1013 tdclause <- clause [pat] (normalB tdexp) []
1014 -- fromDict
1015 fdexp <- loadConstructor name load_fn fields
1016 let fdclause = Clause [VarP objVarName] (NormalB fdexp) []
1017 -- the ArrayObject instance generated from DictObject
1018 arrdec <- genArrayObjectInstance name fields
1019 -- the final instance
1020 return $ [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
1021 [ FunD 'toDict [tdclause]
1022 , FunD 'fromDictWKeys [fdclause]
1023 ]]
1024 ++ [arrdec]
1025
1026 -- | Generates the save object functionality.
1027 genSaveObject :: String -> Q [Dec]
1028 genSaveObject sname = do
1029 let fname = mkName ("save" ++ sname)
1030 sigt <- [t| $(conT $ mkName sname) -> JSON.JSValue |]
1031 cclause <- [| showJSONtoDict |]
1032 return [SigD fname sigt, ValD (VarP fname) (NormalB cclause) []]
1033
1034 -- | Generates the code for saving an object's field, handling the
1035 -- various types of fields that we have.
1036 saveObjectField :: Name -> Field -> Q Exp
1037 saveObjectField fvar field = do
1038 let formatFn = fromMaybe [| JSON.showJSON &&& (const []) |] $
1039 fieldShow field
1040 formatFnTyped = sigE formatFn
1041 [t| $(fieldType field) -> (JSON.JSValue, [(String, JSON.JSValue)]) |]
1042 let formatCode v = [| let (actual, extra) = $formatFnTyped $(v)
1043 in ($nameE, actual) : extra |]
1044 case fieldIsOptional field of
1045 OptionalOmitNull -> [| case $(fvarE) of
1046 Nothing -> []
1047 Just v -> $(formatCode [| v |])
1048 |]
1049 OptionalSerializeNull -> [| case $(fvarE) of
1050 Nothing -> [( $nameE, JSON.JSNull )]
1051 Just v -> $(formatCode [| v |])
1052 |]
1053 NotOptional -> case (fieldDefault field, fieldSerializeDefault field) of
1054 (Just v, False) -> [| if $v /= $fvarE
1055 then $(formatCode fvarE)
1056 else [] |]
1057 -- If a default value exists and we shouldn't serialize
1058 -- default fields - serialize only if the value differs
1059 -- from the default one.
1060 _ -> formatCode fvarE
1061 AndRestArguments -> [| M.toList $(varE fvar) |]
1062 where nameE = stringE (fieldName field)
1063 fvarE = varE fvar
1064
1065 -- | Generates the showJSON clause for a given object name.
1066 objectShowJSON :: String -> Q Dec
1067 objectShowJSON name = do
1068 body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
1069 return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
1070
1071 -- | Generates the load object functionality.
1072 genLoadObject :: String -> Q (Dec, Dec)
1073 genLoadObject sname = do
1074 let fname = mkName $ "load" ++ sname
1075 sigt <- [t| JSON.JSValue -> JSON.Result $(conT $ mkName sname) |]
1076 cclause <- [| readJSONfromDict |]
1077 return $ (SigD fname sigt,
1078 FunD fname [Clause [] (NormalB cclause) []])
1079
1080 -- | Generates code for loading an object's field.
1081 loadObjectField :: [Field] -> Field -> Q Exp
1082 loadObjectField allFields field = do
1083 let otherNames = fieldsDictKeysQ . filter (on (/=) fieldName field)
1084 $ allFields
1085 -- these are used in all patterns below
1086 let objvar = varE objVarName
1087 objfield = stringE (fieldName field)
1088 case (fieldDefault field, fieldIsOptional field) of
1089 -- Only non-optional fields without defaults must have a value;
1090 -- we treat both optional types the same, since
1091 -- 'maybeFromObj' can deal with both missing and null values
1092 -- appropriately (the same)
1093 (Nothing, NotOptional) ->
1094 loadFn field [| fromObj $objvar $objfield |] objvar
1095 -- AndRestArguments need not to be parsed at all,
1096 -- they're just extracted from the list of other fields.
1097 (Nothing, AndRestArguments) ->
1098 [| return . M.fromList
1099 . filter (not . (`S.member` $(otherNames)) . fst)
1100 $ $objvar |]
1101 _ -> loadFnOpt field [| maybeFromObj $objvar $objfield |] objvar
1102
1103 -- | Generates the set of all used JSON dictionary keys for a field
1104 fieldDictKeys :: Field -> Exp
1105 fieldDictKeys field = AppE (VarE 'S.fromList)
1106 . ListE . map (LitE . StringL) $ liftA2 (:) fieldName fieldExtraKeys field
1107
1108 -- | Generates the list of all used JSON dictionary keys for a list of fields
1109 fieldsDictKeys :: [Field] -> Exp
1110 fieldsDictKeys fields =
1111 AppE (VarE 'S.unions) . ListE . map fieldDictKeys $ fields
1112
1113 -- | Generates the list of all used JSON dictionary keys for a list of fields
1114 fieldsDictKeysQ :: [Field] -> Q Exp
1115 fieldsDictKeysQ = return . fieldsDictKeys
1116
1117
1118 -- | Generates the list of all used JSON dictionary keys for a list of fields,
1119 -- depending on if any of them has 'AndRestArguments' flag.
1120 fieldsUsedKeysQ :: [Field] -> Q Exp
1121 fieldsUsedKeysQ fields
1122 | any ((==) AndRestArguments . fieldIsOptional) fields
1123 = [| allUsedKeys |]
1124 | otherwise = [| mkUsedKeys $(fieldsDictKeysQ fields) |]
1125
1126 -- | Builds the readJSON instance for a given object name.
1127 objectReadJSON :: String -> Q Dec
1128 objectReadJSON name = do
1129 let s = mkName "s"
1130 body <- [| $(varE . mkName $ "load" ++ name) =<<
1131 readJSONWithDesc $(stringE name) False $(varE s) |]
1132 return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
1133
1134 -- * Inheritable parameter tables implementation
1135
1136 -- | Compute parameter type names.
1137 paramTypeNames :: String -> (String, String)
1138 paramTypeNames root = ("Filled" ++ root ++ "Params",
1139 "Partial" ++ root ++ "Params")
1140
1141 -- | Compute information about the type of a parameter field.
1142 paramFieldTypeInfo :: String -> Field -> Q (Name, Strict, Type)
1143 paramFieldTypeInfo field_pfx fd = do
1144 t <- actualFieldType fd
1145 let n = mkName . (++ "P") . (field_pfx ++) .
1146 fieldRecordName $ fd
1147 return (n, NotStrict, AppT (ConT ''Maybe) t)
1148
1149 -- | Build a parameter declaration.
1150 --
1151 -- This function builds two different data structures: a /filled/ one,
1152 -- in which all fields are required, and a /partial/ one, in which all
1153 -- fields are optional. Due to the current record syntax issues, the
1154 -- fields need to be named differrently for the two structures, so the
1155 -- partial ones get a /P/ suffix.
1156 buildParam :: String -> String -> [Field] -> Q [Dec]
1157 buildParam sname field_pfx fields = do
1158 let (sname_f, sname_p) = paramTypeNames sname
1159 name_f = mkName sname_f
1160 name_p = mkName sname_p
1161 fields_f <- mapM (fieldTypeInfo field_pfx) fields
1162 fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
1163 let decl_f = RecC name_f fields_f
1164 decl_p = RecC name_p fields_p
1165 let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
1166 declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
1167 ser_decls_f <- buildObjectSerialisation sname_f fields
1168 ser_decls_p <- buildPParamSerialisation sname_p fields
1169 fill_decls <- fillParam sname field_pfx fields
1170 return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
1171 buildParamAllFields sname fields
1172
1173 -- | Builds a list of all fields of a parameter.
1174 buildParamAllFields :: String -> [Field] -> [Dec]
1175 buildParamAllFields sname fields =
1176 let vname = mkName ("all" ++ sname ++ "ParamFields")
1177 sig = SigD vname (AppT ListT (ConT ''String))
1178 val = ListE $ map (LitE . StringL . fieldName) fields
1179 in [sig, ValD (VarP vname) (NormalB val) []]
1180
1181 -- | Generates the serialisation for a partial parameter.
1182 buildPParamSerialisation :: String -> [Field] -> Q [Dec]
1183 buildPParamSerialisation sname fields = do
1184 let name = mkName sname
1185 dictdecls <- genDictObject savePParamField loadPParamField sname fields
1186 savedecls <- genSaveObject sname
1187 (loadsig, loadfn) <- genLoadObject sname
1188 shjson <- objectShowJSON sname
1189 rdjson <- objectReadJSON sname
1190 let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
1191 [rdjson, shjson]
1192 return $ dictdecls ++ savedecls ++ [loadsig, loadfn, instdecl]
1193
1194 -- | Generates code to save an optional parameter field.
1195 savePParamField :: Name -> Field -> Q Exp
1196 savePParamField fvar field = do
1197 checkNonOptDef field
1198 let actualVal = mkName "v"
1199 normalexpr <- saveObjectField actualVal field
1200 -- we have to construct the block here manually, because we can't
1201 -- splice-in-splice
1202 return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
1203 (NormalB (ConE '[])) []
1204 , Match (ConP 'Just [VarP actualVal])
1205 (NormalB normalexpr) []
1206 ]
1207
1208 -- | Generates code to load an optional parameter field.
1209 loadPParamField :: Field -> Q Exp
1210 loadPParamField field = do
1211 checkNonOptDef field
1212 let name = fieldName field
1213 -- these are used in all patterns below
1214 let objvar = varE objVarName
1215 objfield = stringE name
1216 loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
1217 loadFnOpt field loadexp objvar
1218
1219 -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
1220 buildFromMaybe :: String -> Q Dec
1221 buildFromMaybe fname =
1222 valD (varP (mkName $ "n_" ++ fname))
1223 (normalB [| $(varE 'fromMaybe)
1224 $(varNameE $ "f_" ++ fname)
1225 $(varNameE $ "p_" ++ fname) |]) []
1226
1227 -- | Builds a function that executes the filling of partial parameter
1228 -- from a full copy (similar to Python's fillDict).
1229 fillParam :: String -> String -> [Field] -> Q [Dec]
1230 fillParam sname field_pfx fields = do
1231 let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields
1232 (sname_f, sname_p) = paramTypeNames sname
1233 oname_f = "fobj"
1234 oname_p = "pobj"
1235 name_f = mkName sname_f
1236 name_p = mkName sname_p
1237 fun_name = mkName $ "fill" ++ sname ++ "Params"
1238 le_full = ValD (ConP name_f (map (VarP . mkName . ("f_" ++)) fnames))
1239 (NormalB . VarE . mkName $ oname_f) []
1240 le_part = ValD (ConP name_p (map (VarP . mkName . ("p_" ++)) fnames))
1241 (NormalB . VarE . mkName $ oname_p) []
1242 obj_new = appCons name_f $ map (VarE . mkName . ("n_" ++)) fnames
1243 le_new <- mapM buildFromMaybe fnames
1244 funt <- [t| $(conT name_f) -> $(conT name_p) -> $(conT name_f) |]
1245 let sig = SigD fun_name funt
1246 fclause = Clause [VarP (mkName oname_f), VarP (mkName oname_p)]
1247 (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
1248 fun = FunD fun_name [fclause]
1249 return [sig, fun]
1250
1251 -- * Template code for exceptions
1252
1253 -- | Exception simple error message field.
1254 excErrMsg :: (String, Q Type)
1255 excErrMsg = ("errMsg", [t| String |])
1256
1257 -- | Builds an exception type definition.
1258 genException :: String -- ^ Name of new type
1259 -> SimpleObject -- ^ Constructor name and parameters
1260 -> Q [Dec]
1261 genException name cons = do
1262 let tname = mkName name
1263 declD <- buildSimpleCons tname cons
1264 (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
1265 uncurry saveExcCons
1266 (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
1267 return [declD, loadsig, loadfn, savesig, savefn]
1268
1269 -- | Generates the \"save\" clause for an entire exception constructor.
1270 --
1271 -- This matches the exception with variables named the same as the
1272 -- constructor fields (just so that the spliced in code looks nicer),
1273 -- and calls showJSON on it.
1274 saveExcCons :: String -- ^ The constructor name
1275 -> [SimpleField] -- ^ The parameter definitions for this
1276 -- constructor
1277 -> Q Clause -- ^ Resulting clause
1278 saveExcCons sname fields = do
1279 let cname = mkName sname
1280 fnames <- mapM (newName . fst) fields
1281 let pat = conP cname (map varP fnames)
1282 felems = if null fnames
1283 then conE '() -- otherwise, empty list has no type
1284 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
1285 let tup = tupE [ litE (stringL sname), felems ]
1286 clause [pat] (normalB [| JSON.showJSON $tup |]) []
1287
1288 -- | Generates load code for a single constructor of an exception.
1289 --
1290 -- Generates the code (if there's only one argument, we will use a
1291 -- list, not a tuple:
1292 --
1293 -- @
1294 -- do
1295 -- (x1, x2, ...) <- readJSON args
1296 -- return $ Cons x1 x2 ...
1297 -- @
1298 loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
1299 loadExcConstructor inname sname fields = do
1300 let name = mkName sname
1301 f_names <- mapM (newName . fst) fields
1302 let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
1303 let binds = case f_names of
1304 [x] -> BindS (ListP [VarP x])
1305 _ -> BindS (TupP (map VarP f_names))
1306 cval = appCons name $ map VarE f_names
1307 return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
1308
1309 {-| Generates the loadException function.
1310
1311 This generates a quite complicated function, along the lines of:
1312
1313 @
1314 loadFn (JSArray [JSString name, args]) = case name of
1315 "A1" -> do
1316 (x1, x2, ...) <- readJSON args
1317 return $ A1 x1 x2 ...
1318 "a2" -> ...
1319 s -> fail $ "Unknown exception" ++ s
1320 loadFn v = fail $ "Expected array but got " ++ show v
1321 @
1322 -}
1323 genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
1324 genLoadExc tname sname opdefs = do
1325 let fname = mkName sname
1326 exc_name <- newName "name"
1327 exc_args <- newName "args"
1328 exc_else <- newName "s"
1329 arg_else <- newName "v"
1330 fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
1331 -- default match for unknown exception name
1332 let defmatch = Match (VarP exc_else) (NormalB fails) []
1333 -- the match results (per-constructor blocks)
1334 str_matches <-
1335 mapM (\(s, params) -> do
1336 body_exp <- loadExcConstructor exc_args s params
1337 return $ Match (LitP (StringL s)) (NormalB body_exp) [])
1338 opdefs
1339 -- the first function clause; we can't use [| |] due to TH
1340 -- limitations, so we have to build the AST by hand
1341 let clause1 = Clause [ConP 'JSON.JSArray
1342 [ListP [ConP 'JSON.JSString [VarP exc_name],
1343 VarP exc_args]]]
1344 (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
1345 (VarE exc_name))
1346 (str_matches ++ [defmatch]))) []
1347 -- the fail expression for the second function clause
1348 fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
1349 " but got " ++ show (pp_value $(varE arg_else)) ++ "'"
1350 |]
1351 -- the second function clause
1352 let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
1353 sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
1354 return $ (SigD fname sigt, FunD fname [clause1, clause2])