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