On Mon, Sep 26, 2011 at 11:57 AM, Iustin Pop <[email protected]> wrote:
> This patch replaces the current hard-coded JSON instances (all alike,
> just manual conversion to/from string) with auto-generated code based
> on Template Haskell
> (http://www.haskell.org/haskellwiki/Template_Haskell).
>
> The reduction in code line is not big, as the helper module is well
> documented and thus overall we gain about 70 code lines; however, if
> we ignore comments we're in good shape, and any future addition of
> such data types will be much simpler and less error-prone.
> ---
> Makefile.am | 3 +-
> htools/Ganeti/HTools/Types.hs | 107 +++++------------------
> htools/Ganeti/Jobs.hs | 81 +++++-------------
> htools/Ganeti/OpCodes.hs | 30 +++----
> htools/Ganeti/THH.hs | 187
> +++++++++++++++++++++++++++++++++++++++++
> 5 files changed, 248 insertions(+), 160 deletions(-)
> create mode 100644 htools/Ganeti/THH.hs
>
> diff --git a/Makefile.am b/Makefile.am
> index 5d4f608..b3edd40 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -361,7 +361,8 @@ HS_LIB_SRCS = \
> htools/Ganeti/HTools/Program/Hspace.hs \
> htools/Ganeti/Jobs.hs \
> htools/Ganeti/Luxi.hs \
> - htools/Ganeti/OpCodes.hs
> + htools/Ganeti/OpCodes.hs \
> + htools/Ganeti/THH.hs
>
> HS_BUILT_SRCS = htools/Ganeti/HTools/Version.hs htools/Ganeti/Constants.hs
> HS_BUILT_SRCS_IN = $(patsubst %,%.in,$(HS_BUILT_SRCS))
> diff --git a/htools/Ganeti/HTools/Types.hs b/htools/Ganeti/HTools/Types.hs
> index 75dbce5..8e6b6a4 100644
> --- a/htools/Ganeti/HTools/Types.hs
> +++ b/htools/Ganeti/HTools/Types.hs
> @@ -1,3 +1,5 @@
> +{-# LANGUAGE TemplateHaskell #-}
> +
> {-| Some common types.
>
> -}
> @@ -72,6 +74,7 @@ import qualified Data.Map as M
> import qualified Text.JSON as JSON
>
> import qualified Ganeti.Constants as C
> +import qualified Ganeti.THH as THH
>
> -- | The instance index type.
> type Idx = Int
> @@ -100,36 +103,12 @@ type GroupID = String
> -- Ord instance will order them in the order they are defined, so when
> -- changing this data type be careful about the interaction with the
> -- desired sorting order.
> -data AllocPolicy
> - = AllocPreferred -- ^ This is the normal status, the group
> - -- should be used normally during allocations
> - | AllocLastResort -- ^ This group should be used only as
> - -- last-resort, after the preferred groups
> - | AllocUnallocable -- ^ This group must not be used for new
> - -- allocations
> - deriving (Show, Read, Eq, Ord, Enum, Bounded)
> -
> --- | Convert a string to an alloc policy.
> -allocPolicyFromString :: (Monad m) => String -> m AllocPolicy
> -allocPolicyFromString s =
> - case () of
> - _ | s == C.allocPolicyPreferred -> return AllocPreferred
> - | s == C.allocPolicyLastResort -> return AllocLastResort
> - | s == C.allocPolicyUnallocable -> return AllocUnallocable
> - | otherwise -> fail $ "Invalid alloc policy mode: " ++ s
> -
> --- | Convert an alloc policy to the Ganeti string equivalent.
> -allocPolicyToString :: AllocPolicy -> String
> -allocPolicyToString AllocPreferred = C.allocPolicyPreferred
> -allocPolicyToString AllocLastResort = C.allocPolicyLastResort
> -allocPolicyToString AllocUnallocable = C.allocPolicyUnallocable
> -
> -instance JSON.JSON AllocPolicy where
> - showJSON = JSON.showJSON . allocPolicyToString
> - readJSON s = case JSON.readJSON s of
> - JSON.Ok s' -> allocPolicyFromString s'
> - JSON.Error e -> JSON.Error $
> - "Can't parse alloc_policy: " ++ e
> +$(THH.declareSADT "AllocPolicy"
> + [ ("AllocPreferred", 'C.allocPolicyPreferred)
> + , ("AllocLastResort", 'C.allocPolicyLastResort)
> + , ("AllocUnallocable", 'C.allocPolicyUnallocable)
> + ])
> +$(THH.makeJSONInstance ''AllocPolicy)
>
> -- | The resource spec type.
> data RSpec = RSpec
> @@ -182,41 +161,15 @@ data IMove = Failover -- ^ Failover the
> instance (f)
> deriving (Show, Read)
>
> -- | Instance disk template type.
> -data DiskTemplate = DTDiskless
> - | DTFile
> - | DTSharedFile
> - | DTPlain
> - | DTBlock
> - | DTDrbd8
> - deriving (Show, Read, Eq, Enum, Bounded)
> -
> --- | Converts a DiskTemplate to String.
> -diskTemplateToString :: DiskTemplate -> String
> -diskTemplateToString DTDiskless = C.dtDiskless
> -diskTemplateToString DTFile = C.dtFile
> -diskTemplateToString DTSharedFile = C.dtSharedFile
> -diskTemplateToString DTPlain = C.dtPlain
> -diskTemplateToString DTBlock = C.dtBlock
> -diskTemplateToString DTDrbd8 = C.dtDrbd8
> -
> --- | Converts a DiskTemplate from String.
> -diskTemplateFromString :: (Monad m) => String -> m DiskTemplate
> -diskTemplateFromString s =
> - case () of
> - _ | s == C.dtDiskless -> return DTDiskless
> - | s == C.dtFile -> return DTFile
> - | s == C.dtSharedFile -> return DTSharedFile
> - | s == C.dtPlain -> return DTPlain
> - | s == C.dtBlock -> return DTBlock
> - | s == C.dtDrbd8 -> return DTDrbd8
> - | otherwise -> fail $ "Invalid disk template: " ++ s
> -
> -instance JSON.JSON DiskTemplate where
> - showJSON = JSON.showJSON . diskTemplateToString
> - readJSON s = case JSON.readJSON s of
> - JSON.Ok s' -> diskTemplateFromString s'
> - JSON.Error e -> JSON.Error $
> - "Can't parse disk_template as string: "
> ++ e
> +$(THH.declareSADT "DiskTemplate"
> + [ ("DTDiskless", 'C.dtDiskless)
> + , ("DTFile", 'C.dtFile)
> + , ("DTSharedFile", 'C.dtSharedFile)
> + , ("DTPlain", 'C.dtPlain)
> + , ("DTBlock", 'C.dtBlock)
> + , ("DTDrbd8", 'C.dtDrbd8)
> + ])
> +$(THH.makeJSONInstance ''DiskTemplate)
>
> -- | Formatted solution output for one move (involved nodes and
> -- commands.
> @@ -347,21 +300,9 @@ class Element a where
> setIdx :: a -> Int -> a
>
> -- | The iallocator node-evacuate evac_mode type.
> -data EvacMode = ChangePrimary
> - | ChangeSecondary
> - | ChangeAll
> - deriving (Show, Read)
> -
> -instance JSON.JSON EvacMode where
> - showJSON mode = case mode of
> - ChangeAll -> JSON.showJSON C.iallocatorNevacAll
> - ChangePrimary -> JSON.showJSON C.iallocatorNevacPri
> - ChangeSecondary -> JSON.showJSON C.iallocatorNevacSec
> - readJSON v =
> - case JSON.readJSON v of
> - JSON.Ok s | s == C.iallocatorNevacAll -> return ChangeAll
> - | s == C.iallocatorNevacPri -> return ChangePrimary
> - | s == C.iallocatorNevacSec -> return ChangeSecondary
> - | otherwise -> fail $ "Invalid evacuate mode " ++ s
> - JSON.Error e -> JSON.Error $
> - "Can't parse evacuate mode as string: " ++ e
> +$(THH.declareSADT "EvacMode"
> + [ ("ChangePrimary", 'C.iallocatorNevacPri)
> + , ("ChangeSecondary", 'C.iallocatorNevacSec)
> + , ("ChangeAll", 'C.iallocatorNevacAll)
> + ])
> +$(THH.makeJSONInstance ''EvacMode)
> diff --git a/htools/Ganeti/Jobs.hs b/htools/Ganeti/Jobs.hs
> index ed7bc7d..1e2cebe 100644
> --- a/htools/Ganeti/Jobs.hs
> +++ b/htools/Ganeti/Jobs.hs
> @@ -1,3 +1,5 @@
> +{-# LANGUAGE TemplateHaskell #-}
> +
> {-| Implementation of the job information.
>
> -}
> @@ -32,67 +34,30 @@ import Text.JSON (readJSON, showJSON, JSON)
> import qualified Text.JSON as J
>
> import qualified Ganeti.Constants as C
> +import qualified Ganeti.THH as THH
>
> -- | Our ADT for the OpCode status at runtime (while in a job).
> -data OpStatus = OP_STATUS_QUEUED
> - | OP_STATUS_WAITING
> - | OP_STATUS_CANCELING
> - | OP_STATUS_RUNNING
> - | OP_STATUS_CANCELED
> - | OP_STATUS_SUCCESS
> - | OP_STATUS_ERROR
> - deriving (Eq, Enum, Bounded, Show, Read)
> -
> -instance JSON OpStatus where
> - showJSON os = showJSON w
> - where w = case os of
> - OP_STATUS_QUEUED -> C.opStatusQueued
> - OP_STATUS_WAITING -> C.opStatusWaiting
> - OP_STATUS_CANCELING -> C.opStatusCanceling
> - OP_STATUS_RUNNING -> C.opStatusRunning
> - OP_STATUS_CANCELED -> C.opStatusCanceled
> - OP_STATUS_SUCCESS -> C.opStatusSuccess
> - OP_STATUS_ERROR -> C.opStatusError
> - readJSON s = case readJSON s of
> - J.Ok v | v == C.opStatusQueued -> J.Ok OP_STATUS_QUEUED
> - | v == C.opStatusWaiting -> J.Ok OP_STATUS_WAITING
> - | v == C.opStatusCanceling -> J.Ok OP_STATUS_CANCELING
> - | v == C.opStatusRunning -> J.Ok OP_STATUS_RUNNING
> - | v == C.opStatusCanceled -> J.Ok OP_STATUS_CANCELED
> - | v == C.opStatusSuccess -> J.Ok OP_STATUS_SUCCESS
> - | v == C.opStatusError -> J.Ok OP_STATUS_ERROR
> - | otherwise -> J.Error ("Unknown opcode status " ++ v)
> - _ -> J.Error ("Cannot parse opcode status " ++ show s)
> +$(THH.declareSADT "OpStatus"
> + [ ("OP_STATUS_QUEUED", 'C.opStatusQueued)
> + , ("OP_STATUS_WAITING", 'C.opStatusWaiting)
> + , ("OP_STATUS_CANCELING", 'C.opStatusCanceling)
> + , ("OP_STATUS_RUNNING", 'C.opStatusRunning)
> + , ("OP_STATUS_CANCELED", 'C.opStatusCanceled)
> + , ("OP_STATUS_SUCCESS", 'C.opStatusSuccess)
> + , ("OP_STATUS_ERROR", 'C.opStatusError)
> + ])
> +$(THH.makeJSONInstance ''OpStatus)
>
> -- | The JobStatus data type. Note that this is ordered especially
> -- such that greater\/lesser comparison on values of this type makes
> -- sense.
> -data JobStatus = JOB_STATUS_QUEUED
> - | JOB_STATUS_WAITING
> - | JOB_STATUS_RUNNING
> - | JOB_STATUS_SUCCESS
> - | JOB_STATUS_CANCELING
> - | JOB_STATUS_CANCELED
> - | JOB_STATUS_ERROR
> - deriving (Eq, Enum, Ord, Bounded, Show, Read)
> -
> -instance JSON JobStatus where
> - showJSON js = showJSON w
> - where w = case js of
> - JOB_STATUS_QUEUED -> C.jobStatusQueued
> - JOB_STATUS_WAITING -> C.jobStatusWaiting
> - JOB_STATUS_CANCELING -> C.jobStatusCanceling
> - JOB_STATUS_RUNNING -> C.jobStatusRunning
> - JOB_STATUS_CANCELED -> C.jobStatusCanceled
> - JOB_STATUS_SUCCESS -> C.jobStatusSuccess
> - JOB_STATUS_ERROR -> C.jobStatusError
> - readJSON s = case readJSON s of
> - J.Ok v | v == C.jobStatusQueued -> J.Ok JOB_STATUS_QUEUED
> - | v == C.jobStatusWaiting -> J.Ok JOB_STATUS_WAITING
> - | v == C.jobStatusCanceling -> J.Ok JOB_STATUS_CANCELING
> - | v == C.jobStatusRunning -> J.Ok JOB_STATUS_RUNNING
> - | v == C.jobStatusSuccess -> J.Ok JOB_STATUS_SUCCESS
> - | v == C.jobStatusCanceled -> J.Ok JOB_STATUS_CANCELED
> - | v == C.jobStatusError -> J.Ok JOB_STATUS_ERROR
> - | otherwise -> J.Error ("Unknown job status " ++ v)
> - _ -> J.Error ("Unknown job status " ++ show s)
> +$(THH.declareSADT "JobStatus"
> + [ ("JOB_STATUS_QUEUED", 'C.jobStatusQueued)
> + , ("JOB_STATUS_WAITING", 'C.jobStatusWaiting)
> + , ("JOB_STATUS_CANCELING", 'C.jobStatusCanceling)
> + , ("JOB_STATUS_RUNNING", 'C.jobStatusRunning)
> + , ("JOB_STATUS_CANCELED", 'C.jobStatusCanceled)
> + , ("JOB_STATUS_SUCCESS", 'C.jobStatusSuccess)
> + , ("JOB_STATUS_ERROR", 'C.jobStatusError)
> + ])
> +$(THH.makeJSONInstance ''JobStatus)
> diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs
> index 0930598..b3fc1f3 100644
> --- a/htools/Ganeti/OpCodes.hs
> +++ b/htools/Ganeti/OpCodes.hs
> @@ -1,3 +1,5 @@
> +{-# LANGUAGE TemplateHaskell #-}
> +
> {-| Implementation of the opcodes.
>
> -}
> @@ -34,27 +36,19 @@ import Text.JSON (readJSON, showJSON, makeObj, JSON)
> import qualified Text.JSON as J
> import Text.JSON.Types
>
> +import qualified Ganeti.Constants as C
> +import qualified Ganeti.THH as THH
> +
> import Ganeti.HTools.Utils
>
> -- | Replace disks type.
> -data ReplaceDisksMode = ReplaceOnPrimary
> - | ReplaceOnSecondary
> - | ReplaceNewSecondary
> - | ReplaceAuto
> - deriving (Show, Read, Eq)
> -
> -instance JSON ReplaceDisksMode where
> - showJSON m = case m of
> - ReplaceOnPrimary -> showJSON "replace_on_primary"
> - ReplaceOnSecondary -> showJSON "replace_on_secondary"
> - ReplaceNewSecondary -> showJSON "replace_new_secondary"
> - ReplaceAuto -> showJSON "replace_auto"
> - readJSON s = case readJSON s of
> - J.Ok "replace_on_primary" -> J.Ok ReplaceOnPrimary
> - J.Ok "replace_on_secondary" -> J.Ok ReplaceOnSecondary
> - J.Ok "replace_new_secondary" -> J.Ok ReplaceNewSecondary
> - J.Ok "replace_auto" -> J.Ok ReplaceAuto
> - _ -> J.Error "Can't parse a valid ReplaceDisksMode"
> +$(THH.declareSADT "ReplaceDisksMode"
> + [ ("ReplaceOnPrimary", 'C.replaceDiskPri)
> + , ("ReplaceOnSecondary", 'C.replaceDiskSec)
> + , ("ReplaceNewSecondary", 'C.replaceDiskChg)
> + , ("ReplaceAuto", 'C.replaceDiskAuto)
> + ])
> +$(THH.makeJSONInstance ''ReplaceDisksMode)
>
> -- | OpCode representation.
> --
> diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
> new file mode 100644
> index 0000000..fe5e4ae
> --- /dev/null
> +++ b/htools/Ganeti/THH.hs
> @@ -0,0 +1,187 @@
> +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
> +
> +{-| TemplateHaskell helper for HTools.
> +
> +As TemplateHaskell require that splices be defined in a separate
> +module, we combine all the TemplateHaskell functionality that HTools
> +needs in this module (except the one for unittests).
> +
> +-}
> +
> +{-
> +
> +Copyright (C) 2011 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
> +the Free Software Foundation; either version 2 of the License, or
> +(at your option) any later version.
> +
> +This program is distributed in the hope that it will be useful, but
> +WITHOUT ANY WARRANTY; without even the implied warranty of
> +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
> +General Public License for more details.
> +
> +You should have received a copy of the GNU General Public License
> +along with this program; if not, write to the Free Software
> +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
> +02110-1301, USA.
> +
> +-}
> +
> +module Ganeti.THH ( declareSADT
> + , makeJSONInstance
> + ) where
> +
> +import Data.Char
> +import Language.Haskell.TH
> +
> +import qualified Text.JSON as JSON
> +
> +-- | Ensure first letter is lowercase.
> +--
> +-- Used to convert type name to function prefix, e.g. in @data Aa ->
> +-- aaToString@.
> +ensureLower :: String -> String
> +ensureLower [] = []
> +ensureLower (x:xs) = toLower x:xs
> +
> +-- | ToString function name.
> +toStrName :: String -> Name
> +toStrName = mkName . (++ "ToString") . ensureLower
> +
> +-- | FromString function name.
> +fromStrName :: String -> Name
> +fromStrName = mkName . (++ "FromString") . ensureLower
> +
> +-- | Generates a data type declaration.
> +--
> +-- The type will have a fixed list of instances
> +strADTDecl :: String -> [String] -> Dec
> +strADTDecl name constructors =
> + DataD [] (mkName name) []
> + (map (flip NormalC [] . mkName) constructors)
> + [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
> +
I take that the first argument is not a Name for consistency with the
second argument?
> +-- | Generates a toString function.
> +--
> +-- This generates a simple function of the form:
> +--
> +-- @
> +-- nameToString :: Name -> String
> +-- nameToString Cons1 = var1
> +-- nameToString Cons2 = \"value2\"
> +-- @
> +genToString :: Name -> Name -> [(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
> + return [SigD fname sigt, FunD fname clauses]
> +
> +-- | Generates a fromString function.
> +--
> +-- The function generated is monadic and can fail parsing the
> +-- string. It is of the form:
> +--
> +-- @
> +-- nameFromString :: (Monad m) => String -> m Name
> +-- nameFromString s | s == var1 = Cons1
> +-- | s == \"value2\" = Cons2
> +-- | otherwise = fail /.../
> +-- @
> +genFromString :: Name -> Name -> [(String, Name)] -> Q [Dec]
> +genFromString fname tname constructors = do
> + -- signature of form (Monad m) => String -> m $name
> + sigt <- [t| (Monad m) => String -> m $(conT tname) |]
> + -- clauses for a guarded pattern
> + let varp = mkName "s"
> + varpe = varE varp
> + clauses <- mapM (\(c, v) -> do
> + -- the clause match condition
> + g <- normalG [| $varpe == $(varE v) |]
> + -- the clause result
> + r <- [| return $(conE (mkName c)) |]
> + return (g, r)) constructors
> + -- the otherwise clause (fallback)
> + oth_clause <- do
> + g <- normalG [| otherwise |]
> + r <- [|fail ("Invalid string value for type " ++
> + $(litE (stringL (nameBase tname))) ++ ": " ++ $varpe) |]
> + return (g, r)
> + let fun = FunD fname [Clause [VarP varp]
> + (GuardedB (clauses++[oth_clause])) []]
> + return [SigD fname sigt, fun]
> +
> +-- | Generates a data type from a given string format.
> +--
> +-- The format is expected to multiline. The first line contains the
> +-- type name, and the rest of the lines must contain two words: the
> +-- constructor name and then the string representation of the
> +-- respective constructor.
> +--
> +-- The function will generate the data type declaration, and then two
> +-- functions:
> +--
> +-- * /name/ToString, which converts the type to a string
> +--
> +-- * /name/FromString, which (monadically) converts from a string to the type
> +--
> +-- Note that this is basically just a custom show/read instance,
> +-- nothing else.
> +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
> + fromstr <- genFromString (fromStrName sname) name cons
> + return $ ddecl:tostr ++ fromstr
The second 'let' seems redundant, I think? (just let, not ddecl ;) )
> +
> +
> +-- | Creates the showJSON member of a JSON instance declaration.
> +--
> +-- This will create what is the equivalent of:
> +--
> +-- @
> +-- showJSON = showJSON . /name/ToString
> +-- @
> +--
> +-- in an instance JSON /name/ declaration
> +genShowJSON :: String -> Q [Dec]
> +genShowJSON name = [d| showJSON = JSON.showJSON . $(varE (toStrName name)) |]
> +
> +-- | Creates the readJSON member of a JSON instance declaration.
> +--
> +-- This will create what is the equivalent of:
> +--
> +-- @
> +-- readJSON s = case readJSON s of
> +-- Ok s' -> /name/FromString s'
> +-- Error e -> Error /description/
> +-- @
> +--
> +-- in an instance JSON /name/ declaration
> +genReadJSON :: String -> Q Dec
> +genReadJSON name = do
> + let s = mkName "s"
> + body <- [| case JSON.readJSON $(varE s) of
> + JSON.Ok s' -> $(varE (fromStrName name)) s'
> + JSON.Error e ->
> + JSON.Error $ "Can't parse string value for type " ++
> + $(litE (StringL name)) ++ ": " ++ e
> + |]
> + return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []]
> +
> +-- | Generates a JSON instance for a given type.
> +--
> +-- This assumes that the /name/ToString and /name/FromString functions
> +-- have been defined as by the 'declareSADT' function.
> +makeJSONInstance :: Name -> Q [Dec]
> +makeJSONInstance name = do
> + let base = nameBase name
> + showJ <- genShowJSON base
> + readJ <- genReadJSON base
> +
> + return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
Hmm no newline before return, I think
> --
> 1.7.3.1
>
>
Rest LGTM
