From: Mart Lubbers <mart@martlubbers.net>
Date: Sun, 6 Sep 2020 09:34:30 +0000 (+0200)
Subject: more kinds
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=8f88b900008b3b54b7214bea9fff6ec97702224b;p=clean-tests.git

more kinds
---

diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index 553dac5..cb1296c 100644
--- 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
--- 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
--- 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]])