From: Mart Lubbers <mart@martlubbers.net>
Date: Sun, 6 Sep 2020 14:14:45 +0000 (+0200)
Subject: .
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=c2914dc5aee23c84e5987915cfead21787256860;p=clean-tests.git

.
---

diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl
index 7f751da..c77320e 100644
--- a/gengen/Data/GenType.dcl
+++ b/gengen/Data/GenType.dcl
@@ -68,7 +68,13 @@ typeName :: Type -> String
 /**
  * Gives the genType for a type
  */
-typeGenType :: Type -> GenType
+typeGenType :: Type -> [GenType]
+
+/**
+ * Return the kind of the type
+ */
+:: Kind = KStar | KArrow Kind Kind
+genTypeKind :: Type -> Kind
 
 /**
  * Predicate whether the outer type is a builtin type
diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index cb1296c..37f6df5 100644
--- a/gengen/Data/GenType.icl
+++ b/gengen/Data/GenType.icl
@@ -263,19 +263,22 @@ typeName (TyNewType i _ _) = i.gtd_name
 typeName (TyObject i _) = i.gtd_name
 typeName (TyRecord i _) = i.grd_name
 
-typeGenType :: Type -> GenType
-typeGenType (TyBasic a) = GenTypeCons $ toString a
-typeGenType (TyRef a) = GenTypeCons $ toString a
-typeGenType (TyArrow l r) = GenTypeArrow (typeGenType l) (typeGenType r)
-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 :: Type -> [GenType]
+typeGenType (TyBasic a) = [GenTypeCons $ toString a]
+typeGenType (TyRef a) = [GenTypeCons $ toString a]
+typeGenType (TyArrow l r) = GenTypeArrow <$> typeGenType l <*> typeGenType r
+typeGenType (TyArray s a) = GenTypeApp (GenTypeCons (toString s)) <$> typeGenType a
+typeGenType (TyUList s a) = [GenTypeCons "_#Nil":GenTypeApp (GenTypeCons (toString s)) <$> typeGenType a]
+typeGenType (TyUMaybe a) = [GenTypeCons "_#Nothing":GenTypeApp (GenTypeCons "_#Just") <$> 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]
+typeGenType (TyObject _ fs) = [c.gcd_type\\(c, _)<-fs]
+
+genTypeKind :: GenType -> Kind
+genTypeKind (GenTypeCons _) = KStar
+genTypeKind (GenTypeVar _) = KStar
+genTypeKind (GenTypeArrow l r) = undef
+genTypeKind (GenTypeApp l r) = undef
 
 instance isBuiltin String
 where
diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl
index b9b7bc4..7f1556d 100644
--- a/gengen/Data/GenType/CParser.icl
+++ b/gengen/Data/GenType/CParser.icl
@@ -105,6 +105,7 @@ where
  */
 :: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
 :: TPState :== 'Data.Map'.Map String (String, Bool)
+import Debug.Trace
 parsers :: [[Type]] -> Either String ([String], [String])
 parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
 where
@@ -118,7 +119,7 @@ where
 		pd (TyUList _ _) = ", void *parse_0(uint8_t (*get)())"
 		pd (TyUMaybe _) = ", void *parse_0(uint8_t (*get)())"
 		pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..gtd.gtd_arity-1]]
-		pd (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity grd.grd_type-1]]
+		pd (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity (trace_stdout grd.grd_type)-1]]
 //		pd (TyNewType _ _ _) = abort "not implemented yet\n"
 		pd t = abort $ "not implemented yet: " +++ toString t +++ "\n"
 
@@ -126,8 +127,8 @@ where
 	recordArity (GenTypeCons _) = 0
 	recordArity (GenTypeVar _) = 0
 	recordArity (GenTypeApp _ _) = 0
-	recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 0
-	recordArity (GenTypeArrow l r) = inc $ recordArity r
+	recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 1
+	recordArity (GenTypeArrow l r) = inc $ recordArity l
 
 	parsergroup :: [Type] -> TPMonad
 	parsergroup ts
diff --git a/gengen/test.icl b/gengen/test.icl
index f7f2e17..c5f2f42 100644
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -17,7 +17,7 @@ import Data.GenType.CType
 import Data.GenType.CParser
 import Text
 
-derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest
+derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest, MR
 
 :: T a = T2 a Char
 :: NT =: NT Int
@@ -38,6 +38,7 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp,
 
 :: ER = {nat :: Int, bool :: Bool}
 :: RA a = {a1 :: a, a2 :: Int}
+:: MR m = {b1 :: m Int}
 
 :: CP = CLeft Int Bool | CRight Char Char
 
@@ -111,6 +112,7 @@ Start w = foldr ($) w
 	, genFiles "raint" raInt
 	, genFiles "lmint" lmInt
 	, genFiles "trEitherInt" trEitherInt
+	, genFiles "mrMaybe" mrMaybe
 	]
 //	( flatTypedef $ gTypeToType $ unBox t
 //	, typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
@@ -138,6 +140,9 @@ where
 	trEitherInt :: Box GType (Tr Either Int)
 	trEitherInt = gType{|*|}
 
+	mrMaybe :: Box GType (MR ?)
+	mrMaybe = gType{|*|}
+
 //Start = typedefs //$ (\x->[[gTypeToType x]])
 //	$ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
 //	$ (\x->[[x]])