X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/d8cb8e1340c1dcee4f609be7847b4512c78136fb..01e524934eae5ae964c51a19ff2a1a1011f5e51a:/htools/Ganeti/THH.hs diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 972e4c7..9bdde6f 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} -{-| TemplateHaskell helper for HTools. +{-| TemplateHaskell helper for Ganeti Haskell code. As TemplateHaskell require that splices be defined in a separate module, we combine all the TemplateHaskell functionality that HTools @@ -33,6 +33,7 @@ module Ganeti.THH ( declareSADT , declareIADT , makeJSONInstance , genOpID + , genAllOpIDs , genOpCode , genStrOfOp , genStrOfKey @@ -42,33 +43,33 @@ module Ganeti.THH ( declareSADT , defaultField , optionalField , renameField - , containerField , customField , timeStampFields , uuidFields , serialFields , tagsFields + , TagSet , buildObject , buildObjectSerialisation , buildParam - , Container + , DictObject(..) ) where -import Control.Arrow -import Control.Monad (liftM, liftM2) +import Control.Monad (liftM) import Data.Char import Data.List -import qualified Data.Map as M +import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Language.Haskell.TH import qualified Text.JSON as JSON -import Ganeti.HTools.JSON - -- * Exported types -type Container = M.Map String +-- | Class of objects that can be converted to 'JSObject' +-- lists-format. +class DictObject a where + toDict :: a -> [(String, JSON.JSValue)] -- | Serialised field data type. data Field = Field { fieldName :: String @@ -77,7 +78,6 @@ data Field = Field { fieldName :: String , fieldShow :: Maybe (Q Exp) , fieldDefault :: Maybe (Q Exp) , fieldConstr :: Maybe String - , fieldIsContainer :: Bool , fieldIsOptional :: Bool } @@ -90,7 +90,6 @@ simpleField fname ftype = , fieldShow = Nothing , fieldDefault = Nothing , fieldConstr = Nothing - , fieldIsContainer = False , fieldIsOptional = False } @@ -107,10 +106,6 @@ defaultField defval field = field { fieldDefault = Just defval } optionalField :: Field -> Field optionalField field = field { fieldIsOptional = True } --- | Marks a field as a container. -containerField :: Field -> Field -containerField field = field { fieldIsContainer = True } - -- | Sets custom functions on a field. customField :: Name -- ^ The name of the read function -> Name -- ^ The name of the show function @@ -119,9 +114,12 @@ customField :: Name -- ^ The name of the read function customField readfn showfn field = field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) } +-- | Computes the record name for a given field, based on either the +-- string value in the JSON serialisation or the custom named if any +-- exists. fieldRecordName :: Field -> String fieldRecordName (Field { fieldName = name, fieldConstr = alias }) = - maybe (camelCase name) id alias + fromMaybe (camelCase name) alias -- | Computes the preferred variable name to use for the value of this -- field. If the field has a specific constructor name, then we use a @@ -134,8 +132,7 @@ fieldVariable f = _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f actualFieldType :: Field -> Q Type -actualFieldType f | fieldIsContainer f = [t| Container $t |] - | fieldIsOptional f = [t| Maybe $t |] +actualFieldType f | fieldIsOptional f = [t| Maybe $t |] | otherwise = t where t = fieldType f @@ -154,30 +151,34 @@ loadFn :: Field -- ^ The field definition -> Q Exp -- ^ The value of the field as existing in the JSON message -> Q Exp -- ^ The entire object in JSON object format -> Q Exp -- ^ Resulting expression -loadFn (Field { fieldIsContainer = True }) expr _ = - [| $expr >>= readContainer |] loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |] loadFn _ expr _ = expr -- * Common field declarations +-- | Timestamp fields description. timeStampFields :: [Field] timeStampFields = [ defaultField [| 0::Double |] $ simpleField "ctime" [t| Double |] , defaultField [| 0::Double |] $ simpleField "mtime" [t| Double |] ] +-- | Serial number fields description. serialFields :: [Field] serialFields = [ renameField "Serial" $ simpleField "serial_no" [t| Int |] ] +-- | UUID fields description. uuidFields :: [Field] uuidFields = [ simpleField "uuid" [t| String |] ] +-- | Tag set type alias. +type TagSet = Set.Set String + -- | Tag field description. tagsFields :: [Field] tagsFields = [ defaultField [| Set.empty |] $ - simpleField "tags" [t| Set.Set String |] ] + simpleField "tags" [t| TagSet |] ] -- * Helper functions @@ -212,8 +213,7 @@ toRawName = mkName . (++ "ToRaw") . ensureLower fromRawName :: String -> Name fromRawName = mkName . (++ "FromRaw") . ensureLower --- | Converts a name to it's varE/litE representations. --- +-- | Converts a name to it's varE\/litE representations. reprE :: Either String Name -> Q Exp reprE = either stringE varE @@ -225,18 +225,6 @@ appFn :: Exp -> Exp -> Exp appFn f x | f == VarE 'id = x | otherwise = AppE f x --- | Container loader -readContainer :: (Monad m, JSON.JSON a) => - JSON.JSObject JSON.JSValue -> m (Container a) -readContainer obj = do - let kjvlist = JSON.fromJSObject obj - kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist - return $ M.fromList kalist - --- | Container dumper -showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue -showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList - -- * Template code for simple raw type-equivalent ADTs -- | Generates a data type declaration. @@ -314,7 +302,7 @@ genFromRaw traw fname tname constructors = do -- -- * /name/FromRaw, which (monadically) converts from a raw type to the type -- --- Note that this is basically just a custom show/read instance, +-- Note that this is basically just a custom show\/read instance, -- nothing else. declareADT :: Name -> String -> [(String, Name)] -> Q [Dec] declareADT traw sname cons = do @@ -398,6 +386,15 @@ constructorName (NormalC name _) = return name constructorName (RecC name _) = return name constructorName x = fail $ "Unhandled constructor " ++ show x +-- | Extract all constructor names from a given type. +reifyConsNames :: Name -> Q [String] +reifyConsNames name = do + reify_result <- reify name + case reify_result of + TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons + o -> fail $ "Unhandled name passed to reifyConsNames, expected\ + \ type constructor but got '" ++ show o ++ "'" + -- | Builds the generic constructor-to-string function. -- -- This generates a simple function of the following form: @@ -407,12 +404,11 @@ constructorName x = fail $ "Unhandled constructor " ++ show x -- fname (ConStructorTwo {}) = trans_fun("ConStructorTwo") -- @ -- --- This builds a custom list of name/string pairs and then uses --- 'genToRaw' to actually generate the function +-- This builds a custom list of name\/string pairs and then uses +-- 'genToRaw' to actually generate the function. genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec] genConstrToStr trans_fun name fname = do - TyConI (DataD _ _ _ cons _) <- reify name - cnames <- mapM (liftM nameBase . constructorName) cons + cnames <- reifyConsNames name let svalues = map (Left . trans_fun) cnames genToRaw ''String (mkName fname) name $ zip cnames svalues @@ -420,6 +416,28 @@ genConstrToStr trans_fun name fname = do genOpID :: Name -> String -> Q [Dec] genOpID = genConstrToStr deCamelCase +-- | Builds a list with all defined constructor names for a type. +-- +-- @ +-- vstr :: String +-- vstr = [...] +-- @ +-- +-- Where the actual values of the string are the constructor names +-- mapped via @trans_fun@. +genAllConstr :: (String -> String) -> Name -> String -> Q [Dec] +genAllConstr trans_fun name vstr = do + cnames <- reifyConsNames name + let svalues = sort $ map trans_fun cnames + vname = mkName vstr + sig = SigD vname (AppT ListT (ConT ''String)) + body = NormalB (ListE (map (LitE . StringL) svalues)) + return $ [sig, ValD (VarP vname) body []] + +-- | Generates a list of all defined opcode IDs. +genAllOpIDs :: Name -> String -> Q [Dec] +genAllOpIDs = genAllConstr deCamelCase + -- | OpCode parameter (field) type. type OpParam = (String, Q Type, Q Exp) @@ -485,6 +503,7 @@ genSaveOpCode opdefs = do sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |] return $ (SigD fname sigt, FunD fname cclauses) +-- | Generates load code for a single constructor of the opcode data type. loadConstructor :: String -> [Field] -> Q Exp loadConstructor sname fields = do let name = mkName sname @@ -494,6 +513,7 @@ loadConstructor sname fields = do fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)] return $ DoE fstmts' +-- | Generates the loadOpCode function. genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec) genLoadOpCode opdefs = do let fname = mkName "loadOpCode" @@ -528,7 +548,7 @@ genStrOfKey :: Name -> String -> Q [Dec] genStrOfKey = genConstrToStr ensureLower -- | LuxiOp parameter type. -type LuxiParam = (String, Q Type, Q Exp) +type LuxiParam = (String, Q Type) -- | Generates the LuxiOp data type. -- @@ -537,19 +557,16 @@ type LuxiParam = (String, Q Type, Q Exp) -- 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: +-- There are two 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, _) -> + fields' <- mapM (\(_, qt) -> qt >>= \t -> return (NotStrict, t)) fields return $ NormalC (mkName cname) fields') @@ -563,14 +580,14 @@ genLuxiOp name cons = do -- | Generates the \"save\" expression for a single luxi parameter. saveLuxiField :: Name -> LuxiParam -> Q Exp -saveLuxiField fvar (_, qt, fn) = - [| JSON.showJSON ( $(liftM2 appFn fn $ varE fvar) ) |] +saveLuxiField fvar (_, qt) = + [| JSON.showJSON $(varE fvar) |] -- | Generates the \"save\" clause for entire LuxiOp constructor. saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause saveLuxiConstructor (sname, fields) = do let cname = mkName sname - fnames = map (\(nm, _, _) -> mkName nm) fields + fnames = map (mkName . fst) fields pat = conP cname (map varP fnames) flist = map (uncurry saveLuxiField) (zip fnames fields) finval = if null flist @@ -605,6 +622,7 @@ buildObject sname field_pfx fields = do ser_decls <- buildObjectSerialisation sname fields return $ declD:ser_decls +-- | Generates an object definition: data type and its JSON instance. buildObjectSerialisation :: String -> [Field] -> Q [Dec] buildObjectSerialisation sname fields = do let name = mkName sname @@ -616,13 +634,18 @@ buildObjectSerialisation sname fields = do [rdjson, shjson] return $ savedecls ++ [loadsig, loadfn, instdecl] +-- | The toDict function name for a given type. +toDictName :: String -> Name +toDictName sname = mkName ("toDict" ++ sname) + +-- | Generates the save object functionality. genSaveObject :: (Name -> Field -> Q Exp) -> String -> [Field] -> Q [Dec] genSaveObject save_fn sname fields = do let name = mkName sname fnames <- mapM (newName . fieldVariable) fields let pat = conP name (map varP fnames) - let tdname = mkName ("toDict" ++ sname) + let tdname = toDictName sname tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |] let felems = map (uncurry save_fn) (zip fnames fields) @@ -637,9 +660,10 @@ genSaveObject save_fn sname fields = do return [SigD tdname tdsigt, FunD tdname [tclause], SigD fname sigt, ValD (VarP fname) (NormalB cclause) []] +-- | Generates the code for saving an object's field, handling the +-- various types of fields that we have. saveObjectField :: Name -> Field -> Q Exp saveObjectField fvar field - | isContainer = [| [( $nameE , JSON.showJSON . showContainer $ $fvarE)] |] | fisOptional = [| case $(varE fvar) of Nothing -> [] Just v -> [( $nameE, JSON.showJSON v)] @@ -649,16 +673,17 @@ saveObjectField fvar field Just fn -> [| let (actual, extra) = $fn $fvarE in extra ++ [( $nameE, JSON.showJSON actual)] |] - where isContainer = fieldIsContainer field - fisOptional = fieldIsOptional field + where fisOptional = fieldIsOptional field nameE = stringE (fieldName field) fvarE = varE fvar +-- | Generates the showJSON clause for a given object name. objectShowJSON :: String -> Q Dec objectShowJSON name = do body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |] return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []] +-- | Generates the load object functionality. genLoadObject :: (Field -> Q (Name, Stmt)) -> String -> [Field] -> Q (Dec, Dec) genLoadObject load_fn sname fields = do @@ -677,6 +702,7 @@ genLoadObject load_fn sname fields = do return $ (SigD funname sigt, FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []]) +-- | Generates code for loading an object's field. loadObjectField :: Field -> Q (Name, Stmt) loadObjectField field = do let name = fieldVariable field @@ -696,6 +722,7 @@ loadObjectField field = do return (fvar, BindS (VarP fvar) bexp) +-- | Builds the readJSON instance for a given object name. objectReadJSON :: String -> Q Dec objectReadJSON name = do let s = mkName "s" @@ -743,8 +770,25 @@ buildParam sname field_pfx fields = do ser_decls_f <- buildObjectSerialisation sname_f fields ser_decls_p <- buildPParamSerialisation sname_p fields fill_decls <- fillParam sname field_pfx fields - return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls - + return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++ + buildParamAllFields sname fields ++ + buildDictObjectInst name_f sname_f + +-- | Builds a list of all fields of a parameter. +buildParamAllFields :: String -> [Field] -> [Dec] +buildParamAllFields sname fields = + let vname = mkName ("all" ++ sname ++ "ParamFields") + sig = SigD vname (AppT ListT (ConT ''String)) + val = ListE $ map (LitE . StringL . fieldName) fields + in [sig, ValD (VarP vname) (NormalB val) []] + +-- | Builds the 'DictObject' instance for a filled parameter. +buildDictObjectInst :: Name -> String -> [Dec] +buildDictObjectInst name sname = + [InstanceD [] (AppT (ConT ''DictObject) (ConT name)) + [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]] + +-- | Generates the serialisation for a partial parameter. buildPParamSerialisation :: String -> [Field] -> Q [Dec] buildPParamSerialisation sname fields = do let name = mkName sname @@ -756,6 +800,7 @@ buildPParamSerialisation sname fields = do [rdjson, shjson] return $ savedecls ++ [loadsig, loadfn, instdecl] +-- | Generates code to save an optional parameter field. savePParamField :: Name -> Field -> Q Exp savePParamField fvar field = do checkNonOptDef field @@ -768,6 +813,8 @@ savePParamField fvar field = do , Match (ConP 'Just [VarP actualVal]) (NormalB normalexpr) [] ] + +-- | Generates code to load an optional parameter field. loadPParamField :: Field -> Q (Name, Stmt) loadPParamField field = do checkNonOptDef field @@ -788,6 +835,8 @@ buildFromMaybe fname = $(varNameE $ "f_" ++ fname) $(varNameE $ "p_" ++ fname) |]) [] +-- | Builds a function that executes the filling of partial parameter +-- from a full copy (similar to Python's fillDict). fillParam :: String -> String -> [Field] -> Q [Dec] fillParam sname field_pfx fields = do let fnames = map (\fd -> field_pfx ++ fieldRecordName fd) fields