Merge branch 'master' of github.com:dopefishh/cc1516

[cc1516.git] / sem.icl

diff --git a/sem.icl b/sem.icl
index dc774cc..ef825e4 100644 (file)
--- a/sem.icl
+++ b/sem.icl
@@ -3,12 +3,17 @@ implementation module sem
 import qualified Data.Map as Map
 
 from Data.Func import $
-from StdFunc import o
+from StdFunc import o, flip, const, id
 
+import Control.Monad
 import Data.Either
+import Data.Maybe
+import Data.Monoid
+import Data.List 
 
 import StdString
 import StdList
+import StdMisc
 import StdEnum
 import RWST
 import GenEq
@@ -17,9 +22,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 
@@ -27,16 +33,135 @@ import AST
        | 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 (AST vd fd) = Right $ (AST vd fd, 'Map'.newMap)
+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]
+       toString mp = 
+               concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 
 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