TH simplification for Luxi

This patch simplifies the generation of save constructors for LuxiOp
by always using showJSON over an array of JSValues, instead of having
to pass showJSON in most cases, except the 5-tuple case.

Signed-off-by: Agata Murawska <agatamurawska@google.com>
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Iustin Pop <iustin@google.com>
[iustin@google.com: fixed a few issues]

diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index 7ad1e58..e83823b 100644 (file)
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -68,72 +68,55 @@ $(genLuxiOp "LuxiOp"
        [ ("names",  [t| [String] |], [| id |])
        , ("fields", [t| [String] |], [| id |])
        , ("lock",   [t| Bool     |], [| id |])
-       ],
-       [| J.showJSON |])
+       ])
     , ("QueryGroups",
        [ ("names",  [t| [String] |], [| id |])
        , ("fields", [t| [String] |], [| id |])
        , ("lock",   [t| Bool     |], [| id |])
-       ],
-       [| J.showJSON |])
+       ])
     , ("QueryInstances",
        [ ("names",  [t| [String] |], [| id |])
        , ("fields", [t| [String] |], [| id |])
        , ("lock",   [t| Bool     |], [| id |])
-       ],
-       [| J.showJSON |])
+       ])
     , ("QueryJobs",
        [ ("ids",    [t| [Int]    |], [| map show |])
        , ("fields", [t| [String] |], [| id |])
-       ],
-       [| J.showJSON |])
+       ])
     , ("QueryExports",
        [ ("nodes", [t| [String] |], [| id |])
        , ("lock",  [t| Bool     |], [| id |])
-       ],
-       [| J.showJSON |])
+       ])
     , ("QueryConfigValues",
-       [ ("fields", [t| [String] |], [| id |]) ],
-       [| J.showJSON |])
-    , ("QueryClusterInfo",
-       [],
-       [| J.showJSON |])
+       [ ("fields", [t| [String] |], [| id |]) ])
+    , ("QueryClusterInfo", [])
     , ("QueryTags",
        [ ("kind", [t| String |], [| id |])
        , ("name", [t| String |], [| id |])
-       ],
-       [| J.showJSON |])
+       ])
     , ("SubmitJob",
-       [ ("job", [t| [OpCode] |], [| id |]) ],
-       [| J.showJSON |])
+       [ ("job", [t| [OpCode] |], [| id |]) ])
     , ("SubmitManyJobs",
-       [ ("ops", [t| [[OpCode]] |], [| id |]) ],
-       [| J.showJSON |])
+       [ ("ops", [t| [[OpCode]] |], [| id |]) ])
     , ("WaitForJobChange",
-       [ ("job",      [t| Int     |], [| J.showJSON |])
-       , ("fields",   [t| [String]|], [| J.showJSON |])
-       , ("prev_job", [t| JSValue |], [| J.showJSON |])
-       , ("prev_log", [t| JSValue |], [| J.showJSON |])
-       , ("tmout",    [t| Int     |], [| J.showJSON |])
-       ],
-       [| \(j, f, pj, pl, t) -> JSArray [j, f, pj, pl, t] |])
+       [ ("job",      [t| Int     |], [| id |])
+       , ("fields",   [t| [String]|], [| id |])
+       , ("prev_job", [t| JSValue |], [| id |])
+       , ("prev_log", [t| JSValue |], [| id |])
+       , ("tmout",    [t| Int     |], [| id |])
+       ])
     , ("ArchiveJob",
-       [ ("job", [t| Int |], [| show |]) ],
-       [| J.showJSON |])
+       [ ("job", [t| Int |], [| show |]) ])
     , ("AutoArchiveJobs",
        [ ("age",   [t| Int |], [| id |])
        , ("tmout", [t| Int |], [| id |])
-       ],
-       [| J.showJSON |])
+       ])
     , ("CancelJob",
-       [("job", [t| Int |], [| show |]) ],
-       [| J.showJSON |])
+       [("job", [t| Int |], [| show |]) ])
     , ("SetDrainFlag",
-       [ ("flag", [t| Bool |], [| id |]) ],
-       [| J.showJSON |])
+       [ ("flag", [t| Bool |], [| id |]) ])
     , ("SetWatcherPause",
-       [ ("duration", [t| Double |], [| (: []) |]) ],
-       [| J.showJSON |])
+       [ ("duration", [t| Double |], [| (: []) |]) ])
   ])
 
 -- | The serialisation of LuxiOps into strings in messages.

diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index e576b4a..82e44a5 100644 (file)
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -444,9 +444,9 @@ type LuxiParam = (String, Q Type, Q Exp)
 -- * operation; this is the operation performed on the parameter before
 --   serialization
 --
-genLuxiOp :: String -> [(String, [LuxiParam], Q Exp)] -> Q [Dec]
+genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec]
 genLuxiOp name cons = do
-  decl_d <- mapM (\(cname, fields, _) -> do
+  decl_d <- mapM (\(cname, fields) -> do
                     fields' <- mapM (\(_, qt, _) ->
                                          qt >>= \t -> return (NotStrict, t))
                                fields
@@ -457,18 +457,20 @@ genLuxiOp name cons = do
   return [declD, savesig, savefn]
 
 -- | Generates the \"save\" clause for entire LuxiOp constructor.
-saveLuxiConstructor :: (String, [LuxiParam], Q Exp) -> Q Clause
-saveLuxiConstructor (sname, fields, finfn) =
+saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause
+saveLuxiConstructor (sname, fields) =
   let cname = mkName sname
       fnames = map (\(nm, _, _) -> mkName nm) fields
       pat = conP cname (map varP fnames)
-      flist = map (\(nm, _, fn) -> liftM2 appFn fn $ varNameE nm) fields
-      finval = appE finfn (tupE flist)
-  in
-    clause [pat] (normalB finval) []
+      flist = map (\(nm, _, fn) -> liftM2 appFn fn $ (varNameE nm)) fields
+      showlist = map (\x -> [| JSON.showJSON $x |]) flist
+      finval = case showlist of
+                 [] -> [| JSON.showJSON () |]
+                 _ -> [| JSON.showJSON $(listE showlist) |]
+  in clause [pat] (normalB finval) []
 
 -- | Generates the main save LuxiOp function.
-genSaveLuxiOp :: [(String, [LuxiParam], Q Exp)] -> Q (Dec, Dec)
+genSaveLuxiOp :: [(String, [LuxiParam])] -> Q (Dec, Dec)
 genSaveLuxiOp opdefs = do
   sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
   let fname = mkName "opToArgs"