X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/6bd26f00fe637a0c8c5d4f7e9fe2408361902d33..98508e7f2049127f58af27db5ad7a1eb0ed519dc:/htools/Ganeti/THH.hs diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 43e732a..9bdde6f 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# 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 @@ -10,7 +10,7 @@ needs in this module (except the one for unittests). {- -Copyright (C) 2011 Google Inc. +Copyright (C) 2011, 2012 Google Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -33,8 +33,8 @@ module Ganeti.THH ( declareSADT , declareIADT , makeJSONInstance , genOpID + , genAllOpIDs , genOpCode - , noDefault , genStrOfOp , genStrOfKey , genLuxiOp @@ -43,31 +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 @@ -76,7 +78,6 @@ data Field = Field { fieldName :: String , fieldShow :: Maybe (Q Exp) , fieldDefault :: Maybe (Q Exp) , fieldConstr :: Maybe String - , fieldIsContainer :: Bool , fieldIsOptional :: Bool } @@ -89,7 +90,6 @@ simpleField fname ftype = , fieldShow = Nothing , fieldDefault = Nothing , fieldConstr = Nothing - , fieldIsContainer = False , fieldIsOptional = False } @@ -106,25 +106,33 @@ 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 :: Q Exp -> Q Exp -> Field -> Field +customField :: Name -- ^ The name of the read function + -> Name -- ^ The name of the show function + -> Field -- ^ The original field + -> Field -- ^ Updated field customField readfn showfn field = - field { fieldRead = Just readfn, fieldShow = Just showfn } + 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 +-- first-letter-lowercased version of that; otherwise, we simply use +-- the field name. See also 'fieldRecordName'. fieldVariable :: Field -> String -fieldVariable = map toLower . fieldRecordName +fieldVariable f = + case (fieldConstr f) of + Just name -> ensureLower name + _ -> 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 @@ -135,31 +143,43 @@ checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) = fail $ "Default field " ++ name ++ " used in parameter declaration" checkNonOptDef _ = return () -loadFn :: Field -> Q Exp -> Q Exp -loadFn (Field { fieldIsContainer = True }) expr = [| $expr >>= readContainer |] -loadFn (Field { fieldRead = Just readfn }) expr = [| $expr >>= $readfn |] -loadFn _ expr = expr - -saveFn :: Field -> Q Exp -> Q Exp -saveFn (Field { fieldIsContainer = True }) expr = [| showContainer $expr |] -saveFn (Field { fieldRead = Just readfn }) expr = [| $readfn $expr |] -saveFn _ expr = expr +-- | Produces the expression that will de-serialise a given +-- field. Since some custom parsing functions might need to use the +-- entire object, we do take and pass the object to any custom read +-- functions. +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 { 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| TagSet |] ] + -- * Helper functions -- | Ensure first letter is lowercase. @@ -193,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 @@ -206,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. @@ -240,7 +247,7 @@ strADTDecl name constructors = -- @ genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec] genToRaw traw fname tname constructors = do - sigt <- [t| $(conT tname) -> $(conT traw) |] + let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw) -- the body clauses, matching on the constructor and returning the -- raw value clauses <- mapM (\(c, v) -> clause [recP (mkName c) []] @@ -295,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 @@ -322,8 +329,10 @@ declareSADT = declareADT ''String -- @ -- -- in an instance JSON /name/ declaration -genShowJSON :: String -> Q [Dec] -genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toRawName name)) |] +genShowJSON :: String -> Q Dec +genShowJSON name = do + body <- [| JSON.showJSON . $(varE (toRawName name)) |] + return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []] -- | Creates the readJSON member of a JSON instance declaration. -- @@ -357,7 +366,7 @@ makeJSONInstance name = do let base = nameBase name showJ <- genShowJSON base readJ <- genReadJSON base - return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)] + return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]] -- * Template code for opcodes @@ -369,7 +378,7 @@ deCamelCase = -- | Transform an underscore_name into a CamelCase one. camelCase :: String -> String camelCase = concatMap (ensureUpper . drop 1) . - groupBy (\_ b -> b /= '_') . ('_':) + groupBy (\_ b -> b /= '_' && b /= '-') . ('_':) -- | Computes the name of a given constructor. constructorName :: Con -> Q Name @@ -377,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: @@ -386,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 @@ -399,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) @@ -408,27 +447,15 @@ type OpParam = (String, Q Type, Q Exp) -- datatype and the JSON serialisation out of it. We can't use a -- generic serialisation since we need to be compatible with Ganeti's -- own, so we have a few quirks to work around. --- --- There are three things to be defined for each parameter: --- --- * name --- --- * type; if this is 'Maybe', will only be serialised if it's a --- 'Just' value --- --- * default; if missing, won't raise an exception, but will instead --- use the default --- genOpCode :: String -- ^ Type name to use - -> [(String, [OpParam])] -- ^ Constructor name and parameters + -> [(String, [Field])] -- ^ Constructor name and parameters -> Q [Dec] genOpCode name cons = do decl_d <- mapM (\(cname, fields) -> do -- we only need the type of the field, without Q - fields' <- mapM (\(_, qt, _) -> - qt >>= \t -> return (NotStrict, t)) - fields - return $ NormalC (mkName cname) fields') + fields' <- mapM actualFieldType fields + let fields'' = zip (repeat NotStrict) fields' + return $ NormalC (mkName cname) fields'') cons let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] @@ -443,42 +470,23 @@ isOptional :: Type -> Bool isOptional (AppT (ConT dt) _) | dt == ''Maybe = True isOptional _ = False --- | Generates the \"save\" expression for a single opcode parameter. --- --- There is only one special handling mode: if the parameter is of --- 'Maybe' type, then we only save it if it's a 'Just' value, --- otherwise we skip it. -saveField :: Name -- ^ The name of variable that contains the value - -> OpParam -- ^ Parameter definition - -> Q Exp -saveField fvar (fname, qt, _) = do - t <- qt - let fnexp = stringE fname - fvare = varE fvar - (if isOptional t - then [| case $fvare of - Just v' -> [( $fnexp, $showJSONE v')] - Nothing -> [] - |] - else [| [( $fnexp, $showJSONE $fvare )] |]) - -- | Generates the \"save\" clause for an entire opcode constructor. -- -- This matches the opcode with variables named the same as the -- constructor fields (just so that the spliced in code looks nicer), --- and passes those name plus the parameter definition to 'saveField'. +-- and passes those name plus the parameter definition to 'saveObjectField'. saveConstructor :: String -- ^ The constructor name - -> [OpParam] -- ^ The parameter definitions for this + -> [Field] -- ^ The parameter definitions for this -- constructor -> Q Clause -- ^ Resulting clause saveConstructor sname fields = do let cname = mkName sname - let fnames = map (\(n, _, _) -> mkName n) fields + fnames <- mapM (newName . fieldVariable) fields let pat = conP cname (map varP fnames) - let felems = map (uncurry saveField) (zip fnames fields) + let felems = map (uncurry saveObjectField) (zip fnames fields) -- now build the OP_ID serialisation opid = [| [( $(stringE "OP_ID"), - $showJSONE $(stringE . deCamelCase $ sname) )] |] + JSON.showJSON $(stringE . deCamelCase $ sname) )] |] flist = listE (opid:felems) -- and finally convert all this to a json object flist' = [| $(varNameE "makeObj") (concat $flist) |] @@ -488,51 +496,25 @@ saveConstructor sname fields = do -- -- This builds a per-constructor match clause that contains the -- respective constructor-serialisation code. -genSaveOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) +genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec) genSaveOpCode opdefs = do cclauses <- mapM (uncurry saveConstructor) opdefs let fname = mkName "saveOpCode" sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |] return $ (SigD fname sigt, FunD fname cclauses) --- | Generates the \"load\" field for a single parameter. --- --- There is custom handling, depending on how the parameter is --- specified. For a 'Maybe' type parameter, we allow that it is not --- present (via 'Utils.maybeFromObj'). Otherwise, if there is a --- default value, we allow the parameter to be abset, and finally if --- there is no default value, we require its presence. -loadField :: OpParam -> Q (Name, Stmt) -loadField (fname, qt, qdefa) = do - let fvar = mkName fname - t <- qt - defa <- qdefa - -- these are used in all patterns below - let objvar = varNameE "o" - objfield = stringE fname - bexp <- if isOptional t - then [| $((varNameE "maybeFromObj")) $objvar $objfield |] - else case defa of - AppE (ConE dt) defval | dt == 'Just -> - -- but has a default value - [| $(varNameE "fromObjWithDefault") - $objvar $objfield $(return defval) |] - ConE dt | dt == 'Nothing -> - [| $(varNameE "fromObj") $objvar $objfield |] - s -> fail $ "Invalid default value " ++ show s ++ - ", expecting either 'Nothing' or a 'Just defval'" - return (fvar, BindS (VarP fvar) bexp) - -loadConstructor :: String -> [OpParam] -> Q Exp +-- | 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 - fbinds <- mapM loadField fields + fbinds <- mapM loadObjectField fields let (fnames, fstmts) = unzip fbinds let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)] return $ DoE fstmts' -genLoadOpCode :: [(String, [OpParam])] -> Q (Dec, Dec) +-- | Generates the loadOpCode function. +genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec) genLoadOpCode opdefs = do let fname = mkName "loadOpCode" arg1 = mkName "v" @@ -555,10 +537,6 @@ genLoadOpCode opdefs = do sigt <- [t| JSON.JSValue -> JSON.Result $(conT (mkName "OpCode")) |] return $ (SigD fname sigt, FunD fname [Clause [VarP arg1] (NormalB body) []]) --- | No default type. -noDefault :: Q Exp -noDefault = conE 'Nothing - -- * Template code for luxi -- | Constructor-to-string for LuxiOp. @@ -570,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. -- @@ -579,37 +557,37 @@ 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') cons - let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read] + let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] (savesig, savefn) <- genSaveLuxiOp cons - return [declD, savesig, savefn] + req_defs <- declareSADT "LuxiReq" . + map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $ + cons + return $ [declD, savesig, savefn] ++ req_defs -- | 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 @@ -640,10 +618,11 @@ buildObject sname field_pfx fields = do let name = mkName sname fields_d <- mapM (fieldTypeInfo field_pfx) fields let decl_d = RecC name fields_d - let declD = DataD [] name [] [decl_d] [''Show, ''Read] + let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq] 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 @@ -652,16 +631,21 @@ buildObjectSerialisation sname fields = do shjson <- objectShowJSON sname rdjson <- objectReadJSON sname let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) - (rdjson:shjson) + [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 - let fnames = map (mkName . fieldVariable) fields + 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) @@ -676,25 +660,30 @@ 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 , $showJSONE . showContainer $ $fvarE)] |] | fisOptional = [| case $(varE fvar) of Nothing -> [] - Just v -> [( $nameE, $showJSONE v)] + Just v -> [( $nameE, JSON.showJSON v)] |] | otherwise = case fieldShow field of - Nothing -> [| [( $nameE, $showJSONE $fvarE)] |] - Just fn -> [| [( $nameE, $showJSONE . $fn $ $fvarE)] |] - where isContainer = fieldIsContainer field - fisOptional = fieldIsOptional field + Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |] + Just fn -> [| let (actual, extra) = $fn $fvarE + in extra ++ [( $nameE, JSON.showJSON actual)] + |] + where fisOptional = fieldIsOptional field nameE = stringE (fieldName field) fvarE = varE fvar -objectShowJSON :: String -> Q [Dec] -objectShowJSON name = - [d| showJSON = JSON.showJSON . $(varE . mkName $ "save" ++ name) |] +-- | 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 @@ -713,10 +702,11 @@ 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 - fvar = mkName name + fvar <- newName name -- these are used in all patterns below let objvar = varNameE "o" objfield = stringE (fieldName field) @@ -728,10 +718,11 @@ loadObjectField field = do [| $(varNameE "fromObjWithDefault") $objvar $objfield $defv |] Nothing -> [| $(varNameE "fromObj") $objvar $objfield |] - bexp <- loadFn field loadexp + bexp <- loadFn field loadexp objvar 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" @@ -774,13 +765,30 @@ buildParam sname field_pfx fields = do fields_p <- mapM (paramFieldTypeInfo field_pfx) fields let decl_f = RecC name_f fields_f decl_p = RecC name_p fields_p - let declF = DataD [] name_f [] [decl_f] [''Show, ''Read] - declP = DataD [] name_p [] [decl_p] [''Show, ''Read] + let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq] + declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq] 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 @@ -789,9 +797,10 @@ buildPParamSerialisation sname fields = do shjson <- objectShowJSON sname rdjson <- objectReadJSON sname let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) - (rdjson:shjson) + [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 @@ -804,16 +813,18 @@ 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 let name = fieldName field - fvar = mkName name + fvar <- newName name -- these are used in all patterns below let objvar = varNameE "o" objfield = stringE name loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |] - bexp <- loadFn field loadexp + bexp <- loadFn field loadexp objvar return (fvar, BindS (VarP fvar) bexp) -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@. @@ -824,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