| 1 |
|
{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
|
|
1 |
{-# LANGUAGE TemplateHaskell #-}
|
| 2 |
2 |
|
| 3 |
3 |
{-| TemplateHaskell helper for HTools.
|
| 4 |
4 |
|
| ... | ... | |
| 34 |
34 |
, makeJSONInstance
|
| 35 |
35 |
, genOpID
|
| 36 |
36 |
, genOpCode
|
| 37 |
|
, noDefault
|
| 38 |
37 |
, genStrOfOp
|
| 39 |
38 |
, genStrOfKey
|
| 40 |
39 |
, genLuxiOp
|
| ... | ... | |
| 119 |
118 |
fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
|
| 120 |
119 |
maybe (camelCase name) id alias
|
| 121 |
120 |
|
|
121 |
-- | Computes the preferred variable name to use for the value of this
|
|
122 |
-- field. If the field has a specific constructor name, then we use a
|
|
123 |
-- first-letter-lowercased version of that; otherwise, we simply use
|
|
124 |
-- the field name. See also 'fieldRecordName'.
|
| 122 |
125 |
fieldVariable :: Field -> String
|
| 123 |
|
fieldVariable = map toLower . fieldRecordName
|
|
126 |
fieldVariable f =
|
|
127 |
case (fieldConstr f) of
|
|
128 |
Just name -> ensureLower name
|
|
129 |
_ -> fieldName f
|
| 124 |
130 |
|
| 125 |
131 |
actualFieldType :: Field -> Q Type
|
| 126 |
132 |
actualFieldType f | fieldIsContainer f = [t| Container $t |]
|
| ... | ... | |
| 408 |
414 |
-- datatype and the JSON serialisation out of it. We can't use a
|
| 409 |
415 |
-- generic serialisation since we need to be compatible with Ganeti's
|
| 410 |
416 |
-- own, so we have a few quirks to work around.
|
| 411 |
|
--
|
| 412 |
|
-- There are three things to be defined for each parameter:
|
| 413 |
|
--
|
| 414 |
|
-- * name
|
| 415 |
|
--
|
| 416 |
|
-- * type; if this is 'Maybe', will only be serialised if it's a
|
| 417 |
|
-- 'Just' value
|
| 418 |
|
--
|
| 419 |
|
-- * default; if missing, won't raise an exception, but will instead
|
| 420 |
|
-- use the default
|
| 421 |
|
--
|
| 422 |
417 |
genOpCode :: String -- ^ Type name to use
|
| 423 |
|
-> [(String, [OpParam])] -- ^ Constructor name and parameters
|
|
418 |
-> [(String, [Field])] -- ^ Constructor name and parameters
|
| 424 |
419 |
-> Q [Dec]
|
| 425 |
420 |
genOpCode name cons = do
|
| 426 |
421 |
decl_d <- mapM (\(cname, fields) -> do
|
| 427 |
422 |
-- we only need the type of the field, without Q
|
| 428 |
|
fields' <- mapM (\(_, qt, _) ->
|
| 429 |
|
qt >>= \t -> return (NotStrict, t))
|
| 430 |
|
fields
|
| 431 |
|
return $ NormalC (mkName cname) fields')
|
|
423 |
fields' <- mapM actualFieldType fields
|
|
424 |
let fields'' = zip (repeat NotStrict) fields'
|
|
425 |
return $ NormalC (mkName cname) fields'')
|
| 432 |
426 |
cons
|
| 433 |
427 |
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
|
| 434 |
428 |
|
| ... | ... | |
| 443 |
437 |
isOptional (AppT (ConT dt) _) | dt == ''Maybe = True
|
| 444 |
438 |
isOptional _ = False
|
| 445 |
439 |
|
| 446 |
|
-- | Generates the \"save\" expression for a single opcode parameter.
|
| 447 |
|
--
|
| 448 |
|
-- There is only one special handling mode: if the parameter is of
|
| 449 |
|
-- 'Maybe' type, then we only save it if it's a 'Just' value,
|
| 450 |
|
-- otherwise we skip it.
|
| 451 |
|
saveField :: Name -- ^ The name of variable that contains the value
|
| 452 |
|
-> OpParam -- ^ Parameter definition
|
| 453 |
|
-> Q Exp
|
| 454 |
|
saveField fvar (fname, qt, _) = do
|
| 455 |
|
t <- qt
|
| 456 |
|
let fnexp = stringE fname
|
| 457 |
|
fvare = varE fvar
|
| 458 |
|
(if isOptional t
|
| 459 |
|
then [| case $fvare of
|
| 460 |
|
Just v' -> [( $fnexp, $showJSONE v')]
|
| 461 |
|
Nothing -> []
|
| 462 |
|
|]
|
| 463 |
|
else [| [( $fnexp, $showJSONE $fvare )] |])
|
| 464 |
|
|
| 465 |
440 |
-- | Generates the \"save\" clause for an entire opcode constructor.
|
| 466 |
441 |
--
|
| 467 |
442 |
-- This matches the opcode with variables named the same as the
|
| 468 |
443 |
-- constructor fields (just so that the spliced in code looks nicer),
|
| 469 |
|
-- and passes those name plus the parameter definition to 'saveField'.
|
|
444 |
-- and passes those name plus the parameter definition to 'saveObjectField'.
|
| 470 |
445 |
saveConstructor :: String -- ^ The constructor name
|
| 471 |
|
-> [OpParam] -- ^ The parameter definitions for this
|
|
446 |
-> [Field] -- ^ The parameter definitions for this
|
| 472 |
447 |
-- constructor
|
| 473 |
448 |
-> Q Clause -- ^ Resulting clause
|
| 474 |
449 |
saveConstructor sname fields = do
|
| 475 |
450 |
let cname = mkName sname
|
| 476 |
|
let fnames = map (\(n, _, _) -> mkName n) fields
|
|
451 |
let fnames = map (mkName . fieldVariable) fields
|
| 477 |
452 |
let pat = conP cname (map varP fnames)
|
| 478 |
|
let felems = map (uncurry saveField) (zip fnames fields)
|
|
453 |
let felems = map (uncurry saveObjectField) (zip fnames fields)
|
| 479 |
454 |
-- now build the OP_ID serialisation
|
| 480 |
455 |
opid = [| [( $(stringE "OP_ID"),
|
| 481 |
456 |
$showJSONE $(stringE . deCamelCase $ sname) )] |]
|
| ... | ... | |
| 488 |
463 |
--
|
| 489 |
464 |
-- This builds a per-constructor match clause that contains the
|
| 490 |
465 |
-- respective constructor-serialisation code.
|
| 491 |
|
genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec)
|
|
466 |
genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec)
|
| 492 |
467 |
genSaveOpCode opdefs = do
|
| 493 |
468 |
cclauses <- mapM (uncurry saveConstructor) opdefs
|
| 494 |
469 |
let fname = mkName "saveOpCode"
|
| 495 |
470 |
sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |]
|
| 496 |
471 |
return $ (SigD fname sigt, FunD fname cclauses)
|
| 497 |
472 |
|
| 498 |
|
-- | Generates the \"load\" field for a single parameter.
|
| 499 |
|
--
|
| 500 |
|
-- There is custom handling, depending on how the parameter is
|
| 501 |
|
-- specified. For a 'Maybe' type parameter, we allow that it is not
|
| 502 |
|
-- present (via 'Utils.maybeFromObj'). Otherwise, if there is a
|
| 503 |
|
-- default value, we allow the parameter to be abset, and finally if
|
| 504 |
|
-- there is no default value, we require its presence.
|
| 505 |
|
loadField :: OpParam -> Q (Name, Stmt)
|
| 506 |
|
loadField (fname, qt, qdefa) = do
|
| 507 |
|
let fvar = mkName fname
|
| 508 |
|
t <- qt
|
| 509 |
|
defa <- qdefa
|
| 510 |
|
-- these are used in all patterns below
|
| 511 |
|
let objvar = varNameE "o"
|
| 512 |
|
objfield = stringE fname
|
| 513 |
|
bexp <- if isOptional t
|
| 514 |
|
then [| $((varNameE "maybeFromObj")) $objvar $objfield |]
|
| 515 |
|
else case defa of
|
| 516 |
|
AppE (ConE dt) defval | dt == 'Just ->
|
| 517 |
|
-- but has a default value
|
| 518 |
|
[| $(varNameE "fromObjWithDefault")
|
| 519 |
|
$objvar $objfield $(return defval) |]
|
| 520 |
|
ConE dt | dt == 'Nothing ->
|
| 521 |
|
[| $(varNameE "fromObj") $objvar $objfield |]
|
| 522 |
|
s -> fail $ "Invalid default value " ++ show s ++
|
| 523 |
|
", expecting either 'Nothing' or a 'Just defval'"
|
| 524 |
|
return (fvar, BindS (VarP fvar) bexp)
|
| 525 |
|
|
| 526 |
|
loadConstructor :: String -> [OpParam] -> Q Exp
|
|
473 |
loadConstructor :: String -> [Field] -> Q Exp
|
| 527 |
474 |
loadConstructor sname fields = do
|
| 528 |
475 |
let name = mkName sname
|
| 529 |
|
fbinds <- mapM loadField fields
|
|
476 |
fbinds <- mapM loadObjectField fields
|
| 530 |
477 |
let (fnames, fstmts) = unzip fbinds
|
| 531 |
478 |
let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames
|
| 532 |
479 |
fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]
|
| 533 |
480 |
return $ DoE fstmts'
|
| 534 |
481 |
|
| 535 |
|
genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec)
|
|
482 |
genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
|
| 536 |
483 |
genLoadOpCode opdefs = do
|
| 537 |
484 |
let fname = mkName "loadOpCode"
|
| 538 |
485 |
arg1 = mkName "v"
|
| ... | ... | |
| 555 |
502 |
sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |]
|
| 556 |
503 |
return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []])
|
| 557 |
504 |
|
| 558 |
|
-- | No default type.
|
| 559 |
|
noDefault :: Q Exp
|
| 560 |
|
noDefault = conE 'Nothing
|
| 561 |
|
|
| 562 |
505 |
-- * Template code for luxi
|
| 563 |
506 |
|
| 564 |
507 |
-- | Constructor-to-string for LuxiOp.
|