module Language.Qux.Annotated.TypeResolver (
Resolve,
runResolve,
Context(..),
context, emptyContext,
Locals,
retrieve,
resolve, resolveProgram, resolveDecl, resolveStmt, resolveExpr, resolveValue,
extractType
) where
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.State
import Data.List (nub)
import Data.Map (Map)
import qualified Data.Map as Map
import Language.Qux.Annotated.Parser (SourcePos)
import Language.Qux.Annotated.Syntax (simp)
import qualified Language.Qux.Annotated.Syntax as Ann
import Language.Qux.Syntax
type Resolve = Reader Context
runResolve :: Resolve a -> Context -> a
runResolve = runReader
data Context = Context {
functions :: Map Id [Type]
}
context :: Program -> Context
context (Program _ decls) = Context {
functions = Map.fromList $ [(name, map fst parameters) | (FunctionDecl name parameters _) <- decls]
}
emptyContext :: Context
emptyContext = Context { functions = Map.empty }
type Locals = Map Id Type
retrieve :: MonadReader Context m => Id -> StateT Locals m (Maybe [Type])
retrieve name = do
maybeLocal <- gets $ (fmap (:[])) . (Map.lookup name)
maybeDef <- asks $ (Map.lookup name) . functions
return $ maybeLocal <|> maybeDef
resolve :: Ann.Program SourcePos -> Ann.Program SourcePos
resolve program = runResolve (resolveProgram program) (context $ simp program)
resolveProgram :: Ann.Program SourcePos -> Resolve (Ann.Program SourcePos)
resolveProgram (Ann.Program pos module_ decls) = mapM resolveDecl decls >>= \decls' -> return $ Ann.Program pos module_ decls'
resolveDecl :: Ann.Decl SourcePos -> Resolve (Ann.Decl SourcePos)
resolveDecl (Ann.FunctionDecl pos name parameters stmts) = do
stmts' <- evalStateT (resolveBlock stmts) (Map.fromList [(simp p, simp t) | (t, p) <- parameters])
return $ Ann.FunctionDecl pos name parameters stmts'
resolveBlock :: [Ann.Stmt SourcePos] -> StateT Locals Resolve [Ann.Stmt SourcePos]
resolveBlock = mapM resolveStmt
resolveStmt :: Ann.Stmt SourcePos -> StateT Locals Resolve (Ann.Stmt SourcePos)
resolveStmt (Ann.IfStmt pos condition trueStmts falseStmts) = do
condition' <- resolveExpr condition
trueStmts' <- resolveBlock trueStmts
falseStmts' <- resolveBlock falseStmts
return $ Ann.IfStmt pos condition' trueStmts' falseStmts'
resolveStmt (Ann.ReturnStmt pos expr) = do
expr' <- resolveExpr expr
return $ Ann.ReturnStmt pos expr'
resolveStmt (Ann.WhileStmt pos condition stmts) = do
condition' <- resolveExpr condition
stmts' <- resolveBlock stmts
return $ Ann.WhileStmt pos condition' stmts'
resolveExpr :: Ann.Expr SourcePos -> StateT Locals Resolve (Ann.Expr SourcePos)
resolveExpr (Ann.ApplicationExpr pos name arguments) = retrieve (simp name) >>= maybe
(error "internal error: undefined function call has no type (try applying name resolution)")
(\types -> do
arguments_ <- mapM resolveExpr arguments
return $ Ann.TypedExpr pos (last types) (Ann.ApplicationExpr pos name arguments_))
resolveExpr (Ann.BinaryExpr pos op lhs rhs) = do
lhs' <- resolveExpr lhs
rhs' <- resolveExpr rhs
let type_ = case op of
Acc -> let (ListType inner) = extractType lhs' in inner
Mul -> IntType
Div -> IntType
Mod -> IntType
Add -> extractType lhs'
Sub -> extractType lhs'
Lt -> BoolType
Lte -> BoolType
Gt -> BoolType
Gte -> BoolType
Eq -> BoolType
Neq -> BoolType
return $ Ann.TypedExpr pos type_ (Ann.BinaryExpr pos op lhs' rhs')
resolveExpr (Ann.ListExpr pos elements) = do
elements' <- mapM resolveExpr elements
let types = map extractType elements'
case length (nub types) == 1 of
True -> return $ Ann.TypedExpr pos (ListType $ head types) (Ann.ListExpr pos elements')
False -> error "internal error: top type not implemented"
resolveExpr e@(Ann.TypedExpr _ _ _) = return e
resolveExpr (Ann.UnaryExpr pos op expr) = do
expr' <- resolveExpr expr
return $ Ann.TypedExpr pos IntType (Ann.UnaryExpr pos op expr')
resolveExpr e@(Ann.ValueExpr pos value) = return $ Ann.TypedExpr pos (resolveValue value) e
resolveValue :: Value -> Type
resolveValue (BoolValue _) = BoolType
resolveValue (IntValue _) = IntType
resolveValue (ListValue elements) = case length (nub types) == 1 of
True -> ListType $ head types
False -> error "internal error: top type not implemented"
where
types = map resolveValue elements
resolveValue NilValue = NilType
extractType :: Ann.Expr a -> Type
extractType (Ann.TypedExpr _ type_ _) = type_
extractType _ = error "internal error: type resolution not complete"