X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=ef825e4009a130aa2bf50df0d65de5676eae386b;hb=5573b4ce8215a277a82146a8dae4c4e7ef205bd8;hp=6c788545afd143990f050128583df1806b8bd4c8;hpb=a5e0570125597dc2ecd76ff7435acd92c6b7adef;p=cc1516.git

diff --git a/sem.icl b/sem.icl
index 6c78854..ef825e4 100644
--- a/sem.icl
+++ b/sem.icl
@@ -1,163 +1,167 @@
 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, flip, const, id
+
 import Control.Monad
-import Control.Monad.State
-import Control.Monad.Identity
-import StdMisc
-from StdFunc import id, const
+import Data.Either
+import Data.Maybe
+import Data.Monoid
+import Data.List 
+
 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 = Env (State Gamma (Either SemError a))
-
-instance Functor Env where
-    fmap f m = liftM f m
-
-instance Applicative Env where
-    (<*>) f g   = ap f g
-    pure  a     = Env $ pure $ Right a
-
-//instance Alternative Env where
-//    empty       = Env $ pure $ Left (Error "Undefined error")
-//    (<|>) f g   = f >>= \ef -> g >>= \eg -> Env $ pure $ case ef of 
-//        Left e  = eg
-//        Right r = Right r
-
-instance Monad Env where
-    bind e f    = e >>= \ee -> Env $ pure $ case ee of
-        (Left e) = Left e
-        (Right r) = f r
-
-get = state $ \s -> (s,s)
-
-instance toString SemError where
-    toString (ParseError p e) = concat [
-        toString p,"SemError: ParseError: ", e]
-    toString (Error e) = "SemError: " +++ e
-    toString (UnifyErrorStub t1 t2) = toString (UnifyError {line=0,col=0} t1 t2)
-    toString (UnifyError p t1 t2) = concat [
-        toString p,
-        "SemError: Cannot unify types. Expected: ",
-        toString t1, ". Given: ", toString t2]
+:: 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
+	| SanityError Pos String
+	| Error String
+
+variableStream :: [String]
+variableStream = map toString [1..]
 
 sem :: AST -> SemOutput
