implementation module sem
-from Data.Map import :: Map
+import qualified Data.Map as Map
+
+from Data.Func import $
+from StdFunc import o, flip, const, id
+
+import Control.Monad
import Data.Either
-import Control.Monad.State
+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
-from yard import :: Error
-:: Gamma :== Map String Type
-:: Env a :== State Gamma 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
+ | SanityError Pos String
+ | Error String
+
+variableStream :: [String]
+variableStream = map toString [1..]
+
+sem :: AST -> SemOutput
+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]
+
+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
-sem :: ParserOutput -> SemOutput
-sem (Left p) = Left p
-sem (Right (AST vd fd)) = undef
-// foldM semVarDecl vd
-// >>= \gamma ->foldM typecheck gamma fd
+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)
-semVarDecl :: Env VarDecl
-semVarDecl = undef
-
+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
repositories / cc1516.git / blobdiff