quox/exe/Options.idr

259 lines
7.5 KiB
Idris
Raw Normal View History

2023-10-20 11:42:01 -04:00
module Options
import Quox.Pretty
2024-04-04 12:13:45 -04:00
import Quox.Log
2024-04-04 12:10:53 -04:00
import Data.DPair
import Data.SortedMap
2023-10-20 11:42:01 -04:00
import System
import System.Console.GetOpt
import System.File
import System.Term
import Derive.Prelude
%default total
2023-10-20 11:42:01 -04:00
%language ElabReflection
public export
2023-11-05 09:47:52 -05:00
data OutFile = File String | Console | NoOut
2023-10-20 11:42:01 -04:00
%name OutFile f
2023-11-30 08:46:45 -05:00
%runElab derive "OutFile" [Eq, Show]
2023-10-20 11:42:01 -04:00
public export
2023-11-27 01:39:17 -05:00
data Phase = Parse | Check | Erase | Scheme | End
2023-10-20 11:42:01 -04:00
%name Phase p
2023-11-30 08:46:45 -05:00
%runElab derive "Phase" [Eq, Show]
2023-10-20 11:42:01 -04:00
2023-11-27 01:39:17 -05:00
||| a list of all intermediate `Phase`s (excluding `End`)
2023-10-20 11:42:01 -04:00
public export %inline
allPhases : List Phase
allPhases = %runElab do
cs <- getCons $ fst !(lookupName "Phase")
2023-11-27 01:39:17 -05:00
traverse (check . var) $ fromMaybe [] $ init' cs
2023-10-20 11:42:01 -04:00
2023-11-27 01:39:17 -05:00
||| `Guess` is `Term` for a terminal and `NoHL` for a file
2023-11-05 09:47:52 -05:00
public export
data HLType = Guess | NoHL | Term | Html
2023-11-30 08:46:45 -05:00
%runElab derive "HLType" [Eq, Show]
2023-11-05 09:47:52 -05:00
2023-11-27 01:39:17 -05:00
public export
record Dump where
constructor MkDump
parse, check, erase, scheme : OutFile
%name Dump dump
%runElab derive "Dump" [Show]
2023-10-20 11:42:01 -04:00
public export
record Options where
constructor MkOpts
2024-04-04 12:13:45 -04:00
include : List String
dump : Dump
outFile : OutFile
until : Maybe Phase
hlType : HLType
flavor : Pretty.Flavor
width : Nat
logLevels : LogLevels
logFile : OutFile
2023-10-20 11:42:01 -04:00
%name Options opts
%runElab derive "Options" [Show]
2023-11-05 09:40:19 -05:00
export
defaultWidth : IO Nat
defaultWidth = do
w <- cast {to = Nat} <$> getTermCols
pure $ if w == 0 then 80 else w
2023-10-20 11:42:01 -04:00
export
defaultOpts : IO Options
defaultOpts = pure $ MkOpts {
2024-04-04 12:13:45 -04:00
include = ["."],
dump = MkDump NoOut NoOut NoOut NoOut,
outFile = Console,
until = Nothing,
hlType = Guess,
flavor = Unicode,
width = !defaultWidth,
logLevels = defaultLogLevels,
logFile = Console
2023-10-20 11:42:01 -04:00
}
private
data HelpType = Common | All
private
data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options)
%name OptAction act
private
2023-11-27 01:39:17 -05:00
toOutFile : String -> OutFile
toOutFile "" = NoOut
toOutFile "-" = Console
toOutFile f = File f
2023-10-20 11:42:01 -04:00
private
toPhase : String -> OptAction
toPhase str =
let lstr = toLower str in
case find (\p => toLower (show p) == lstr) allPhases of
2023-11-27 01:39:17 -05:00
Just p => Ok $ setPhase p
Nothing => Err "unknown phase name \{show str}\nphases: \{phaseNames}"
2023-11-27 01:39:17 -05:00
where
phaseNames = joinBy ", " $ map (toLower . show) allPhases
defConsole : OutFile -> OutFile
defConsole NoOut = Console
defConsole f = f
setPhase : Phase -> Options -> Options
setPhase Parse = {until := Just Parse, dump.parse $= defConsole}
setPhase Check = {until := Just Check, dump.check $= defConsole}
setPhase Erase = {until := Just Erase, dump.erase $= defConsole}
setPhase Scheme = {until := Just Scheme, dump.scheme $= defConsole}
setPhase End = id
2023-10-20 11:42:01 -04:00
private
toWidth : String -> OptAction
toWidth s = case parsePositive s of
Just n => Ok {width := n}
Nothing => Err "invalid width: \{show s}"
2023-11-05 09:47:52 -05:00
private
toHLType : String -> OptAction
toHLType str = case toLower str of
"none" => Ok {hlType := NoHL}
"term" => Ok {hlType := Term}
"html" => Ok {hlType := Html}
2023-11-27 01:39:17 -05:00
_ => Err "unknown highlighting type \{show str}\ntypes: term, html, none"
2024-04-04 12:10:53 -04:00
||| like ghc, `-i ""` clears the search path;
||| `-i a:b:c` adds `a`, `b`, `c` to the end
2023-11-27 01:39:17 -05:00
private
dirListFlag : String -> List String -> List String
2024-04-04 12:10:53 -04:00
dirListFlag "" val = []
dirListFlag dirs val = val ++ toList (split (== ':') dirs)
2023-11-05 09:47:52 -05:00
2024-04-04 12:13:45 -04:00
private
splitLogFlag : String -> Either String (List (Maybe LogCategory, LogLevel))
splitLogFlag = traverse flag1 . toList . split (== ':') where
parseLogCategory : String -> Either String LogCategory
parseLogCategory cat = do
let Just cat = toLogCategory cat
| _ => let catList = joinBy ", " logCategories in
Left "unknown log category. categories are:\n\{catList}"
pure cat
parseLogLevel : String -> Either String LogLevel
parseLogLevel lvl = do
let Just lvl = parsePositive lvl
| _ => Left "log level \{lvl} not a number"
let Just lvl = toLogLevel lvl
| _ => Left "log level \{show lvl} out of range 0\{show maxLogLevel}"
pure lvl
flag1 : String -> Either String (Maybe LogCategory, LogLevel)
flag1 str = do
let (first, second) = break (== '=') str
case strM second of
StrCons '=' lvl => do
cat <- parseLogCategory first
lvl <- parseLogLevel lvl
pure (Just cat, lvl)
StrNil => (Nothing,) <$> parseLogLevel first
_ => Left "invalid log flag \{str}"
private
setLogFlag : LogLevels -> (Maybe LogCategory, LogLevel) -> LogLevels
setLogFlag lvls (Nothing, lvl) = {defLevel := lvl} lvls
setLogFlag lvls (Just name, lvl) = {levels $= ((name, lvl) ::)} lvls
private
logFlag : String -> OptAction
logFlag str = case splitLogFlag str of
Left err => Err err
Right flags => Ok $ \o => {logLevels := foldl setLogFlag o.logLevels flags} o
2023-10-20 11:42:01 -04:00
private
commonOptDescrs' : List (OptDescr OptAction)
commonOptDescrs' = [
2023-11-27 01:39:17 -05:00
MkOpt ['i'] ["include"]
(ReqArg (\is => Ok {include $= dirListFlag is}) "<dir>:<dir>...")
"add directories to look for source files",
MkOpt ['o'] ["output"] (ReqArg (\s => Ok {outFile := toOutFile s}) "<file>")
2023-10-20 11:42:01 -04:00
"output file (\"-\" for stdout, \"\" for no output)",
MkOpt ['P'] ["phase"] (ReqArg toPhase "<phase>")
2024-04-04 12:13:45 -04:00
"stop after the given phase",
MkOpt ['l'] ["log"] (ReqArg logFlag "[<cat>=]<n>:...")
"set log level",
MkOpt ['L'] ["log-file"] (ReqArg (\s => Ok {logFile := toOutFile s}) "<file>")
"set log output file"
2023-10-20 11:42:01 -04:00
]
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)",
2023-11-05 09:47:52 -05:00
MkOpt [] ["color", "colour"] (ReqArg toHLType "<type>")
2023-11-27 01:39:17 -05:00
"select highlighting type",
2024-04-04 12:10:53 -04:00
MkOpt [] ["dump-parse"]
(ReqArg (\s => Ok {dump.parse := toOutFile s}) "<file>")
2023-11-27 01:39:17 -05:00
"dump AST",
2024-04-04 12:10:53 -04:00
MkOpt [] ["dump-check"]
(ReqArg (\s => Ok {dump.check := toOutFile s}) "<file>")
2023-11-27 01:39:17 -05:00
"dump typechecker output",
2024-04-04 12:10:53 -04:00
MkOpt [] ["dump-erase"]
(ReqArg (\s => Ok {dump.erase := toOutFile s}) "<file>")
2023-11-27 01:39:17 -05:00
"dump erasure output",
2024-04-04 12:10:53 -04:00
MkOpt [] ["dump-scheme"]
(ReqArg (\s => Ok {dump.scheme := toOutFile s}) "<file>")
2023-11-27 01:39:17 -05:00
"dump scheme output (without prelude)"
2023-10-20 11:42:01 -04:00
]
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
2023-11-05 09:47:52 -05:00
usageHeader = trim """
quox [options] [file.quox ...]
rawr
"""
2023-10-20 11:42:01 -04:00
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
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
2023-11-27 01:39:17 -05:00
pure (app, opts, res.nonOptions)