On Mon, Sep 26, 2011 at 11:57 AM, Iustin Pop <[email protected]> wrote:
> 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.
> ---
> 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 b3fc1f3..af973f1 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 fe5e4ae..5b85492 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,8 @@ declareSADT :: String -> [(String, Name)] -> Q [Dec]
> declareSADT sname cons = do
> let name = mkName sname
> let ddecl = strADTDecl sname (map fst cons)
> - tostr <- genToString (toStrName sname) name cons
> + tostr <- genToString (toStrName sname) name $
> + map (\(a, b) -> (a, Right b)) cons
I think I'dput the map into separate variable for readability reasons
> fromstr <- genFromString (fromStrName sname) name cons
> return $ ddecl:tostr ++ fromstr
>
> @@ -185,3 +195,33 @@ makeJSONInstance name = do
> 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
> + info <- reify name
> + let TyConI (DataD _ _ _ cons _) = info
Why not TyConl (DataD _ _ _ cons _) <- reinfy name? You do not seem to
use info anywhere else..
> + cnames <- mapM (liftM nameBase . constructorName) cons
> + let svalues = map (Left . deCamelCase) cnames
> + genToString (mkName fname) name $ zip cnames svalues
> --
> 1.7.3.1
>
>
Rest LGTM
