diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 7584a2b5d1a83e99ef7b3ea65bfb2b4d1afdea34..dd479600eee1f2a2c1c55127d3b4142f4640cf4c 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -43,6 +43,8 @@ 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 -> @@ -51,6 +53,14 @@ ensureLower :: String -> String 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 @@ -62,8 +72,9 @@ fromStrName = mkName . (++ "FromString") . 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 + +-- * Template code for simple string-equivalent ADTs -- | Generates a data type declaration. -- @@ -183,7 +194,7 @@ genReadJSON name = do 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) []] @@ -198,6 +209,8 @@ makeJSONInstance name = do 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 = @@ -282,15 +295,14 @@ saveField :: Name -- ^ The name of variable that contains the value -> 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. -- @@ -307,12 +319,11 @@ saveConstructor sname fields = do 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. @@ -339,17 +350,17 @@ loadField (fname, qt, qdefa) = do 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) @@ -371,8 +382,8 @@ genLoadOpCode opdefs = do 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) |]