From: Mart Lubbers <mart@martlubbers.net>
Date: Sat, 23 Apr 2016 12:35:25 +0000 (+0200)
Subject: liftT toegevoegd
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=db5038e77428fe6a74d469535d35ce68afcc2e83;p=cc1516.git

liftT toegevoegd
---

diff --git a/RWST.dcl b/RWST.dcl
index 70a07e1..582bb0d 100644
--- a/RWST.dcl
+++ b/RWST.dcl
@@ -2,6 +2,7 @@ definition module RWST
 
 from Control.Applicative import class Applicative
 from Control.Monad import class Monad
+from Control.Monad.Trans import class MonadTrans
 from Data.Functor import class Functor
 from Data.Functor.Identity import :: Identity
 from Data.Monoid import class Monoid, class Semigroup
@@ -22,6 +23,7 @@ withRWS :: (r` s -> (r, s)) (RWS r w s a) -> RWS r` w s a
 instance Functor (RWST r w s m) | Monad m & Monoid w
 instance Applicative (RWST r w s m) | Monad m & Monoid w
 instance Monad (RWST r w s m) | Monad m & Monoid w
+instance MonadTrans (RWST r w s) | Monoid w
 
 runRWST :: (RWST r w s m a) r s -> m (a, s, w)
 evalRWST :: (RWST r w s m a) r s -> m (a, w) | Monad m
diff --git a/RWST.icl b/RWST.icl
index 712f71e..2f02d6d 100644
--- a/RWST.icl
+++ b/RWST.icl
@@ -8,6 +8,7 @@ import Data.Functor.Identity
 import Data.Functor
 import Data.Monoid
 import Control.Monad
+import Control.Monad.Trans
 import Control.Applicative
 
 // The RWS monad 
@@ -46,6 +47,9 @@ instance Monad (RWST r w s m) | Monad m & Monoid w where
 		>>= \(a, s`, w)->runRWST (k a) r s`
 		>>= \(b, s``,w`)->pure (b, s``, mappend w w`)
 
+instance MonadTrans (RWST r w s) | Monoid w where
+	liftT m = RWST \_ s->m >>= \a->pure (a, s, mempty)
+
 runRWST :: (RWST r w s m a) r s -> m (a, s, w)
 runRWST (RWST f) r s = f r s
 
diff --git a/sem.icl b/sem.icl
index ef825e4..365729b 100644
--- a/sem.icl
+++ b/sem.icl
@@ -6,6 +6,7 @@ from Data.Func import $
 from StdFunc import o, flip, const, id
 
 import Control.Monad
+import Control.Monad.Trans
 import Data.Either
 import Data.Maybe
 import Data.Monoid
@@ -96,23 +97,33 @@ fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)
 class infer a :: a -> Infer Type
 
 op2Type :: Op2 -> Infer Type
-op2Type op  | elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
-                = pure (IntType ->> IntType ->> IntType)
-            | elem op [BiEquals, BiUnEqual]
-                = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
-            | elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
-                = pure (IntType ->> IntType ->> BoolType)
-            | elem op [BiAnd, BiOr]
-                = pure (BoolType ->> BoolType ->> BoolType)
-            | op == BiCons 
-                = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
+op2Type op
+| elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
+	= pure (IntType ->> IntType ->> IntType)
+| elem op [BiEquals, BiUnEqual]
+	= fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
+| elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
+	= pure (IntType ->> IntType ->> BoolType)
+| elem op [BiAnd, BiOr]
+	= pure (BoolType ->> BoolType ->> BoolType)
+| op == BiCons 
+	= fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)
 
 op1Type :: Op1 -> Infer Type
 op1Type UnNegation = pure $ (BoolType ->> BoolType)
 op1Type UnMinus = pure $ (IntType ->> IntType)
 
+//instantiate :: Scheme -> Infer Type
+//instantiate (Forall as t) = mapM (const fresh) as
+
+lookupEnv :: String -> Infer Type
+lookupEnv ident = asks ('Map'.get ident)
+	>>= \m->case m of
+		Nothing = liftT $ Left $ UndeclaredVariableError zero ident
+		Just (Forall as t) = pure t //instantiate ???
+
 instance infer Expr where
-	infer (VarExpr _ vd) = undef
+	infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
 	infer (Op2Expr _ e1 op e2) = case op of
 		BiPlus = pure IntType
 		BiMinus = pure IntType