more kinds

diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index 553dac5..cb1296c 100644 (file)
--- a/gengen/Data/GenType.icl
+++ b/gengen/Data/GenType.icl
@@ -271,13 +271,12 @@ typeGenType (TyArray s a) = GenTypeApp (GenTypeCons (toString s)) (typeGenType a
 typeGenType (TyUList s a) = GenTypeApp (GenTypeCons (toString s)) (typeGenType a)
 typeGenType (TyUMaybe a) = GenTypeApp (GenTypeCons "_#Maybe") (typeGenType a)
 typeGenType (TyNewType _ _ a) = abort "typeGenType for newtypes not yet implemented\n"
+typeGenType (TyRecord i _) = i.grd_type
 typeGenType (TyObject i _) = gent i.gtd_arity (GenTypeCons i.gtd_name)
 where
        gent 0 t = t
        gent n t = gent (dec n) (GenTypeApp t (GenTypeVar n))
 
-typeGenType (TyRecord i _) = i.grd_type
-
 instance isBuiltin String
 where
        isBuiltin s = [()\\(l, r)<-predef | l == s || r == s] =: [_:_]

diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl
index c0ce75d..b9b7bc4 100644 (file)
--- a/gengen/Data/GenType/CParser.icl
+++ b/gengen/Data/GenType/CParser.icl
@@ -167,7 +167,7 @@ where
                | and [t =: [] \\ (_, t)<-fs]
                        = tell ["\t*r = (", consName ti, ") get();\n"]
        //Single constructor, single field (box)
-       parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
+       parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = ":fmtField ci.gcd_type [");\n"]]
        //Single constructor
        parser t=:(TyObject ti [(ci, ts)])
                = fmtFields 1 ci.gcd_type ["r" <-> "f" +++ toString i\\i<-indexList ts]
@@ -189,15 +189,12 @@ where
        fmtFields :: Int GenType [String] -> TPMonad
        fmtFields i _ [] = pure ()
        fmtFields i (GenTypeArrow l r) [x:xs]
-               = tell [createArray i '\t', x, " = "] >>| fmtField l >>| tell [");\n"] >>| fmtFields i r xs
-
-       fmtField :: GenType -> TPMonad
-       fmtField (GenTypeCons a) = tell ["parse_", safe a, "(get"]
-       fmtField (GenTypeVar a) = tell ["parse_", toString a, "(get"]
-       fmtField t=:(GenTypeApp _ _)
-               = let [x:xs] = ufold t in fmtField x >>| case ufold t of
-                       [] = tell [")"]
-                       xs = tell [", "] >>| sequence_ (intersperse (tell [", "]) (map (\s->fmtField s >>| tell [")"]) xs))
+               = tell [createArray i '\t', x, " = "] >>| tell (fmtField l []) >>| tell [");\n"] >>| fmtFields i r xs
+
+       fmtField :: GenType [String] -> [String]
+       fmtField (GenTypeCons a) c = ["parse_", safe a, "(get":c]
+       fmtField (GenTypeVar a) c = ["parse_", toString a, "(get":c]
+       fmtField t=:(GenTypeApp _ _) c = ufold t c
        where
-               ufold (GenTypeApp l r) = [l:ufold r]
-               ufold t = [t]
+               ufold (GenTypeApp l r) c = ufold l [", ":fmtField r [")":c]]
+               ufold t c = fmtField t c

diff --git a/gengen/test.icl b/gengen/test.icl
index 66ef797..f7f2e17 100644 (file)
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -110,6 +110,7 @@ Start w = foldr ($) w
        , genFiles "cp" cp
        , genFiles "raint" raInt
        , genFiles "lmint" lmInt
+       , genFiles "trEitherInt" trEitherInt
        ]
 //     ( flatTypedef $ gTypeToType $ unBox t
 //     , typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
@@ -134,6 +135,9 @@ where
        lmInt :: Box GType [?Int]
        lmInt = gType{|*|}
 
+       trEitherInt :: Box GType (Tr Either Int)
+       trEitherInt = gType{|*|}
+
 //Start = typedefs //$ (\x->[[gTypeToType x]])
 //     $ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
 //     $ (\x->[[x]])