quox/exe/Main.idr

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)
-}