On Thu, Sep 29, 2011 at 11:49:34AM +0200, Agata Murawska wrote:
> 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?
Actually, that was not intended; probably a left over from a previous
version of the patch. Since the caller already has it transformed to a
Name, I'll pass the name in, thanks.
> > +-- | 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 ;) )
Indeed. I usually use such redundant lets during development because
then you can move each individual line around.
> > +
> > +
> > +-- | 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
Ack.
Interdiff (also fixes one missing dot in docstring):
diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs
index fe5e4ae..6e539a4 100644
--- a/htools/Ganeti/THH.hs
+++ b/htools/Ganeti/THH.hs
@@ -56,10 +56,10 @@ fromStrName = mkName . (++ "FromString") . ensureLower
-- | Generates a data type declaration.
--
--- The type will have a fixed list of instances
-strADTDecl :: String -> [String] -> Dec
+-- The type will have a fixed list of instances.
+strADTDecl :: Name -> [String] -> Dec
strADTDecl name constructors =
- DataD [] (mkName name) []
+ DataD [] name []
(map (flip NormalC [] . mkName) constructors)
[''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord]
@@ -134,7 +134,7 @@ genFromString fname tname constructors = do
declareSADT :: String -> [(String, Name)] -> Q [Dec]
declareSADT sname cons = do
let name = mkName sname
- let ddecl = strADTDecl sname (map fst cons)
+ ddecl = strADTDecl name (map fst cons)
tostr <- genToString (toStrName sname) name cons
fromstr <- genFromString (fromStrName sname) name cons
return $ ddecl:tostr ++ fromstr
@@ -183,5 +183,4 @@ makeJSONInstance name = do
let base = nameBase name
showJ <- genShowJSON base
readJ <- genReadJSON base
-
return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)]
--
iustin
