commit 2af78b9766f792abd79103e819f0c8b0c0745d9b
Author: Iustin Pop <iustin@google.com>
Date:   Fri Aug 24 20:38:43 2012 +0200

    Expand THH with more functionality for parameters
    
    This adds two related improvements to THH:
    
    - for parameters, we declare a list with all their fields, so that
      Query2 can build the list of fields (e.g. for hvparams, or ndparams)
      automatically
    
    - we declare a new type class for "DictObjects", i.e. objects which
      can be converted to a [(String, JSValue)] list of pairs; while this
      applies to all our objects, it will be used first for filled
      parameters, so that we can implement the lookup functions
      generically
    
    Note that we re-export the new class from Objects.hs, so that other
    modules don't have to import THH.
    
    Signed-off-by: Iustin Pop <iustin@google.com>
    Reviewed-by: Agata Murawska <agatamurawska@google.com>

diff --git a/htools/Ganeti/Objects.hs b/htools/Ganeti/Objects.hs
index 423547e..6ba8927 100644
--- a/htools/Ganeti/Objects.hs
+++ b/htools/Ganeti/Objects.hs
@@ -35,6 +35,7 @@ module Ganeti.Objects
   , PartialNicParams(..)
   , FilledNicParams(..)
   , fillNicParams
+  , allNicParamFields
   , PartialNic(..)
   , DiskMode(..)
   , DiskType(..)
@@ -44,6 +45,7 @@ module Ganeti.Objects
   , PartialBeParams(..)
   , FilledBeParams(..)
   , fillBeParams
+  , allBeParamFields
   , Hypervisor(..)
   , AdminState(..)
   , adminStateFromRaw
@@ -52,6 +54,7 @@ module Ganeti.Objects
   , PartialNDParams(..)
   , FilledNDParams(..)
   , fillNDParams
+  , allNDParamFields
   , Node(..)
   , NodeRole(..)
   , nodeRoleToRaw
@@ -60,6 +63,7 @@ module Ganeti.Objects
   , FilledISpecParams(..)
   , PartialISpecParams(..)
   , fillISpecParams
+  , allISpecParamFields
   , FilledIPolicy(..)
   , PartialIPolicy(..)
   , fillIPolicy
@@ -79,6 +83,7 @@ module Ganeti.Objects
   , UuidObject(..)
   , SerialNoObject(..)
   , TagsObject(..)
+  , DictObject(..) -- re-exported from THH
   ) where
 
 import Data.List (foldl')
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 980578d..49d1aa1 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -51,6 +51,7 @@ module Ganeti.THH ( declareSADT
                   , buildObject
                   , buildObjectSerialisation
                   , buildParam
+                  , DictObject(..)
                   ) where
 
 import Control.Monad (liftM)
@@ -64,6 +65,11 @@ import qualified Text.JSON as JSON
 
 -- * Exported types
 
+-- | Class of objects that can be converted to 'JSObject'
+-- lists-format.
+class DictObject a where
+  toDict :: a -> [(String, JSON.JSValue)]
+
 -- | Serialised field data type.
 data Field = Field { fieldName        :: String
                    , fieldType        :: Q Type
@@ -624,6 +630,10 @@ buildObjectSerialisation sname fields = do
                  [rdjson, shjson]
   return $ savedecls ++ [loadsig, loadfn, instdecl]
 
+-- | The toDict function name for a given type.
+toDictName :: String -> Name
+toDictName sname = mkName ("toDict" ++ sname)
+
 -- | Generates the save object functionality.
 genSaveObject :: (Name -> Field -> Q Exp)
               -> String -> [Field] -> Q [Dec]
@@ -631,7 +641,7 @@ genSaveObject save_fn sname fields = do
   let name = mkName sname
   fnames <- mapM (newName . fieldVariable) fields
   let pat = conP name (map varP fnames)
-  let tdname = mkName ("toDict" ++ sname)
+  let tdname = toDictName sname
   tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]
 
   let felems = map (uncurry save_fn) (zip fnames fields)
@@ -756,7 +766,23 @@ buildParam sname field_pfx fields = do
   ser_decls_f <- buildObjectSerialisation sname_f fields
   ser_decls_p <- buildPParamSerialisation sname_p fields
   fill_decls <- fillParam sname field_pfx fields
-  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls
+  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++
+           buildParamAllFields sname fields ++
+           buildDictObjectInst name_f sname_f
+
+-- | Builds a list of all fields of a parameter.
+buildParamAllFields :: String -> [Field] -> [Dec]
+buildParamAllFields sname fields =
+  let vname = mkName ("all" ++ sname ++ "ParamFields")
+      sig = SigD vname (AppT ListT (ConT ''String))
+      val = ListE $ map (LitE . StringL . fieldName) fields
+  in [sig, ValD (VarP vname) (NormalB val) []]
+
+-- | Builds the 'DictObject' instance for a filled parameter.
+buildDictObjectInst :: Name -> String -> [Dec]
+buildDictObjectInst name sname =
+  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
+   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]
 
 -- | Generates the serialisation for a partial parameter.
 buildPParamSerialisation :: String -> [Field] -> Q [Dec]
