gengeng

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

diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index 951b3f4..a391391 100644 (file)
--- a/gengen/Data/GenType.icl
+++ b/gengen/Data/GenType.icl
@@ -3,7 +3,7 @@ implementation module Data.GenType
 import StdEnv, StdGeneric
 import Control.Applicative
 
-import Control.Monad => qualified join
+import Control.Monad
 import Control.Monad.State
 import Data.GenEq
 import Control.Monad.Writer
@@ -14,7 +14,7 @@ import Data.Functor.Identity
 import Data.Generics
 import Data.List
 import Data.Maybe
-import Text
+from Text import class Text(concat), instance Text String
 
 derive bimap Box
 derive gEq BasicType, UListType, ArrayType, GenType
@@ -44,6 +44,7 @@ gTypeEqShallow _ (GTyRecord j _) (GTyRef i) = i == j.grd_name
 gTypeEqShallow i (GTyArrow l1 r1) (GTyArrow l2 r2) = gTypeEqShallow (dec i) l1 l2 && gTypeEqShallow (dec i) r1 r2
 gTypeEqShallow i (GTyArray s1 a1) (GTyArray s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
 gTypeEqShallow i (GTyUList s1 a1) (GTyUList s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
+gTypeEqShallow i (GTyUMaybe a1) (GTyUMaybe a2) = gTypeEqShallow (dec i) a1 a2
 gTypeEqShallow _ GTyUnit GTyUnit = True
 gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
 gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
@@ -63,6 +64,7 @@ where
        (==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
        (==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
        (==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
+       (==) (TyUMaybe a1) (TyUMaybe a2) = a1 == a2
        (==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
                = i1.gtd_name == i2.gtd_name && a1 == a2
        (==) (TyObject i1 a1) (TyObject i2 a2)
@@ -104,6 +106,7 @@ where
        print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
        print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
        print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
+       print (GTyUMaybe a) c = ["?#":print a ["]":c]]
        print GTyUnit c = ["UNIT":c]
        print (GTyEither l r) c = ["(EITHER ":print l [" ":print r [")":c]]]
        print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
@@ -118,6 +121,7 @@ where
        print (TyArrow l r) c = print l [" -> ":print r c]
        print (TyArray s a) c = ["{":print s ["}":print a c]]
        print (TyUList s a) c = ["[#":print s ["]":print a c]]
+       print (TyUMaybe a) c = ["?#":print a c]
        print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
                [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
        where
@@ -170,6 +174,7 @@ gTypeToType (GTyRef a) = TyRef a
 gTypeToType (GTyArrow l r) = TyArrow (gTypeToType l) (gTypeToType r)
 gTypeToType (GTyArray s a) = TyArray s (gTypeToType a)
 gTypeToType (GTyUList s a) = TyUList s (gTypeToType a)
+gTypeToType (GTyUMaybe a) = TyUMaybe (gTypeToType a)
 gTypeToType (GTyRecord i t) = TyRecord i (gtrec t [])
 where
        gtrec :: GType [(GenericFieldDescriptor, Type)] -> [(GenericFieldDescriptor, Type)]
@@ -207,6 +212,7 @@ where
        refs (GTyArrow l r) c = refs l $ refs r c
        refs (GTyArray _ a) c = refs a c
        refs (GTyUList _ a) c = refs a c
+       refs (GTyUMaybe a) c = refs a c
        refs (GTyBasic _) c = c
        refs a=:(GTyRef _) c = [a:c]
 
@@ -242,6 +248,7 @@ where
        mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
        mkf (GTyArray s a) = GTyArray s <$> mkf a
        mkf (GTyUList s a) = GTyUList s <$> mkf a
+       mkf (GTyUMaybe a) = GTyUMaybe <$> mkf a
        mkf a=:(GTyBasic _) = addIfNotThere a
        mkf a=:(GTyRef _) = pure a
 
@@ -250,7 +257,8 @@ typeName (TyBasic a) = toString a
 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 (TyUList s a) = "[#" +++ toString s +++ 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
@@ -302,6 +310,7 @@ where
        replaceBuiltins (TyArrow l r) = TyArrow (replaceBuiltins l) (replaceBuiltins r)
        replaceBuiltins (TyArray s a) = TyArray s (replaceBuiltins a)
        replaceBuiltins (TyUList s a) = TyUList s (replaceBuiltins a)
+       replaceBuiltins (TyUMaybe a) = TyUMaybe (replaceBuiltins a)
        replaceBuiltins (TyNewType i j a) = TyNewType (replaceBuiltins i) (replaceBuiltins j) (replaceBuiltins a)
        replaceBuiltins (TyObject i cs) = TyObject (replaceBuiltins i) [(replaceBuiltins i, map replaceBuiltins fs)\\(i, fs)<-cs]
        replaceBuiltins (TyRecord j fs) = TyRecord (replaceBuiltins j) [(replaceBuiltins i, replaceBuiltins a)\\(i, a)<-fs]
@@ -313,6 +322,7 @@ where
        replaceBuiltins (GTyArrow l r) = GTyArrow (replaceBuiltins l) (replaceBuiltins r)
        replaceBuiltins (GTyArray s a) = GTyArray s (replaceBuiltins a)
        replaceBuiltins (GTyUList s a) = GTyUList s (replaceBuiltins a)
+       replaceBuiltins (GTyUMaybe a) = GTyUMaybe (replaceBuiltins a)
        replaceBuiltins (GTyObject i a) = GTyObject (replaceBuiltins i) (replaceBuiltins a)
        replaceBuiltins (GTyRecord i a) = GTyRecord (replaceBuiltins i) (replaceBuiltins a)
        replaceBuiltins (GTyCons i a) = GTyCons (replaceBuiltins i) (replaceBuiltins a)
@@ -353,7 +363,7 @@ gType{|Bool|} = box $ GTyBasic BTBool
 gType{|Real|} = box $ GTyBasic BTReal
 gType{|Char|} = box $ GTyBasic BTChar
 gType{|World|} = box $ GTyBasic BTWorld
-gType{|Dynamic|} = box $ GTyBasic BTDynamic
+//gType{|Dynamic|} = box $ GTyBasic BTDynamic
 gType{|File|} = box $ GTyBasic BTFile
 gType{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
 gType{|[#]|} a = box $ GTyUList ULLazy $ unBox a
@@ -362,6 +372,7 @@ gType{|{}|} a = box $ GTyArray ALazy $ unBox a
 gType{|{!}|} a = box $ GTyArray AStrict $ unBox a
 gType{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
 gType{|{32#}|} a = box $ GTyArray APacked $ unBox a
+gType{|(?#)|} a = box $ GTyUMaybe $ unBox a
 derive gType ?, ?^
 derive gType [], [! ], [ !], [!!]
 derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)