From: Mart Lubbers 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]])