sem.icl

   1 implementation module sem
   2
   3 import qualified Data.Map as Map
   4 from Data.Func import $
   5 import Data.Maybe
   6 import Data.Void
   7 import Data.Either
   8 import Data.Functor
   9 import Control.Applicative
  10 import Control.Monad
  11 import Control.Monad.State
  12 import Control.Monad.Identity
  13 import Math.Random
  14 import Control.Monad.Trans
  15 import StdMisc
  16 from StdFunc import id, const, o
  17 import StdString
  18 import StdTuple
  19 import StdList
  20 import StdBool
  21 import GenEq
  22
  23 from Text import class Text(concat), instance Text String
  24
  25 import AST
  26 from parse import :: ParserOutput, :: Error
  27
  28 :: Gamma :== ('Map'.Map String Type, [String])
  29 :: Env a :== StateT Gamma (Either SemError) a
  30 //StateT (Gamma -> Either SemError (a, Gamma))
  31
  32 //we need to redefine this even though it is in Control.Monad.State
  33 instance MonadTrans (StateT Gamma) where
  34     liftT m = StateT \s-> m >>= \a-> return (a, s)
  35
  36 get :== gets id
  37
  38 sem :: AST -> SemOutput
  39 sem (AST vd fd) = case runStateT m ('Map'.newMap, getRandomStream 1) of
  40     Left e = Left [e]
  41     Right ((vds, fds), gamma) = Right ((AST vds fds), gamma)
  42 where
  43     m :: Env ([VarDecl], [FunDecl])
  44     m = mapM semVarDecl vd >>= \vd1 ->
  45         mapM semFunDecl fd >>= \fd1 ->
  46         mapM semVarDecl vd1 >>= \vd2 ->
  47         mapM semFunDecl fd1 >>= \fd2 ->
  48         mapM semVarDecl vd2 >>= \vd3 ->
  49         mapM semFunDecl fd2 >>= \fd3 ->
  50         mapM semVarDecl vd3 >>= \vd4 ->
  51         mapM semFunDecl fd3 >>= \fd4 ->  //Dit is puur om te proberen
  52         pure (vd4, fd4)
  53
  54 semFunDecl :: FunDecl -> Env FunDecl
  55 semFunDecl fd=:(FunDecl p f args mt vds stmts) =
  56     (case mt of
  57         Nothing = genType args >>= \infft->putIdent f infft >>| pure infft
  58         Just t = putIdent f t >>| pure t) >>= \ft ->
  59     saveGamma >>= \gamma ->
  60         matchFunctions args ft >>= \tres->
  61     mapM semVarDecl vds >>= \newvds->
  62     mapM (checkStmt tres) stmts >>= \newstmts->
  63         case mt of
  64                 Nothing = inferReturnType stmts
  65                         >>= \returntype->reconstructType args tres
  66                         >>= \ftype->restoreGamma gamma
  67                         >>| putIdent f ftype >>| pure (
  68                         FunDecl p f args (Just ftype) newvds newstmts)
  69                 Just t = restoreGamma gamma
  70                         >>| pure (FunDecl p f args mt newvds newstmts)
  71
  72 inferReturnType :: [Stmt] -> Env Type
  73 inferReturnType [] = pure VoidType
  74 inferReturnType [ReturnStmt (Just t):rest] = typeExpr t
  75 inferReturnType [ReturnStmt _:rest] = pure VoidType
  76 inferReturnType [_:rest] = inferReturnType rest
  77
  78 reconstructType :: [String] Type -> Env Type
  79 reconstructType [] t = pure t
  80 reconstructType [x:xs] t = gets (\(st, r)->'Map'.get x st)
  81         >>= \mtype->case mtype of
  82                 Nothing = liftT $ Left $ Error "Not used ????"
  83                 Just type = reconstructType xs t >>= \resttype->pure (type ->> resttype)
  84
  85 genType :: [String] -> Env Type
  86 genType [] = freshIdent >>= \fi->pure $ IdType fi
  87 genType [x:xs] = liftM2 (->>) (freshIdent >>= \fi->pure $ IdType fi)
  88         (genType xs)
  89
  90 matchFunctions :: [String] Type -> Env Type
  91 matchFunctions [] (_ ->> _) = liftT $ Left $ Error "Not enough arguments"
  92 matchFunctions _ (VoidType ->> _) = liftT $ Left $ Error "Cannot have a void type in the middle of the function definition"
  93 matchFunctions [x:xs] (t1 ->> t2) =
  94         modify (\(st, r)->('Map'.put x t1 st, r)) >>| matchFunctions xs t2
  95 matchFunctions [] t = pure t
  96 matchFunctions _ t = liftT $ Left $ Error "Too much argumnts"
  97
  98 semVarDecl :: VarDecl -> Env VarDecl
  99 semVarDecl (VarDecl pos type ident ex) = unify type ex
 100     >>= \t-> putIdent ident t >>| (pure $ VarDecl pos t ident ex)
 101
 102 checkStmt ::Type Stmt -> Env Stmt
 103 checkStmt t (IfStmt c st se) = unify BoolType c >>| mapM (checkStmt t) st
 104     >>= \st1-> mapM (checkStmt t) se >>= \se1-> pure (IfStmt c st1 se1)
 105 checkStmt t w=:(WhileStmt c et) = unify BoolType c >>| mapM (checkStmt t) et
 106     >>= \et1-> pure w
 107 checkStmt t a=:(AssStmt (VarDef ident fs) e) = gets (\(st, r)->'Map'.get ident st)
 108     >>= \mt->case mt of
 109         Nothing = liftT $ Left $ UndeclaredVariableError zero ident
 110         Just t = unify t fs >>= \t1 -> unify t1 e >>| pure a
 111 checkStmt t r=:(FunStmt (FunCall f es)) = typeFun f es >>| pure r
 112 checkStmt VoidType r=:(ReturnStmt Nothing) = pure r
 113 checkStmt t r=:(ReturnStmt (Just e)) = unify t e >>| pure r
 114
 115 typeExpr :: Expr -> Env Type
 116 typeExpr (IntExpr _ _) = pure IntType
 117 typeExpr (CharExpr _ _) = pure CharType
 118 typeExpr (BoolExpr _ _) = pure BoolType
 119 typeExpr (Op1Expr p UnNegation expr) = unify BoolType expr
 120 typeExpr (Op1Expr p UnMinus expr) = unify IntType expr
 121 typeExpr (TupleExpr p (e1, e2)) = typeExpr e1
 122     >>= \t1-> typeExpr e2 >>= \t2-> pure $ TupleType (t1, t2)
 123 typeExpr (Op2Expr p e1 op e2)
 124 | isMember op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod] =
 125         typeOp2 e1 e2 op [IntType] IntType
 126 | isMember op [BiEquals, BiUnEqual] =
 127         typeOp2 e1 e2 op [IntType, BoolType, CharType] BoolType
 128 | isMember op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq] =
 129         typeOp2 e1 e2 op [IntType, CharType] BoolType
 130 | isMember op [BiAnd, BiOr] =
 131         typeOp2 e1 e2 op [BoolType] BoolType
 132 | op == BiCons = typeExpr e1 >>= \t1-> typeExpr e2
 133         >>= \t2-> unify (ListType t1) t2
 134 typeExpr (EmptyListExpr p) = freshIdent >>= \frsh-> let t = IdType frsh in
 135     putIdent frsh t >>| pure t
 136 typeExpr (FunExpr p (FunCall f es)) = typeFun f es
 137 typeExpr (VarExpr p (VarDef ident fs)) = gets (\(st, r)->'Map'.get ident st)
 138     >>= \mt->case mt of
 139         Nothing = liftT $ Left $ UndeclaredVariableError p ident
 140         Just t = unify t fs
 141 typeOp2 :: Expr Expr Op2 [Type] Type -> Env Type
 142 typeOp2 e1 e2 op ts ret = typeExpr e1 >>= \t1-> typeExpr e2 >>= \t2->
 143     unify t1 t2 >>= \t3->if (isMember t3 [IdType "":ts]) (pure ret)
 144         (liftT $ Left $ OperatorError (extrPos e1) op t3)
 145
 146 buildFunctionType :: String [Expr] -> Env Type
 147 buildFunctionType frsh [] = let t = IdType frsh in putIdent frsh t >>| pure t
 148 buildFunctionType frsh [e:es] = (->>) <$> typeExpr e <*> buildFunctionType frsh es
 149
 150 unifyApp :: Type [Expr] -> Env Type
 151 unifyApp t [] = pure t
 152 unifyApp (tf1 ->> tf2) [t1:ts] = unify tf1 t1 >>| unifyApp tf2 ts
 153 unifyApp t1 t2 = liftT $ Left $ UnifyError zero t1 (IdType "[expressions, FIXME]")
 154
 155 typeFun :: String [Expr] -> Env Type
 156 typeFun f es = gets (\(st, r)->'Map'.get f st) >>= \mt-> case mt of
 157     Nothing = freshIdent >>= \frsh-> buildFunctionType frsh es
 158         >>= \ft-> putIdent f ft >>| (pure $ IdType frsh)
 159     Just t = unifyApp t es
 160
 161 resultType :: Type -> Type
 162 resultType (_ ->> t) = resultType t
 163 resultType t = t
 164
 165 class unify a :: Type a -> Env Type
 166
 167 instance unify [FieldSelector] where
 168     unify t [] = pure t
 169     unify (ListType t) [FieldHd:fs] = unify t fs
 170     unify t=:(ListType _) [FieldTl:fs] = unify t fs
 171     unify (TupleType (t, _)) [FieldFst:fs] = unify t fs
 172     unify (TupleType (_, t)) [FieldSnd:fs] = unify t fs
 173     unify t [fs:_] = liftT $ Left $ FieldSelectorError zero t fs
 174
 175 instance unify Expr where
 176         unify (_ ->> _) e = liftT $ Left $ ParseError (extrPos e)
 177                         "Expression cannot be a higher order function. Yet..."
 178         unify VoidType e = liftT $ Left $ ParseError (extrPos e)
 179                         "Expression cannot be a Void type."
 180 //      unify (IdType _) e = liftT $ Left $ ParseError (extrPos e)
 181 //                      "Expression cannot be an polymorf type."
 182     unify VarType e = typeExpr e
 183     //we have to cheat to decorate the error, can be done nicer?
 184         unify t=:(IdType id) e = typeExpr e >>= \tex->unify t tex
 185                 >>= \type->putIdent id type >>| pure type
 186     unify t e = StateT $ \s0 -> let res = runStateT m s0 in case res of
 187         Left err = Left $ decErr e err
 188         Right t = Right t //note, t :: (Type, Gamma)
 189     where m = typeExpr e >>= \tex-> unify t tex
 190
 191 instance unify Type where
 192         unify IntType IntType = pure IntType
 193         unify BoolType BoolType = pure BoolType
 194         unify CharType CharType = pure CharType
 195     unify (IdType i) t=:(IdType j) = replace i t >>| pure t
 196     unify t (IdType i) = unify (IdType i) t
 197     unify (IdType i) t = replace i t >>| pure t
 198     unify (ListType t1) (ListType t2) = unify t1 t2 >>| (pure $ ListType t1)
 199     unify (ta1 ->> ta2) (tb1 ->> tb2) = unify ta1 tb1 >>= \ta-> unify ta2 tb2
 200         >>= \tb-> pure (ta ->> tb)
 201     unify VoidType VoidType = pure VoidType
 202         unify t1 t2 = liftT $ Left $ UnifyError zero t1 t2
 203
 204 instance zero Pos where
 205         zero = {line=0,col=0}
 206
 207 decErr :: Expr SemError -> SemError
 208 decErr e (UnifyError _ t1 t2) = UnifyError (extrPos e) t1 t2
 209 decErr e (FieldSelectorError _ t fs) = FieldSelectorError (extrPos e) t fs
 210 decErr e (ParseError _ s) = ParseError (extrPos e) s
 211 decErr e err = err
 212
 213 dc2 :: Expr (Either SemError a) -> Either SemError a
 214 dc2 e (Right t) = Right t
 215 dc2 e (Left err) = Left err
 216
 217 extrPos :: Expr -> Pos
 218 extrPos (VarExpr p _) = p
 219 extrPos (Op2Expr p _ _ _) = p
 220 extrPos (Op1Expr p _ _) = p
 221 extrPos (IntExpr p _) = p
 222 extrPos (CharExpr p _) = p
 223 extrPos (BoolExpr p _) = p
 224 extrPos (FunExpr p _) = p
 225 extrPos (EmptyListExpr p) = p
 226 extrPos (TupleExpr p _) = p
 227
 228 instance toString Gamma where
 229         toString (mp, _) = concat
 230                 [concat [k, ": ", toString v, "\n"]\\(k, v) <- 'Map'.toList mp]
 231
 232 getRandomStream :: Int -> [String]
 233 getRandomStream i = genIdents $ filter (isAlpha o toChar) (genRandInt i)
 234     where
 235         genIdents r = let (ic, r2) = splitAt 5 r in [toString ic: genIdents r2]
 236
 237 freshIdent :: Env String
 238 freshIdent = get >>= \(st, [ident:rest])-> put (st, rest)
 239     >>| case 'Map'.get ident st of
 240         Nothing = pure ident
 241         _       = freshIdent
 242
 243 putIdent :: String Type -> Env Void
 244 putIdent i t = gets (\(st, r)->'Map'.get i st) >>= \mt -> case mt of
 245     Nothing = modify (\(st, r)->('Map'.put i t st, r))
 246     Just t2 = unify t t2 >>= \t3-> modify (\(st, r)->('Map'.put i t3 st, r))
 247
 248 replace :: String Type -> Env Void
 249 replace ident type = get >>= \(st, fr)->put ('Map'.fromList $
 250         map (itupdate ident type) ('Map'.toList st), fr)
 251     where
 252         itupdate :: String Type (String, Type) -> (String, Type)
 253         itupdate ident newtype ov=:(key, IdType type) = if (ident == type)
 254             (key, newtype) ov
 255         itupdate ident newtype (key, TupleType (t1, t2))
 256         # (_, t1) = itupdate ident newtype (key, t1)
 257         # (_, t2) = itupdate ident newtype (key, t2)
 258         = (key, TupleType (t1, t2))
 259         itupdate ident newtype (key, ListType t1)
 260         # (_, t1) = itupdate ident newtype (key, t1)
 261         = (key, ListType t1)
 262         itupdate _ _ k = k
 263
 264 instance toString SemError where
 265     toString (ParseError p e) = concat [
 266         toString p,"SemError: ParseError: ", e]
 267     toString (Error e) = "SemError: " +++ e
 268     toString (UnifyError p t1 t2) = concat [
 269         toString p,
 270         "SemError: Cannot unify types. Expected: ",
 271         toString t1, ". Given: ", toString t2]
 272     toString (FieldSelectorError p t fs) = concat [
 273         toString p,
 274         "SemError: Cannot select ", toString fs, " from type: ",
 275         toString t]
 276     toString (OperatorError p o t) = concat [
 277         toString p,
 278         "SemError: No ", toString o, " for type ",
 279         toString t]
 280     toString (UndeclaredVariableError p ident) = concat [
 281         toString p, "SemError: identifier: ", ident, " undefined."]
 282
 283 saveGamma :: Env Gamma
 284 saveGamma = get
 285
 286 restoreGamma :: Gamma -> Env Void
 287 restoreGamma (oldstate, _) = gets snd >>= \newr->put (oldstate, newr)
 288
 289 derive gEq Type
 290 instance == Type where
 291         (==) (IdType _) (IdType _) = True
 292         (==) o1 o2 = gEq{|*|} o1 o2