159 lines
4.1 KiB
Idris
159 lines
4.1 KiB
Idris
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)
|