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: Iustin Pop <iustin@google.com>
Reviewed-by: Helga Velroyen <helgav@google.com>

diff --git a/htools/Ganeti/Luxi.hs b/htools/Ganeti/Luxi.hs
index b933eb5..622eceb 100644 (file)
--- a/htools/Ganeti/Luxi.hs
+++ b/htools/Ganeti/Luxi.hs
@@ -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 |] ]
     )
   ])
 

diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 584c712..489413d 100644 (file)
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -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