gengen/Data/GenType.icl

   1 implementation module Data.GenType
   2
   3 import StdEnv, StdGeneric
   4 import Control.Applicative
   5
   6 import Control.Monad => qualified join
   7 import Control.Monad.State
   8 import Data.GenEq
   9 import Control.Monad.Writer
  10 import Control.Monad.Trans
  11 import Data.Func
  12 import Data.Functor
  13 import Data.Functor.Identity
  14 import Data.Generics
  15 import Data.List
  16 import Data.Maybe
  17 import Text
  18
  19 derive bimap Box
  20 derive gEq BasicType, UListType, ArrayType, GenType
  21 instance == BasicType where (==) a b = a === b
  22 instance == UListType where (==) a b = a === b
  23 instance == ArrayType where (==) a b = a === b
  24 instance == GenType where (==) a b = a === b
  25 instance == GType where (==) x y = gTypeEqShallow (2<<30-1) x y
  26
  27 /**
  28  * Compares two GTypes only up to a given depth
  29  *
  30  * @param depth
  31  * @param lhs
  32  * @param rhs
  33  * @return equality
  34  */
  35 gTypeEqShallow :: Int GType GType -> Bool
  36 gTypeEqShallow i _ _
  37         | i < 0 = True
  38 gTypeEqShallow _ (GTyBasic i) (GTyBasic j) = i == j
  39 gTypeEqShallow _ (GTyRef i) (GTyRef j) = i == j
  40 gTypeEqShallow _ (GTyRef i) (GTyObject j _) = i == j.gtd_name
  41 gTypeEqShallow _ (GTyRef i) (GTyRecord j _) = i == j.grd_name
  42 gTypeEqShallow _ (GTyObject j _) (GTyRef i) = i == j.gtd_name
  43 gTypeEqShallow _ (GTyRecord j _) (GTyRef i) = i == j.grd_name
  44 gTypeEqShallow i (GTyArrow l1 r1) (GTyArrow l2 r2) = gTypeEqShallow (dec i) l1 l2 && gTypeEqShallow (dec i) r1 r2
  45 gTypeEqShallow i (GTyArray s1 a1) (GTyArray s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
  46 gTypeEqShallow i (GTyUList s1 a1) (GTyUList s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
  47 gTypeEqShallow _ GTyUnit GTyUnit = True
  48 gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
  49 gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
  50 gTypeEqShallow i (GTyCons i1 a1) (GTyCons i2 a2) = i1.gcd_name == i2.gcd_name && gTypeEqShallow i a1 a2
  51 gTypeEqShallow i (GTyField i1 a1) (GTyField i2 a2)
  52         = i1.gfd_name == i2.gfd_name && i1.gfd_cons.grd_name == i2.gfd_cons.grd_name && gTypeEqShallow i a1 a2
  53 gTypeEqShallow i (GTyObject i1 a1) (GTyObject i2 a2)
  54         = i1.gtd_name == i2.gtd_name && gTypeEqShallow (dec i) a1 a2
  55 gTypeEqShallow i (GTyRecord i1 a1) (GTyRecord i2 a2)
  56         = i1.grd_name == i2.grd_name && gTypeEqShallow (dec i) a1 a2
  57 gTypeEqShallow _ _ _ = False
  58
  59 instance == Type
  60 where
  61         (==) (TyBasic a1) (TyBasic a2) = a1 == a2
  62         (==) (TyRef a1) (TyRef a2) = a1 == a2
  63         (==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
  64         (==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
  65         (==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
  66         (==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
  67                 = i1.gtd_name == i2.gtd_name && a1 == a2
  68         (==) (TyObject i1 a1) (TyObject i2 a2)
  69                 = i1.gtd_name == i2.gtd_name && length a1 == length a2
  70                 && and [l1.gcd_name == l2.gcd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
  71         (==) (TyRecord i1 a1) (TyRecord i2 a2)
  72                 = i1.grd_name == i2.grd_name && length a1 == length a2
  73                 && and [l1.gfd_name == l2.gfd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
  74         (==) _ _ = False
  75
  76 class print a :: a [String] -> [String]
  77 instance print Bool where print s c = [toString s:c]
  78 instance print Int where print s c = [toString s:c]
  79 instance print Char where print s c = [toString s:c]
  80 instance print String where print s c = [s:c]
  81 instance print BasicType
  82 where
  83         print BTInt c = ["Int":c]
  84         print BTChar c = ["Char":c]
  85         print BTReal c = ["Real":c]
  86         print BTBool c = ["Bool":c]
  87         print BTDynamic c = ["Dynamic":c]
  88         print BTFile c = ["File":c]
  89         print BTWorld c = ["World":c]
  90 instance print UListType
  91 where
  92         print ULStrict c = ["!":c]
  93         print ULLazy c = c
  94 instance print ArrayType
  95 where
  96         print AStrict c = ["!":c]
  97         print AUnboxed c = ["#":c]
  98         print APacked c = ["32#":c]
  99         print ALazy c = c
 100 instance print GType
 101 where
 102         print (GTyBasic s) c = print s c
 103         print (GTyRef s) c = [s:c]
 104         print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
 105         print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
 106         print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
 107         print GTyUnit c = ["UNIT":c]
 108         print (GTyEither l r) c = ["(EITHER ":print l [" ":print r [")":c]]]
 109         print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
 110         print (GTyCons i a) c = ["(CONS ", i.gcd_name, " ":print a [")":c]]
 111         print (GTyField i a) c = ["(FIELD ", i.gfd_name, " ":print a [")":c]]
 112         print (GTyObject i a) c = ["(OBJECT ", i.gtd_name, " ":print a [")":c]]
 113         print (GTyRecord i a) c = ["(RECORD ", i.grd_name, " ":print a [")":c]]
 114 instance print Type
 115 where
 116         print (TyBasic s) c = print s c
 117         print (TyRef s) c = [s:c]
 118         print (TyArrow l r) c = print l [" -> ":print r c]
 119         print (TyArray s a) c = ["{":print s ["}":print a c]]
 120         print (TyUList s a) c = ["[#":print s ["]":print a c]]
 121         print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
 122                 [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
 123         where
 124                 nttype (GenTypeArrow l r) = l
 125         print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
 126                 [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
 127         print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
 128                         $ [" ":isperse " | " (map pCons conses) c]
 129         where
 130                 pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
 131                 pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
 132                 where
 133                         n c = case i.gcd_prio of
 134                                 GenConsNoPrio = [i.gcd_name:c]
 135                                 GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
 136                                         GenConsAssocRight = "r";
 137                                         GenConsAssocLeft = "l"
 138                                         _ = "", " ":print s c]
 139
 140 pTyVars :: String Int [String] -> [String]
 141 pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
 142
 143 pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
 144 pField pre [] _ = []
 145 pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
 146
 147 instance print GenType
 148 where
 149         print (GenTypeVar i) c = print (['a'..] !! i) c
 150         print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
 151         where
 152                 collectApps (GenTypeApp l r) c = collectApps l [print r:c]
 153                 collectApps a c = [print a:c]
 154         print (GenTypeCons s) c = [s:c]
 155         print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
 156
 157 instance toString GType where toString a = concat $ print a []
 158 instance toString Type where toString a = concat $ print a []
 159 instance toString BasicType where toString a = concat $ print a []
 160 instance toString ArrayType where toString a = concat $ print a []
 161 instance toString UListType where toString a = concat $ print a []
 162 instance toString GenType where toString a = concat $ print a []
 163
 164 isperse :: a [[a] -> [a]] [a] -> [a]
 165 isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
 166
 167 gTypeToType :: GType -> Type
 168 gTypeToType (GTyBasic a) = TyBasic a
 169 gTypeToType (GTyRef a) = TyRef a
 170 gTypeToType (GTyArrow l r) = TyArrow (gTypeToType l) (gTypeToType r)
 171 gTypeToType (GTyArray s a) = TyArray s (gTypeToType a)
 172 gTypeToType (GTyUList s a) = TyUList s (gTypeToType a)
 173 gTypeToType (GTyRecord i t) = TyRecord i (gtrec t [])
 174 where
 175         gtrec :: GType [(GenericFieldDescriptor, Type)] -> [(GenericFieldDescriptor, Type)]
 176         gtrec (GTyField i t) c = [(i, gTypeToType t):c]
 177         gtrec (GTyPair l r) c = gtrec l $ gtrec r c
 178         gtrec _ c = c
 179 gTypeToType (GTyObject i=:{gtd_num_conses=0} t)
 180         = TyNewType i (hd i.gtd_conses) (gTypeToType t)
 181 gTypeToType (GTyObject i t) = TyObject i (gtobj t [])
 182 where
 183         gtobj :: GType [(GenericConsDescriptor, [Type])] -> [(GenericConsDescriptor, [Type])]
 184         gtobj (GTyEither l r) c = gtobj l $ gtobj r c
 185         gtobj (GTyCons i a) c = [(i, gtcons a []):c]
 186         gtobj _ c = c
 187
 188         gtcons :: GType [Type] -> [Type]
 189         gtcons GTyUnit c = c
 190         gtcons (GTyPair l r) c = gtcons l $ gtcons r c
 191         gtcons t c = [gTypeToType t:c]
 192
 193 :: FlatMonad :== State FMState GType
 194 :: FMState = { objects :: [String], types :: [GType], otypes :: [GType], depth :: Int }
 195 flattenGType :: GType -> [[GType]]
 196 flattenGType ot
 197         # {types} = execState (mkf ot) {objects=[], otypes=[], types=[], depth=10}
 198         = scc [(t, refs t [])\\t<-types]
 199 where
 200         refs (GTyObject _ a) c = refs a c
 201         refs (GTyRecord _ a) c = refs a c
 202         refs (GTyEither l r) c = refs l $ refs r c
 203         refs (GTyPair l r) c = refs l $ refs r c
 204         refs (GTyCons _ a) c = refs a c
 205         refs (GTyField _ a) c = refs a c
 206         refs GTyUnit c = c
 207         refs (GTyArrow l r) c = refs l $ refs r c
 208         refs (GTyArray _ a) c = refs a c
 209         refs (GTyUList _ a) c = refs a c
 210         refs (GTyBasic _) c = c
 211         refs a=:(GTyRef _) c = [a:c]
 212
 213         write :: (a GType -> GType) a GType -> FlatMonad | genericDescriptorName a
 214         write cons t a = getState >>= \s
 215                 //We have seen the type but it might've had different arguments
 216                 | isMember name s.objects
 217                         //We have not seen this configuration
 218                         | isEmpty [ot \\ ot<-s.otypes | gTypeEqShallow s.depth ot a]
 219                                 = modify (\x->{x & depth=dec x.depth}) *> mkf a *> pure (GTyRef name)
 220                         //If not, just return the basictype
 221                                 = pure $ GTyRef name
 222                 //We have not seen the type so we add, calculate and output it
 223                 = cons t <$ modify (\x->{x & otypes=[a:x.otypes], objects=[name:x.objects]}) <*> mkf a
 224                         >>= \ty->addIfNotThere ty >>| pure (GTyRef name)
 225         where
 226                 name = genericDescriptorName t
 227
 228         addIfNotThere :: GType -> FlatMonad
 229         addIfNotThere ty = getState >>= \s
 230                 | isMember ty s.types
 231                         = pure ty
 232                         = modify (\s->{s & types=[ty:s.types]}) >>| pure ty
 233
 234         mkf :: GType -> FlatMonad
 235         mkf (GTyObject t a) = write GTyObject t a
 236         mkf (GTyRecord t a) = write GTyRecord t a
 237         mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
 238         mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
 239         mkf (GTyCons i a) = GTyCons i <$> mkf a
 240         mkf (GTyField i a) = GTyField i <$> mkf a
 241         mkf GTyUnit = pure GTyUnit
 242         mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
 243         mkf (GTyArray s a) = GTyArray s <$> mkf a
 244         mkf (GTyUList s a) = GTyUList s <$> mkf a
 245         mkf a=:(GTyBasic _) = addIfNotThere a
 246         mkf a=:(GTyRef _) = pure a
 247
 248 typeName :: Type -> String
 249 typeName (TyBasic a) = toString a
 250 typeName (TyRef a) = a
 251 typeName (TyArrow l r) = typeName l +++ "->" +++ typeName r
 252 typeName (TyArray s a) = "{" +++ toString s +++ typeName a +++ "}"
 253 typeName (TyUList s a) = "{" +++ toString s +++ typeName a +++ "}"
 254 typeName (TyNewType i _ _) = i.gtd_name
 255 typeName (TyObject i _) = i.gtd_name
 256 typeName (TyRecord i _) = i.grd_name
 257
 258 instance isBuiltin String
 259 where
 260         isBuiltin s = [()\\(l, r)<-predef | l == s || r == s] =: [_:_]
 261 instance isBuiltin Type
 262 where
 263         isBuiltin (TyObject i a) = isBuiltin i.gtd_name
 264         isBuiltin (TyRecord i a) = isBuiltin i.grd_name
 265         isBuiltin (TyRef a) = isBuiltin a
 266         isBuiltin _ = True
 267 instance isBuiltin GType
 268 where
 269         isBuiltin (GTyObject i a) = isBuiltin i.gtd_name
 270         isBuiltin (GTyRecord i a) = isBuiltin i.grd_name
 271         isBuiltin (GTyRef a) = isBuiltin a
 272         isBuiltin _ = True
 273
 274 instance isBasic Type
 275 where
 276         isBasic (TyBasic t) = True
 277         isBasic _ = False
 278
 279 instance isBasic GType
 280 where
 281         isBasic (GTyBasic t) = True
 282         isBasic _ = False
 283
 284 instance replaceBuiltins GenericFieldDescriptor
 285 where
 286         replaceBuiltins s = {s & gfd_name=replaceBuiltins s.gfd_name}
 287 instance replaceBuiltins GenericConsDescriptor
 288 where
 289         replaceBuiltins s = {s & gcd_name=replaceBuiltins s.gcd_name, gcd_type=replaceBuiltins s.gcd_type}
 290 instance replaceBuiltins GenericTypeDefDescriptor
 291 where
 292         replaceBuiltins s = {s & gtd_name=replaceBuiltins s.gtd_name}
 293 instance replaceBuiltins GenericRecordDescriptor
 294 where
 295         replaceBuiltins s = {s & grd_name=replaceBuiltins s.grd_name, grd_type=replaceBuiltins s.grd_type}
 296 instance replaceBuiltins String
 297 where
 298         replaceBuiltins a = fromMaybe a $ lookup a predef
 299 instance replaceBuiltins Type
 300 where
 301         replaceBuiltins (TyRef a) = TyRef (replaceBuiltins a)
 302         replaceBuiltins (TyArrow l r) = TyArrow (replaceBuiltins l) (replaceBuiltins r)
 303         replaceBuiltins (TyArray s a) = TyArray s (replaceBuiltins a)
 304         replaceBuiltins (TyUList s a) = TyUList s (replaceBuiltins a)
 305         replaceBuiltins (TyNewType i j a) = TyNewType (replaceBuiltins i) (replaceBuiltins j) (replaceBuiltins a)
 306         replaceBuiltins (TyObject i cs) = TyObject (replaceBuiltins i) [(replaceBuiltins i, map replaceBuiltins fs)\\(i, fs)<-cs]
 307         replaceBuiltins (TyRecord j fs) = TyRecord (replaceBuiltins j) [(replaceBuiltins i, replaceBuiltins a)\\(i, a)<-fs]
 308         replaceBuiltins t = t
 309 instance replaceBuiltins GType
 310 where
 311         replaceBuiltins (GTyEither l r) = GTyEither (replaceBuiltins l) (replaceBuiltins r)
 312         replaceBuiltins (GTyPair l r) = GTyPair (replaceBuiltins l) (replaceBuiltins r)
 313         replaceBuiltins (GTyArrow l r) = GTyArrow (replaceBuiltins l) (replaceBuiltins r)
 314         replaceBuiltins (GTyArray s a) = GTyArray s (replaceBuiltins a)
 315         replaceBuiltins (GTyUList s a) = GTyUList s (replaceBuiltins a)
 316         replaceBuiltins (GTyObject i a) = GTyObject (replaceBuiltins i) (replaceBuiltins a)
 317         replaceBuiltins (GTyRecord i a) = GTyRecord (replaceBuiltins i) (replaceBuiltins a)
 318         replaceBuiltins (GTyCons i a) = GTyCons (replaceBuiltins i) (replaceBuiltins a)
 319         replaceBuiltins (GTyField i a) = GTyField (replaceBuiltins i) (replaceBuiltins a)
 320         replaceBuiltins (GTyRef a) = GTyRef (replaceBuiltins a)
 321         replaceBuiltins a = a
 322 instance replaceBuiltins GenType
 323 where
 324         replaceBuiltins (GenTypeCons a) = GenTypeCons (replaceBuiltins a)
 325         replaceBuiltins (GenTypeApp l r) = GenTypeApp (replaceBuiltins l) (replaceBuiltins r)
 326         replaceBuiltins (GenTypeArrow l r) = GenTypeArrow (replaceBuiltins l) (replaceBuiltins r)
 327         replaceBuiltins a = a
 328
 329 predef :: [(String, String)]
 330 predef =:
 331         [ ("_List", "[]"), ("_Cons", "(:)"), ("_Nil", "[]")
 332         , ("_!List", "[! ]"), ("_!Cons", "(:)"), ("_!Nil", "[! ]")
 333         , ("_List!", "[ !]"), ("_Cons!", "(:)"), ("_Nil!", "[ !]")
 334         , ("_!List!", "[!!]"), ("_!Cons!", "(:)"), ("_!Nil!", "[ !]")
 335         , ("_#List", "[#]"), ("_#Cons", "(:)"), ("_#Nil", "[#]")
 336         , ("_#List!", "[#!]"), ("_#Cons!", "(:)"), ("_#Nil!", "[#!]")
 337         , ("_!Maybe", "?"), ("_!Just", "?Just"), ("_!Nothing", "?None")
 338         , ("_Maybe", "?^"), ("_Just", "?^Just"), ("_Nothing", "?^None")
 339         , ("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}"), ("_32#Array", "{32#}")
 340         , ("_Unit", "()")
 341         :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
 342
 343 generic type a :: Box GType a
 344 gType{|UNIT|} = box GTyUnit
 345 gType{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
 346 gType{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
 347 gType{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
 348 gType{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
 349 gType{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
 350 gType{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
 351 gType{|Int|} = box $ GTyBasic BTInt
 352 gType{|Bool|} = box $ GTyBasic BTBool
 353 gType{|Real|} = box $ GTyBasic BTReal
 354 gType{|Char|} = box $ GTyBasic BTChar
 355 gType{|World|} = box $ GTyBasic BTWorld
 356 gType{|Dynamic|} = box $ GTyBasic BTDynamic
 357 gType{|File|} = box $ GTyBasic BTFile
 358 gType{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
 359 gType{|[#]|} a = box $ GTyUList ULLazy $ unBox a
 360 gType{|[#!]|} a = box $ GTyUList ULStrict $ unBox a
 361 gType{|{}|} a = box $ GTyArray ALazy $ unBox a
 362 gType{|{!}|} a = box $ GTyArray AStrict $ unBox a
 363 gType{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
 364 gType{|{32#}|} a = box $ GTyArray APacked $ unBox a
 365 derive gType ?, ?^
 366 derive gType [], [! ], [ !], [!!]
 367 derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)