X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=23fb04aa5aa1778bf3c6ed436b7898b3736600b6;hb=13a108705dbabbc75711ce9b3b29fe508262919f;hp=99aa44a41f9b8cbf51d10dd8e3702fb74c222f13;hpb=df7fbaaf21817473f51525a2c8f03b0a5a37b823;p=cc1516.git

diff --git a/sem.icl b/sem.icl
index 99aa44a..23fb04a 100644
--- a/sem.icl
+++ b/sem.icl
@@ -1,110 +1,116 @@
 implementation module sem
 
 import qualified Data.Map as Map
+
 from Data.Func import $
-import Data.Maybe
-import Data.Either
-import Data.Functor
-import Control.Applicative
+from StdFunc import o
+
 import Control.Monad
-import Control.Monad.State
-import Control.Monad.Identity
-import StdMisc
-from StdFunc import id, const
+import Data.Either
+import Data.Monoid
+
 import StdString
 import StdList
+import StdMisc
+import StdEnum
+import RWST
+import GenEq
 
 from Text import class Text(concat), instance Text String
 
 import AST
-from parse import :: ParserOutput, :: Error
 
-:: Gamma :== 'Map'.Map String Type
-:: Env a :== (State 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 
+    | FieldSelectorError Pos Type FieldSelector 
+	| OperatorError Pos Op2 Type
+    | UndeclaredVariableError Pos String
+    | ArgumentMisMatchError Pos String
+	| Error String
 
-instance toString SemError where
-	toString (ParseError p e) = concat [
-		toString p,"SemError: ParseError: ", e]
-	toString (Error e) = "SemError: " +++ e
-	toString (UnifyError p t1 t2) = concat [
-		toString p,
-		"SemError: Cannot unify types. Expected: ",
-		toString t1, ". Given: ", toString t2]
+variableStream :: [String]
+variableStream = map toString [1..]
 
 sem :: AST -> SemOutput
-sem (AST vd fd)
-# (eithervds, gamma) = runState (mapM semVarDecl vd) 'Map'.newMap
-# (eitherfds, gamma) = runState (mapM semFunDecl fd) gamma
-= case splitEithers eithervds of
-	(Left errs) = Left $ errs ++ [x\\(Left x)<-eitherfds]
-	(Right vds) = case splitEithers eitherfds of
-		(Left errs) = Left errs
-		(Right fds) = Right $ AST vds fds
-
-splitEithers :: [Either a b] -> Either [a] [b]
-splitEithers [] = Right []
-splitEithers [Right x:xs] = splitEithers xs >>= \rest->Right [x:rest]
-splitEithers xs = Left $ [x\\(Left x)<-xs]
-
-semFunDecl :: FunDecl -> Env FunDecl
-semFunDecl f = pure $ Right f
-
-semVarDecl :: VarDecl -> Env VarDecl
-semVarDecl v = pure $ Right v
-//Right v
-//semVarDecl vd=:(VarDecl pos type ident expr) = case unify type expr of
-//	Left e = Left e
-//	//TODO ident in de environment
-//	Right e = Right $ pure vd
-//
-//typeExpr :: Expr -> Env Type
-//typeExpr (IntExpr _ _) = Right $ pure IntType
-//typeExpr (CharExpr _ _) = Right $ pure CharType
-//typeExpr (BoolExpr _ _) = Right $ pure BoolType
-//typeExpr (Op1Expr p UnNegation expr) = undef//typeExpr expr 
-////	>>= \exprtype->case exprtype of
-////		Right BoolType = Right $ pure BoolType
-////		t = Left $ UnifyError p BoolType exprtype
-//typeExpr (Op1Expr p UnMinus expr) = undef// typeExpr expr 
-////	>>= \exprtype->case exprtype of
-////		IntType = Right $ pure IntType
-////		t = Left $ UnifyError p IntType exprtype
-//// typeExpr (Op2Expr Pos Expr Op2 Expr) = undef
-////typeExpr (FunExpr Pos FunCall
-////typeExpr (EmptyListExpr Pos 
-////typeExpr (TupleExpr Pos (Expr, Expr)
-////typeExpr (VarExpr Pos VarDef) = undef
-////
-//class unify a :: Type a -> Env a
-//
-//instance unify Type where
-//	unify IntType IntType = Right $ pure IntType
-//	unify BoolType BoolType = Right $ pure BoolType
-//	unify CharType CharType = Right $ pure CharType
-//	unify _ _ = undef
-//
-//instance unify Expr where
-//	unify type expr = case type of
-//		_ ->> _ = Left $ ParseError (extrPos expr)
-//			"Expression cannot be a higher order function. Yet..."
-//		VoidType = Left $ ParseError (extrPos expr)
-//			"Expression cannot be a Void type."
-//		IdType _ = Left $ ParseError (extrPos expr)
-//			"Expression cannot be an polymorf type."
-//		TupleType (_, _) = undef
-//		ListType _ = undef
-//		IntType = undef
-//		BoolType = undef
-//		CharType = undef
-//		VarType = undef
-//
-//extrPos :: Expr -> Pos
-//extrPos (VarExpr p _) = p
-//extrPos (Op2Expr p _ _ _) = p
-//extrPos (Op1Expr p _ _) = p
-//extrPos (IntExpr p _) = p
-//extrPos (CharExpr p _) = p
-//extrPos (BoolExpr p _) = p
-//extrPos (FunExpr p _) = p
-//extrPos (EmptyListExpr p) = p
-//extrPos (TupleExpr p _) = p
+sem (AST fd) = Right (AST 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 _ _ _ _) = 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