On Wed, Sep 18, 2013 at 12:42:39PM +0200, Klaus Aehlig wrote:
> On Wed, Sep 18, 2013 at 11:16:15AM +0200, Jose A. Lopes wrote:
> > Add 'declareLADT' in Template Haskell module to declare Haskell
> > datatypes using 'String's directly as values for the JSON
> > serialization, as opposed to 'Name's which is what the current
> > 'declareADT' allows. To achieve this, 'genFromRaw' must be
> > generalized, similarly to 'genToRaw'.
> >
> > Signed-off-by: Jose A. Lopes <[email protected]>
> > ---
> > src/Ganeti/THH.hs | 21 ++++++++++++++++++---
> > 1 file changed, 18 insertions(+), 3 deletions(-)
> >
> > diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
> > index edc148e..0052b1f 100644
> > --- a/src/Ganeti/THH.hs
> > +++ b/src/Ganeti/THH.hs
> > @@ -30,6 +30,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor,
> > Boston, MA
> > -}
> >
> > module Ganeti.THH ( declareSADT
> > + , declareLADT
> > , declareIADT
> > , makeJSONInstance
> > , deCamelCase
> > @@ -360,7 +361,7 @@ genToRaw traw fname tname constructors = do
> > -- | s == \"value2\" = Cons2
> > -- | otherwise = fail /.../
> > -- @
> > -genFromRaw :: Name -> Name -> Name -> [(String, Name)] -> Q [Dec]
> > +genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q
> > [Dec]
> > genFromRaw traw fname tname constructors = do
> > -- signature of form (Monad m) => String -> m $name
> > sigt <- [t| (Monad m) => $(conT traw) -> m $(conT tname) |]
> > @@ -369,7 +370,7 @@ genFromRaw traw fname tname constructors = do
> > varpe = varE varp
> > clauses <- mapM (\(c, v) -> do
> > -- the clause match condition
> > - g <- normalG [| $varpe == $(varE v) |]
> > + g <- normalG [| $varpe == $(reprE v) |]
> > -- the clause result
> > r <- [| return $(conE (mkName c)) |]
> > return (g, r)) constructors
> > @@ -406,7 +407,21 @@ declareADT traw sname cons = do
> > -- process cons in the format expected by genToRaw
> > cons' = map (\(a, b) -> (a, Right b)) cons
> > toraw <- genToRaw traw (toRawName sname) name cons'
> > - fromraw <- genFromRaw traw (fromRawName sname) name cons
> > + fromraw <- genFromRaw traw (fromRawName sname) name cons'
> > + return $ ddecl:toraw ++ fromraw
> > +
> > +-- | Generates a data type from a given raw format
> > +--
> > +-- This is similar to 'declareSADT' but uses 'String' as values to the
> > +-- constructors as opposed to names
> > +declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
> > +declareLADT traw sname cons = do
> > + let name = mkName sname
> > + ddecl = strADTDecl name (map fst cons)
> > + -- process cons in the format expected by genToRaw
> > + cons' = map (\(a, b) -> (a, Left b)) cons
> > + toraw <- genToRaw traw (toRawName sname) name cons'
> > + fromraw <- genFromRaw traw (fromRawName sname) name cons'
> > return $ ddecl:toraw ++ fromraw
>
> NACK.
>
> Here you're doublicating the code of declareADT, instead of factoring
> out a common functional. Why not change the currect declareADT to
>
> declareSomeADT :: (a -> Either String Name) -> Name -> String -> [(String,
> a)] -> Q [Dec]
>
> and have
>
> declareADT = declareSomeADT Left
> declareLADT = declareSomeADT Right
>
> ? (The declareSomeADT would stay internally and not be exported.)
Interdiff
diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
index 0052b1f..7865e6f 100644
--- a/src/Ganeti/THH.hs
+++ b/src/Ganeti/THH.hs
@@ -400,35 +400,25 @@ genFromRaw traw fname tname constructors = do
--
-- Note that this is basically just a custom show\/read instance,
-- nothing else.
-declareADT :: Name -> String -> [(String, Name)] -> Q [Dec]
-declareADT traw sname cons = do
+declareADT
+ :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
+declareADT fn traw sname cons = do
let name = mkName sname
ddecl = strADTDecl name (map fst cons)
-- process cons in the format expected by genToRaw
- cons' = map (\(a, b) -> (a, Right b)) cons
+ cons' = map (\(a, b) -> (a, fn b)) cons
toraw <- genToRaw traw (toRawName sname) name cons'
fromraw <- genFromRaw traw (fromRawName sname) name cons'
return $ ddecl:toraw ++ fromraw
--- | Generates a data type from a given raw format
---
--- This is similar to 'declareSADT' but uses 'String' as values to the
--- constructors as opposed to names
declareLADT :: Name -> String -> [(String, String)] -> Q [Dec]
-declareLADT traw sname cons = do
- let name = mkName sname
- ddecl = strADTDecl name (map fst cons)
- -- process cons in the format expected by genToRaw
- cons' = map (\(a, b) -> (a, Left b)) cons
- toraw <- genToRaw traw (toRawName sname) name cons'
- fromraw <- genFromRaw traw (fromRawName sname) name cons'
- return $ ddecl:toraw ++ fromraw
+declareLADT = declareADT Left
declareIADT :: String -> [(String, Name)] -> Q [Dec]
-declareIADT = declareADT ''Int
+declareIADT = declareADT Right ''Int
declareSADT :: String -> [(String, Name)] -> Q [Dec]
-declareSADT = declareADT ''String
+declareSADT = declareADT Right ''String
-- | Creates the showJSON member of a JSON instance declaration.
--
Thanks,
Jose
