From 392b823861ae02cc42454abce8c97e606931c3d6 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 20 Apr 2016 16:29:35 +0200
Subject: [PATCH] small update, inference

---
 RWST.dcl |  7 +++--
 RWST.icl | 11 ++++----
 sem.icl  | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++++---
 3 files changed, 83 insertions(+), 13 deletions(-)

diff --git a/RWST.dcl b/RWST.dcl
index 334df7e..70a07e1 100644
--- a/RWST.dcl
+++ b/RWST.dcl
@@ -2,7 +2,6 @@ definition module RWST
 
 from Control.Applicative import class Applicative
 from Control.Monad import class Monad
-from Data.Void import :: Void
 from Data.Functor import class Functor
 from Data.Functor.Identity import :: Identity
 from Data.Monoid import class Monoid, class Semigroup
@@ -36,7 +35,7 @@ local :: (r -> r) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m
 asks :: (r -> a) -> RWST r w s m a | Monoid w & Monad m
 
 // Writer operations
-tell :: w -> RWST r w s m Void | Monoid w & Monad m
+tell :: w -> RWST r w s m () | Monoid w & Monad m
 listen :: (RWST r w s m a) -> RWST r w s m (a, w) | Monoid w & Monad m
 pass :: (RWST r w s m (a, w -> w)) -> RWST r w s m a | Monoid w & Monad m
 listens :: (w -> b) (RWST r w s m a) -> RWST r w s m (a, b)| Monoid w & Monad m
@@ -44,8 +43,8 @@ censor :: (w -> w) (RWST r w s m a) -> RWST r w s m a | Monoid w & Monad m
 
 // State operations
 get :: RWST r w s m s | Monoid w & Monad m
-put :: s -> RWST r w s m Void | Monoid w & Monad m
-modify :: (s -> s) -> RWST r w s m Void | Monoid w & Monad m
+put :: s -> RWST r w s m () | Monoid w & Monad m
+modify :: (s -> s) -> RWST r w s m () | Monoid w & Monad m
 gets :: (s -> a) -> RWST r w s m a | Monoid w & Monad m
 
 // Lifting other operations
diff --git a/RWST.icl b/RWST.icl
index 9caa0e6..712f71e 100644
--- a/RWST.icl
+++ b/RWST.icl
@@ -4,7 +4,6 @@ from StdFunc import o
 import StdTuple
 
 from Data.Func import $
-import Data.Void
 import Data.Functor.Identity
 import Data.Functor
 import Data.Monoid
@@ -73,8 +72,8 @@ asks :: (r -> a) -> RWST r w s m a | Monoid w & Monad m
 asks f = ask >>= \r->pure $ f r
 
 // Writer operations
-tell :: w -> RWST r w s m Void | Monoid w & Monad m
-tell w = RWST \_ s->pure (Void, s,w)
+tell :: w -> RWST r w s m () | Monoid w & Monad m
+tell w = RWST \_ s->pure ((), s,w)
 
 listen :: (RWST r w s m a) -> RWST r w s m (a, w) | Monoid w & Monad m
 listen m = RWST \r s->runRWST m r s >>= \(a, s`, w)->pure ((a, w), s`, w)
@@ -92,10 +91,10 @@ censor f m = pass $ m >>= \a->pure (a, f)
 get :: RWST r w s m s | Monoid w & Monad m
 get = RWST \_ s->pure (s, s, mempty)
 
-put :: s -> RWST r w s m Void | Monoid w & Monad m
-put s = RWST \_ _->pure (Void, s, mempty)
+put :: s -> RWST r w s m () | Monoid w & Monad m
+put s = RWST \_ _->pure ((), s, mempty)
 
-modify :: (s -> s) -> RWST r w s m Void | Monoid w & Monad m
+modify :: (s -> s) -> RWST r w s m () | Monoid w & Monad m
 modify f = get >>= \s->put $ f s
  
 gets :: (s -> a) -> RWST r w s m a | Monoid w & Monad m