-sem x = undef
-/*
-putIdent :: String Type -> Env Void
-putIdent i t = gets ('Map'.get i) >>= \mt -> case mt of
-    Nothing = pure <$> modify ('Map'.put i t)
-    Just t2 = unify t t2 >>= \r -> case r of
-        Left e  = pure $ Left e
-        Right t3 = pure <$> modify ('Map'.put i t3)
+sem a=:(AST fd) = case foldM (const $ hasNoDups fd) () fd 
+		>>| foldM (const isNiceMain) () fd
+		>>| hasMain fd of
+	Left e = Left [e]
+	_ = pure (a, 'Map'.newMap)
+where
+		hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
+		hasNoDups fds (FunDecl p n _ _ _ _)
+		# mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
+		= case catMaybes mbs of
+			[] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
+			[x] = pure ()
+			[_:x] = Left $ SanityError p (concat 
+				[n, " multiply defined at ", toString p])
+
+		hasMain :: [FunDecl] -> Either SemError ()
+		hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
+		hasMain [_:fd] = hasMain fd
+		hasMain [] = Left $ SanityError zero "no main function defined"
+
+		isNiceMain :: FunDecl -> Either SemError ()
+		isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
+			([_:_], _) = Left $ SanityError p "main must have arity 0"
+			([], t) = (case t of
+				Nothing = pure ()
+				Just VoidType = pure ()
+				_ = Left $ SanityError p "main has to return Void")
+		isNiceMain _ = pure ()
+
+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]
 
-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 vd=:(VarDecl pos type ident ex) = unify type ex
-	>>= \et->case et of
-		Left err = pure $ Left err
-		Right t = putIdent ident t >>| pure (Right $ VarDecl pos t ident ex)
-
-typeExpr :: Expr -> Env Type
-typeExpr (IntExpr _ _) = pure $ Right IntType
-typeExpr (CharExpr _ _) = pure $ Right CharType
-typeExpr (BoolExpr _ _) = pure $ Right BoolType
-typeExpr (Op1Expr p UnNegation expr) = unify BoolType expr
-typeExpr (Op1Expr p UnMinus expr) = unify IntType expr
-typeExpr (TupleExpr p (e1, e2)) = typeExpr e1 
-	>>= \ete1->typeExpr e2 >>= \ete2->pure (
-		ete1 >>= \te1->ete2 >>= \te2->Right $ TupleType (te1, te2))
-//Int
-typeExpr (Op2Expr p e1 BiPlus e2) = unify IntType e1 >>| unify IntType e2
-typeExpr (Op2Expr p e1 BiMinus e2) = unify IntType e1 >>| unify IntType e2
-typeExpr (Op2Expr p e1 BiTimes e2) = unify IntType e1 >>| unify IntType e2
-typeExpr (Op2Expr p e1 BiDivide e2) = unify IntType e1 >>| unify IntType e2
-typeExpr (Op2Expr p e1 BiMod e2) = unify IntType e1 >>| unify IntType e2
-//bool, char of int
-typeExpr (Op2Expr p e1 BiEquals e2) = undef
-typeExpr (Op2Expr p e1 BiUnEqual e2) = undef
-//char of int
-typeExpr (Op2Expr p e1 BiLesser e2) = undef
-typeExpr (Op2Expr p e1 BiGreater e2) = undef
-typeExpr (Op2Expr p e1 BiLesserEq e2) = undef
-typeExpr (Op2Expr p e1 BiGreaterEq e2) = undef
-//bool
-typeExpr (Op2Expr p e1 BiAnd e2) = undef
-typeExpr (Op2Expr p e1 BiOr e2) = undef
-//a
-typeExpr (Op2Expr p e1 BiCons e2) = undef
-//typeExpr (FunExpr Pos FunCall) = undef
-//typeExpr (EmptyListExpr Pos) = undef
-//typeExpr (VarExpr Pos VarDef) = undef //when checking var-expr, be sure to put the infered type
-                                        //in the context
-
-class unify a :: Type a -> Env Type
-
-instance unify Expr where
-	unify (_ ->> _) e = pure $ Left $ ParseError (extrPos e)
-			"Expression cannot be a higher order function. Yet..."
-	unify VoidType e = pure $ Left $ ParseError (extrPos e)
-			"Expression cannot be a Void type."
-	unify (IdType _) e = pure $ Left $ ParseError (extrPos e)
-			"Expression cannot be an polymorf type."
-    unify VarType e = typeExpr e
-	unify t e = typeExpr e
-		>>= \eithertype->case eithertype of
-			Left e = pure $ Left e
-			Right tex = unify t tex >>= \eitherun->case eitherun of
-				Left err = pure $ Left $ decErr e err
-				Right t = pure $ Right t
-
-instance unify Type where
-	unify IntType IntType = pure $ Right IntType
-	unify BoolType BoolType = pure $ Right BoolType
-	unify CharType CharType = pure $ Right CharType
-	unify t1 t2 = pure $ Left $ UnifyError zero t1 t2
-
-instance zero Pos where
-	zero = {line=0,col=0}
-
-decErr :: Expr SemError -> SemError
-decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
-decErr e (ParseError _ s) = ParseError (extrPos e) s
-decErr e err = err
-
-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
-*/
\ No newline at end of file
+instance toString SemError where
+	toString (SanityError p e) = concat [toString p, 
+		"SemError: SanityError: ", e]
+	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 )
+
+fresh :: Infer Type
+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)
+
+op1Type :: Op1 -> Infer Type
+op1Type UnNegation = pure $ (BoolType ->> BoolType)
+op1Type UnMinus = pure $ (IntType ->> IntType)
+
+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