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