From 6111e296a8a0e115fe85f3a6b7826164aa2590c8 Mon Sep 17 00:00:00 2001
From: Iustin Pop <iustin@google.com>
Date: Tue, 20 Sep 2011 16:17:53 +0900
Subject: [PATCH] Use TemplateHaskell to build the opID function
This replaces the hand-coded opID with one automatically generated
from the constructor names, similar to the way Python does it, except
it's done at compilation time as opposed to runtime.
Again, the code line delta does not favour this patch, but this
eliminates error-prone, manual code with auto-generated one; in case
we add more opcode support, this will help a lot.
Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Agata Murawska <agatamurawska@google.com>
---
htools/Ganeti/OpCodes.hs | 7 +-----
htools/Ganeti/THH.hs | 46 +++++++++++++++++++++++++++++++++++++---
2 files changed, 44 insertions(+), 9 deletions(-)
diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs
index b3fc1f33a..af973f183 100644
--- a/htools/Ganeti/OpCodes.hs
+++ b/htools/Ganeti/OpCodes.hs
@@ -62,12 +62,7 @@ data OpCode = OpTestDelay Double Bool [String]
deriving (Show, Read, Eq)
--- | Computes the OP_ID for an OpCode.
-opID :: OpCode -> String
-opID (OpTestDelay _ _ _) = "OP_TEST_DELAY"
-opID (OpInstanceReplaceDisks _ _ _ _ _) = "OP_INSTANCE_REPLACE_DISKS"
-opID (OpInstanceFailover {}) = "OP_INSTANCE_FAILOVER"
-opID (OpInstanceMigrate {}) = "OP_INSTANCE_MIGRATE"
+$(THH.genOpID ''OpCode "opID")
-- | Loads an OpCode from the JSON serialised form.
loadOpCode :: JSValue -> J.Result OpCode
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index 6e539a43d..808836f20 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -31,9 +31,12 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
module Ganeti.THH ( declareSADT
, makeJSONInstance
+ , genOpID
) where
+import Control.Monad (liftM)
import Data.Char
+import Data.List
import Language.Haskell.TH
import qualified Text.JSON as JSON
@@ -54,6 +57,12 @@ toStrName = mkName . (++ "ToString") . ensureLower
fromStrName :: String -> Name
fromStrName = mkName . (++ "FromString") . ensureLower
+-- | Converts a name to it's varE/litE representations.
+--
+reprE :: Either String Name -> Q Exp
+reprE (Left name) = litE (StringL name)
+reprE (Right name) = varE name
+
-- | Generates a data type declaration.
--
-- The type will have a fixed list of instances.
@@ -72,13 +81,13 @@ strADTDecl name constructors =
-- nameToString Cons1 = var1
-- nameToString Cons2 = \"value2\"
-- @
-genToString :: Name -> Name -> [(String, Name)] -> Q [Dec]
+genToString :: Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genToString fname tname constructors = do
sigt <- [t| $(conT tname) -> String |]
-- the body clauses, matching on the constructor and returning the
-- string value
clauses <- mapM (\(c, v) -> clause [recP (mkName c) []]
- (normalB (varE v)) []) constructors
+ (normalB (reprE v)) []) constructors
return [SigD fname sigt, FunD fname clauses]
-- | Generates a fromString function.
@@ -135,7 +144,9 @@ declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT sname cons = do
let name = mkName sname
ddecl = strADTDecl name (map fst cons)
- tostr <- genToString (toStrName sname) name cons
+ -- process cons in the format expected by genToString
+ cons' = map (\(a, b) -> (a, Right b)) cons
+ tostr <- genToString (toStrName sname) name cons'
fromstr <- genFromString (fromStrName sname) name cons
return $ ddecl:tostr ++ fromstr
@@ -184,3 +195,32 @@ makeJSONInstance name = do
showJ <- genShowJSON base
readJ <- genReadJSON base
return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
+
+-- | Transforms a CamelCase string into an_underscore_based_one.
+deCamelCase :: String -> String
+deCamelCase =
+ intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b)
+
+-- | Computes the name of a given constructor
+constructorName :: Con -> Q Name
+constructorName (NormalC name _) = return name
+constructorName (RecC name _) = return name
+constructorName x = fail $ "Unhandled constructor " ++ show x
+
+-- | Builds the constructor-to-string function.
+--
+-- This generates a simple function of the following form:
+--
+-- @
+-- fname (ConStructorOne {}) = "CON_STRUCTOR_ONE"
+-- fname (ConStructorTwo {}) = "CON_STRUCTOR_TWO"
+-- @
+--
+-- This builds a custom list of name/string pairs and then uses
+-- 'genToString' to actually generate the function
+genOpID :: Name -> String -> Q [Dec]
+genOpID name fname = do
+ TyConI (DataD _ _ _ cons _) <- reify name
+ cnames <- mapM (liftM nameBase . constructorName) cons
+ let svalues = map (Left . deCamelCase) cnames
+ genToString (mkName fname) name $ zip cnames svalues
--
GitLab