Due to the (now removed) custom filter field, we needed a conversion function. Since now that field is gone, we can move to a simpler Luxi TH implementation.
Signed-off-by: Iustin Pop <[email protected]> --- htools/Ganeti/Luxi.hs | 64 ++++++++++++++++++++++++------------------------ htools/Ganeti/THH.hs | 17 +++++------- 2 files changed, 39 insertions(+), 42 deletions(-) diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs index 8f0c296..70c7785 100644 --- a/htools/Ganeti/Luxi.hs +++ b/htools/Ganeti/Luxi.hs @@ -113,69 +113,69 @@ $(makeJSONInstance ''QrViaLuxi) -- | Currently supported Luxi operations and JSON serialization. $(genLuxiOp "LuxiOp" [(luxiReqQuery, - [ ("what", [t| QrViaLuxi |], [| id |]) - , ("fields", [t| [String] |], [| id |]) - , ("qfilter", [t| Qlang.Filter |], [| id |]) + [ ("what", [t| QrViaLuxi |]) + , ("fields", [t| [String] |]) + , ("qfilter", [t| Qlang.Filter |]) ]) , (luxiReqQueryNodes, - [ ("names", [t| [String] |], [| id |]) - , ("fields", [t| [String] |], [| id |]) - , ("lock", [t| Bool |], [| id |]) + [ ("names", [t| [String] |]) + , ("fields", [t| [String] |]) + , ("lock", [t| Bool |]) ]) , (luxiReqQueryGroups, - [ ("names", [t| [String] |], [| id |]) - , ("fields", [t| [String] |], [| id |]) - , ("lock", [t| Bool |], [| id |]) + [ ("names", [t| [String] |]) + , ("fields", [t| [String] |]) + , ("lock", [t| Bool |]) ]) , (luxiReqQueryInstances, - [ ("names", [t| [String] |], [| id |]) - , ("fields", [t| [String] |], [| id |]) - , ("lock", [t| Bool |], [| id |]) + [ ("names", [t| [String] |]) + , ("fields", [t| [String] |]) + , ("lock", [t| Bool |]) ]) , (luxiReqQueryJobs, - [ ("ids", [t| [Int] |], [| id |]) - , ("fields", [t| [String] |], [| id |]) + [ ("ids", [t| [Int] |]) + , ("fields", [t| [String] |]) ]) , (luxiReqQueryExports, - [ ("nodes", [t| [String] |], [| id |]) - , ("lock", [t| Bool |], [| id |]) + [ ("nodes", [t| [String] |]) + , ("lock", [t| Bool |]) ]) , (luxiReqQueryConfigValues, - [ ("fields", [t| [String] |], [| id |]) ] + [ ("fields", [t| [String] |]) ] ) , (luxiReqQueryClusterInfo, []) , (luxiReqQueryTags, - [ ("kind", [t| String |], [| id |]) - , ("name", [t| String |], [| id |]) + [ ("kind", [t| String |]) + , ("name", [t| String |]) ]) , (luxiReqSubmitJob, - [ ("job", [t| [OpCode] |], [| id |]) ] + [ ("job", [t| [OpCode] |]) ] ) , (luxiReqSubmitManyJobs, - [ ("ops", [t| [[OpCode]] |], [| id |]) ] + [ ("ops", [t| [[OpCode]] |]) ] ) , (luxiReqWaitForJobChange, - [ ("job", [t| Int |], [| id |]) - , ("fields", [t| [String]|], [| id |]) - , ("prev_job", [t| JSValue |], [| id |]) - , ("prev_log", [t| JSValue |], [| id |]) - , ("tmout", [t| Int |], [| id |]) + [ ("job", [t| Int |]) + , ("fields", [t| [String]|]) + , ("prev_job", [t| JSValue |]) + , ("prev_log", [t| JSValue |]) + , ("tmout", [t| Int |]) ]) , (luxiReqArchiveJob, - [ ("job", [t| Int |], [| id |]) ] + [ ("job", [t| Int |]) ] ) , (luxiReqAutoArchiveJobs, - [ ("age", [t| Int |], [| id |]) - , ("tmout", [t| Int |], [| id |]) + [ ("age", [t| Int |]) + , ("tmout", [t| Int |]) ]) , (luxiReqCancelJob, - [ ("job", [t| Int |], [| id |]) ] + [ ("job", [t| Int |]) ] ) , (luxiReqSetDrainFlag, - [ ("flag", [t| Bool |], [| id |]) ] + [ ("flag", [t| Bool |]) ] ) , (luxiReqSetWatcherPause, - [ ("duration", [t| Double |], [| id |]) ] + [ ("duration", [t| Double |]) ] ) ]) diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index fcea9a5..76e3281 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -52,7 +52,7 @@ module Ganeti.THH ( declareSADT , buildParam ) where -import Control.Monad (liftM, liftM2) +import Control.Monad (liftM) import Data.Char import Data.List import qualified Data.Set as Set @@ -498,7 +498,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. -- @@ -507,19 +507,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') @@ -533,14 +530,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 -- 1.7.7.3
