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

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 ...@@ -101,73 +101,73 @@ type JobId = Int
-- | Currently supported Luxi operations and JSON serialization. -- | Currently supported Luxi operations and JSON serialization.
$(genLuxiOp "LuxiOp" $(genLuxiOp "LuxiOp"
[ (luxiReqQuery, [ (luxiReqQuery,
[ ("what", [t| Qlang.ItemType |]) [ simpleField "what" [t| Qlang.ItemType |]
, ("fields", [t| [String] |]) , simpleField "fields" [t| [String] |]
, ("qfilter", [t| Qlang.Filter Qlang.FilterField |]) , simpleField "qfilter" [t| Qlang.Filter Qlang.FilterField |]
]) ])
, (luxiReqQueryFields, , (luxiReqQueryFields,
[ ("what", [t| Qlang.ItemType |]) [ simpleField "what" [t| Qlang.ItemType |]
, ("fields", [t| [String] |]) , simpleField "fields" [t| [String] |]
]) ])
, (luxiReqQueryNodes, , (luxiReqQueryNodes,
[ ("names", [t| [String] |]) [ simpleField "names" [t| [String] |]
, ("fields", [t| [String] |]) , simpleField "fields" [t| [String] |]
, ("lock", [t| Bool |]) , simpleField "lock" [t| Bool |]
]) ])
, (luxiReqQueryGroups, , (luxiReqQueryGroups,
[ ("names", [t| [String] |]) [ simpleField "names" [t| [String] |]
, ("fields", [t| [String] |]) , simpleField "fields" [t| [String] |]
, ("lock", [t| Bool |]) , simpleField "lock" [t| Bool |]
]) ])
, (luxiReqQueryInstances, , (luxiReqQueryInstances,
[ ("names", [t| [String] |]) [ simpleField "names" [t| [String] |]
, ("fields", [t| [String] |]) , simpleField "fields" [t| [String] |]
, ("lock", [t| Bool |]) , simpleField "lock" [t| Bool |]
]) ])
, (luxiReqQueryJobs, , (luxiReqQueryJobs,
[ ("ids", [t| [Int] |]) [ simpleField "ids" [t| [Int] |]
, ("fields", [t| [String] |]) , simpleField "fields" [t| [String] |]
]) ])
, (luxiReqQueryExports, , (luxiReqQueryExports,
[ ("nodes", [t| [String] |]) [ simpleField "nodes" [t| [String] |]
, ("lock", [t| Bool |]) , simpleField "lock" [t| Bool |]
]) ])
, (luxiReqQueryConfigValues, , (luxiReqQueryConfigValues,
[ ("fields", [t| [String] |]) ] [ simpleField "fields" [t| [String] |] ]
) )
, (luxiReqQueryClusterInfo, []) , (luxiReqQueryClusterInfo, [])
, (luxiReqQueryTags, , (luxiReqQueryTags,
[ ("kind", [t| TagObject |]) [ simpleField "kind" [t| TagObject |]
, ("name", [t| String |]) , simpleField "name" [t| String |]
]) ])
, (luxiReqSubmitJob, , (luxiReqSubmitJob,
[ ("job", [t| [OpCode] |]) ] [ simpleField "job" [t| [OpCode] |] ]
) )
, (luxiReqSubmitManyJobs, , (luxiReqSubmitManyJobs,
[ ("ops", [t| [[OpCode]] |]) ] [ simpleField "ops" [t| [[OpCode]] |] ]
) )
, (luxiReqWaitForJobChange, , (luxiReqWaitForJobChange,
[ ("job", [t| Int |]) [ simpleField "job" [t| Int |]
, ("fields", [t| [String]|]) , simpleField "fields" [t| [String]|]
, ("prev_job", [t| JSValue |]) , simpleField "prev_job" [t| JSValue |]
, ("prev_log", [t| JSValue |]) , simpleField "prev_log" [t| JSValue |]
, ("tmout", [t| Int |]) , simpleField "tmout" [t| Int |]
]) ])
, (luxiReqArchiveJob, , (luxiReqArchiveJob,
[ ("job", [t| Int |]) ] [ simpleField "job" [t| Int |] ]
) )
, (luxiReqAutoArchiveJobs, , (luxiReqAutoArchiveJobs,
[ ("age", [t| Int |]) [ simpleField "age" [t| Int |]
, ("tmout", [t| Int |]) , simpleField "tmout" [t| Int |]
]) ])
, (luxiReqCancelJob, , (luxiReqCancelJob,
[ ("job", [t| Int |]) ] [ simpleField "job" [t| Int |] ]
) )
, (luxiReqSetDrainFlag, , (luxiReqSetDrainFlag,
[ ("flag", [t| Bool |]) ] [ simpleField "flag" [t| Bool |] ]
) )
, (luxiReqSetWatcherPause, , (luxiReqSetWatcherPause,
[ ("duration", [t| Double |]) ] [ simpleField "duration" [t| Double |] ]
) )
]) ])
......
...@@ -621,11 +621,17 @@ genStrOfKey = genConstrToStr ensureLower ...@@ -621,11 +621,17 @@ genStrOfKey = genConstrToStr ensureLower
-- --
-- * type -- * type
-- --
genLuxiOp :: String -> SimpleObject -> Q [Dec] genLuxiOp :: String -> [(String, [Field])] -> Q [Dec]
genLuxiOp name cons = do genLuxiOp name cons = do
let tname = mkName name let tname = mkName name
declD <- buildSimpleCons tname cons decl_d <- mapM (\(cname, fields) -> do
(savesig, savefn) <- genSaveSimpleObj tname "opToArgs" -- 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 cons saveLuxiConstructor
req_defs <- declareSADT "LuxiReq" . req_defs <- declareSADT "LuxiReq" .
map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $ map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
...@@ -638,16 +644,16 @@ saveLuxiField fvar (_, qt) = ...@@ -638,16 +644,16 @@ saveLuxiField fvar (_, qt) =
[| JSON.showJSON $(varE fvar) |] [| JSON.showJSON $(varE fvar) |]
-- | Generates the \"save\" clause for entire LuxiOp constructor. -- | Generates the \"save\" clause for entire LuxiOp constructor.
saveLuxiConstructor :: SimpleConstructor -> Q Clause saveLuxiConstructor :: (String, [Field]) -> Q Clause
saveLuxiConstructor (sname, fields) = do saveLuxiConstructor (sname, fields) = do
let cname = mkName sname let cname = mkName sname
fnames = map (mkName . fst) fields fnames <- mapM (newName . fieldVariable) fields
pat = conP cname (map varP fnames) let pat = conP cname (map varP fnames)
flist = map (uncurry saveLuxiField) (zip fnames fields) let felems = map (uncurry saveObjectField) (zip fnames fields)
finval = if null flist flist = if null felems
then [| JSON.showJSON () |] then [| JSON.showJSON () |]
else [| JSON.showJSON $(listE flist) |] else [| JSON.showJSON (map snd $ concat $(listE felems)) |]
clause [pat] (normalB finval) [] clause [pat] (normalB flist) []
-- * "Objects" functionality -- * "Objects" functionality
...@@ -721,9 +727,12 @@ saveObjectField fvar field = ...@@ -721,9 +727,12 @@ saveObjectField fvar field =
|] |]
NotOptional -> NotOptional ->
case fieldShow field of 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)] |] Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
Just fn -> [| let (actual, extra) = $fn $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) where nameE = stringE (fieldName field)
fvarE = varE fvar 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