52 lines
1.7 KiB
Haskell
52 lines
1.7 KiB
Haskell
|
module Program where
|
||
|
|
|
||
|
|
import Check
|
||
|
|
import Control.Monad.Except
|
||
|
|
import qualified Data.Map.Strict as M
|
||
|
|
import Elaborator
|
||
|
|
import Errors
|
||
|
|
import Eval (Env, checkBeta)
|
||
|
|
import qualified Eval
|
||
|
|
import Expr (Expr)
|
||
|
|
import qualified Expr
|
||
|
|
import IR
|
||
|
|
import Parser (parseProgram)
|
||
|
|
import Preprocessor (runPreprocessor)
|
||
|
|
|
||
|
|
insertDef :: Text -> Expr -> Expr -> Env -> Env
|
||
|
|
insertDef name ty body = M.insert name (Eval.Def ty body)
|
||
|
|
|
||
|
|
handleDef :: IRDef -> StateT Env Result ()
|
||
|
|
handleDef (Axiom name ty) = do
|
||
|
|
env <- get
|
||
|
|
whenLeft_ (checkType env $ elaborate ty) throwError
|
||
|
|
modify $ insertDef name (elaborate ty) (Expr.Axiom name)
|
||
|
|
handleDef (Def name Nothing irBody) = do
|
||
|
|
env <- get
|
||
|
|
let body = elaborate irBody
|
||
|
|
let ty = checkType env body
|
||
|
|
either throwError (modify . flip (insertDef name) body) ty
|
||
|
|
handleDef (Def name (Just irTy) irBody) = do
|
||
|
|
env <- get
|
||
|
|
let body = elaborate irBody
|
||
|
|
let ty = elaborate irTy
|
||
|
|
let mty' = checkType env body
|
||
|
|
whenLeft_ mty' throwError
|
||
|
|
whenRight_ mty' $ \ty' -> do
|
||
|
|
case checkBeta env ty ty' of
|
||
|
|
Left err -> throwError err
|
||
|
|
Right False -> throwError $ NotEquivalent ty ty' body
|
||
|
|
Right True -> modify $ insertDef name ty' body
|
||
|
|
|
||
|
|
evalDef :: Env -> IRDef -> Result Env
|
||
|
|
evalDef = flip (execStateT . handleDef)
|
||
|
|
|
||
|
|
handleProgram :: IRProgram -> Result Env
|
||
|
|
handleProgram = flip execStateT M.empty . mapM_ handleDef
|
||
|
|
|
||
|
|
handleAndParseProgram :: String -> Text -> Either String Env
|
||
|
|
handleAndParseProgram filename input = (first toString . handleProgram) =<< parseProgram filename input
|
||
|
|
|
||
|
|
handleAndParseFile :: String -> ExceptT String IO Env
|
||
|
|
handleAndParseFile filename = toString `withExceptT` runPreprocessor filename >>= hoistEither . handleAndParseProgram filename
|