From 185b5b0d3147dd5dc9e38f928bb1ec8f1b3f60df Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Fri, 12 Oct 2012 11:09:05 +0200
Subject: [PATCH] Abstract Luxi template functionality
These are almost generic, so let's change the signatures a bit a make
them fully so.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Adeodato Simo <dato@google.com>
---
htools/Ganeti/THH.hs | 46 +++++++++++++++++++++++++++++---------------
1 file changed, 30 insertions(+), 16 deletions(-)
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 1fe3824eb..643684650 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -236,6 +236,32 @@ appFn :: Exp -> Exp -> Exp
appFn f x | f == VarE 'id = x
| otherwise = AppE f x
+-- | Builds a field for a normal constructor.
+buildConsField :: Q Type -> StrictTypeQ
+buildConsField ftype = do
+ ftype' <- ftype
+ return (NotStrict, ftype')
+
+-- | Builds a constructor based on a simple definition (not field-based).
+buildSimpleCons :: Name -> SimpleObject -> Q Dec
+buildSimpleCons tname cons = do
+ decl_d <- mapM (\(cname, fields) -> do
+ fields' <- mapM (buildConsField . snd) fields
+ return $ NormalC (mkName cname) fields') cons
+ return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq]
+
+-- | Generate the save function for a given type.
+genSaveSimpleObj :: Name -- ^ Object type
+ -> String -- ^ Function name
+ -> SimpleObject -- ^ Object definition
+ -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn
+ -> Q (Dec, Dec)
+genSaveSimpleObj tname sname opdefs fn = do
+ let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue)
+ fname = mkName sname
+ cclauses <- mapM fn opdefs
+ return $ (SigD fname sigt, FunD fname cclauses)
+
-- * Template code for simple raw type-equivalent ADTs
-- | Generates a data type declaration.
@@ -573,14 +599,10 @@ genStrOfKey = genConstrToStr ensureLower
--
genLuxiOp :: String -> SimpleObject -> Q [Dec]
genLuxiOp name cons = do
- decl_d <- mapM (\(cname, fields) -> do
- fields' <- mapM (\(_, qt) ->
- qt >>= \t -> return (NotStrict, t))
- fields
- return $ NormalC (mkName cname) fields')
- cons
- let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq]
- (savesig, savefn) <- genSaveLuxiOp cons
+ let tname = mkName name
+ declD <- buildSimpleCons tname cons
+ (savesig, savefn) <- genSaveSimpleObj tname "opToArgs"
+ cons saveLuxiConstructor
req_defs <- declareSADT "LuxiReq" .
map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $
cons
@@ -603,14 +625,6 @@ saveLuxiConstructor (sname, fields) = do
else [| JSON.showJSON $(listE flist) |]
clause [pat] (normalB finval) []
--- | Generates the main save LuxiOp function.
-genSaveLuxiOp :: SimpleObject-> Q (Dec, Dec)
-genSaveLuxiOp opdefs = do
- sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
- let fname = mkName "opToArgs"
- cclauses <- mapM saveLuxiConstructor opdefs
- return $ (SigD fname sigt, FunD fname cclauses)
-
-- * "Objects" functionality
-- | Extract the field's declaration from a Field structure.
--
GitLab