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_ (Op2Expr p e1 op e2) = unfoldL_ e1 >>= \(fds1, e1_)->
 136         unfoldL_ e2 >>= \(fds2, e2_)->
 137         pure (fds1++fds2, Op2Expr p e1_ op e2_)
 138     unfoldL_ (Op1Expr p op e1) = unfoldL_ e1 >>= \(fds, e1_)->pure (fds, Op1Expr p op e1_)
 139     unfoldL_ (TupleExpr p (e1, e2)) = unfoldL_ e1 >>= \(fds1, e1_)->
 140         unfoldL_ e2 >>= \(fds2, e2_)->
 141         pure (fds1++fds2, TupleExpr p (e1_, e2_))
 142     unfoldL_ e = pure ([], e)
 143
 144 //------------
 145 //------------
 146 //      TYPING
 147 //------------
 148 //------------
 149
 150 class Typeable a where
 151     ftv :: a -> [TVar]
 152     subst :: Substitution a -> a
 153
 154 instance Typeable Scheme where
 155     ftv (Forall bound t) = difference (ftv t) bound
 156     subst s (Forall bound t) = Forall bound $ subst s_ t
 157         where s_ = 'Map'.filterWithKey (\k _ -> not (elem k bound)) s
 158
 159 instance Typeable [a] | Typeable a where
 160     ftv types   = foldr (\t ts-> ftv t ++ ts) [] types
 161     subst s ts  = map (\t->subst s t) ts
 162
 163 instance Typeable Type where
 164     ftv (TupleType (t1, t2))    = ftv t1 ++ ftv t2
 165     ftv (ListType t)            = ftv t
 166     ftv (IdType tvar)           = [tvar]
 167     ftv (FuncType t)            = ftv t
 168     ftv (t1 ->> t2)             = ftv t1 ++ ftv t2
 169     ftv _                       = []
 170     subst s (TupleType (t1, t2))= TupleType (subst s t1, subst s t2)
 171     subst s (ListType t1)       = ListType (subst s t1)
 172     subst s (FuncType t)        = FuncType (subst s t)
 173     subst s (t1 ->> t2)         = (subst s t1) ->> (subst s t2)
 174     subst s t1=:(IdType tvar)   = 'Map'.findWithDefault t1 tvar s
 175     subst s t                   = t
 176
 177 instance Typeable Gamma where
 178     ftv gamma       = concatMap id $ map ftv ('Map'.elems gamma)
 179     subst s gamma   = Mapmap (subst s) gamma
 180
 181 extend :: String Scheme Gamma -> Gamma
 182 extend k t g = 'Map'.put k t g
 183
 184 //// ------------------------
 185 //// algorithm U, Unification
 186 //// ------------------------
 187 instance zero Substitution where zero = 'Map'.newMap
 188
 189 compose :: Substitution Substitution -> Substitution
 190 compose s1 s2 = 'Map'.union (Mapmap (subst s1) s2) s1
 191 //Note: just like function compositon compose does snd first
 192
 193 occurs :: TVar a -> Bool | Typeable a
 194 occurs tvar a = elem tvar (ftv a)
 195
 196 unify :: Type Type -> Either SemError Substitution
 197 unify t1 t2=:(IdType tv)    | t1 == (IdType tv) = Right zero
 198                             | occurs tv t1 = Left $ InfiniteTypeError zero t1
 199                             | otherwise = Right $ 'Map'.singleton tv t1
 200 unify t1=:(IdType tv) t2 = unify t2 t1
 201 unify (ta1->>ta2) (tb1->>tb2) = unify ta1 tb1 >>= \s1->
 202                                 unify (subst s1 ta2) (subst s1 tb2) >>= \s2->
 203                                 Right $ compose s2 s1
 204 unify (TupleType (ta1,ta2)) (TupleType (tb1,tb2)) = unify ta1 tb1 >>= \s1->
 205                                                     unify (subst s1 ta2) (subst s1 tb2) >>= \s2->
 206                                                     Right $ compose s2 s1
 207 unify (ListType t1) (ListType t2) = unify t1 t2
 208 unify (FuncType t1) (FuncType t2) = unify t1 t2
 209 unify t1 t2 | t1 == t2  = Right zero
 210             | otherwise = Left $ UnifyError zero t1 t2
 211
 212 //// ------------------------
 213 //// Algorithm M, Inference and Solving
 214 //// ------------------------
 215 gamma :: Typing Gamma
 216 gamma = gets fst
 217 putGamma :: Gamma -> Typing ()
 218 putGamma g = modify (appFst $ const g) >>| pure ()
 219 changeGamma :: (Gamma -> Gamma) -> Typing Gamma
 220 changeGamma f = modify (appFst f) >>| gamma
 221 withGamma :: (Gamma -> a) -> Typing a
 222 withGamma f = f <$> gamma
 223 fresh :: Typing Type
 224 fresh = gets snd >>= \vars->
 225         modify (appSnd $ const $ tail vars) >>|
 226         pure (IdType (head vars))
 227
 228 lift :: (Either SemError a) -> Typing a
 229 lift (Left e) = liftT $ Left e
 230 lift (Right v) = pure v
 231
 232 //instantiate maps a schemes type variables to variables with fresh names
 233 //and drops the quantification: i.e. forall a,b.a->[b] becomes c->[d]
 234 instantiate :: Scheme -> Typing Type
 235 instantiate (Forall bound t) =
 236     mapM (const fresh) bound >>= \newVars->
 237     let s = 'Map'.fromList (zip (bound,newVars)) in
 238     pure (subst s t)
 239
 240 //generalize quentifies all free type variables in a type which are not
 241 //in the gamma
 242 generalize :: Type -> Typing Scheme
 243 generalize t = gamma >>= \g-> pure $ Forall (difference (ftv t) (ftv g)) t
 244
 245 lookup :: String -> Typing Type
 246 lookup k = gamma >>= \g-> case 'Map'.member k g of
 247     False = liftT (Left $ UndeclaredVariableError zero k)
 248     True = instantiate $ 'Map'.find k g
 249
 250 //The inference class
 251 //When tying it all together we will treat the program is a big
 252 //let x=e1 in let y=e2 in ....
 253 class infer a :: a -> Typing (Substitution, Type, a)
 254
 255 ////---- Inference for Expressions ----
 256
 257 instance infer Expr where
 258  infer e = case e of
 259     VarExpr _ (VarDef k fs) = lookup k >>= \t ->
 260         foldM foldFieldSelectors t fs >>= \finalT ->
 261         pure (zero, finalT, e)
 262
 263     Op2Expr p e1 op e2 =
 264         infer e1 >>= \(s1, t1, e1_) ->
 265         applySubst s1 >>|
 266         infer e2 >>= \(s2, t2, e2_) ->
 267         applySubst s2 >>|
 268         fresh >>= \tv ->
 269         let given = t1 ->> t2 ->> tv in
 270         op2Type op >>= \expected ->
 271         lift (unify expected given) >>= \s3 ->
 272         applySubst s3 >>|
 273         pure ((compose s3 $ compose s2 s1), subst s3 tv, Op2Expr p e1_ op e2_)
 274
 275     Op1Expr p op e1 =
 276         infer e1 >>= \(s1, t1, e1_) ->
 277         applySubst s1 >>|
 278         fresh >>= \tv ->
 279         let given = t1 ->> tv in
 280         op1Type op >>= \expected ->
 281         lift (unify expected given) >>= \s2 ->
 282         applySubst s2 >>|
 283         pure (compose s2 s1, subst s2 tv, Op1Expr p op e1)
 284
 285     EmptyListExpr _ = (\tv->(zero,ListType tv,e)) <$> fresh
 286
 287     TupleExpr p (e1, e2) =
 288         infer e1 >>= \(s1, t1, e1_) ->
 289         applySubst s1 >>|
 290         infer e2 >>= \(s2, t2, e2_) ->
 291         applySubst s2 >>|
 292         pure (compose s2 s1, TupleType (t1,t2), TupleExpr p (e1_,e2_))
 293
 294     LambdaExpr _ _ _ = liftT $ Left $ Error "PANIC: lambdas should be Unfolded"
 295
 296     FunExpr p f args fs =
 297         lookup f >>= \expected ->
 298         let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
 299         foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
 300         applySubst s1 >>|
 301         (case f of
 302             "print" = case head argTs of
 303                 IntType = pure "1printint"
 304                 CharType = pure "1printchar"
 305                 BoolType = pure "1printbool"
 306                 ListType (CharType) = pure "1printstr"
 307                 t = liftT $ Left $ SanityError p ("can not print " +++ toString t)
 308             _ = pure f
 309         ) >>= \newF->
 310         fresh >>= \tv->case expected of
 311             FuncType t = foldM foldFieldSelectors t fs >>= \returnType ->
 312                 pure (s1, returnType, (FunExpr p newF args fs))
 313             _ = (let given = foldr (->>) tv argTs in
 314                 lift (unify expected given) >>= \s2->
 315                 applySubst s2 >>|
 316                 let fReturnType = subst s2 tv in
 317                 foldM foldFieldSelectors fReturnType fs >>= \returnType ->
 318                 pure (compose s2 s1, returnType, FunExpr p newF args_ fs))
 319
 320     IntExpr _ _ = pure $ (zero, IntType, e)
 321     BoolExpr _ _ = pure $ (zero, BoolType, e)
 322     CharExpr _ _ = pure $ (zero, CharType, e)
 323
 324 foldFieldSelectors :: Type FieldSelector -> Typing Type
 325 foldFieldSelectors (ListType t) (FieldHd) = pure t
 326 foldFieldSelectors t=:(ListType _) (FieldTl) = pure t
 327 foldFieldSelectors (TupleType (t1, _)) (FieldFst) = pure t1
 328 foldFieldSelectors (TupleType (_, t2)) (FieldSnd) = pure t2
 329 foldFieldSelectors t fs = liftT $ Left $ FieldSelectorError zero t fs
 330
 331 op2Type :: Op2 -> Typing Type
 332 op2Type op
 333 | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
 334   = pure (IntType ->> IntType ->> IntType)
 335 | elem op [BiEquals, BiUnEqual]
 336   = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
 337 | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
 338   = pure (IntType ->> IntType ->> BoolType)
 339 | elem op [BiAnd, BiOr]
 340   = pure (BoolType ->> BoolType ->> BoolType)
 341 | op == BiCons
 342   = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 343
 344 op1Type :: Op1 -> Typing Type
 345 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 346 op1Type UnMinus = pure $ (IntType ->> IntType)
 347
 348 ////----- Inference for Statements -----
 349 applySubst :: Substitution -> Typing Gamma
 350 applySubst s = changeGamma (subst s)
 351
 352 instance infer Stmt where
 353  infer s = case s of
 354     IfStmt e th el =
 355         infer e >>= \(s1, et, e_)->
 356         lift (unify et BoolType) >>= \s2 ->
 357         applySubst (compose s2 s1) >>|
 358         infer th >>= \(s3, tht, th_)->
 359         applySubst s3 >>|
 360         infer el >>= \(s4, elt, el_)->
 361         applySubst s4 >>|
 362         lift (unify tht elt) >>= \s5->
 363         let sub = compose s5 $ compose s4 $ compose s3 $ compose s2 s1 in
 364         pure (sub, subst s5 tht, IfStmt e_ th_ el_)
 365
 366     WhileStmt e wh =
 367         infer e >>= \(s1, et, e_)->
 368         lift (unify et BoolType) >>= \s2 ->
 369         applySubst (compose s2 s1) >>|
 370         infer wh >>= \(s3, wht, wh_)->
 371         pure (compose s3 $ compose s2 s1, subst s3 wht, WhileStmt e_ wh_)
 372
 373     AssStmt vd=:(VarDef k fs) e =
 374         lookup k >>= \expected ->
 375         infer e >>= \(s1, given, e_)->
 376         foldM reverseFs given (reverse fs) >>= \varType->
 377         lift (unify expected varType) >>= \s2->
 378         let s = compose s2 s1 in
 379         applySubst s >>|
 380         changeGamma (extend k (Forall [] (subst s varType))) >>|
 381         pure (s, VoidType, AssStmt vd e_)
 382
 383     FunStmt f args fs =
 384         lookup f >>= \expected ->
 385         let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
 386         foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
 387         fresh >>= \tv->
 388         let given = foldr (->>) tv argTs in
 389         lift (unify expected given) >>= \s2->
 390         let fReturnType = subst s2 tv in
 391         foldM foldFieldSelectors fReturnType fs >>= \returnType ->
 392         (case f of
 393             "print" = case head argTs of
 394                 IntType = pure "1printint"
 395                 CharType = pure "1printchar"
 396                 BoolType = pure "1printbool"
 397                 ListType (CharType) = pure "1printstr"
 398                 t = liftT $ Left $ SanityError zero ("can not print " +++ toString t)
 399             _ = pure f) >>= \newF->
 400         pure (compose s2 s1, VoidType, FunStmt newF args_ fs)
 401
 402     ReturnStmt Nothing = pure (zero, VoidType, s)
 403     //hier ook sub applyen
 404     ReturnStmt (Just e) = infer e >>= \(sub, t, e_)-> pure (sub, t, ReturnStmt (Just e_))
 405
 406 reverseFs :: Type FieldSelector -> Typing Type
 407 reverseFs t FieldHd = pure $ ListType t
 408 reverseFs t FieldTl = pure t
 409 reverseFs t FieldFst = fresh >>= \tv -> pure $ TupleType (t, tv)
 410 reverseFs t FieldSnd = fresh >>= \tv -> pure $ TupleType (tv, t)
 411
 412 //The type of a list of statements is either an encountered
 413 //return, or VoidType
 414 instance infer [a] | infer a where
 415     infer []        = pure (zero, VoidType, [])
 416     infer [stmt:ss] =
 417         infer stmt >>= \(s1, t1, s_) ->
 418         applySubst s1 >>|
 419         infer ss >>= \(s2, t2, ss_) ->
 420         applySubst s2 >>|
 421         case t1 of
 422             VoidType = pure (compose s2 s1, t2, [s_:ss_])
 423             _ = case t2 of
 424                 VoidType = pure (compose s2 s1, t1, [s_:ss_])
 425                 _ = lift (unify t1 t2) >>= \s3 ->
 426                     pure (compose s3 $ compose s2 s1, t1, [s_:ss_])
 427
 428 //the type class inferes the type of an AST element (VarDecl or FunDecl)
 429 //and adds it to the AST element
 430 class type a :: a -> Typing (Substitution, a)
 431
 432 instance type VarDecl where
 433     type (VarDecl p expected k e) =
 434         infer e >>= \(s1, given, e_) ->
 435         applySubst s1 >>|
 436         case expected of
 437             Nothing = pure zero
 438             Just expected_ = lift (unify expected_ given)
 439         >>= \s2->
 440         applySubst s2 >>|
 441         let vtype = subst (compose s2 s1) given in
 442         generalize vtype >>= \t ->
 443         changeGamma (extend k t) >>|
 444         pure (compose s2 s1, VarDecl p (Just vtype) k e_)
 445
 446 instance type FunDecl where
 447     type fd=:(FunDecl p f args expected vds stmts) =
 448         gamma >>= \outerScope-> //functions are infered in their own scopde
 449         introduce f >>|
 450         mapM introduce args >>= \argTs->
 451         fresh >>= \tempTv ->
 452         let temp = foldr (->>) tempTv argTs in
 453         (case expected of
 454             Just expected_ = lift (unify expected_ temp)
 455             _   = pure zero
 456         ) >>= \s0->
 457         applySubst s0 >>|
 458         type vds >>= \(s1, tVds)->
 459         applySubst s1 >>|
 460         infer stmts >>= \(s2, result, stmts_)->
 461         applySubst s1 >>|
 462         let argTs_ = map (subst $ compose s2 $ compose s1 s0) argTs in
 463         let given = foldr (->>) result argTs_ in
 464         (case expected of
 465             Nothing = pure zero
 466             Just (FuncType expected_) = lift (unify expected_ given)
 467             Just expected_ = lift (unify expected_ given)
 468         ) >>= \s3 ->
 469         let ftype = subst (compose s3 $ compose s2 $ compose s1 s0) given in
 470         (case ftype of
 471             _ ->> _ = pure ftype
 472             _       = pure $ FuncType ftype
 473         ) >>= \ftype_->
 474         generalize ftype_ >>= \t->
 475         putGamma outerScope >>|
 476         changeGamma (extend f t) >>|
 477         pure (compose s3 $ compose s2 $ compose s1 s0,
 478                 FunDecl p f args (Just ftype_) tVds stmts_)
 479
 480 instance type [a] | type a where
 481     type []     = pure (zero, [])
 482     type [v:vs] =
 483         type v >>= \(s1, v_)->
 484         applySubst s1 >>|
 485         type vs >>= \(s2, vs_)->
 486         applySubst (compose s2 s1) >>|
 487         pure (compose s2 s1, [v_:vs_])
 488
 489 introduce :: String -> Typing Type
 490 introduce k =
 491     fresh >>= \tv ->
 492     changeGamma (extend k (Forall [] tv)) >>|
 493     pure tv
 494
 495 instance toString Scheme where
 496     toString (Forall x t) =
 497         concat ["Forall ": intersperse "," x] +++ concat [". ", toString t];
 498
 499 instance toString Gamma where
 500     toString mp =
 501         concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 502
 503 instance toString Substitution where
 504     toString subs =
 505         concat [concat [k, ": ", toString t, "\n"]\\(k, t)<-'Map'.toList subs]
 506
 507 instance toString SemError where
 508     toString (SanityError p e) = concat [toString p,
 509         "SemError: SanityError: ", e]
 510     toString (ParseError p s) = concat [toString p,
 511         "ParseError: ", s]
 512     toString (UnifyError p t1 t2) = concat [toString p,
 513         "Can not unify types, expected|given:\n", toString t1,
 514         "\n", toString t2]
 515     toString (InfiniteTypeError p t) = concat [toString p,
 516         "Infinite type: ", toString t]
 517     toString (FieldSelectorError p t fs) = concat [toString p,
 518         "Can not run fieldselector '", toString fs, "' on type: ",
 519         toString t]
 520     toString (OperatorError p op t) = concat [toString p,
 521         "Operator error, operator '", toString op, "' can not be",
 522         "used on type: ", toString t]
 523     toString (UndeclaredVariableError p k) = concat [toString p,
 524         "Undeclared identifier: ", k]
 525     toString (ArgumentMisMatchError p str) = concat [toString p,
 526         "Argument mismatch: ", str]
 527     toString (Error e) = concat ["Unknown error during semantical",
 528         "analysis: ", e]
 529
 530 instance toString (Maybe a) | toString a where
 531     toString Nothing = "Nothing"
 532     toString (Just e) = concat ["Just ", toString e]
 533
 534 instance MonadTrans (StateT (Gamma, [TVar])) where
 535     liftT m = StateT \s-> m >>= \a-> return (a, s)
 536
 537 Mapmap :: (a->b) ('Map'.Map k a) -> ('Map'.Map k b)
 538 Mapmap _ 'Map'.Tip = 'Map'.Tip
 539 Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v)
 540                                         (Mapmap f ml)
 541                                         (Mapmap f mr)