167 lines
4.0 KiB
Idris
167 lines
4.0 KiB
Idris
module Main
|
||
|
||
import Quox.Syntax as Q
|
||
import Quox.Definition as Q
|
||
import Quox.Untyped.Syntax as U
|
||
import Quox.Parser
|
||
import Quox.Untyped.Erase
|
||
import Quox.Untyped.Scheme
|
||
import Quox.Pretty
|
||
import Quox.Log
|
||
import Options
|
||
import Output
|
||
import Error
|
||
import CompileMonad
|
||
|
||
import System
|
||
import System.File
|
||
import Data.IORef
|
||
import Control.Eff
|
||
|
||
%default total
|
||
|
||
%hide Doc.(>>=)
|
||
%hide Core.(>>=)
|
||
|
||
%hide FromParser.Error
|
||
%hide Erase.Error
|
||
%hide Lexer.Error
|
||
%hide Parser.Error
|
||
|
||
|
||
private
|
||
Step : Type -> Type -> Type
|
||
Step a b = OpenFile -> a -> Eff Compile b
|
||
|
||
private
|
||
step : ConsoleChannel -> Phase -> OutFile -> Step a b -> a -> Eff CompileStop b
|
||
step console phase file act x = do
|
||
opts <- askAt OPTS
|
||
res <- withOutFile console file fromError $ \h => lift $ act h x
|
||
when (opts.until == Just phase) stopHere
|
||
pure res
|
||
where
|
||
fromError : String -> FileError -> Eff CompileStop c
|
||
fromError file err = throw $ WriteError file err
|
||
|
||
|
||
private covering
|
||
parse : Step String PFile
|
||
parse h file = do
|
||
Just ast <- loadFile noLoc file
|
||
| Nothing => pure []
|
||
outputStr h $ show ast
|
||
pure ast
|
||
|
||
private covering
|
||
check : Step PFile (List Q.NDefinition)
|
||
check h decls =
|
||
map concat $ for decls $ \decl => do
|
||
defs <- liftFromParser $ fromPTopLevel decl
|
||
outputDocs h $ traverse (\(x, d) => prettyDef x d) defs
|
||
pure defs
|
||
|
||
private covering
|
||
erase : Step (List Q.NDefinition) (List U.NDefinition)
|
||
erase h defList =
|
||
for defList $ \(x, def) => do
|
||
def <- liftErase defs $ eraseDef defs x def
|
||
outputDoc h $ U.prettyDef x def
|
||
pure (x, def)
|
||
where defs = SortedMap.fromList defList
|
||
|
||
private covering
|
||
scheme : Step (List U.NDefinition) (List Sexp, List Id)
|
||
scheme h defs = do
|
||
sexps' <- for defs $ \(x, d) => do
|
||
(msexp, mains) <- liftScheme $ defToScheme x d
|
||
outputDoc h $ case msexp of
|
||
Just s => prettySexp s
|
||
Nothing => pure $ hsep [";;", prettyName x, "erased"]
|
||
pure (msexp, mains)
|
||
pure $ bimap catMaybes concat $ unzip sexps'
|
||
|
||
private covering
|
||
output : Step (List Sexp, List Id) ()
|
||
output h (sexps, mains) = do
|
||
main <- case mains of
|
||
[m] => pure m
|
||
[] => throw NoMain
|
||
_ => throw $ MultipleMains mains
|
||
lift $ outputDocs h $ do
|
||
res <- traverse prettySexp sexps
|
||
runner <- makeRunMain main
|
||
pure $ text Scheme.prelude :: res ++ [runner]
|
||
|
||
private covering
|
||
processFile : String -> Eff Compile ()
|
||
processFile file = withEarlyStop $ pipeline !(askAt OPTS) file where
|
||
pipeline : Options -> String -> Eff CompileStop ()
|
||
pipeline opts =
|
||
step CErr Parse opts.dump.parse Main.parse >=>
|
||
step CErr Check opts.dump.check Main.check >=>
|
||
step CErr Erase opts.dump.erase Main.erase >=>
|
||
step CErr Scheme opts.dump.scheme Main.scheme >=>
|
||
step COut End opts.outFile Main.output
|
||
|
||
|
||
export covering
|
||
main : IO ()
|
||
main = do
|
||
(_, opts, files) <- options
|
||
case !(runCompile opts !newState $ traverse_ processFile files) of
|
||
Right () => pure ()
|
||
Left e => dieError opts e
|
||
|
||
|
||
-----------------------------------
|
||
{-
|
||
|
||
private
|
||
text : PrettyOpts -> List String
|
||
text _ =
|
||
["",
|
||
#" ___ ___ _____ __ __"#,
|
||
#"/ _ `/ // / _ \\ \ /"#,
|
||
#"\_, /\_,_/\___/_\_\"#,
|
||
#" /_/"#,
|
||
""]
|
||
|
||
-- ["",
|
||
-- #" __ _ _ _ _____ __"#,
|
||
-- #"/ _` | || / _ \ \ /"#,
|
||
-- #"\__, |\_,_\___/_\_\"#,
|
||
-- #" |_|"#,
|
||
-- ""]
|
||
|
||
private
|
||
qtuwu : PrettyOpts -> List String
|
||
qtuwu opts =
|
||
if opts.unicode then
|
||
[#" ___,-´⎠ "#,
|
||
#"(·`──´ ◡ -´⎠"#,
|
||
#" \/\/──´⎞/`──´ "#,
|
||
#" ⎜⎟───,-₎ ⎞ "#,
|
||
#" ⎝⎠ (‾‾) ⎟ "#,
|
||
#" (‾‾‾) ⎟ "#]
|
||
else
|
||
[#" ___,-´/ "#,
|
||
#"(.`--´ u -´/"#,
|
||
#" \/\/--´|/`--´ "#,
|
||
#" ||---,-, \ "#,
|
||
#" `´ (--) | "#,
|
||
#" (---) | "#]
|
||
|
||
private
|
||
join1 : PrettyOpts -> String -> String -> String
|
||
join1 opts l r =
|
||
if opts.color then
|
||
" " <+> show (colored Green l) <+> " " <+> show (colored Magenta r)
|
||
else
|
||
" " <+> l <+> " " <+> r
|
||
|
||
export
|
||
banner : PrettyOpts -> String
|
||
banner opts = unlines $ zipWith (join1 opts) (qtuwu opts) (text opts)
|
||
-}
|