diff --git a/bowtie/src/Bowtie/Interpret.hs b/bowtie/src/Bowtie/Interpret.hs index a7d5379..afc6f1c 100644 --- a/bowtie/src/Bowtie/Interpret.hs +++ b/bowtie/src/Bowtie/Interpret.hs @@ -1,4 +1,12 @@ -module Bowtie.Interpret where +module Bowtie.Interpret + ( IError(..) + , interpret + , interpretProgram + , sourcesToAST + , sourcesToCore + , concatSource + , prettyError + ) where import Bowtie.Lib.Environment import Bowtie.Lib.Prelude @@ -24,55 +32,109 @@ data IError | TypeError Infer.TypeError deriving (Eq, Show) +-- | For test and REPL use. interpret :: Text -> Either IError Untyped.Expr interpret src = interpretProgram mempty ("", src) +-- | For use by the executable. interpretProgram :: HashMap FilePath Text -> (FilePath, Text) -> Either IError Untyped.Expr interpretProgram libFiles appFile = do - (_, core) <- sourcesToCore libFiles appFile + (_, res) <- interpretImpl libFiles appFile + (_, _, val) <- res + pure val + +-- | Internal. +-- +-- NOTE: Environment is just the data types. +interpretImpl + :: HashMap FilePath Text + -> (FilePath, Text) + -> Either + IError + ( AST + , Either + IError + (Environment, Core.Expr, Untyped.Expr) + ) +interpretImpl libFiles appFile = do + + -- Parse + + let + parse :: (FilePath, Text) -> Either IError AST + parse = + Bifunctor.first ParseError . uncurry Surface.Parse.parse + + libPrograms <- for (hashmapToSortedList libFiles) parse + appProgram <- parse appFile + + -- Combine + + ast <- Bifunctor.first + NameClash + (concatSource (libPrograms <> [appProgram])) -- PERFORMANCE + + -- Kindcheck and infer + let - untyped :: Untyped.Expr - untyped = - Erase.erase core + res :: Either IError (Environment, Core.Expr, Untyped.Expr) + res = do + let + env :: Environment + env = + kindcheck (astTypes ast) + + dsg :: Surface.Expr + dsg = + Desugar.extractResult (astTerms ast) - case Eval.eval mempty untyped of - Left e -> - panic ("Evaluating failed (this should never happen): " <> show e) + (_, _, explicitlyTypedExpr) <- Bifunctor.first + TypeError + (Infer.elaborate env dsg) - Right a -> - pure a + -- Desugar and erase + let + core :: Core.Expr + core = + Desugar.desugar explicitlyTypedExpr + + untyped :: Untyped.Expr + untyped = + Erase.erase core + + -- Eval + + case Eval.eval mempty untyped of + Left e -> + panic ("Evaluating failed (this should never happen): " <> show e) + + Right val -> + pure (env, core, val) + + pure (ast, res) + +-- | For use by tests or other packages. sourcesToAST :: HashMap FilePath Text -> (FilePath, Text) -> Either IError AST sourcesToAST libFiles appFile = do - libPrograms <- Bifunctor.first ParseError (for (hashmapToSortedList libFiles) parse) - appProgram <- Bifunctor.first ParseError (parse appFile) - Bifunctor.first NameClash (concatSource (libPrograms <> [appProgram])) -- PERFORMANCE - where - parse :: (FilePath, Text) -> Either ParserErrorBundle AST - parse = - uncurry Surface.Parse.parse + (ast, _) <- interpretImpl libFiles appFile + pure ast --- | NOTE: Environment is just the data types. -sourcesToCore :: HashMap FilePath Text -> (FilePath, Text) -> Either IError (Environment, Core.Expr) +-- | For use by tests or other packages. +-- +-- NOTE: Environment is just the data types. +sourcesToCore + :: HashMap FilePath Text + -> (FilePath, Text) + -> Either IError (Environment, Core.Expr) sourcesToCore libFiles appFile = do - ast <- sourcesToAST libFiles appFile - let - env :: Environment - env = - kindcheck (astTypes ast) - - dsg :: Surface.Expr - dsg = - Desugar.extractResult (astTerms ast) - - (_, _, explicitlyTypedExpr) <- Bifunctor.first - TypeError - (Infer.elaborate env dsg) - pure (env, Desugar.desugar explicitlyTypedExpr) + (_, res) <- interpretImpl libFiles appFile + (env, core, _) <- res + pure (env, core) concatSource :: [AST] -> Either Text AST concatSource =