277 lines
6.9 KiB
Idris
277 lines
6.9 KiB
Idris
module Main
|
||
|
||
import Quox.Syntax as Q
|
||
import Quox.Parser
|
||
import Quox.Definition as Q
|
||
import Quox.Pretty
|
||
import Quox.Untyped.Syntax as U
|
||
import Quox.Untyped.Erase
|
||
import Quox.Untyped.Scheme
|
||
import Options
|
||
|
||
import Data.IORef
|
||
import Data.SortedSet
|
||
import Text.Show.PrettyVal
|
||
import Text.Show.Pretty
|
||
import System
|
||
import System.File
|
||
import Control.Eff
|
||
|
||
%hide Doc.(>>=)
|
||
%hide Core.(>>=)
|
||
|
||
|
||
private
|
||
die : HasIO io => (opts : LayoutOpts) -> Doc opts -> io a
|
||
die opts err = do
|
||
ignore $ fPutStr stderr $ render opts err
|
||
exitFailure
|
||
|
||
private
|
||
hlFor : HLType -> OutFile -> HL -> Highlight
|
||
hlFor Guess Console = highlightSGR
|
||
hlFor Guess _ = noHighlight
|
||
hlFor NoHL _ = noHighlight
|
||
hlFor Term _ = highlightSGR
|
||
hlFor Html _ = highlightHtml
|
||
|
||
private
|
||
runPretty : Options -> Eff Pretty a -> a
|
||
runPretty opts act =
|
||
runPrettyWith Outer opts.flavor (hlFor opts.hlType opts.outFile) 2 act
|
||
|
||
private
|
||
putErrLn : HasIO io => String -> io ()
|
||
putErrLn = ignore . fPutStrLn stderr
|
||
|
||
private
|
||
record State where
|
||
constructor MkState
|
||
seen : IORef SeenSet
|
||
defs : IORef Q.Definitions
|
||
ns : IORef Mods
|
||
suf : IORef NameSuf
|
||
%name Main.State state
|
||
|
||
private
|
||
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
|
||
| NoMain
|
||
| MultipleMains (List Id)
|
||
%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
|
||
prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts)
|
||
prettyError (ParseError file e) = prettyParseError file e
|
||
prettyError (FromParserError e) = FromParser.prettyError True e
|
||
prettyError (EraseError e) = Erase.prettyError True e
|
||
prettyError NoMain = pure "no #[main] function given"
|
||
prettyError (MultipleMains xs) =
|
||
pure $ sep ["multiple #[main] functions given:",
|
||
separateLoose "," !(traverse prettyId xs)]
|
||
prettyError (WriteError file e) = pure $
|
||
hangSingle 2 (text "couldn't write file \{file}:") (pshow e)
|
||
|
||
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]
|
||
|
||
|
||
private
|
||
data StopTag = STOP
|
||
|
||
private
|
||
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
|
||
outputStr : Lazy String -> Eff Compile ()
|
||
outputStr str =
|
||
case !(asksAt OPTS outFile) of
|
||
NoOut => pure ()
|
||
Console => putStr str
|
||
File f => do
|
||
res <- withFile f WriteTruncate pure $ \h => fPutStr h str
|
||
rethrow $ mapFst (WriteError f) res
|
||
|
||
private
|
||
outputDocs : (opts : Options) ->
|
||
({opts : LayoutOpts} -> List (Doc opts)) -> Eff Compile ()
|
||
outputDocs opts doc =
|
||
outputStr $ concat $ map (render (Opts opts.width)) doc
|
||
|
||
private
|
||
outputDocStopIf : Phase ->
|
||
({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) ->
|
||
Eff CompileStop ()
|
||
outputDocStopIf p docs = do
|
||
opts <- askAt OPTS
|
||
when (opts.until == Just p) $ Prelude.do
|
||
lift $ outputDocs !(askAt OPTS) (runPretty opts docs)
|
||
stopHere
|
||
|
||
private
|
||
liftFromParser : Eff FromParserIO a -> Eff CompileStop a
|
||
liftFromParser act =
|
||
runEff act $ with Union.(::)
|
||
[handleExcept $ \err => throw $ FromParserError err,
|
||
handleStateIORef !(asksAt STATE defs),
|
||
handleStateIORef !(asksAt STATE ns),
|
||
handleStateIORef !(asksAt STATE suf),
|
||
\g => send g]
|
||
|
||
private
|
||
liftErase : Q.Definitions -> Eff Erase a -> Eff CompileStop a
|
||
liftErase defs act =
|
||
runEff act
|
||
[handleExcept $ \err => throw $ EraseError err,
|
||
handleStateIORef !(asksAt STATE suf)]
|
||
|
||
private
|
||
liftScheme : Eff Scheme a -> Eff CompileStop (a, List Id)
|
||
liftScheme act = do
|
||
runEff [|MkPair act (getAt MAIN)|]
|
||
[handleStateIORef !(newIORef empty),
|
||
handleStateIORef !(newIORef [])]
|
||
|
||
|
||
private
|
||
oneMain : Has (Except Error) fs => List Id -> Eff fs Id
|
||
oneMain [] = throw NoMain
|
||
oneMain [x] = pure x
|
||
oneMain mains = throw $ MultipleMains mains
|
||
|
||
|
||
private
|
||
processFile : String -> Eff Compile ()
|
||
processFile file = withEarlyStop $ do
|
||
Just ast <- loadFile noLoc file
|
||
| Nothing => pure ()
|
||
-- putErrLn "checking \{file}"
|
||
when (!(asksAt OPTS until) == Just Parse) $ do
|
||
lift $ outputStr $ show ast
|
||
stopHere
|
||
defList <- liftFromParser $ concat <$> traverse fromPTopLevel ast
|
||
outputDocStopIf Check $
|
||
traverse (uncurry Q.prettyDef) defList
|
||
let defs = SortedMap.fromList defList
|
||
erased <- liftErase defs $
|
||
traverse (\(x, d) => (x,) <$> eraseDef defs x d) defList
|
||
outputDocStopIf Erase $
|
||
traverse (uncurry U.prettyDef) erased
|
||
(scheme, mains) <- liftScheme $ map catMaybes $
|
||
traverse (uncurry defToScheme) erased
|
||
outputDocStopIf Scheme $
|
||
intersperse empty <$> traverse prettySexp scheme
|
||
opts <- askAt OPTS
|
||
main <- oneMain mains
|
||
lift $ outputDocs opts $ intersperse empty $ runPretty opts $ do
|
||
res <- traverse prettySexp scheme
|
||
runner <- makeRunMain main
|
||
pure $ text Scheme.prelude :: res ++ [runner]
|
||
|
||
export
|
||
main : IO ()
|
||
main = do
|
||
(_, opts, files) <- options
|
||
case !(runCompile opts !newState $ traverse_ processFile files) of
|
||
Right () => pure ()
|
||
Left e => die (Opts opts.width) $
|
||
runPretty ({outFile := Console} opts) $
|
||
prettyError 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)
|
||
-}
|