kinds

diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl
index dfcfe96..c01eca9 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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]])