sem.icl

   1 implementation module sem
   2
   3 import qualified Data.Map as Map
   4
   5 from Data.Func import $
   6 from StdFunc import o, flip, const, id
   7
   8 import Control.Monad
   9 import Control.Monad.Trans
  10 import Data.Either
  11 import Data.Maybe
  12 import Data.Monoid
  13 import Data.List
  14 import Data.Functor
  15
  16 import StdString
  17 import StdList
  18 import StdMisc
  19 import StdEnum
  20 import RWST
  21 import GenEq
  22
  23 from Text import class Text(concat), instance Text String
  24
  25 import AST
  26
  27
  28 :: Scheme = Forall [TVar] Type
  29 :: Gamma :== 'Map'.Map String Scheme //map from Variables! to types
  30 :: Substitution :== 'Map'.Map TVar Type
  31 :: Constraints :== [(Type, Type)]
  32 :: Infer a :== RWST Gamma Constraints [String] (Either SemError) a
  33 :: SemError
  34         = ParseError Pos String
  35         | UnifyError Pos Type Type
  36     | FieldSelectorError Pos Type FieldSelector
  37         | OperatorError Pos Op2 Type
  38     | UndeclaredVariableError Pos String
  39     | ArgumentMisMatchError Pos String
  40         | SanityError Pos String
  41         | Error String
  42
  43 instance zero Gamma where
  44         zero = 'Map'.newMap
  45
  46 variableStream :: [String]
  47 variableStream = map toString [1..]
  48
  49 sem :: AST -> Either [SemError] Constraints
  50 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd
  51                 >>| foldM (const isNiceMain) () fd
  52                 >>| hasMain fd of
  53         Left e = Left [e]
  54         _ = case execRWST (constraints fd) zero variableStream of
  55                 Left e = Left [e]
  56                 Right (a, b) = Right b
  57 where
  58                 constraints :: [FunDecl] -> Infer ()
  59         constraints _ = pure ()
  60         //TODO: fix
  61                 //constraints fds = mapM_ funconstraint fds >>| pure ()
  62
  63                 funconstraint :: FunDecl -> Infer ()
  64                 funconstraint fd=:(FunDecl _ ident args mt vardecls stmts) = case mt of
  65                         Nothing = abort "Cannot infer functions yet"
  66                         Just t = inEnv (ident, (Forall [] t)) (
  67                                 mapM_ vardeclconstraint vardecls >>| pure ())
  68
  69                 vardeclconstraint :: VarDecl -> Infer ()
  70         vardeclconstraint _ = pure ()
  71         //TODO: fix!
  72                 //vardeclconstraint (VarDecl p mt ident expr) = infer expr
  73                         //>>= \it->inEnv (ident, (Forall [] it)) (pure ())
  74
  75                 hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
  76                 hasNoDups fds (FunDecl p n _ _ _ _)
  77                 # mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
  78                 = case catMaybes mbs of
  79                         [] = Left $ SanityError p "HUH THIS SHOULDN'T HAPPEN"
  80                         [x] = pure ()
  81                         [_:x] = Left $ SanityError p (concat
  82                                 [n, " multiply defined at ", toString p])
  83
  84                 hasMain :: [FunDecl] -> Either SemError ()
  85                 hasMain [(FunDecl _ "main" _ _ _ _):fd] = pure ()
  86                 hasMain [_:fd] = hasMain fd
  87                 hasMain [] = Left $ SanityError zero "no main function defined"
  88
  89                 isNiceMain :: FunDecl -> Either SemError ()
  90                 isNiceMain (FunDecl p "main" as mt _ _) = case (as, mt) of
  91                         ([_:_], _) = Left $ SanityError p "main must have arity 0"
  92                         ([], t) = (case t of
  93                                 Nothing = pure ()
  94                                 Just VoidType = pure ()
  95                                 _ = Left $ SanityError p "main has to return Void")
  96                 isNiceMain _ = pure ()
  97
  98 instance toString Scheme where
  99         toString (Forall x t) =
 100                 concat ["Forall ": map ((+++) "\n") x] +++ toString t
 101
 102 instance toString Gamma where
 103         toString mp =
 104                 concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 105
 106 instance toString SemError where
 107         toString (SanityError p e) = concat [toString p,
 108                 "SemError: SanityError: ", e]
 109         toString se = "SemError: "
 110
 111 inEnv :: (String, Scheme) (Infer a) -> Infer a
 112 inEnv (x, sc) m = local ('Map'.put x sc) m
 113
 114 class Typeable a where
 115     ftv :: a -> [TVar]
 116     subst :: Substitution a -> a
 117
 118 instance Typeable Scheme where
 119     ftv (Forall bound t) = difference (ftv t) bound
 120     subst s (Forall bound t) = Forall bound $ subst s_ t
 121         where s_ = 'Map'.filterWithKey (\k _ -> not (elem k bound)) s
 122
 123 instance Typeable [a] | Typeable a where
 124     ftv types   = foldr (\t ts-> ftv t ++ ts) [] types
 125     subst s ts  = map (\t->subst s t) ts
 126
 127 instance Typeable Type where
 128     ftv (TupleType (t1, t2))    = ftv t1 ++ ftv t2
 129     ftv (ListType t)            = ftv t
 130     ftv (IdType tvar)           = [tvar]
 131     ftv (t1 ->> t2)             = ftv t1 ++ ftv t2
 132     ftv _                       = []
 133     subst s (TupleType (t1, t2))= TupleType (subst s t1, subst s t2)
 134     subst s (ListType t1)       = ListType (subst s t1)
 135     subst s (t1 ->> t2)         = (subst s t1) ->> (subst s t2)
 136     subst s t1=:(IdType tvar)   = 'Map'.findWithDefault t1 tvar s
 137     subst s t                   = t
 138
 139 instance Typeable Gamma where
 140     ftv gamma       = concatMap id $ map ftv ('Map'.elems gamma)
 141     subst s gamma   = Mapmap (subst s) gamma
 142
 143 //// ------------------------
 144 //// algorithm U, Unification (outside of Monad)
 145 //// ------------------------
 146 instance zero Substitution where zero = 'Map'.newMap
 147 compose :: Substitution Substitution -> Substitution
 148 compose s1 s2 = undef
 149 //unify ::
 150
 151
 152
 153
 154 Mapmap :: (a->b) ('Map'.Map k a) -> ('Map'.Map k b)
 155 Mapmap _ 'Map'.Tip = 'Map'.Tip
 156 Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v)
 157                                         (Mapmap f ml)
 158                                         (Mapmap f mr)
 159
 160 //// ------------------------
 161 //// First step: Inference
 162 //// ------------------------//
 163
 164 //unify :: Type Type -> Infer ()
 165 //unify t1 t2 = tell [(t1, t2)]//
 166
 167 //fresh :: Infer Type
 168 //fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)//
 169
 170 //op2Type :: Op2 -> Infer Type
 171 //op2Type op
 172 //| elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
 173 //      = pure (IntType ->> IntType ->> IntType)
 174 //| elem op [BiEquals, BiUnEqual]
 175 //      = fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
 176 //| elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
 177 //      = pure (IntType ->> IntType ->> BoolType)
 178 //| elem op [BiAnd, BiOr]
 179 //      = pure (BoolType ->> BoolType ->> BoolType)
 180 //| op == BiCons
 181 //      = fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)//
 182
 183 //op1Type :: Op1 -> Infer Type
 184 //op1Type UnNegation = pure $ (BoolType ->> BoolType)
 185 //op1Type UnMinus = pure $ (IntType ->> IntType)//
 186
 187 ////instantiate :: Scheme -> Infer Type
 188 ////instantiate (Forall as t) = mapM (const fresh) as//
 189
 190 //lookupEnv :: String -> Infer Type
 191 //lookupEnv ident = asks ('Map'.get ident)
 192 //      >>= \m->case m of
 193 //              Nothing = liftT $ Left $ UndeclaredVariableError zero ident
 194 //              Just (Forall as t) = pure t //instantiate ???//
 195
 196 //class infer a :: a -> Infer Type
 197 //instance infer Expr where
 198 //      infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
 199 //    infer (Op2Expr _ e1 op e2) =
 200 //        infer e1 >>= \t1 ->
 201 //        infer e2 >>= \t2 ->
 202 //        fresh >>= \frsh ->
 203 //        let given = t1 ->> (t2 ->> frsh) in
 204 //        op2Type op >>= \expected ->
 205 //        unify expected given >>|
 206 //        return frsh
 207 //      infer (Op1Expr _ op e) =
 208 //        infer e >>= \t1 ->
 209 //        fresh >>= \frsh ->
 210 //        let given = t1 ->> frsh in
 211 //        op1Type op >>= \expected ->
 212 //        unify expected given >>|
 213 //        pure frsh
 214 //      infer (IntExpr _ _) = pure IntType
 215 //      infer (CharExpr _ _) = pure CharType
 216 //      infer (BoolExpr _ _) = pure BoolType
 217 //      infer (FunExpr _ f args sels) =  //todo, iets met field selectors
 218 //        lookupEnv f >>= \expected ->
 219 //        fresh >>= \frsh ->
 220 //        mapM infer args >>= \argTypes ->
 221 //        let given = foldr (->>) frsh argTypes in
 222 //        unify expected given >>|
 223 //        pure frsh
 224 //      infer (EmptyListExpr _) = ListType <$> fresh
 225 //      infer (TupleExpr _ (e1, e2)) =
 226 //              infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)//
 227
 228 ////:: VarDef = VarDef String [FieldSelector]
 229 ////:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
 230 ////:: Op1 = UnNegation | UnMinus
 231 ////:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
 232 ////    BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
 233 ////:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
 234 ////:: FunCall = FunCall String [Expr]
 235 ////:: Stmt
 236 ////    = IfStmt Expr [Stmt] [Stmt]
 237 ////    | WhileStmt Expr [Stmt]
 238 ////    | AssStmt VarDef Expr
 239 ////    | FunStmt FunCall
 240 ////    | ReturnStmt (Maybe Expr)
 241 ////:: Pos = {line :: Int, col :: Int}
 242 ////:: AST = AST [VarDecl] [FunDecl]
 243 ////:: VarDecl = VarDecl Pos Type String Expr
 244 ////:: Type
 245 ////    = TupleType (Type, Type)
 246 ////    | ListType Type
 247 ////    | IdType String
 248 ////    | IntType
 249 ////    | BoolType
 250 ////    | CharType
 251 ////    | VarType
 252 ////    | VoidType
 253 ////    | (->>) infixl 7 Type Type