From: Mart Lubbers <mart@martlubbers.net>
Date: Mon, 7 Sep 2020 04:31:54 +0000 (+0200)
Subject: kinds
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=0e8437e6a914d01fba3c42418f30b51c82d88044;p=clean-tests.git

kinds
---

diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl
index dfcfe96..c01eca9 100644
--- a/gengen/Data/GenType.dcl
+++ b/gengen/Data/GenType.dcl
@@ -71,10 +71,11 @@ typeName :: Type -> String
 typeGenType :: Type -> [GenType]
 
 /**
- * Return the kind of the type
+ * Return an approximation of the kind of the type given all the constructors
  */
 :: Kind = KStar | (KArrow) infixr 1 Kind Kind
-genTypeKind :: GenType -> Kind
+genTypeKind :: [GenType] -> Kind
+instance toString Kind
 
 /**
  * Predicate whether the outer type is a builtin type
diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index f218c93..4d2e311 100644
--- a/gengen/Data/GenType.icl
+++ b/gengen/Data/GenType.icl
@@ -274,11 +274,22 @@ typeGenType (TyNewType _ _ a) = abort "typeGenType for newtypes not yet implemen
 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) = genTypeKind l KArrow genTypeKind r
-genTypeKind (GenTypeApp l r) = genTypeKind l KArrow genTypeKind r
+genTypeKind :: [GenType] -> Kind
+genTypeKind ts = foldr (KArrow) KStar $ map snd $ sortBy ((<) `on` fst) $ foldr (\t->gt t id) [] ts
+where
+	gt :: GenType (Kind -> Kind) [(Int, Kind)] -> [(Int, Kind)]
+	gt (GenTypeCons _) c ks = ks
+	gt (GenTypeVar i) c ks = case lookup i ks of
+		Nothing = [(i, c KStar):ks]
+		Just KStar = [(i, c KStar):filter ((<>)i o fst) ks]
+		Just _ = ks
+	gt (GenTypeArrow l r) c ks = gt l id $ gt r id ks
+	gt (GenTypeApp l r) c ks = gt l ((KArrow) KStar o c) $ gt r id ks
+instance toString Kind where toString k = concat $ print k []
+instance print Kind
+where
+	print KStar c = ["*":c]
+	print (l KArrow r) c = ["(":print l ["->":print r [")":c]]]
 
 instance isBuiltin String
 where
diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl
index 1776e28..130ee3d 100644
--- a/gengen/Data/GenType/CParser.icl
+++ b/gengen/Data/GenType/CParser.icl
@@ -114,7 +114,7 @@ where
 
 	parsedef :: Type [String] -> [String]
 	parsedef t c
-		# (pt, _) = trace_stdout (parsefun t, map genTypeKind $ typeGenType t)
+		# (pt, _) = trace_stdout (parsefun t, toString $ genTypeKind $ typeGenType t)
 		= ctypename t [" *", /*parsefun */pt, "(uint8_t (*get)()",pd t, ")":c]
 	where
 		pd (TyBasic s) = ""
diff --git a/gengen/test.icl b/gengen/test.icl
index c5f2f42..8d41f40 100644
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -17,7 +17,9 @@ 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, MR
+derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest, MR, P
+
+:: P m = P (Tr m Int) | P2 (m Bool Bool)
 
 :: T a = T2 a Char
 :: NT =: NT Int
@@ -113,6 +115,7 @@ Start w = foldr ($) w
 	, genFiles "lmint" lmInt
 	, genFiles "trEitherInt" trEitherInt
 	, genFiles "mrMaybe" mrMaybe
+	, genFiles "pEither" pEither
 	]
 //	( flatTypedef $ gTypeToType $ unBox t
 //	, typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
@@ -143,6 +146,9 @@ where
 	mrMaybe :: Box GType (MR ?)
 	mrMaybe = gType{|*|}
 
+	pEither :: Box GType (P Either)
+	pEither = gType{|*|}
+
 //Start = typedefs //$ (\x->[[gTypeToType x]])
 //	$ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
 //	$ (\x->[[x]])