more kinds

[clean-tests.git] / gengen / Data / GenType / CParser.icl

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