quox/exe/Main.idr

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