quox/exe/Options.idr

159 lines
4.1 KiB
Idris
Raw Normal View History

2023-10-20 11:42:01 -04:00
module Options
import Quox.Pretty
import System
import System.Console.GetOpt
import System.File
import System.Term
import Derive.Prelude
%language ElabReflection
public export
data OutFile = File String | Stdout | None
%name OutFile f
%runElab derive "OutFile" [Eq, Ord, Show]
public export
data Phase = Parse | Check | Erase
%name Phase p
%runElab derive "Phase" [Eq, Ord, Show]
||| a list of all `Phase`s
public export %inline
allPhases : List Phase
allPhases = %runElab do
-- as a script so it stays up to date
cs <- getCons $ fst !(lookupName "Phase")
traverse (check . var) cs
public export
record Options where
constructor MkOpts
color : Bool
outFile : OutFile
until : Maybe Phase
flavor : Pretty.Flavor
width : Nat
include : List String
%name Options opts
%runElab derive "Options" [Show]
export
defaultOpts : IO Options
defaultOpts = pure $ MkOpts {
color = True,
outFile = Stdout,
until = Nothing,
flavor = Unicode,
width = cast !getTermCols,
include = ["."]
}
private
data HelpType = Common | All
private
data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options)
%name OptAction act
private
toOutFile : String -> OptAction
toOutFile "" = Ok {outFile := None}
toOutFile "-" = Ok {outFile := Stdout}
toOutFile f = Ok {outFile := File f}
private
phaseName : Phase -> String
phaseName Parse = "parse"
phaseName Check = "check"
phaseName Erase = "erase"
private
toPhase : String -> OptAction
toPhase str = case toLower str of
"parse" => Ok {until := Just Parse}
"check" => Ok {until := Just Check}
"erase" => Ok {until := Just Erase}
_ => Err "unknown phase name \{show str}\nphases: \{phaseNames}"
where phaseNames = joinBy ", " $ map phaseName allPhases
private
toWidth : String -> OptAction
toWidth s = case parsePositive s of
Just n => Ok {width := n}
Nothing => Err "invalid width: \{show s}"
private
commonOptDescrs' : List (OptDescr OptAction)
commonOptDescrs' = [
MkOpt ['i'] ["include"] (ReqArg (\i => Ok {include $= (i ::)}) "<dir>")
"add a directory to look for source files",
MkOpt ['o'] ["output"] (ReqArg toOutFile "<file>")
"output file (\"-\" for stdout, \"\" for no output)",
MkOpt ['P'] ["phase"] (ReqArg toPhase "<phase>")
"phase to stop at (by default go as far as exists)"
]
private
extraOptDescrs : List (OptDescr OptAction)
extraOptDescrs = [
MkOpt [] ["unicode"] (NoArg $ Ok {flavor := Unicode})
"use unicode syntax when printing (default)",
MkOpt [] ["ascii"] (NoArg $ Ok {flavor := Ascii})
"use ascii syntax when printing",
MkOpt [] ["width"] (ReqArg toWidth "<width>")
"max output width (defaults to terminal width)",
MkOpt [] ["color", "colour"] (NoArg $ Ok {color := True})
"use colour output (default)",
MkOpt [] ["no-color", "no-colour"] (NoArg $ Ok {color := False})
"don't use colour output"
]
private
helpOptDescrs : List (OptDescr OptAction)
helpOptDescrs = [
MkOpt ['h'] ["help"] (NoArg $ ShowHelp Common) "show common options",
MkOpt [] ["help-all"] (NoArg $ ShowHelp All) "show all options"
]
commonOptDescrs = commonOptDescrs' ++ helpOptDescrs
allOptDescrs = commonOptDescrs' ++ extraOptDescrs ++ helpOptDescrs
export
usageHeader : String
usageHeader = joinBy "\n" [
"quox [options] [file.quox ...]",
"rawr"
]
export
usage : List (OptDescr _) -> IO a
usage ds = do
ignore $ fPutStr stderr $ usageInfo usageHeader ds
exitSuccess
private
applyAction : Options -> OptAction -> IO Options
applyAction opts (ShowHelp Common) = usage commonOptDescrs
applyAction opts (ShowHelp All) = usage allOptDescrs
applyAction opts (Err err) = die err
applyAction opts (Ok f) = pure $ f opts
private
finalise : Options -> Options
finalise = {include $= reverse}
export
options : IO (String, Options, List String)
options = do
app :: args <- getArgs
| [] => die "couldn't get command line arguments"
let res = getOpt Permute allOptDescrs args
unless (null res.errors) $
die $ trim $ concat res.errors
unless (null res.unrecognized) $
die "unrecognised options: \{joinBy ", " res.unrecognized}"
opts <- foldlM applyAction !defaultOpts res.options
pure (app, finalise opts, res.nonOptions)