Merge pull request #7 from choeger/master

Simplify TI Monad

AlgorithmW.cabal

@@ -23,5 +23,5 @@ source-repository head
 
 executable AlgorithmW
   main-is:             AlgorithmW.lhs
-  build-depends:       base >=4.5 && <4.10, containers >=0.4 && <0.6, mtl >=2.2.1 && <2.3, pretty >=1.1 && <1.2
+  build-depends:       base >=4.5 && <4.11, containers >=0.4 && <0.6, mtl >=2.2.1 && <2.3, pretty >=1.1 && <1.2
   default-language:    Haskell2010

AlgorithmW.lhs

@@ -212,22 +212,19 @@ into details here.
 \begin{code}
 data TIEnv = TIEnv  {}
 
-data TIState = TIState {  tiSupply :: Int,
-                          tiSubst :: Subst}
+type TIState = Int
 
-type TI a = ExceptT String (ReaderT TIEnv (State TIState)) a
+type TI a = ExceptT String (State TIState) a
 
 runTI :: TI a -> (Either String a, TIState)
-runTI t = runState (runReaderT (runExceptT t) initTIEnv) initTIState
-  where initTIEnv = TIEnv{}
-        initTIState = TIState{tiSupply = 0,
-                              tiSubst = Map.empty}
+runTI t = runState (runExceptT t) initTIState
+  where initTIState = 0
 
 newTyVar :: String -> TI Type
 newTyVar prefix =
     do  s <- get
-        put s{tiSupply = tiSupply s + 1}
-        return (TVar  (prefix ++ show (tiSupply s)))
+        put (s + 1)
+        return (TVar  (prefix ++ show s))
 \end{code}
 %
 The instantiation function replaces all bound type variables in a type
@@ -254,7 +251,7 @@ mgu (TVar u) t               =  varBind u t
 mgu t (TVar u)               =  varBind u t
 mgu TInt TInt                =  return nullSubst
 mgu TBool TBool              =  return nullSubst
-mgu t1 t2                    =  throwError $ "types do not unify: " ++ show t1 ++ 
+mgu t1 t2                    =  throwError $ "types do not unify: " ++ show t1 ++
                                 " vs. " ++ show t2
 
 varBind :: String -> Type -> TI Subst
@@ -282,7 +279,7 @@ the type of the expression.
 %
 \begin{code}
 ti        ::  TypeEnv -> Exp -> TI (Subst, Type)
-ti (TypeEnv env) (EVar n) = 
+ti (TypeEnv env) (EVar n) =
     case Map.lookup n env of
        Nothing     ->  throwError $ "unbound variable: " ++ n
        Just sigma  ->  do  t <- instantiate sigma
@@ -415,15 +412,15 @@ instance Show Exp where
 prExp                  ::  Exp -> PP.Doc
 prExp (EVar name)      =   PP.text name
 prExp (ELit lit)       =   prLit lit
-prExp (ELet x b body)  =   PP.text "let" PP.<+> 
+prExp (ELet x b body)  =   PP.text "let" PP.<+>
                            PP.text x PP.<+> PP.text "=" PP.<+>
                            prExp b PP.<+> PP.text "in" PP.$$
                            PP.nest 2 (prExp body)
 prExp (EApp e1 e2)     =   prExp e1 PP.<+> prParenExp e2
 prExp (EAbs n e)       =   PP.char '\\' PP.<+> PP.text n PP.<+>
                            PP.text "->" PP.<+>
                            prExp e
-                                                                   
+
 
 prParenExp    ::  Exp -> PP.Doc
 prParenExp t  =   case t of
@@ -444,7 +441,7 @@ instance Show Scheme where
 
 prScheme                  ::  Scheme -> PP.Doc
 prScheme (Scheme vars t)  =   PP.text "All" PP.<+>
-                              PP.hcat 
+                              PP.hcat
                                 (PP.punctuate PP.comma (map PP.text vars))
                               PP.<> PP.text "." PP.<+> prType t
 \end{code}
@@ -472,9 +469,9 @@ prConstraint (CEquivalent t1 t2) = PP.hsep [prType t1, PP.text "=", prType t2]
 prConstraint (CExplicitInstance t s) =
     PP.hsep [prType t, PP.text "<~", prScheme s]
 prConstraint (CImplicitInstance t1 m t2) =
-    PP.hsep [prType t1, 
-             PP.text "<=" PP.<> 
-               PP.parens (PP.hcat (PP.punctuate PP.comma (map PP.text (Set.toList m)))), 
+    PP.hsep [prType t1,
+             PP.text "<=" PP.<>
+               PP.parens (PP.hcat (PP.punctuate PP.comma (map PP.text (Set.toList m)))),
              prType t2]
 
 type Assum = [(String, Type)]