import qualified Text.JSON as JSON
import Text.JSON.Pretty (pp_value)
+import Ganeti.JSON
+
-- * Exported types
-- | Class of objects that can be converted to 'JSObject'
, fieldType :: Q Type
, fieldRead :: Maybe (Q Exp)
, fieldShow :: Maybe (Q Exp)
+ , fieldExtraKeys :: [String]
, fieldDefault :: Maybe (Q Exp)
, fieldConstr :: Maybe String
, fieldIsOptional :: OptionalType
, fieldType = ftype
, fieldRead = Nothing
, fieldShow = Nothing
+ , fieldExtraKeys = []
, fieldDefault = Nothing
, fieldConstr = Nothing
, fieldIsOptional = NotOptional
optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull }
-- | Sets custom functions on a 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 (varE readfn), fieldShow = Just (varE showfn) }
+customField :: Name -- ^ The name of the read function
+ -> Name -- ^ The name of the show function
+ -> [String] -- ^ The name of extra field keys
+ -> Field -- ^ The original field
+ -> Field -- ^ Updated field
+customField readfn showfn extra field =
+ field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn)
+ , fieldExtraKeys = extra }
-- | Computes the record name for a given field, based on either the
-- string value in the JSON serialisation or the custom named if any
-- | A definition for ADTs with simple fields.
type SimpleObject = [SimpleConstructor]
+-- | A type alias for a constructor of a regular object.
+type Constructor = (String, [Field])
+
-- * Helper functions
-- | Ensure first letter is lowercase.
-- | showJSON as an expression, for reuse.
showJSONE :: Q Exp
-showJSONE = varNameE "showJSON"
+showJSONE = varE 'JSON.showJSON
+
+-- | makeObj as an expression, for reuse.
+makeObjE :: Q Exp
+makeObjE = varE 'JSON.makeObj
+
+-- | fromObj (Ganeti specific) as an expression, for reuse.
+fromObjE :: Q Exp
+fromObjE = varE 'fromObj
-- | ToRaw function name.
toRawName :: String -> Name
decl_d <- mapM (\(cname, fields) -> do
fields' <- mapM (buildConsField . snd) fields
return $ NormalC (mkName cname) fields') cons
- return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
+ return $ DataD [] tname [] decl_d [''Show, ''Eq]
-- | Generate the save function for a given type.
genSaveSimpleObj :: Name -- ^ Object type
strADTDecl name constructors =
DataD [] name []
(map (flip NormalC [] . mkName) constructors)
- [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
+ [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
-- | Generates a toRaw function.
--
genShowJSON :: String -> Q Dec
genShowJSON name = do
body <- [| JSON.showJSON . $(varE (toRawName name)) |]
- return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
+ return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
-- | Creates the readJSON member of a JSON instance declaration.
--
$(stringE name) ++ ": " ++ e ++ " from " ++
show $(varE s)
|]
- return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
+ return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
-- | Generates a JSON instance for a given type.
--
-- 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.
-genOpCode :: String -- ^ Type name to use
- -> [(String, [Field])] -- ^ Constructor name and parameters
+genOpCode :: String -- ^ Type name to use
+ -> [Constructor] -- ^ Constructor name and parameters
-> Q [Dec]
genOpCode name cons = do
let tname = mkName name
decl_d <- mapM (\(cname, fields) -> do
-- we only need the type of the field, without Q
- fields' <- mapM actualFieldType fields
- let fields'' = zip (repeat NotStrict) fields'
- return $ NormalC (mkName cname) fields'')
+ fields' <- mapM (fieldTypeInfo "op") fields
+ return $ RecC (mkName cname) fields')
cons
- let declD = DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
+ let declD = DataD [] tname [] decl_d [''Show, ''Eq]
- (savesig, savefn) <- genSaveOpCode tname "saveOpCode" cons
- (uncurry saveConstructor)
+ let (allfsig, allffn) = genAllOpFields "allOpFields" cons
+ save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode"
+ cons (uncurry saveConstructor) True
(loadsig, loadfn) <- genLoadOpCode cons
- return [declD, loadsig, loadfn, savesig, savefn]
+ return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs
+
+-- | Generates the function pattern returning the list of fields for a
+-- given constructor.
+genOpConsFields :: Constructor -> Clause
+genOpConsFields (cname, fields) =
+ let op_id = deCamelCase cname
+ fvals = map (LitE . StringL) . sort . nub $
+ concatMap (\f -> fieldName f:fieldExtraKeys f) fields
+ in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) []
+
+-- | Generates a list of all fields of an opcode constructor.
+genAllOpFields :: String -- ^ Function name
+ -> [Constructor] -- ^ Object definition
+ -> (Dec, Dec)
+genAllOpFields sname opdefs =
+ let cclauses = map genOpConsFields opdefs
+ other = Clause [WildP] (NormalB (ListE [])) []
+ fname = mkName sname
+ sigt = AppT (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String))
+ in (SigD fname sigt, FunD fname (cclauses++[other]))
-- | Generates the \"save\" clause for an entire opcode constructor.
--
JSON.showJSON $(stringE . deCamelCase $ sname) )] |]
flist = listE (opid:felems)
-- and finally convert all this to a json object
- flist' = [| $(varNameE "makeObj") (concat $flist) |]
+ flist' = [| concat $flist |]
clause [pat] (normalB flist') []
-- | Generates the main save opcode function.
--
-- This builds a per-constructor match clause that contains the
-- respective constructor-serialisation code.
-genSaveOpCode :: Name -- ^ Object ype
- -> String -- ^ Function name
- -> [(String, [Field])] -- ^ Object definition
- -> ((String, [Field]) -> Q Clause) -- ^ Constructor save fn
- -> Q (Dec, Dec)
-genSaveOpCode tname sname opdefs fn = do
- cclauses <- mapM fn opdefs
- let fname = mkName sname
- sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
- return $ (SigD fname sigt, FunD fname cclauses)
+genSaveOpCode :: Name -- ^ Object ype
+ -> String -- ^ To 'JSValue' function name
+ -> String -- ^ To 'JSObject' function name
+ -> [Constructor] -- ^ Object definition
+ -> (Constructor -> Q Clause) -- ^ Constructor save fn
+ -> Bool -- ^ Whether to generate
+ -- obj or just a
+ -- list\/tuple of values
+ -> Q [Dec]
+genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do
+ tdclauses <- mapM fn opdefs
+ let typecon = ConT tname
+ jvalname = mkName jvalstr
+ jvalsig = AppT (AppT ArrowT typecon) (ConT ''JSON.JSValue)
+ tdname = mkName tdstr
+ tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |]
+ jvalclause <- if gen_object
+ then [| $makeObjE . $(varE tdname) |]
+ else [| JSON.showJSON . map snd . $(varE tdname) |]
+ return [ SigD tdname tdsig
+ , FunD tdname tdclauses
+ , SigD jvalname jvalsig
+ , ValD (VarP jvalname) (NormalB jvalclause) []]
-- | Generates load code for a single constructor of the opcode data type.
loadConstructor :: String -> [Field] -> Q Exp
return $ DoE fstmts'
-- | Generates the loadOpCode function.
-genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec)
+genLoadOpCode :: [Constructor] -> Q (Dec, Dec)
genLoadOpCode opdefs = do
let fname = mkName "loadOpCode"
arg1 = mkName "v"
opid = mkName "op_id"
st1 <- bindS (varP objname) [| liftM JSON.fromJSObject
(JSON.readJSON $(varE arg1)) |]
- st2 <- bindS (varP opid) [| $(varNameE "fromObj")
- $(varE objname) $(stringE "OP_ID") |]
+ st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |]
-- the match results (per-constructor blocks)
mexps <- mapM (uncurry loadConstructor) opdefs
fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |]
--
-- * type
--
-genLuxiOp :: String -> [(String, [Field])] -> Q [Dec]
+genLuxiOp :: String -> [Constructor] -> Q [Dec]
genLuxiOp name cons = do
let tname = mkName name
decl_d <- mapM (\(cname, fields) -> do
let fields'' = zip (repeat NotStrict) fields'
return $ NormalC (mkName cname) fields'')
cons
- let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
- (savesig, savefn) <- genSaveOpCode tname "opToArgs"
- cons saveLuxiConstructor
+ let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
+ save_decs <- genSaveOpCode tname "opToArgs" "opToDict"
+ cons saveLuxiConstructor False
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 -> SimpleField -> Q Exp
-saveLuxiField fvar (_, qt) =
- [| JSON.showJSON $(varE fvar) |]
+ return $ declD:save_decs ++ req_defs
-- | Generates the \"save\" clause for entire LuxiOp constructor.
-saveLuxiConstructor :: (String, [Field]) -> Q Clause
+saveLuxiConstructor :: Constructor -> Q Clause
saveLuxiConstructor (sname, fields) = do
let cname = mkName sname
fnames <- mapM (newName . fieldVariable) fields
let pat = conP cname (map varP fnames)
let felems = map (uncurry saveObjectField) (zip fnames fields)
- flist = if null felems
- then [| JSON.showJSON () |]
- else [| JSON.showJSON (map snd $ concat $(listE felems)) |]
+ flist = [| concat $(listE felems) |]
clause [pat] (normalB flist) []
-- * "Objects" functionality
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, ''Eq]
+ let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
ser_decls <- buildObjectSerialisation sname fields
return $ declD:ser_decls
tdlist = [| concat $flist |]
iname = mkName "i"
tclause <- clause [pat] (normalB tdlist) []
- cclause <- [| $(varNameE "makeObj") . $(varE tdname) |]
+ cclause <- [| $makeObjE . $(varE tdname) |]
let fname = mkName ("save" ++ sname)
sigt <- [t| $(conT name) -> JSON.JSValue |]
return [SigD tdname tdsigt, FunD tdname [tclause],
objectShowJSON :: String -> Q Dec
objectShowJSON name = do
body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
- return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]
+ return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []]
-- | Generates the load object functionality.
genLoadObject :: (Field -> Q (Name, Stmt))
-- we treat both optional types the same, since
-- 'maybeFromObj' can deal with both missing and null values
-- appropriately (the same)
- then [| $(varNameE "maybeFromObj") $objvar $objfield |]
+ then [| $(varE 'maybeFromObj) $objvar $objfield |]
else case fieldDefault field of
Just defv ->
- [| $(varNameE "fromObjWithDefault") $objvar
+ [| $(varE 'fromObjWithDefault) $objvar
$objfield $defv |]
- Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
+ Nothing -> [| $fromObjE $objvar $objfield |]
bexp <- loadFn field loadexp objvar
return (fvar, BindS (VarP fvar) bexp)
JSON.Error $ "Can't parse value for type " ++
$(stringE name) ++ ": " ++ e
|]
- return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
+ return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []]
-- * Inheritable parameter tables implementation
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, ''Eq]
- declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]
+ let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
+ declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
ser_decls_f <- buildObjectSerialisation sname_f fields
ser_decls_p <- buildPParamSerialisation sname_p fields
fill_decls <- fillParam sname field_pfx fields
-- these are used in all patterns below
let objvar = varNameE "o"
objfield = stringE name
- loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
+ loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |]
bexp <- loadFn field loadexp objvar
return (fvar, BindS (VarP fvar) bexp)
buildFromMaybe :: String -> Q Dec
buildFromMaybe fname =
valD (varP (mkName $ "n_" ++ fname))
- (normalB [| $(varNameE "fromMaybe")
+ (normalB [| $(varE 'fromMaybe)
$(varNameE $ "f_" ++ fname)
$(varNameE $ "p_" ++ fname) |]) []
projects / ganeti-local / blobdiff