quox/exe/Main.idr

243 lines
5.8 KiB
Idris
Raw Normal View History

2022-04-27 14:04:03 -04:00
module Main
2021-07-07 07:11:39 -04:00
2023-10-20 11:42:01 -04:00
import Quox.Syntax as Q
2023-03-31 13:31:29 -04:00
import Quox.Parser
2023-10-20 11:42:01 -04:00
import Quox.Definition as Q
2023-03-31 13:31:29 -04:00
import Quox.Pretty
2023-10-20 11:42:01 -04:00
import Quox.Untyped.Syntax as U
import Quox.Untyped.Erase
import Options
2021-07-20 16:05:19 -04:00
2023-03-31 13:31:29 -04:00
import Data.IORef
import Data.SortedSet
2023-10-20 11:42:01 -04:00
import Text.Show.PrettyVal
import Text.Show.Pretty
import System
import System.File
2023-03-31 13:31:29 -04:00
import Control.Eff
2021-07-20 16:05:19 -04:00
2023-10-20 11:42:01 -04:00
%hide Doc.(>>=)
%hide Core.(>>=)
parameters {auto _ : HasIO io} (width : Nat)
private
putDoc : Doc (Opts width) -> io ()
putDoc = putStr . render _
private
fPutDoc : File -> Doc (Opts width) -> io (Either FileError ())
fPutDoc h = fPutStr h . render _
private
putDocErr : Doc (Opts width) -> io ()
putDocErr = ignore . fPutDoc stderr
private
die : Doc (Opts width) -> io a
die err = do putDocErr err; exitFailure
private
runPretty : Options -> Eff Pretty a -> a
runPretty opts act =
let doColor = opts.color && opts.outFile == Stdout
hl = if doColor then highlightSGR else noHighlight
in
runPrettyWith Outer opts.flavor hl 2 act
private
putErrLn : HasIO io => String -> io ()
putErrLn = ignore . fPutStrLn stderr
2023-05-14 13:58:46 -04:00
private
2023-10-20 11:42:01 -04:00
record State where
constructor MkState
seen : IORef SeenSet
defs : IORef Q.Definitions
ns : IORef Mods
suf : IORef NameSuf
%name Main.State state
2023-05-14 13:58:46 -04:00
private
2023-10-20 11:42:01 -04:00
newState : HasIO io => io State
newState = pure $ MkState {
seen = !(newIORef empty),
defs = !(newIORef empty),
ns = !(newIORef [<]),
suf = !(newIORef 0)
}
private
data Error
= ParseError String Parser.Error
| FromParserError FromParser.Error
| EraseError Erase.Error
| WriteError FilePath FileError
%hide FromParser.Error
%hide Erase.Error
%hide Lexer.Error
%hide Parser.Error
private
loadError : Loc -> FilePath -> FileError -> Error
loadError loc file err = FromParserError $ LoadError loc file err
private
data CompileTag = OPTS | STATE
private
Compile : List (Type -> Type)
Compile =
[Except Error,
ReaderL STATE State, ReaderL OPTS Options,
LoadFile, IO]
private
runCompile : Options -> State -> Eff Compile a -> IO (Either Error a)
runCompile opts state act =
fromIOErr $ runEff act $ with Union.(::)
[handleExcept (\e => ioLeft e),
handleReaderConst state,
handleReaderConst opts,
handleLoadFileIOE loadError ParseError state.seen opts.include,
liftIO]
2023-05-14 13:58:46 -04:00
private
2023-10-20 11:42:01 -04:00
data StopTag = STOP
2023-05-14 13:58:46 -04:00
private
2023-10-20 11:42:01 -04:00
CompileStop : List (Type -> Type)
CompileStop = FailL STOP :: Compile
private
withEarlyStop : Has (FailL STOP) fs => Eff fs () -> Eff (fs - FailL STOP) ()
withEarlyStop = ignore . runFailAt STOP
private
stopHere : Has (FailL STOP) fs => Eff fs ()
stopHere = failAt STOP
private
FlexDoc : Type
FlexDoc = {opts : LayoutOpts} -> Doc opts
private
outputDoc : FlexDoc -> Eff Compile ()
outputDoc doc =
case !(asksAt OPTS outFile) of
None => pure ()
Stdout => putDoc !(asksAt OPTS width) doc
File f => do
res <- withFile f WriteTruncate pure $ \h =>
fPutDoc !(asksAt OPTS width) h doc
rethrow $ mapFst (WriteError f) res
private
outputDocStopIf : Phase -> FlexDoc -> Eff CompileStop ()
outputDocStopIf p doc =
when (!(asksAt OPTS until) == Just p) $ do
lift (outputDoc doc)
stopHere
private
liftFromParser : Eff FromParserIO a -> Eff CompileStop a
liftFromParser act =
runEff act $ with Union.(::)
[handleExcept (\err => throw $ FromParserError err),
2023-10-20 11:42:01 -04:00
handleStateIORef !(asksAt STATE defs),
handleStateIORef !(asksAt STATE ns),
handleStateIORef !(asksAt STATE suf),
\g => send g]
2023-10-20 11:42:01 -04:00
private
liftErase : Q.Definitions -> Eff Erase a -> Eff CompileStop a
liftErase defs act =
runEff act
[\case Err e => throw $ EraseError e,
\case Ask => pure defs,
handleStateIORef !(asksAt STATE suf)]
private
processFile : String -> Eff Compile ()
processFile file = withEarlyStop $ do
Just ast <- loadFile noLoc file
| Nothing => pure ()
putErrLn "checking \{file}"
outputDocStopIf Parse $ dumpDoc ast
defList <- liftFromParser $ concat <$> traverse fromPTopLevel ast
outputDocStopIf Check $ runPretty !(askAt OPTS) $
vsep <$> traverse (uncurry Q.prettyDef) defList
let defs = SortedMap.fromList defList
erased <- liftErase defs $
traverse (\(x, d) => (x,) <$> eraseDef x d) defList
outputDocStopIf Erase $ runPretty !(askAt OPTS) $
vsep . catMaybes <$> traverse (uncurry U.prettyDef) erased
die "that's all folks"
private
dieError : HasIO io => Options -> Error -> io a
dieError opts e = do
die opts.width $ runPretty opts $ case e of
ParseError file e => prettyParseError file e
FromParserError e => FromParser.prettyError True e
EraseError e => Erase.prettyError True e
WriteError file e => pure $
hangSingle 2 (text "couldn't write file \{file}:") (pshow e)
2023-03-31 13:31:29 -04:00
export
main : IO ()
main = do
2023-10-20 11:42:01 -04:00
(_, opts, files) <- options
case !(runCompile opts !newState $ traverse_ processFile files) of
Right () => pure ()
Left e => dieError opts e
2023-03-31 13:31:29 -04:00
-----------------------------------
2023-05-14 13:58:46 -04:00
{-
2021-07-20 16:05:19 -04:00
2022-04-11 08:09:37 -04:00
private
2022-04-11 15:58:33 -04:00
text : PrettyOpts -> List String
2022-04-11 08:09:37 -04:00
text _ =
["",
#" ___ ___ _____ __ __"#,
#"/ _ `/ // / _ \\ \ /"#,
#"\_, /\_,_/\___/_\_\"#,
#" /_/"#,
""]
2022-03-06 19:19:26 -05:00
2022-04-11 08:09:37 -04:00
private
2022-04-11 15:58:33 -04:00
qtuwu : PrettyOpts -> List String
2022-04-11 08:09:37 -04:00
qtuwu opts =
if opts.unicode then
[#" ___,-´⎠ "#,
#"(·`──´ ◡ -´⎠"#,
2023-02-26 04:58:47 -05:00
#" \/\/──´⎞/`──´ "#,
#" ⎜⎟───,-₎ ⎞ "#,
#" ⎝⎠ (‾‾) ⎟ "#,
2022-04-11 08:09:37 -04:00
#" (‾‾‾) ⎟ "#]
else
[#" ___,-´/ "#,
#"(.`--´ u -´/"#,
#" \/\/--´|/`--´ "#,
2023-02-26 04:58:47 -05:00
#" ||---,-, \ "#,
#" `´ (--) | "#,
2022-04-11 08:09:37 -04:00
#" (---) | "#]
private
2022-04-11 15:58:33 -04:00
join1 : PrettyOpts -> String -> String -> String
2022-04-11 08:09:37 -04:00
join1 opts l r =
if opts.color then
" " <+> show (colored Green l) <+> " " <+> show (colored Magenta r)
else
" " <+> l <+> " " <+> r
export
2022-04-11 15:58:33 -04:00
banner : PrettyOpts -> String
2022-04-11 08:09:37 -04:00
banner opts = unlines $ zipWith (join1 opts) (qtuwu opts) (text opts)
2023-05-14 13:58:46 -04:00
-}