, genOpID
, genOpCode
, noDefault
+ , genStrOfOp
+ , genStrOfKey
+ , genLuxiOp
) where
-import Control.Monad (liftM)
+import Control.Monad (liftM, liftM2)
import Data.Char
import Data.List
import Language.Haskell.TH
import qualified Text.JSON as JSON
+-- * Helper functions
+
-- | Ensure first letter is lowercase.
--
-- Used to convert type name to function prefix, e.g. in @data Aa ->
ensureLower [] = []
ensureLower (x:xs) = toLower x:xs
+-- | Helper for quoted expressions.
+varNameE :: String -> Q Exp
+varNameE = varE . mkName
+
+-- | showJSON as an expression, for reuse.
+showJSONE :: Q Exp
+showJSONE = varNameE "showJSON"
+
-- | ToString function name.
toStrName :: String -> Name
toStrName = mkName . (++ "ToString") . ensureLower
-- | Converts a name to it's varE/litE representations.
--
reprE :: Either String Name -> Q Exp
-reprE (Left name) = litE (StringL name)
-reprE (Right name) = varE name
+reprE = either stringE varE
+
+-- | Smarter function application.
+--
+-- This does simply f x, except that if is 'id', it will skip it, in
+-- order to generate more readable code when using -ddump-splices.
+appFn :: Exp -> Exp -> Exp
+appFn f x | f == VarE 'id = x
+ | otherwise = AppE f x
+
+-- * Template code for simple string-equivalent ADTs
-- | Generates a data type declaration.
--
JSON.Ok s' -> $(varE (fromStrName name)) s'
JSON.Error e ->
JSON.Error $ "Can't parse string value for type " ++
- $(litE (StringL name)) ++ ": " ++ e
+ $(stringE name) ++ ": " ++ e
|]
return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
readJ <- genReadJSON base
return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
+-- * Template code for opcodes
+
-- | Transforms a CamelCase string into an_underscore_based_one.
deCamelCase :: String -> String
deCamelCase =
intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
--- | Computes the name of a given constructor
+-- | Computes the name of a given constructor.
constructorName :: Con -> Q Name
constructorName (NormalC name _) = return name
constructorName (RecC name _) = return name
constructorName x = fail $ "Unhandled constructor " ++ show x
--- | Builds the constructor-to-string function.
+-- | Builds the generic constructor-to-string function.
--
-- This generates a simple function of the following form:
--
-- @
--- fname (ConStructorOne {}) = "CON_STRUCTOR_ONE"
--- fname (ConStructorTwo {}) = "CON_STRUCTOR_TWO"
+-- fname (ConStructorOne {}) = trans_fun("ConStructorOne")
+-- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo")
-- @
--
-- This builds a custom list of name/string pairs and then uses
-- 'genToString' to actually generate the function
-genOpID :: Name -> String -> Q [Dec]
-genOpID name fname = do
+genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec]
+genConstrToStr trans_fun name fname = do
TyConI (DataD _ _ _ cons _) <- reify name
cnames <- mapM (liftM nameBase . constructorName) cons
- let svalues = map (Left . deCamelCase) cnames
+ let svalues = map (Left . trans_fun) cnames
genToString (mkName fname) name $ zip cnames svalues
+-- | Constructor-to-string for OpCode.
+genOpID :: Name -> String -> Q [Dec]
+genOpID = genConstrToStr deCamelCase
--- | OpCode parameter (field) type
+-- | OpCode parameter (field) type.
type OpParam = (String, Q Type, Q Exp)
-- | Generates the OpCode data type.
(loadsig, loadfn) <- genLoadOpCode cons
return [declD, loadsig, loadfn, savesig, savefn]
--- | Checks whether a given parameter is options
+-- | Checks whether a given parameter is options.
--
-- This requires that it's a 'Maybe'.
isOptional :: Type -> Bool
-> Q Exp
saveField fvar (fname, qt, _) = do
t <- qt
- let showJ = varE (mkName "showJSON")
- fnexp = litE (stringL fname)
+ let fnexp = stringE fname
fvare = varE fvar
(if isOptional t
then [| case $fvare of
- Just v' -> [( $fnexp, $showJ v')]
+ Just v' -> [( $fnexp, $showJSONE v')]
Nothing -> []
|]
- else [| [( $fnexp, $showJ $fvare )] |])
+ else [| [( $fnexp, $showJSONE $fvare )] |])
-- | Generates the \"save\" clause for an entire opcode constructor.
--
let pat = conP cname (map varP fnames)
let felems = map (uncurry saveField) (zip fnames fields)
-- now build the OP_ID serialisation
- opid = [| [( $(litE (stringL "OP_ID")),
- $(varE (mkName "showJSON"))
- $(litE . stringL . deCamelCase $ sname) )] |]
+ opid = [| [( $(stringE "OP_ID"),
+ $showJSONE $(stringE . deCamelCase $ sname) )] |]
flist = listE (opid:felems)
-- and finally convert all this to a json object
- flist' = [| $(varE (mkName "makeObj")) (concat $flist) |]
+ flist' = [| $(varNameE "makeObj") (concat $flist) |]
clause [pat] (normalB flist') []
-- | Generates the main save opcode function.
t <- qt
defa <- qdefa
-- these are used in all patterns below
- let objvar = varE (mkName "o")
- objfield = litE (StringL fname)
+ let objvar = varNameE "o"
+ objfield = stringE fname
bexp <- if isOptional t
- then [| $((varE (mkName "maybeFromObj"))) $objvar $objfield |]
+ then [| $((varNameE "maybeFromObj")) $objvar $objfield |]
else case defa of
AppE (ConE dt) defval | dt == 'Just ->
-- but has a default value
- [| $(varE (mkName "fromObjWithDefault"))
+ [| $(varNameE "fromObjWithDefault")
$objvar $objfield $(return defval) |]
ConE dt | dt == 'Nothing ->
- [| $(varE (mkName "fromObj")) $objvar $objfield |]
+ [| $(varNameE "fromObj") $objvar $objfield |]
s -> fail $ "Invalid default value " ++ show s ++
", expecting either 'Nothing' or a 'Just defval'"
return (fvar, BindS (VarP fvar) bexp)
opid = mkName "op_id"
st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
(JSON.readJSON $(varE arg1)) |]
- st2 <- bindS (varP opid) [| $(varE (mkName "fromObj"))
- $(varE objname) $(litE (stringL "OP_ID")) |]
+ st2 <- bindS (varP opid) [| $(varNameE "fromObj")
+ $(varE objname) $(stringE "OP_ID") |]
-- the match results (per-constructor blocks)
mexps <- mapM (uncurry loadConstructor) opdefs
fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
-- | No default type.
noDefault :: Q Exp
noDefault = conE 'Nothing
+
+-- * Template code for luxi
+
+-- | Constructor-to-string for LuxiOp.
+genStrOfOp :: Name -> String -> Q [Dec]
+genStrOfOp = genConstrToStr id
+
+-- | Constructor-to-string for MsgKeys.
+genStrOfKey :: Name -> String -> Q [Dec]
+genStrOfKey = genConstrToStr ensureLower
+
+-- | LuxiOp parameter type.
+type LuxiParam = (String, Q Type, Q Exp)
+
+-- | Generates the LuxiOp data type.
+--
+-- This takes a Luxi operation definition and builds both the
+-- datatype and the function trnasforming the arguments to JSON.
+-- We can't use anything less generic, because the way different
+-- operations are serialized differs on both parameter- and top-level.
+--
+-- There are three things to be defined for each parameter:
+--
+-- * name
+--
+-- * type
+--
+-- * operation; this is the operation performed on the parameter before
+-- serialization
+--
+genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
+genLuxiOp name cons = do
+ decl_d <- mapM (\(cname, fields) -> do
+ fields' <- mapM (\(_, qt, _) ->
+ qt >>= \t -> return (NotStrict, t))
+ fields
+ return $ NormalC (mkName cname) fields')
+ cons
+ let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]
+ (savesig, savefn) <- genSaveLuxiOp cons
+ return [declD, savesig, savefn]
+
+-- | Generates the \"save\" clause for entire LuxiOp constructor.
+saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
+saveLuxiConstructor (sname, fields) =
+ let cname = mkName sname
+ fnames = map (\(nm, _, _) -> mkName nm) fields
+ pat = conP cname (map varP fnames)
+ flist = map (\(nm, _, fn) -> liftM2 appFn fn $ (varNameE nm)) fields
+ showlist = map (\x -> [| JSON.showJSON $x |]) flist
+ finval = case showlist of
+ [] -> [| JSON.showJSON () |]
+ _ -> [| JSON.showJSON $(listE showlist) |]
+ in clause [pat] (normalB finval) []
+
+-- | Generates the main save LuxiOp function.
+genSaveLuxiOp :: [(String, [LuxiParam])] -> Q (Dec, Dec)
+genSaveLuxiOp opdefs = do
+ sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
+ let fname = mkName "opToArgs"
+ cclauses <- mapM saveLuxiConstructor opdefs
+ return $ (SigD fname sigt, FunD fname cclauses)
projects / ganeti-local / blobdiff