Commit 88609f00 authored by Iustin Pop's avatar Iustin Pop

Switch Luxi TH code from simple to custom fields

This is needed so that we have more flexibility in generating Luxi
serialisation code (deserialisation is still custom). Also, only
exceptions are now using the 'simple' field types, so we might be able
later to convert and remove that TH code as well.

Since we will use custom serialisation fields in the future, we change
the order of serialisation for custom-save fields; Luxi uses
positional as opposed to name-based ordering, so we need to keep this
stable.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarHelga Velroyen <helgav@google.com>
parent a309a3b4
......@@ -101,73 +101,73 @@ type JobId = Int
-- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp"
[ (luxiReqQuery,
[ ("what", [t| Qlang.ItemType |])
, ("fields", [t| [String] |])
, ("qfilter", [t| Qlang.Filter Qlang.FilterField |])
[ simpleField "what" [t| Qlang.ItemType |]
, simpleField "fields" [t| [String] |]
, simpleField "qfilter" [t| Qlang.Filter Qlang.FilterField |]
])
, (luxiReqQueryFields,
[ ("what", [t| Qlang.ItemType |])
, ("fields", [t| [String] |])
[ simpleField "what" [t| Qlang.ItemType |]
, simpleField "fields" [t| [String] |]
])
, (luxiReqQueryNodes,
[ ("names", [t| [String] |])
, ("fields", [t| [String] |])
, ("lock", [t| Bool |])
[ simpleField "names" [t| [String] |]
, simpleField "fields" [t| [String] |]
, simpleField "lock" [t| Bool |]
])
, (luxiReqQueryGroups,
[ ("names", [t| [String] |])
, ("fields", [t| [String] |])
, ("lock", [t| Bool |])
[ simpleField "names" [t| [String] |]
, simpleField "fields" [t| [String] |]
, simpleField "lock" [t| Bool |]
])
, (luxiReqQueryInstances,
[ ("names", [t| [String] |])
, ("fields", [t| [String] |])
, ("lock", [t| Bool |])
[ simpleField "names" [t| [String] |]
, simpleField "fields" [t| [String] |]
, simpleField "lock" [t| Bool |]
])
, (luxiReqQueryJobs,
[ ("ids", [t| [Int] |])
, ("fields", [t| [String] |])
[ simpleField "ids" [t| [Int] |]
, simpleField "fields" [t| [String] |]
])
, (luxiReqQueryExports,
[ ("nodes", [t| [String] |])
, ("lock", [t| Bool |])
[ simpleField "nodes" [t| [String] |]
, simpleField "lock" [t| Bool |]
])
, (luxiReqQueryConfigValues,
[ ("fields", [t| [String] |]) ]
[ simpleField "fields" [t| [String] |] ]
)
, (luxiReqQueryClusterInfo, [])
, (luxiReqQueryTags,
[ ("kind", [t| TagObject |])
, ("name", [t| String |])
[ simpleField "kind" [t| TagObject |]
, simpleField "name" [t| String |]
])
, (luxiReqSubmitJob,
[ ("job", [t| [OpCode] |]) ]
[ simpleField "job" [t| [OpCode] |] ]
)
, (luxiReqSubmitManyJobs,
[ ("ops", [t| [[OpCode]] |]) ]
[ simpleField "ops" [t| [[OpCode]] |] ]
)
, (luxiReqWaitForJobChange,
[ ("job", [t| Int |])
, ("fields", [t| [String]|])
, ("prev_job", [t| JSValue |])
, ("prev_log", [t| JSValue |])
, ("tmout", [t| Int |])
[ simpleField "job" [t| Int |]
, simpleField "fields" [t| [String]|]
, simpleField "prev_job" [t| JSValue |]
, simpleField "prev_log" [t| JSValue |]
, simpleField "tmout" [t| Int |]
])
, (luxiReqArchiveJob,
[ ("job", [t| Int |]) ]
[ simpleField "job" [t| Int |] ]
)
, (luxiReqAutoArchiveJobs,
[ ("age", [t| Int |])
, ("tmout", [t| Int |])
[ simpleField "age" [t| Int |]
, simpleField "tmout" [t| Int |]
])
, (luxiReqCancelJob,
[ ("job", [t| Int |]) ]
[ simpleField "job" [t| Int |] ]
)
, (luxiReqSetDrainFlag,
[ ("flag", [t| Bool |]) ]
[ simpleField "flag" [t| Bool |] ]
)
, (luxiReqSetWatcherPause,
[ ("duration", [t| Double |]) ]
[ simpleField "duration" [t| Double |] ]
)
])
......
......@@ -621,11 +621,17 @@ genStrOfKey = genConstrToStr ensureLower
--
-- * type
--
genLuxiOp :: String -> SimpleObject -> Q [Dec]
genLuxiOp :: String -> [(String, [Field])] -> Q [Dec]
genLuxiOp name cons = do
let tname = mkName name
declD <- buildSimpleCons tname cons
(savesig, savefn) <- genSaveSimpleObj tname "opToArgs"
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'')
cons
let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
(savesig, savefn) <- genSaveOpCode tname "opToArgs"
cons saveLuxiConstructor
req_defs <- declareSADT "LuxiReq" .
map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
......@@ -638,16 +644,16 @@ saveLuxiField fvar (_, qt) =
[| JSON.showJSON $(varE fvar) |]
-- | Generates the \"save\" clause for entire LuxiOp constructor.
saveLuxiConstructor :: SimpleConstructor -> Q Clause
saveLuxiConstructor :: (String, [Field]) -> Q Clause
saveLuxiConstructor (sname, fields) = do
let cname = mkName sname
fnames = map (mkName . fst) fields
pat = conP cname (map varP fnames)
flist = map (uncurry saveLuxiField) (zip fnames fields)
finval = if null flist
then [| JSON.showJSON () |]
else [| JSON.showJSON $(listE flist) |]
clause [pat] (normalB finval) []
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)) |]
clause [pat] (normalB flist) []
-- * "Objects" functionality
......@@ -721,9 +727,12 @@ saveObjectField fvar field =
|]
NotOptional ->
case fieldShow field of
-- Note: the order of actual:extra is important, since for
-- some serialisation types (e.g. Luxi), we use tuples
-- (positional info) rather than object (name info)
Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
Just fn -> [| let (actual, extra) = $fn $fvarE
in extra ++ [( $nameE, JSON.showJSON actual)]
in ($nameE, JSON.showJSON actual):extra
|]
where nameE = stringE (fieldName field)
fvarE = varE fvar
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment