Datatypes for haskell RPC calls

[ganeti-local] / htools / Ganeti / THH.hs

diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 87e6b0a..929da6f 100644 (file)
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -10,7 +10,7 @@ needs in this module (except the one for unittests).
 
 {-
 
 
 {-
 

-Copyright (C) 2011 Google Inc.
+Copyright (C) 2011, 2012 Google Inc.

 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by

@@ -110,9 +110,12 @@ containerField :: Field -> Field
 containerField field = field { fieldIsContainer = True }
 
 -- | Sets custom functions on a field.
 containerField field = field { fieldIsContainer = True }
 
 -- | Sets custom functions on a field.

-customField :: Q Exp -> Q Exp -> Field -> Field
+customField :: Name    -- ^ The name of the read function
+            -> Name    -- ^ The name of the show function
+            -> Field   -- ^ The original field
+            -> Field   -- ^ Updated field

 customField readfn showfn field =
 customField readfn showfn field =

-  field { fieldRead = Just readfn, fieldShow = Just showfn }
+  field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) }

 
 fieldRecordName :: Field -> String
 fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =
 
 fieldRecordName :: Field -> String
 fieldRecordName (Field { fieldName = name, fieldConstr = alias }) =

@@ -141,15 +144,18 @@ checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) =
   fail $ "Default field " ++ name ++ " used in parameter declaration"
 checkNonOptDef _ = return ()
 
   fail $ "Default field " ++ name ++ " used in parameter declaration"
 checkNonOptDef _ = return ()
 

-loadFn :: Field -> Q Exp -> Q Exp
-loadFn (Field { fieldIsContainer = True }) expr = [| $expr >>= readContainer |]
-loadFn (Field { fieldRead = Just readfn }) expr = [| $expr >>= $readfn |]
-loadFn _ expr = expr
-
-saveFn :: Field -> Q Exp -> Q Exp
-saveFn (Field { fieldIsContainer = True }) expr = [| showContainer $expr |]
-saveFn (Field { fieldRead = Just readfn }) expr = [| $readfn $expr |]
-saveFn _ expr = expr
+-- | Produces the expression that will de-serialise a given
+-- field. Since some custom parsing functions might need to use the
+-- entire object, we do take and pass the object to any custom read
+-- functions.
+loadFn :: Field   -- ^ The field definition
+       -> Q Exp   -- ^ The value of the field as existing in the JSON message
+       -> Q Exp   -- ^ The entire object in JSON object format
+       -> Q Exp   -- ^ Resulting expression
+loadFn (Field { fieldIsContainer = True }) expr _ =
+  [| $expr >>= readContainer |]
+loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
+loadFn _ expr _ = expr

 
 -- * Common field declarations
 
 
 -- * Common field declarations
 

@@ -246,7 +252,7 @@ strADTDecl name constructors =
 -- @
 genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
 genToRaw traw fname tname constructors = do
 -- @
 genToRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
 genToRaw traw fname tname constructors = do

-  sigt <- [t| $(conT tname) -> $(conT traw) |]
+  let sigt = AppT (AppT ArrowT (ConT tname)) (ConT traw)

   -- the body clauses, matching on the constructor and returning the
   -- raw value
   clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]
   -- the body clauses, matching on the constructor and returning the
   -- raw value
   clauses <- mapM  (\(c, v) -> clause [recP (mkName c) []]

@@ -328,8 +334,10 @@ declareSADT = declareADT ''String
 -- @
 --
 -- in an instance JSON /name/ declaration
 -- @
 --
 -- in an instance JSON /name/ declaration

-genShowJSON :: String -> Q [Dec]
-genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toRawName name)) |]
+genShowJSON :: String -> Q Dec
+genShowJSON name = do
+  body <- [| JSON.showJSON . $(varE (toRawName name)) |]
+  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]

 
 -- | Creates the readJSON member of a JSON instance declaration.
 --
 
 -- | Creates the readJSON member of a JSON instance declaration.
 --

@@ -363,7 +371,7 @@ makeJSONInstance name = do
   let base = nameBase name
   showJ <- genShowJSON base
   readJ <- genReadJSON base
   let base = nameBase name
   showJ <- genShowJSON base
   readJ <- genReadJSON base

-  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
+  return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]

 
 -- * Template code for opcodes
 
 
 -- * Template code for opcodes
 

@@ -539,9 +547,12 @@ genLuxiOp name cons = do
                                fields
                     return $ NormalC (mkName cname) fields')
             cons
                                fields
                     return $ NormalC (mkName cname) fields')
             cons

-  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read]
+  let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]

   (savesig, savefn) <- genSaveLuxiOp cons
   (savesig, savefn) <- genSaveLuxiOp cons

-  return [declD, savesig, savefn]
+  req_defs <- declareSADT "LuxiReq" .
+              map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
+                  cons
+  return $ [declD, savesig, savefn] ++ req_defs

 
 -- | Generates the \"save\" expression for a single luxi parameter.
 saveLuxiField :: Name -> LuxiParam -> Q Exp
 
 -- | Generates the \"save\" expression for a single luxi parameter.
 saveLuxiField :: Name -> LuxiParam -> Q Exp

@@ -595,7 +606,7 @@ buildObjectSerialisation sname fields = do
   shjson <- objectShowJSON sname
   rdjson <- objectReadJSON sname
   let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
   shjson <- objectShowJSON sname
   rdjson <- objectReadJSON sname
   let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))

-                 (rdjson:shjson)
+                 [rdjson, shjson]

   return $ savedecls ++ [loadsig, loadfn, instdecl]
 
 genSaveObject :: (Name -> Field -> Q Exp)
   return $ savedecls ++ [loadsig, loadfn, instdecl]
 
 genSaveObject :: (Name -> Field -> Q Exp)

@@ -628,15 +639,18 @@ saveObjectField fvar field
                   |]
   | otherwise = case fieldShow field of
       Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]
                   |]
   | otherwise = case fieldShow field of
       Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |]

-      Just fn -> [| [( $nameE, JSON.showJSON . $fn $ $fvarE)] |]
+      Just fn -> [| let (actual, extra) = $fn $fvarE
+                    in extra ++ [( $nameE, JSON.showJSON actual)]
+                  |]

   where isContainer = fieldIsContainer field
         fisOptional  = fieldIsOptional field
         nameE = stringE (fieldName field)
         fvarE = varE fvar
 
   where isContainer = fieldIsContainer field
         fisOptional  = fieldIsOptional field
         nameE = stringE (fieldName field)
         fvarE = varE fvar
 

-objectShowJSON :: String -> Q [Dec]
-objectShowJSON name =
-  [d| showJSON = JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
+objectShowJSON :: String -> Q Dec
+objectShowJSON name = do
+  body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |]
+  return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []]

 
 genLoadObject :: (Field -> Q (Name, Stmt))
               -> String -> [Field] -> Q (Dec, Dec)
 
 genLoadObject :: (Field -> Q (Name, Stmt))
               -> String -> [Field] -> Q (Dec, Dec)

@@ -671,7 +685,7 @@ loadObjectField field = do
                    [| $(varNameE "fromObjWithDefault") $objvar
                       $objfield $defv |]
                  Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]
                    [| $(varNameE "fromObjWithDefault") $objvar
                       $objfield $defv |]
                  Nothing -> [| $(varNameE "fromObj") $objvar $objfield |]

-  bexp <- loadFn field loadexp
+  bexp <- loadFn field loadexp objvar

 
   return (fvar, BindS (VarP fvar) bexp)
 
 
   return (fvar, BindS (VarP fvar) bexp)
 

@@ -717,8 +731,8 @@ buildParam sname field_pfx fields = do
   fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
   let decl_f = RecC name_f fields_f
       decl_p = RecC name_p fields_p
   fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
   let decl_f = RecC name_f fields_f
       decl_p = RecC name_p fields_p

-  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read]
-      declP = DataD [] name_p [] [decl_p] [''Show, ''Read]
+  let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq]
+      declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq]

   ser_decls_f <- buildObjectSerialisation sname_f fields
   ser_decls_p <- buildPParamSerialisation sname_p fields
   fill_decls <- fillParam sname field_pfx fields
   ser_decls_f <- buildObjectSerialisation sname_f fields
   ser_decls_p <- buildPParamSerialisation sname_p fields
   fill_decls <- fillParam sname field_pfx fields

@@ -732,7 +746,7 @@ buildPParamSerialisation sname fields = do
   shjson <- objectShowJSON sname
   rdjson <- objectReadJSON sname
   let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
   shjson <- objectShowJSON sname
   rdjson <- objectReadJSON sname
   let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))

-                 (rdjson:shjson)
+                 [rdjson, shjson]

   return $ savedecls ++ [loadsig, loadfn, instdecl]
 
 savePParamField :: Name -> Field -> Q Exp
   return $ savedecls ++ [loadsig, loadfn, instdecl]
 
 savePParamField :: Name -> Field -> Q Exp

@@ -756,7 +770,7 @@ loadPParamField field = do
   let objvar = varNameE "o"
       objfield = stringE name
       loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]
   let objvar = varNameE "o"
       objfield = stringE name
       loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |]

-  bexp <- loadFn field loadexp
+  bexp <- loadFn field loadexp objvar

   return (fvar, BindS (VarP fvar) bexp)
 
 -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.
   return (fvar, BindS (VarP fvar) bexp)
 
 -- | Builds a simple declaration of type @n_x = fromMaybe f_x p_x@.