Revision 4b71f30c htools/Ganeti/THH.hs
| b/htools/Ganeti/THH.hs | ||
|---|---|---|
| 52 | 52 |
, buildParam |
| 53 | 53 |
) where |
| 54 | 54 |
|
| 55 |
import Control.Monad (liftM, liftM2)
|
|
| 55 |
import Control.Monad (liftM) |
|
| 56 | 56 |
import Data.Char |
| 57 | 57 |
import Data.List |
| 58 | 58 |
import qualified Data.Set as Set |
| ... | ... | |
| 499 | 499 |
genStrOfKey = genConstrToStr ensureLower |
| 500 | 500 |
|
| 501 | 501 |
-- | LuxiOp parameter type. |
| 502 |
type LuxiParam = (String, Q Type, Q Exp)
|
|
| 502 |
type LuxiParam = (String, Q Type) |
|
| 503 | 503 |
|
| 504 | 504 |
-- | Generates the LuxiOp data type. |
| 505 | 505 |
-- |
| ... | ... | |
| 508 | 508 |
-- We can't use anything less generic, because the way different |
| 509 | 509 |
-- operations are serialized differs on both parameter- and top-level. |
| 510 | 510 |
-- |
| 511 |
-- There are three things to be defined for each parameter:
|
|
| 511 |
-- There are two things to be defined for each parameter:
|
|
| 512 | 512 |
-- |
| 513 | 513 |
-- * name |
| 514 | 514 |
-- |
| 515 | 515 |
-- * type |
| 516 | 516 |
-- |
| 517 |
-- * operation; this is the operation performed on the parameter before |
|
| 518 |
-- serialization |
|
| 519 |
-- |
|
| 520 | 517 |
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec] |
| 521 | 518 |
genLuxiOp name cons = do |
| 522 | 519 |
decl_d <- mapM (\(cname, fields) -> do |
| 523 |
fields' <- mapM (\(_, qt, _) ->
|
|
| 520 |
fields' <- mapM (\(_, qt) -> |
|
| 524 | 521 |
qt >>= \t -> return (NotStrict, t)) |
| 525 | 522 |
fields |
| 526 | 523 |
return $ NormalC (mkName cname) fields') |
| ... | ... | |
| 534 | 531 |
|
| 535 | 532 |
-- | Generates the \"save\" expression for a single luxi parameter. |
| 536 | 533 |
saveLuxiField :: Name -> LuxiParam -> Q Exp |
| 537 |
saveLuxiField fvar (_, qt, fn) =
|
|
| 538 |
[| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |]
|
|
| 534 |
saveLuxiField fvar (_, qt) = |
|
| 535 |
[| JSON.showJSON $(varE fvar) |]
|
|
| 539 | 536 |
|
| 540 | 537 |
-- | Generates the \"save\" clause for entire LuxiOp constructor. |
| 541 | 538 |
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause |
| 542 | 539 |
saveLuxiConstructor (sname, fields) = do |
| 543 | 540 |
let cname = mkName sname |
| 544 |
fnames = map (\(nm, _, _) -> mkName nm) fields
|
|
| 541 |
fnames = map (mkName . fst) fields
|
|
| 545 | 542 |
pat = conP cname (map varP fnames) |
| 546 | 543 |
flist = map (uncurry saveLuxiField) (zip fnames fields) |
| 547 | 544 |
finval = if null flist |
Also available in: Unified diff