+++ /dev/null
-implementation module Data.GenType
-
-import StdEnv, StdGeneric
-import Control.Applicative
-
-import Control.Monad
-import Control.Monad.State
-import Data.GenEq
-import Control.Monad.Writer
-import Control.Monad.Trans
-import Data.Func
-import Data.Functor
-import Data.Functor.Identity
-import Data.Generics
-import Data.List
-import Data.Maybe
-from Text import class Text(concat), instance Text String
-
-derive bimap Box
-derive gEq BasicType, UListType, ArrayType, GenType
-instance == BasicType where (==) a b = a === b
-instance == UListType where (==) a b = a === b
-instance == ArrayType where (==) a b = a === b
-instance == GenType where (==) a b = a === b
-instance == GType where (==) x y = gTypeEqShallow (2<<30-1) x y
-
-/**
- * Compares two GTypes only up to a given depth
- *
- * @param depth
- * @param lhs
- * @param rhs
- * @return equality
- */
-gTypeEqShallow :: Int GType GType -> Bool
-gTypeEqShallow i _ _
- | i < 0 = True
-gTypeEqShallow _ (GTyBasic i) (GTyBasic j) = i == j
-gTypeEqShallow _ (GTyRef i) (GTyRef j) = i == j
-gTypeEqShallow _ (GTyRef i) (GTyObject j _) = i == j.gtd_name
-gTypeEqShallow _ (GTyRef i) (GTyRecord j _) = i == j.grd_name
-gTypeEqShallow _ (GTyObject j _) (GTyRef i) = i == j.gtd_name
-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
-gTypeEqShallow i (GTyCons i1 a1) (GTyCons i2 a2) = i1.gcd_name == i2.gcd_name && gTypeEqShallow i a1 a2
-gTypeEqShallow i (GTyField i1 a1) (GTyField i2 a2)
- = i1.gfd_name == i2.gfd_name && i1.gfd_cons.grd_name == i2.gfd_cons.grd_name && gTypeEqShallow i a1 a2
-gTypeEqShallow i (GTyObject i1 a1) (GTyObject i2 a2)
- = i1.gtd_name == i2.gtd_name && gTypeEqShallow (dec i) a1 a2
-gTypeEqShallow i (GTyRecord i1 a1) (GTyRecord i2 a2)
- = i1.grd_name == i2.grd_name && gTypeEqShallow (dec i) a1 a2
-gTypeEqShallow _ _ _ = False
-
-instance == Type
-where
- (==) (TyBasic a1) (TyBasic a2) = a1 == a2
- (==) (TyRef a1) (TyRef a2) = a1 == a2
- (==) (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)
- = i1.gtd_name == i2.gtd_name && length a1 == length a2
- && and [l1.gcd_name == l2.gcd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
- (==) (TyRecord i1 a1) (TyRecord i2 a2)
- = i1.grd_name == i2.grd_name && length a1 == length a2
- && and [l1.gfd_name == l2.gfd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
- (==) _ _ = False
-
-class print a :: a [String] -> [String]
-instance print Bool where print s c = [toString s:c]
-instance print Int where print s c = [toString s:c]
-instance print Char where print s c = [toString s:c]
-instance print String where print s c = [s:c]
-instance print BasicType
-where
- print BTInt c = ["Int":c]
- print BTChar c = ["Char":c]
- print BTReal c = ["Real":c]
- print BTBool c = ["Bool":c]
- print BTDynamic c = ["Dynamic":c]
- print BTFile c = ["File":c]
- print BTWorld c = ["World":c]
-instance print UListType
-where
- print ULStrict c = ["!":c]
- print ULLazy c = c
-instance print ArrayType
-where
- print AStrict c = ["!":c]
- print AUnboxed c = ["#":c]
- print APacked c = ["32#":c]
- print ALazy c = c
-instance print GType
-where
- print (GTyBasic s) c = print s c
- print (GTyRef s) c = [s:c]
- 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]]
- print (GTyCons i a) c = ["(CONS ", i.gcd_name, " ":print a [")":c]]
- print (GTyField i a) c = ["(FIELD ", i.gfd_name, " ":print a [")":c]]
- print (GTyObject i a) c = ["(OBJECT ", i.gtd_name, " ":print a [")":c]]
- print (GTyRecord i a) c = ["(RECORD ", i.grd_name, " ":print a [")":c]]
-instance print Type
-where
- print (TyBasic s) c = print s c
- print (TyRef s) c = [s:c]
- 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
- nttype (GenTypeArrow l r) = l
- print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
- [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
- print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
- $ [" ":isperse " | " (map pCons conses) c]
- where
- pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
- pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
- where
- n c = case i.gcd_prio of
- GenConsNoPrio = [i.gcd_name:c]
- GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
- GenConsAssocRight = "r";
- GenConsAssocLeft = "l"
- _ = "", " ":print s c]
-
-pTyVars :: String Int [String] -> [String]
-pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
-
-pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
-pField pre [] _ = []
-pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
-
-instance print GenType
-where
- print (GenTypeVar i) c = print (['a'..] !! i) c
- print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
- where
- collectApps (GenTypeApp l r) c = collectApps l [print r:c]
- collectApps a c = [print a:c]
- print (GenTypeCons s) c = [s:c]
- print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
-
-instance toString GType where toString a = concat $ print a []
-instance toString Type where toString a = concat $ print a []
-instance toString BasicType where toString a = concat $ print a []
-instance toString ArrayType where toString a = concat $ print a []
-instance toString UListType where toString a = concat $ print a []
-instance toString GenType where toString a = concat $ print a []
-
-isperse :: a [[a] -> [a]] [a] -> [a]
-isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
-
-gTypeToType :: GType -> Type
-gTypeToType (GTyBasic a) = TyBasic a
-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)]
- gtrec (GTyField i t) c = [(i, gTypeToType t):c]
- gtrec (GTyPair l r) c = gtrec l $ gtrec r c
- gtrec _ c = c
-gTypeToType (GTyObject i=:{gtd_num_conses=0} t)
- = TyNewType i (hd i.gtd_conses) (gTypeToType t)
-gTypeToType (GTyObject i t) = TyObject i (gtobj t [])
-where
- gtobj :: GType [(GenericConsDescriptor, [Type])] -> [(GenericConsDescriptor, [Type])]
- gtobj (GTyEither l r) c = gtobj l $ gtobj r c
- gtobj (GTyCons i a) c = [(i, gtcons a []):c]
- gtobj _ c = c
-
- gtcons :: GType [Type] -> [Type]
- gtcons GTyUnit c = c
- gtcons (GTyPair l r) c = gtcons l $ gtcons r c
- gtcons t c = [gTypeToType t:c]
-
-:: FlatMonad :== State FMState GType
-:: FMState = { objects :: [String], types :: [GType], otypes :: [GType], depth :: Int }
-flattenGType :: GType -> [[GType]]
-flattenGType ot
- # {types} = execState (mkf ot) {objects=[], otypes=[], types=[], depth=10}
- = scc [(t, refs t [])\\t<-types]
-where
- refs (GTyObject _ a) c = refs a c
- refs (GTyRecord _ a) c = refs a c
- refs (GTyEither l r) c = refs l $ refs r c
- refs (GTyPair l r) c = refs l $ refs r c
- refs (GTyCons _ a) c = refs a c
- refs (GTyField _ a) c = refs a c
- refs GTyUnit c = c
- 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]
-
- write :: (a GType -> GType) a GType -> FlatMonad | genericDescriptorName a
- write cons t a = getState >>= \s
- //We have seen the type but it might've had different arguments
- | isMember name s.objects
- //We have not seen this configuration
- | isEmpty [ot \\ ot<-s.otypes | gTypeEqShallow s.depth ot a]
- = modify (\x->{x & depth=dec x.depth}) *> mkf a *> pure (GTyRef name)
- //If not, just return the basictype
- = pure $ GTyRef name
- //We have not seen the type so we add, calculate and output it
- = cons t <$ modify (\x->{x & otypes=[a:x.otypes], objects=[name:x.objects]}) <*> mkf a
- >>= \ty->addIfNotThere ty >>| pure (GTyRef name)
- where
- name = genericDescriptorName t
-
- addIfNotThere :: GType -> FlatMonad
- addIfNotThere ty = getState >>= \s
- | isMember ty s.types
- = pure ty
- = modify (\s->{s & types=[ty:s.types]}) >>| pure ty
-
- mkf :: GType -> FlatMonad
- mkf (GTyObject t a) = write GTyObject t a
- mkf (GTyRecord t a) = write GTyRecord t a
- mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
- mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
- mkf (GTyCons i a) = GTyCons i <$> mkf a
- mkf (GTyField i a) = GTyField i <$> mkf a
- mkf GTyUnit = pure GTyUnit
- 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
-
-typeName :: Type -> String
-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 (TyUMaybe a) = "?" +++ typeName a
-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) = [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 _ 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
-
-instance isBuiltin String
-where
- isBuiltin s = [()\\(l, r)<-predef | l == s || r == s] =: [_:_]
-instance isBuiltin Type
-where
- isBuiltin (TyObject i a) = isBuiltin i.gtd_name
- isBuiltin (TyRecord i a) = isBuiltin i.grd_name
- isBuiltin (TyRef a) = isBuiltin a
- isBuiltin _ = True
-instance isBuiltin GType
-where
- isBuiltin (GTyObject i a) = isBuiltin i.gtd_name
- isBuiltin (GTyRecord i a) = isBuiltin i.grd_name
- isBuiltin (GTyRef a) = isBuiltin a
- isBuiltin _ = True
-
-instance isBasic Type
-where
- isBasic (TyBasic t) = True
- isBasic _ = False
-
-instance isBasic GType
-where
- isBasic (GTyBasic t) = True
- isBasic _ = False
-
-instance replaceBuiltins GenericFieldDescriptor
-where
- replaceBuiltins s = {s & gfd_name=replaceBuiltins s.gfd_name}
-instance replaceBuiltins GenericConsDescriptor
-where
- replaceBuiltins s = {s & gcd_name=replaceBuiltins s.gcd_name, gcd_type=replaceBuiltins s.gcd_type}
-instance replaceBuiltins GenericTypeDefDescriptor
-where
- replaceBuiltins s = {s & gtd_name=replaceBuiltins s.gtd_name}
-instance replaceBuiltins GenericRecordDescriptor
-where
- replaceBuiltins s = {s & grd_name=replaceBuiltins s.grd_name, grd_type=replaceBuiltins s.grd_type}
-instance replaceBuiltins String
-where
- replaceBuiltins a = fromMaybe a $ lookup a predef
-instance replaceBuiltins Type
-where
- replaceBuiltins (TyRef a) = TyRef (replaceBuiltins a)
- 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]
- replaceBuiltins t = t
-instance replaceBuiltins GType
-where
- replaceBuiltins (GTyEither l r) = GTyEither (replaceBuiltins l) (replaceBuiltins r)
- replaceBuiltins (GTyPair l r) = GTyPair (replaceBuiltins l) (replaceBuiltins r)
- 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)
- replaceBuiltins (GTyField i a) = GTyField (replaceBuiltins i) (replaceBuiltins a)
- replaceBuiltins (GTyRef a) = GTyRef (replaceBuiltins a)
- replaceBuiltins a = a
-instance replaceBuiltins GenType
-where
- replaceBuiltins (GenTypeCons a) = GenTypeCons (replaceBuiltins a)
- replaceBuiltins (GenTypeApp l r) = GenTypeApp (replaceBuiltins l) (replaceBuiltins r)
- replaceBuiltins (GenTypeArrow l r) = GenTypeArrow (replaceBuiltins l) (replaceBuiltins r)
- replaceBuiltins a = a
-
-predef :: [(String, String)]
-predef =:
- [ ("_List", "[]"), ("_Cons", "(:)"), ("_Nil", "[]")
- , ("_!List", "[! ]"), ("_!Cons", "(:)"), ("_!Nil", "[! ]")
- , ("_List!", "[ !]"), ("_Cons!", "(:)"), ("_Nil!", "[ !]")
- , ("_!List!", "[!!]"), ("_!Cons!", "(:)"), ("_!Nil!", "[ !]")
- , ("_#List", "[#]"), ("_#Cons", "(:)"), ("_#Nil", "[#]")
- , ("_#List!", "[#!]"), ("_#Cons!", "(:)"), ("_#Nil!", "[#!]")
- , ("_!Maybe", "?"), ("_!Just", "?Just"), ("_!Nothing", "?None")
- , ("_Maybe", "?^"), ("_Just", "?^Just"), ("_Nothing", "?^None")
- , ("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}"), ("_32#Array", "{32#}")
- , ("_Unit", "()")
- :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
-
-generic type a :: Box GType a
-gType{|UNIT|} = box GTyUnit
-gType{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
-gType{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
-gType{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
-gType{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
-gType{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
-gType{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
-gType{|Int|} = box $ GTyBasic BTInt
-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{|File|} = box $ GTyBasic BTFile
-gType{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
-gType{|[#]|} a = box $ GTyUList ULLazy $ unBox a
-gType{|[#!]|} a = box $ GTyUList ULStrict $ unBox a
-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 (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
repositories / clean-tests.git / blobdiff