diff --git a/sem.icl b/sem.icl
index dc774cc..fa081d4 100644
--- a/sem.icl
+++ b/sem.icl
@@ -5,10 +5,13 @@ import qualified Data.Map as Map
 from Data.Func import $
 from StdFunc import o
 
+import Control.Monad
 import Data.Either
+import Data.Monoid
 
 import StdString
 import StdList
+import StdMisc
 import StdEnum
 import RWST
 import GenEq
@@ -17,9 +20,10 @@ from Text import class Text(concat), instance Text String
 
 import AST
 
-:: Gamma :== 'Map'.Map String Type
-:: Constraint :== String
-:: Infer a :== RWST [String] [Constraint] Gamma (Either SemError) a
+:: Scheme = Forall [String] Type
+:: Gamma :== 'Map'.Map String Scheme
+:: Constraints :== [(Type, Type)]
+:: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
 :: SemError
 	= ParseError Pos String 
 	| UnifyError Pos Type Type 
@@ -35,8 +39,76 @@ variableStream = map toString [1..]
 sem :: AST -> SemOutput
 sem (AST vd fd) = Right $ (AST vd fd, 'Map'.newMap)
 
+instance toString Scheme where
+	toString (Forall x t) = concat ["Forall ": map ((+++) "\n") x] +++ toString t
+
 instance toString Gamma where
 	toString mp = concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 
 instance toString SemError where
 	toString se = "SemError: "
+
+uni :: Type Type -> Infer ()
+uni t1 t2 = tell [(t1, t2)]
+
+inEnv :: (String, Scheme) (Infer a) -> (Infer a)
+inEnv (x, sc) m = local scope m
+	where
+		scope e = 'Map'.put x sc ('Map'.del x e )
+
+class infer a :: a -> Infer Type
+
+instance infer Expr where
+	infer (VarExpr _ vd) = undef
+	infer (Op2Expr _ e1 op e2) = case op of
+		BiPlus = pure IntType
+		BiMinus = pure IntType
+		BiTimes = pure IntType
+		BiDivide = pure IntType
+		BiMod = pure IntType
+		BiLesser = pure IntType
+		BiGreater = pure IntType
+		BiLesserEq = pure IntType
+		BiGreaterEq = pure IntType
+		BiAnd = pure BoolType
+		BiOr = pure BoolType
+		BiEquals = infer e1
+		BiUnEqual = infer e1 // maybe check e2?
+		BiCons = infer e1 >>= \it1->pure $ ListType it1
+	infer (Op1Expr _ op e) = case op of
+		UnMinus = pure IntType
+		UnNegation = pure BoolType
+	infer (IntExpr _ _) = pure IntType
+	infer (CharExpr _ _) = pure CharType
+	infer (BoolExpr _ _) = pure BoolType
+	infer (FunExpr _ fc) = undef
+	infer (EmptyListExpr _) = undef
+	infer (TupleExpr _ (e1, e2)) =
+		infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)
+
+//:: VarDef = VarDef String [FieldSelector]
+//:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
+//:: Op1 = UnNegation | UnMinus
+//:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
+//	BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
+//:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
+//:: FunCall = FunCall String [Expr]
+//:: Stmt 
+//	= IfStmt Expr [Stmt] [Stmt]
+//	| WhileStmt Expr [Stmt]
+//	| AssStmt VarDef Expr
+//	| FunStmt FunCall
+//	| ReturnStmt (Maybe Expr)
+//:: Pos = {line :: Int, col :: Int}
+//:: AST = AST [VarDecl] [FunDecl]
+//:: VarDecl = VarDecl Pos Type String Expr
+//:: Type 
+//	= TupleType (Type, Type)
+//	| ListType Type
+//	| IdType String 
+//	| IntType 
+//	| BoolType
+//	| CharType
+//	| VarType
+//    | VoidType
+//    | (->>) infixl 7 Type Type
-- 
2.20.1