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 ta2 tb2 >>= \s2->
 203                                 Right $ compose s1 s2
 204 unify (TupleType (ta1,ta2)) (TupleType (tb1,tb2)) = unify ta1 tb1 >>= \s1->
 205                                                     unify ta2 tb2 >>= \s2->
 206                                                     Right $ compose s1 s2
 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         infer e2 >>= \(s2, t2, e2_) ->
 266         fresh >>= \tv ->
 267         let given = t1 ->> t2 ->> tv in
 268         op2Type op >>= \expected ->
 269         lift (unify expected given) >>= \s3 ->
 270         pure ((compose s3 $ compose s2 s1), subst s3 tv, Op2Expr p e1_ op e2_)
 271
 272     Op1Expr p op e1 =
 273         infer e1 >>= \(s1, t1, e1_) ->
 274         fresh >>= \tv ->
 275         let given = t1 ->> tv in
 276         op1Type op >>= \expected ->
 277         lift (unify expected given) >>= \s2 ->
 278         pure (compose s2 s1, subst s2 tv, Op1Expr p op e1)
 279
 280     EmptyListExpr _ = (\tv->(zero,tv,e)) <$> fresh
 281
 282     TupleExpr p (e1, e2) =
 283         infer e1 >>= \(s1, t1, e1_) ->
 284         infer e2 >>= \(s2, t2, e2_) ->
 285         pure (compose s2 s1, TupleType (t1,t2), TupleExpr p (e1_,e2_))
 286
 287     LambdaExpr _ _ _ = liftT $ Left $ Error "PANIC: lambdas should be Unfolded"
 288
 289     FunExpr p f args fs =
 290         lookup f >>= \expected ->
 291         let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
 292         foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
 293         (case f of
 294             "print" = case head argTs of
 295                 IntType = pure "1printint"
 296                 CharType = pure "1printchar"
 297                 BoolType = pure "1printbool"
 298                 ListType (CharType) = pure "1printstr"
 299                 t = liftT $ Left $ SanityError p ("can not print " +++ toString t)
 300             _ = pure f
 301         ) >>= \newF->
 302         fresh >>= \tv->case expected of
 303             FuncType t = pure (s1, t, (FunExpr p newF args fs))
 304             _ = (let given = foldr (->>) tv argTs in
 305                 lift (unify expected given) >>= \s2->
 306                 let fReturnType = subst s2 tv in
 307                 foldM foldFieldSelectors fReturnType fs >>= \returnType ->
 308                 pure (compose s2 s1, returnType, FunExpr p newF args_ fs))
 309
 310     IntExpr _ _ = pure $ (zero, IntType, e)
 311     BoolExpr _ _ = pure $ (zero, BoolType, e)
 312     CharExpr _ _ = pure $ (zero, CharType, e)
 313
 314 foldFieldSelectors :: Type FieldSelector -> Typing Type
 315 foldFieldSelectors (ListType t) (FieldHd) = pure t
 316 foldFieldSelectors t=:(ListType _) (FieldTl) = pure t
 317 foldFieldSelectors (TupleType (t1, _)) (FieldFst) = pure t1
 318 foldFieldSelectors (TupleType (_, t2)) (FieldSnd) = pure t2
 319 foldFieldSelectors t fs = liftT $ Left $ FieldSelectorError zero t fs
 320
 321 op2Type :: Op2 -> Typing Type
 322 op2Type op
 323 | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
 324   = pure (IntType ->> IntType ->> IntType)
 325 | elem op [BiEquals, BiUnEqual]
 326   = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
 327 | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
 328   = pure (IntType ->> IntType ->> BoolType)
 329 | elem op [BiAnd, BiOr]
 330   = pure (BoolType ->> BoolType ->> BoolType)
 331 | op == BiCons
 332   = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 333
 334 op1Type :: Op1 -> Typing Type
 335 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 336 op1Type UnMinus = pure $ (IntType ->> IntType)
 337
 338 ////----- Inference for Statements -----
 339 applySubst :: Substitution -> Typing Gamma
 340 applySubst s = changeGamma (subst s)
 341
 342 instance infer Stmt where
 343  infer s = case s of
 344     IfStmt e th el =
 345         infer e >>= \(s1, et, e_)->
 346         lift (unify et BoolType) >>= \s2 ->
 347         applySubst (compose s2 s1) >>|
 348         infer th >>= \(s3, tht, th_)->
 349         applySubst s3 >>|
 350         infer el >>= \(s4, elt, el_)->
 351         applySubst s4 >>|
 352         lift (unify tht elt) >>= \s5->
 353         let sub = compose s5 $ compose s4 $ compose s3 $ compose s2 s1 in
 354         pure (sub, subst s5 tht, IfStmt e_ th_ el_)
 355
 356     WhileStmt e wh =
 357         infer e >>= \(s1, et, e_)->
 358         lift (unify et BoolType) >>= \s2 ->
 359         applySubst (compose s2 s1) >>|
 360         infer wh >>= \(s3, wht, wh_)->
 361         pure (compose s3 $ compose s2 s1, subst s3 wht, WhileStmt e_ wh_)
 362
 363     AssStmt vd=:(VarDef k fs) e =
 364         lookup k >>= \expected ->
 365         infer e >>= \(s1, given, e_)->
 366         foldM reverseFs given (reverse fs) >>= \varType->
 367         lift (unify expected varType) >>= \s2->
 368         let s = compose s2 s1 in
 369         applySubst s >>|
 370         changeGamma (extend k (Forall [] (subst s varType))) >>|
 371         pure (s, VoidType, AssStmt vd e_)
 372
 373     FunStmt f args fs =
 374         lookup f >>= \expected ->
 375         let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
 376         foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
 377         fresh >>= \tv->
 378         let given = foldr (->>) tv argTs in
 379         lift (unify expected given) >>= \s2->
 380         let fReturnType = subst s2 tv in
 381         foldM foldFieldSelectors fReturnType fs >>= \returnType ->
 382         (case f of
 383             "print" = case head argTs of
 384                 IntType = pure "1printint"
 385                 CharType = pure "1printchar"
 386                 BoolType = pure "1printbool"
 387                 ListType (CharType) = pure "1printstr"
 388                 t = liftT $ Left $ SanityError zero ("can not print " +++ toString t)
 389             _ = pure f) >>= \newF->
 390         pure (compose s2 s1, VoidType, FunStmt newF args_ fs)
 391
 392     ReturnStmt Nothing = pure (zero, VoidType, s)
 393     ReturnStmt (Just e) = infer e >>= \(sub, t, e_)-> pure (sub, t, ReturnStmt (Just e_))
 394
 395 reverseFs :: Type FieldSelector -> Typing Type
 396 reverseFs t FieldHd = pure $ ListType t
 397 reverseFs t FieldTl = pure $ ListType t
 398 reverseFs t FieldFst = fresh >>= \tv -> pure $ TupleType (t, tv)
 399 reverseFs t FieldSnd = fresh >>= \tv -> pure $ TupleType (tv, t)
 400
 401 //The type of a list of statements is either an encountered
 402 //return, or VoidType
 403 instance infer [a] | infer a where
 404     infer []        = pure (zero, VoidType, [])
 405     infer [stmt:ss] =
 406         infer stmt >>= \(s1, t1, s_) ->
 407         applySubst s1 >>|
 408         infer ss >>= \(s2, t2, ss_) ->
 409         applySubst s2 >>|
 410         case t1 of
 411             VoidType = pure (compose s2 s1, t2, [s_:ss_])
 412             _ = case t2 of
 413                 VoidType = pure (compose s2 s1, t1, [s_:ss_])
 414                 _ = lift (unify t1 t2) >>= \s3 ->
 415                     pure (compose s3 $ compose s2 s1, t1, [s_:ss_])
 416
 417 //the type class inferes the type of an AST element (VarDecl or FunDecl)
 418 //and adds it to the AST element
 419 class type a :: a -> Typing (Substitution, a)
 420
 421 instance type VarDecl where
 422     type (VarDecl p expected k e) =
 423         infer e >>= \(s1, given, e_) ->
 424         applySubst s1 >>|
 425         case expected of
 426             Nothing = pure zero
 427             Just expected_ = lift (unify expected_ given)
 428         >>= \s2->
 429         applySubst s2 >>|
 430         let vtype = subst (compose s2 s1) given in
 431         generalize vtype >>= \t ->
 432         changeGamma (extend k t) >>|
 433         pure (compose s2 s1, VarDecl p (Just vtype) k e_)
 434
 435 instance type FunDecl where
 436     type fd=:(FunDecl p f args expected vds stmts) =
 437         gamma >>= \outerScope-> //functions are infered in their own scopde
 438         introduce f >>|
 439         mapM introduce args >>= \argTs->
 440         fresh >>= \tempTv ->
 441         let temp = foldr (->>) tempTv argTs in
 442         (case expected of
 443             Just expected_ = lift (unify expected_ temp)
 444             _   = pure zero
 445         ) >>= \s0->
 446         applySubst s0 >>|
 447         type vds >>= \(s1, tVds)->
 448         applySubst s1 >>|
 449         infer stmts >>= \(s2, result, stmts_)->
 450         applySubst s1 >>|
 451         let argTs_ = map (subst $ compose s2 $ compose s1 s0) argTs in
 452         let given = foldr (->>) result argTs_ in
 453         (case expected of
 454             Nothing = pure zero
 455             Just (FuncType expected_) = lift (unify expected_ given)
 456             Just expected_ = lift (unify expected_ given)
 457         ) >>= \s3 ->
 458         let ftype = subst (compose s3 $ compose s2 $ compose s1 s0) given in
 459         (case ftype of
 460             _ ->> _ = pure ftype
 461             _       = pure $ FuncType ftype
 462         ) >>= \ftype_->
 463         generalize ftype_ >>= \t->
 464         putGamma outerScope >>|
 465         changeGamma (extend f t) >>|
 466         pure (compose s3 $ compose s2 $ compose s1 s0,
 467                 FunDecl p f args (Just ftype_) tVds stmts_)
 468
 469 instance type [a] | type a where
 470     type []     = pure (zero, [])
 471     type [v:vs] =
 472         type v >>= \(s1, v_)->
 473         applySubst s1 >>|
 474         type vs >>= \(s2, vs_)->
 475         applySubst (compose s2 s1) >>|
 476         pure (compose s2 s1, [v_:vs_])
 477
 478 introduce :: String -> Typing Type
 479 introduce k =
 480     fresh >>= \tv ->
 481     changeGamma (extend k (Forall [] tv)) >>|
 482     pure tv
 483
 484 instance toString Scheme where
 485     toString (Forall x t) =
 486         concat ["Forall ": intersperse "," x] +++ concat [". ", toString t];
 487
 488 instance toString Gamma where
 489     toString mp =
 490         concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 491
 492 instance toString Substitution where
 493     toString subs =
 494         concat [concat [k, ": ", toString t, "\n"]\\(k, t)<-'Map'.toList subs]
 495
 496 instance toString SemError where
 497     toString (SanityError p e) = concat [toString p,
 498         "SemError: SanityError: ", e]
 499     toString (ParseError p s) = concat [toString p,
 500         "ParseError: ", s]
 501     toString (UnifyError p t1 t2) = concat [toString p,
 502         "Can not unify types, expected|given:\n", toString t1,
 503         "\n", toString t2]
 504     toString (InfiniteTypeError p t) = concat [toString p,
 505         "Infinite type: ", toString t]
 506     toString (FieldSelectorError p t fs) = concat [toString p,
 507         "Can not run fieldselector '", toString fs, "' on type: ",
 508         toString t]
 509     toString (OperatorError p op t) = concat [toString p,
 510         "Operator error, operator '", toString op, "' can not be",
 511         "used on type: ", toString t]
 512     toString (UndeclaredVariableError p k) = concat [toString p,
 513         "Undeclared identifier: ", k]
 514     toString (ArgumentMisMatchError p str) = concat [toString p,
 515         "Argument mismatch: ", str]
 516     toString (Error e) = concat ["Unknown error during semantical",
 517         "analysis: ", e]
 518
 519 instance toString (Maybe a) | toString a where
 520     toString Nothing = "Nothing"
 521     toString (Just e) = concat ["Just ", toString e]
 522
 523 instance MonadTrans (StateT (Gamma, [TVar])) where
 524     liftT m = StateT \s-> m >>= \a-> return (a, s)
 525
 526 Mapmap :: (a->b) ('Map'.Map k a) -> ('Map'.Map k b)
 527 Mapmap _ 'Map'.Tip = 'Map'.Tip
 528 Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v)
 529                                         (Mapmap f ml)
 530                                         (Mapmap f mr)