structure

[clean-tests.git] / gengen / src / GenType.icl

diff --git a/gengen/Data/GenType.icl b/gengen/src/GenType.icl
similarity index 95%
rename from gengen/Data/GenType.icl
rename to gengen/src/GenType.icl
index 4d2e311..cfd52e9 100644 (file)
--- a/gengen/Data/GenType.icl
+++ b/gengen/src/GenType.icl
@@ -1,4 +1,4 @@
-implementation module Data.GenType
+implementation module GenType
 
 import StdEnv, StdGeneric
 import Control.Applicative
@@ -258,7 +258,7 @@ typeName (TyRef a) = a
 typeName (TyArrow l r) = typeName l +++ "->" +++ typeName r
 typeName (TyArray s a) = "{" +++ toString s +++ typeName a +++ "}"
 typeName (TyUList s a) = "[#" +++ toString s +++ typeName a +++ "]"
-typeName (TyUMaybe a) = "?" +++ typeName a
+typeName (TyUMaybe a) = "?#" +++ typeName a
 typeName (TyNewType i _ _) = i.gtd_name
 typeName (TyObject i _) = i.gtd_name
 typeName (TyRecord i _) = i.grd_name
@@ -270,7 +270,7 @@ 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 (TyNewType _ i a) = [i.gcd_type]
 typeGenType (TyRecord i _) = [i.grd_type]
 typeGenType (TyObject _ fs) = [c.gcd_type\\(c, _)<-fs]
 
@@ -278,18 +278,32 @@ 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 (GenTypeCons _) _ ks = ks
+       gt (GenTypeVar i) c ks
+               # k = c KStar
+               = case lookup i ks of
+                       Nothing = [(i, k):ks]
+                       Just k`
+                               | numArr k` > numArr k = ks
+                               = [(i, k):filter ((<>)i o fst) ks]
+       gt (GenTypeArrow l r) _ 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
+
+numArr :: Kind -> Int
+numArr KStar = 0
+numArr (l KArrow r) = inc (numArr l + numArr r)
+
+instance == Kind
 where
-       print KStar c = ["*":c]
-       print (l KArrow r) c = ["(":print l ["->":print r [")":c]]]
+       (==) KStar KStar = True
+       (==) (l1 KArrow r1) (l2 KArrow r2) = l1 == l2 && r1 == r2
+       (==) _ _ = False
+instance toString Kind where toString k = concat $ pr k False []
+
+
+pr :: Kind Bool [String] -> [String]
+pr KStar _ c = ["*":c]
+pr (l KArrow r) b c = [if b "(" "":pr l True ["->":pr r False [if b ")" "":c]]]
 
 instance isBuiltin String
 where