sem.icl

   1 implementation module sem
   2
   3 import qualified Data.Map as Map
   4
   5 from Data.Func import $
   6 from StdFunc import o, flip, const, id
   7
   8 import Control.Applicative
   9 import Control.Monad
  10 import Control.Monad.Trans
  11 import Control.Monad.State
  12 import Data.Either
  13 import Data.Maybe
  14 import Data.Monoid
  15 import Data.List
  16 import Data.Functor
  17 import Data.Tuple
  18
  19 import StdString
  20 import StdTuple
  21 import StdList
  22 import StdMisc
  23 import StdEnum
  24 import GenEq
  25
  26 from Text import class Text(concat), instance Text String
  27
  28 import AST
  29
  30 :: Scheme = Forall [TVar] Type
  31 :: Gamma :== 'Map'.Map String Scheme //map from Variables! to types
  32 :: Typing a :== StateT (Gamma, [TVar]) (Either SemError) a
  33 :: Substitution :== 'Map'.Map TVar Type
  34 :: Constraints :== [(Type, Type)]
  35 :: SemError
  36         = ParseError Pos String
  37         | UnifyError Pos Type Type
  38     | InfiniteTypeError Pos Type
  39     | FieldSelectorError Pos Type FieldSelector
  40         | OperatorError Pos Op2 Type
  41     | UndeclaredVariableError Pos String
  42     | ArgumentMisMatchError Pos String
  43         | SanityError Pos String
  44         | Error String
  45
  46 instance zero Gamma where
  47         zero = 'Map'.newMap
  48
  49 variableStream :: [TVar]
  50 variableStream = map toString [1..]
  51
  52 defaultGamma :: Gamma //includes all default functions
  53 defaultGamma = extend "print" (Forall ["a"] ((IdType "a") ->> VoidType))
  54                 $ extend "isEmpty" (Forall ["a"] ((ListType (IdType "a")) ->> BoolType))
  55                 $ extend "read" (Forall [] (FuncType CharType))
  56                 $ extend "1printchar" (Forall [] (CharType ->> VoidType))
  57                 $ extend "1printint" (Forall [] (IntType ->> VoidType))
  58                 $ extend "1printbool" (Forall [] (BoolType ->> VoidType))
  59                 zero
  60
  61 sem :: AST -> Either [SemError] (AST, Gamma)
  62 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd
  63                         >>| foldM (const isNiceMain) () fd
  64                         >>| hasMain fd
  65                     >>| runStateT (unfoldLambda fd >>= type) (defaultGamma, variableStream) of
  66         Left e = Left [e]
  67     Right ((_,fds),(gam,_)) = Right (AST fds, gam)
  68 where
  69                 hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
  70                 hasNoDups fds (FunDecl p n _ _ _ _)
  71                 # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
  72                 = case catMaybes mbs of
  73                         [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
  74                         [x] = pure ()
  75                         [_:x] = Left $ SanityError p (concat
  76                                 [n, " multiply defined at ", toString p])
  77
  78                 hasMain :: [FunDecl] -> Either SemError ()
  79                 hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
  80                 hasMain [_:fd] = hasMain fd
  81                 hasMain [] = Left $ SanityError zero "no main function defined"
  82
  83                 isNiceMain :: FunDecl -> Either SemError ()
  84                 isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
  85                         ([_:_], _) = Left $ SanityError p "main must have arity 0"
  86                         ([], t) = (case t of
  87                                 Nothing = pure ()
  88                                 Just VoidType = pure ()
  89                                 _ = Left $ SanityError p "main has to return Void")
  90                 isNiceMain _ = pure ()
  91
  92
  93 //------------------
  94 // LAMBDA UNFOLDING
  95 //------------------
  96 unfoldLambda :: [FunDecl] -> Typing [FunDecl]
  97 unfoldLambda [] = pure []
  98 unfoldLambda [fd:fds] = unfoldL_ fd >>= \(gen1, fs_)->
  99                         unfoldLambda fds >>= \gen2->
 100                         pure $ gen1 ++ [fs_] ++ gen2
 101
 102 flattenT :: [([a],b)] -> ([a],[b])
 103 flattenT ts = (flatten $ map fst ts, map snd ts)
 104
 105 class unfoldL_ a :: a -> Typing ([FunDecl], a)
 106
 107 instance unfoldL_ FunDecl where
 108     unfoldL_ (FunDecl p f args mt vds stmts) =
 109         flattenT <$> mapM unfoldL_ vds >>= \(fds1,vds_) ->
 110         flattenT <$> mapM unfoldL_ stmts >>= \(fds2,stmts_)->
 111         pure (fds1 ++ fds2, FunDecl p f args mt vds_ stmts_)
 112
 113 instance unfoldL_ VarDecl where
 114     unfoldL_ (VarDecl p mt v e) = unfoldL_ e >>= \(fds, e_)->pure (fds, VarDecl p mt v e_)
 115
 116 instance unfoldL_ Stmt where
 117     unfoldL_ (IfStmt e th el) = unfoldL_ e >>= \(fds, e_)->pure (fds, IfStmt e_ th el)
 118     unfoldL_ (WhileStmt e c) = unfoldL_ e >>= \(fds, e_)->pure (fds, WhileStmt e_ c)
 119     unfoldL_ (AssStmt vd e) = unfoldL_ e >>= \(fds, e_)->pure (fds, AssStmt vd e_)
 120     unfoldL_ (FunStmt f es fs) = flattenT <$> mapM unfoldL_ es >>= \(fds, es_)->
 121         pure (fds, FunStmt f es_ fs)
 122     unfoldL_ (ReturnStmt (Just e)) = unfoldL_ e >>= \(fds, e_) ->
 123         pure (fds, ReturnStmt (Just e_))
 124     unfoldL_ (ReturnStmt Nothing) = pure ([], ReturnStmt Nothing)
 125
 126 instance unfoldL_ Expr where
 127     unfoldL_ (LambdaExpr p args e) =
 128         fresh >>= \(IdType n) ->
 129         let f = ("2lambda_"+++n) in
 130         let fd = FunDecl p f args Nothing [] [ReturnStmt $ Just e] in
 131         let fe = VarExpr p (VarDef f []) in
 132         pure ([fd], fe)
 133     unfoldL_ (FunExpr p f es fs) = flattenT <$> mapM unfoldL_ es >>= \(fds, es_)->
 134         pure (fds, FunExpr p f es_ fs)
 135     unfoldL_ e = pure ([], e)
 136
 137 //------------
 138 //------------
 139 //      TYPING
 140 //------------
 141 //------------
 142
 143 class Typeable a where
 144     ftv :: a -> [TVar]
 145     subst :: Substitution a -> a
 146
 147 instance Typeable Scheme where
 148     ftv (Forall bound t) = difference (ftv t) bound
 149     subst s (Forall bound t) = Forall bound $ subst s_ t
 150         where s_ = 'Map'.filterWithKey (\k _ -> not (elem k bound)) s
 151
 152 instance Typeable [a] | Typeable a where
 153     ftv types   = foldr (\t ts-> ftv t ++ ts) [] types
 154     subst s ts  = map (\t->subst s t) ts
 155
 156 instance Typeable Type where
 157     ftv (TupleType (t1, t2))    = ftv t1 ++ ftv t2
 158     ftv (ListType t)            = ftv t
 159     ftv (IdType tvar)           = [tvar]
 160     ftv (FuncType t)            = ftv t
 161     ftv (t1 ->> t2)             = ftv t1 ++ ftv t2
 162     ftv _                       = []
 163     subst s (TupleType (t1, t2))= TupleType (subst s t1, subst s t2)
 164     subst s (ListType t1)       = ListType (subst s t1)
 165     subst s (FuncType t)        = FuncType (subst s t)
 166     subst s (t1 ->> t2)         = (subst s t1) ->> (subst s t2)
 167     subst s t1=:(IdType tvar)   = 'Map'.findWithDefault t1 tvar s
 168     subst s t                   = t
 169
 170 instance Typeable Gamma where
 171     ftv gamma       = concatMap id $ map ftv ('Map'.elems gamma)
 172     subst s gamma   = Mapmap (subst s) gamma
 173
 174 extend :: String Scheme Gamma -> Gamma
 175 extend k t g = 'Map'.put k t g
 176
 177 //// ------------------------
 178 //// algorithm U, Unification
 179 //// ------------------------
 180 instance zero Substitution where zero = 'Map'.newMap
 181
 182 compose :: Substitution Substitution -> Substitution
 183 compose s1 s2 = 'Map'.union (Mapmap (subst s1) s2) s1
 184 //Note: just like function compositon compose does snd first
 185
 186 occurs :: TVar a -> Bool | Typeable a
 187 occurs tvar a = elem tvar (ftv a)
 188
 189 unify :: Type Type -> Either SemError Substitution
 190 unify t1 t2=:(IdType tv)    | t1 == (IdType tv) = Right zero
 191                             | occurs tv t1 = Left $ InfiniteTypeError zero t1
 192                             | otherwise = Right $ 'Map'.singleton tv t1
 193 unify t1=:(IdType tv) t2 = unify t2 t1
 194 unify (ta1->>ta2) (tb1->>tb2) = unify ta1 tb1 >>= \s1->
 195                                 unify ta2 tb2 >>= \s2->
 196                                 Right $ compose s1 s2
 197 unify (TupleType (ta1,ta2)) (TupleType (tb1,tb2)) = unify ta1 tb1 >>= \s1->
 198                                                     unify ta2 tb2 >>= \s2->
 199                                                     Right $ compose s1 s2
 200 unify (ListType t1) (ListType t2) = unify t1 t2
 201 unify (FuncType t1) (FuncType t2) = unify t1 t2
 202 unify t1 t2 | t1 == t2  = Right zero
 203             | otherwise = Left $ UnifyError zero t1 t2
 204
 205 //// ------------------------
 206 //// Algorithm M, Inference and Solving
 207 //// ------------------------
 208 gamma :: Typing Gamma
 209 gamma = gets fst
 210 putGamma :: Gamma -> Typing ()
 211 putGamma g = modify (appFst $ const g) >>| pure ()
 212 changeGamma :: (Gamma -> Gamma) -> Typing Gamma
 213 changeGamma f = modify (appFst f) >>| gamma
 214 withGamma :: (Gamma -> a) -> Typing a
 215 withGamma f = f <$> gamma
 216 fresh :: Typing Type
 217 fresh = gets snd >>= \vars->
 218         modify (appSnd $ const $ tail vars) >>|
 219         pure (IdType (head vars))
 220
 221 lift :: (Either SemError a) -> Typing a
 222 lift (Left e) = liftT $ Left e
 223 lift (Right v) = pure v
 224
 225 //instantiate maps a schemes type variables to variables with fresh names
 226 //and drops the quantification: i.e. forall a,b.a->[b] becomes c->[d]
 227 instantiate :: Scheme -> Typing Type
 228 instantiate (Forall bound t) =
 229     mapM (const fresh) bound >>= \newVars->
 230     let s = 'Map'.fromList (zip (bound,newVars)) in
 231     pure (subst s t)
 232
 233 //generalize quentifies all free type variables in a type which are not
 234 //in the gamma
 235 generalize :: Type -> Typing Scheme
 236 generalize t = gamma >>= \g-> pure $ Forall (difference (ftv t) (ftv g)) t
 237
 238 lookup :: String -> Typing Type
 239 lookup k = gamma >>= \g-> case 'Map'.member k g of
 240     False = liftT (Left $ UndeclaredVariableError zero k)
 241     True = instantiate $ 'Map'.find k g
 242
 243 //The inference class
 244 //When tying it all together we will treat the program is a big
 245 //let x=e1 in let y=e2 in ....
 246 class infer a :: a -> Typing (Substitution, Type, a)
 247
 248 ////---- Inference for Expressions ----
 249
 250 instance infer Expr where
 251  infer e = case e of
 252     VarExpr _ (VarDef k fs) = lookup k >>= \t ->
 253         foldM foldFieldSelectors t fs >>= \finalT ->
 254         pure (zero, finalT, e)
 255
 256     Op2Expr p e1 op e2 =
 257         infer e1 >>= \(s1, t1, e1_) ->
 258         infer e2 >>= \(s2, t2, e2_) ->
 259         fresh >>= \tv ->
 260         let given = t1 ->> t2 ->> tv in
 261         op2Type op >>= \expected ->
 262         lift (unify expected given) >>= \s3 ->
 263         pure ((compose s3 $ compose s2 s1), subst s3 tv, Op2Expr p e1_ op e2_)
 264
 265     Op1Expr p op e1 =
 266         infer e1 >>= \(s1, t1, e1_) ->
 267         fresh >>= \tv ->
 268         let given = t1 ->> tv in
 269         op1Type op >>= \expected ->
 270         lift (unify expected given) >>= \s2 ->
 271         pure (compose s2 s1, subst s2 tv, Op1Expr p op e1)
 272
 273     EmptyListExpr _ = (\tv->(zero,tv,e)) <$> fresh
 274
 275     TupleExpr p (e1, e2) =
 276         infer e1 >>= \(s1, t1, e1_) ->
 277         infer e2 >>= \(s2, t2, e2_) ->
 278         pure (compose s2 s1, TupleType (t1,t2), TupleExpr p (e1_,e2_))
 279
 280     LambdaExpr _ _ _ = liftT $ Left $ Error "PANIC: lambdas should be Unfolded"
 281
 282     FunExpr p f args fs =
 283         lookup f >>= \expected ->
 284         let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
 285         foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
 286         (case f of
 287             "print" = case head argTs of
 288                 IntType = pure "1printint"
 289                 CharType = pure "1printchar"
 290                 BoolType = pure "1printbool"
 291                 ListType (CharType) = pure "1printstr"
 292                 t = liftT $ Left $ SanityError p ("can not print " +++ toString t)
 293             _ = pure f
 294         ) >>= \newF->
 295         fresh >>= \tv->case expected of
 296             FuncType t = pure (s1, t, (FunExpr p newF args fs))
 297             _ = (let given = foldr (->>) tv argTs in
 298                 lift (unify expected given) >>= \s2->
 299                 let fReturnType = subst s2 tv in
 300                 foldM foldFieldSelectors fReturnType fs >>= \returnType ->
 301                 pure (compose s2 s1, returnType, FunExpr p newF args_ fs))
 302
 303     IntExpr _ _ = pure $ (zero, IntType, e)
 304     BoolExpr _ _ = pure $ (zero, BoolType, e)
 305     CharExpr _ _ = pure $ (zero, CharType, e)
 306
 307 foldFieldSelectors :: Type FieldSelector -> Typing Type
 308 foldFieldSelectors (ListType t) (FieldHd) = pure t
 309 foldFieldSelectors t=:(ListType _) (FieldTl) = pure t
 310 foldFieldSelectors (TupleType (t1, _)) (FieldFst) = pure t1
 311 foldFieldSelectors (TupleType (_, t2)) (FieldSnd) = pure t2
 312 foldFieldSelectors t fs = liftT $ Left $ FieldSelectorError zero t fs
 313
 314 op2Type :: Op2 -> Typing Type
 315 op2Type op
 316 | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
 317   = pure (IntType ->> IntType ->> IntType)
 318 | elem op [BiEquals, BiUnEqual]
 319   = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
 320 | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
 321   = pure (IntType ->> IntType ->> BoolType)
 322 | elem op [BiAnd, BiOr]
 323   = pure (BoolType ->> BoolType ->> BoolType)
 324 | op == BiCons
 325   = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 326
 327 op1Type :: Op1 -> Typing Type
 328 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 329 op1Type UnMinus = pure $ (IntType ->> IntType)
 330
 331 ////----- Inference for Statements -----
 332 applySubst :: Substitution -> Typing Gamma
 333 applySubst s = changeGamma (subst s)
 334
 335 instance infer Stmt where
 336  infer s = case s of
 337     IfStmt e th el =
 338         infer e >>= \(s1, et, e_)->
 339         lift (unify et BoolType) >>= \s2 ->
 340         applySubst (compose s2 s1) >>|
 341         infer th >>= \(s3, tht, th_)->
 342         applySubst s3 >>|
 343         infer el >>= \(s4, elt, el_)->
 344         applySubst s4 >>|
 345         lift (unify tht elt) >>= \s5->
 346         let sub = compose s5 $ compose s4 $ compose s3 $ compose s2 s1 in
 347         pure (sub, subst s5 tht, IfStmt e_ th_ el_)
 348
 349     WhileStmt e wh =
 350         infer e >>= \(s1, et, e_)->
 351         lift (unify et BoolType) >>= \s2 ->
 352         applySubst (compose s2 s1) >>|
 353         infer wh >>= \(s3, wht, wh_)->
 354         pure (compose s3 $ compose s2 s1, subst s3 wht, WhileStmt e_ wh_)
 355
 356     AssStmt vd=:(VarDef k fs) e =
 357         lookup k >>= \expected ->
 358         infer e >>= \(s1, given, e_)->
 359         foldM reverseFs given (reverse fs) >>= \varType->
 360         lift (unify expected varType) >>= \s2->
 361         let s = compose s2 s1 in
 362         applySubst s >>|
 363         changeGamma (extend k (Forall [] (subst s varType))) >>|
 364         pure (s, VoidType, AssStmt vd e_)
 365
 366     FunStmt f args fs =
 367         lookup f >>= \expected ->
 368         let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
 369         foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
 370         fresh >>= \tv->
 371         let given = foldr (->>) tv argTs in
 372         lift (unify expected given) >>= \s2->
 373         let fReturnType = subst s2 tv in
 374         foldM foldFieldSelectors fReturnType fs >>= \returnType ->
 375         (case f of
 376             "print" = case head argTs of
 377                 IntType = pure "1printint"
 378                 CharType = pure "1printchar"
 379                 BoolType = pure "1printbool"
 380                 ListType (CharType) = pure "1printstr"
 381                 t = liftT $ Left $ SanityError zero ("can not print " +++ toString t)
 382             _ = pure f) >>= \newF->
 383         pure (compose s2 s1, VoidType, FunStmt newF args_ fs)
 384
 385     ReturnStmt Nothing = pure (zero, VoidType, s)
 386     ReturnStmt (Just e) = infer e >>= \(sub, t, e_)-> pure (sub, t, ReturnStmt (Just e_))
 387
 388 reverseFs :: Type FieldSelector -> Typing Type
 389 reverseFs t FieldHd = pure $ ListType t
 390 reverseFs t FieldTl = pure $ ListType t
 391 reverseFs t FieldFst = fresh >>= \tv -> pure $ TupleType (t, tv)
 392 reverseFs t FieldSnd = fresh >>= \tv -> pure $ TupleType (tv, t)
 393
 394 //The type of a list of statements is either an encountered
 395 //return, or VoidType
 396 instance infer [a] | infer a where
 397     infer []        = pure (zero, VoidType, [])
 398     infer [stmt:ss] =
 399         infer stmt >>= \(s1, t1, s_) ->
 400         applySubst s1 >>|
 401         infer ss >>= \(s2, t2, ss_) ->
 402         applySubst s2 >>|
 403         case t1 of
 404             VoidType = pure (compose s2 s1, t2, [s_:ss_])
 405             _ = case t2 of
 406                 VoidType = pure (compose s2 s1, t1, [s_:ss_])
 407                 _ = lift (unify t1 t2) >>= \s3 ->
 408                     pure (compose s3 $ compose s2 s1, t1, [s_:ss_])
 409
 410 //the type class inferes the type of an AST element (VarDecl or FunDecl)
 411 //and adds it to the AST element
 412 class type a :: a -> Typing (Substitution, a)
 413
 414 instance type VarDecl where
 415     type (VarDecl p expected k e) =
 416         infer e >>= \(s1, given, e_) ->
 417         applySubst s1 >>|
 418         case expected of
 419             Nothing = pure zero
 420             Just expected_ = lift (unify expected_ given)
 421         >>= \s2->
 422         applySubst s2 >>|
 423         let vtype = subst (compose s2 s1) given in
 424         generalize vtype >>= \t ->
 425         changeGamma (extend k t) >>|
 426         pure (compose s2 s1, VarDecl p (Just vtype) k e_)
 427
 428 instance type FunDecl where
 429     type fd=:(FunDecl p f args expected vds stmts) =
 430         gamma >>= \outerScope-> //functions are infered in their own scopde
 431         introduce f >>|
 432         mapM introduce args >>= \argTs->
 433         fresh >>= \tempTv ->
 434         let temp = foldr (->>) tempTv argTs in
 435         (case expected of
 436             Just expected_ = lift (unify expected_ temp)
 437             _   = pure zero
 438         ) >>= \s0->
 439         applySubst s0 >>|
 440         type vds >>= \(s1, tVds)->
 441         applySubst s1 >>|
 442         infer stmts >>= \(s2, result, stmts_)->
 443         applySubst s1 >>|
 444         let argTs_ = map (subst $ compose s2 $ compose s1 s0) argTs in
 445         let given = foldr (->>) result argTs_ in
 446         (case expected of
 447             Nothing = pure zero
 448             Just (FuncType expected_) = lift (unify expected_ given)
 449             Just expected_ = lift (unify expected_ given)
 450         ) >>= \s3 ->
 451         let ftype = subst (compose s3 $ compose s2 $ compose s1 s0) given in
 452         (case ftype of
 453             _ ->> _ = pure ftype
 454             _       = pure $ FuncType ftype
 455         ) >>= \ftype_->
 456         generalize ftype_ >>= \t->
 457         putGamma outerScope >>|
 458         changeGamma (extend f t) >>|
 459         pure (compose s3 $ compose s2 $ compose s1 s0,
 460                 FunDecl p f args (Just ftype_) tVds stmts_)
 461
 462 instance type [a] | type a where
 463     type []     = pure (zero, [])
 464     type [v:vs] =
 465         type v >>= \(s1, v_)->
 466         applySubst s1 >>|
 467         type vs >>= \(s2, vs_)->
 468         applySubst (compose s2 s1) >>|
 469         pure (compose s2 s1, [v_:vs_])
 470
 471 introduce :: String -> Typing Type
 472 introduce k =
 473     fresh >>= \tv ->
 474     changeGamma (extend k (Forall [] tv)) >>|
 475     pure tv
 476
 477 instance toString Scheme where
 478     toString (Forall x t) =
 479         concat ["Forall ": intersperse "," x] +++ concat [". ", toString t];
 480
 481 instance toString Gamma where
 482     toString mp =
 483         concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 484
 485 instance toString Substitution where
 486     toString subs =
 487         concat [concat [k, ": ", toString t, "\n"]\\(k, t)<-'Map'.toList subs]
 488
 489 instance toString SemError where
 490     toString (SanityError p e) = concat [toString p,
 491         "SemError: SanityError: ", e]
 492     toString (ParseError p s) = concat [toString p,
 493         "ParseError: ", s]
 494     toString (UnifyError p t1 t2) = concat [toString p,
 495         "Can not unify types, expected|given:\n", toString t1,
 496         "\n", toString t2]
 497     toString (InfiniteTypeError p t) = concat [toString p,
 498         "Infinite type: ", toString t]
 499     toString (FieldSelectorError p t fs) = concat [toString p,
 500         "Can not run fieldselector '", toString fs, "' on type: ",
 501         toString t]
 502     toString (OperatorError p op t) = concat [toString p,
 503         "Operator error, operator '", toString op, "' can not be",
 504         "used on type: ", toString t]
 505     toString (UndeclaredVariableError p k) = concat [toString p,
 506         "Undeclared identifier: ", k]
 507     toString (ArgumentMisMatchError p str) = concat [toString p,
 508         "Argument mismatch: ", str]
 509     toString (Error e) = concat ["Unknown error during semantical",
 510         "analysis: ", e]
 511
 512 instance toString (Maybe a) | toString a where
 513     toString Nothing = "Nothing"
 514     toString (Just e) = concat ["Just ", toString e]
 515
 516 instance MonadTrans (StateT (Gamma, [TVar])) where
 517     liftT m = StateT \s-> m >>= \a-> return (a, s)
 518
 519 Mapmap :: (a->b) ('Map'.Map k a) -> ('Map'.Map k b)
 520 Mapmap _ 'Map'.Tip = 'Map'.Tip
 521 Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v)
 522                                         (Mapmap f ml)
 523                                         (Mapmap f mr)