Commit 2af78b97 authored by Iustin Pop's avatar Iustin Pop

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: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarAgata Murawska <agatamurawska@google.com>
parent da45c352
......@@ -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')
......
......@@ -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]
......
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