170 lines
4.4 KiB
Idris
170 lines
4.4 KiB
Idris
module Options
|
|
|
|
import Quox.Pretty
|
|
import System
|
|
import System.Console.GetOpt
|
|
import System.File
|
|
import System.Term
|
|
import Derive.Prelude
|
|
|
|
%default total
|
|
%language ElabReflection
|
|
|
|
public export
|
|
data OutFile = File String | Console | NoOut
|
|
%name OutFile f
|
|
%runElab derive "OutFile" [Eq, Ord, Show]
|
|
|
|
public export
|
|
data Phase = Parse | Check | Erase | Scheme
|
|
%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
|
|
|
|
||| "guess" is Term for a terminal and NoHL for a file
|
|
public export
|
|
data HLType = Guess | NoHL | Term | Html
|
|
%runElab derive "HLType" [Eq, Ord, Show]
|
|
|
|
public export
|
|
record Options where
|
|
constructor MkOpts
|
|
hlType : HLType
|
|
outFile : OutFile
|
|
until : Maybe Phase
|
|
flavor : Pretty.Flavor
|
|
width : Nat
|
|
include : List String
|
|
%name Options opts
|
|
%runElab derive "Options" [Show]
|
|
|
|
export
|
|
defaultWidth : IO Nat
|
|
defaultWidth = do
|
|
w <- cast {to = Nat} <$> getTermCols
|
|
pure $ if w == 0 then 80 else w
|
|
|
|
export
|
|
defaultOpts : IO Options
|
|
defaultOpts = pure $ MkOpts {
|
|
hlType = Guess,
|
|
outFile = Console,
|
|
until = Nothing,
|
|
flavor = Unicode,
|
|
width = !defaultWidth,
|
|
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 := NoOut}
|
|
toOutFile "-" = Ok {outFile := Console}
|
|
toOutFile f = Ok {outFile := File f}
|
|
|
|
private
|
|
toPhase : String -> OptAction
|
|
toPhase str =
|
|
let lstr = toLower str in
|
|
case find (\p => toLower (show p) == lstr) allPhases of
|
|
Just p => Ok {until := Just p}
|
|
Nothing => Err "unknown phase name \{show str}\nphases: \{phaseNames}"
|
|
where phaseNames = joinBy ", " $ map (toLower . show) allPhases
|
|
|
|
private
|
|
toWidth : String -> OptAction
|
|
toWidth s = case parsePositive s of
|
|
Just n => Ok {width := n}
|
|
Nothing => Err "invalid width: \{show s}"
|
|
|
|
private
|
|
toHLType : String -> OptAction
|
|
toHLType str = case toLower str of
|
|
"none" => Ok {hlType := NoHL}
|
|
"term" => Ok {hlType := Term}
|
|
"html" => Ok {hlType := Html}
|
|
_ => Err "unknown highlighting type \{str}\ntypes: term, html, none"
|
|
|
|
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"] (ReqArg toHLType "<type>")
|
|
"select highlighting type"
|
|
]
|
|
|
|
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 = trim """
|
|
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)
|