gengen/src/GenType.icl

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