{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Arguments
(
Config
, blank
, simple
, complex
, baselineOptions
, Parameters(..)
, ParameterValue(..)
, LongName(..)
, ShortName
, Description
, Options(..)
, Commands(..)
, parseCommandLine
, extractValidEnvironments
, InvalidCommandLine(..)
, buildUsage
, buildVersion
) where
import Control.Exception.Safe (Exception(displayException))
import Data.Hashable (Hashable)
import qualified Data.List as List
import Data.Maybe (fromMaybe)
import Data.Text.Prettyprint.Doc (Doc, Pretty(..), nest, fillCat
, emptyDoc, hardline, softline, fillBreak, align, (<+>), fillSep, indent)
import Data.Text.Prettyprint.Doc.Util (reflow)
import Data.String
import System.Environment (getProgName)
import Core.Data.Structures
import Core.System.Base
import Core.Text.Rope
import Core.Text.Utilities
import Core.Program.Metadata
type ShortName = Char
type Description = Rope
newtype LongName = LongName String
deriving (Show, IsString, Eq, Hashable, Ord)
instance Key LongName
instance Pretty LongName where
pretty (LongName name) = pretty name
instance Textual LongName where
intoRope (LongName str) = intoRope str
fromRope = LongName . fromRope
data Config
= Blank
| Simple [Options]
| Complex [Commands]
blank :: Config
blank = Blank
simple :: [Options] -> Config
simple options = Simple (options ++ baselineOptions)
complex :: [Commands] -> Config
complex commands = Complex (commands ++ [Global baselineOptions])
data Commands
= Global [Options]
| Command LongName Description [Options]
data Options
= Option LongName (Maybe ShortName) ParameterValue Description
| Argument LongName Description
| Variable LongName Description
data ParameterValue
= Value String
| Empty
deriving (Show, Eq)
instance IsString ParameterValue where
fromString x = Value x
data Parameters
= Parameters {
commandNameFrom :: Maybe LongName
, parameterValuesFrom :: Map LongName ParameterValue
, environmentValuesFrom :: Map LongName ParameterValue
} deriving (Show, Eq)
baselineOptions :: [Options]
baselineOptions =
[ Option "verbose" (Just 'v') Empty [quote|
Turn on event tracing. By default the logging stream will go to
standard output on your terminal.
|]
, Option "debug" Nothing Empty [quote|
Turn on debug level logging. Implies --verbose.
|]
]
data InvalidCommandLine
= InvalidOption String
| UnknownOption String
| MissingArgument LongName
| UnexpectedArguments [String]
| UnknownCommand String
| NoCommandFound
| HelpRequest (Maybe LongName)
| VersionRequest
deriving (Show, Eq)
instance Exception InvalidCommandLine where
displayException e = case e of
InvalidOption arg ->
let
one = "Option '" ++ arg ++ "' illegal.\n\n"
two = [quote|
Options must either be long form with a double dash, for example:
--verbose
or, when available with a short version, a single dash and a single
character. They need to be listed individually:
-v -a
When an option takes a value it has to be in long form and the value
indicated with an equals sign, for example:
--tempdir=/tmp
with complex values escaped according to the rules of your shell:
--username="Ada Lovelace"
For options valid in this program, please see --help.
|]
in
one ++ two
UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized."
MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing."
UnexpectedArguments args ->
let
quoted = List.intercalate "', '" args
in [quote|
Unexpected trailing arguments:
|] ++ quoted ++ [quote|
For arguments expected by this program, please see --help.
|]
UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized."
NoCommandFound -> [quote|
No command specified.
Usage is of the form:
|] ++ programName ++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS]
See --help for details.
|]
HelpRequest _ -> ""
VersionRequest -> ""
programName :: String
programName = unsafePerformIO getProgName
parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters
parseCommandLine config argv = case config of
Blank -> return (Parameters Nothing emptyMap emptyMap)
Simple options -> do
params <- extractor Nothing options argv
return (Parameters Nothing params emptyMap)
Complex commands ->
let
globalOptions = extractGlobalOptions commands
modes = extractValidModes commands
in do
(possibles,argv') <- splitCommandLine1 argv
params1 <- extractor Nothing globalOptions possibles
(first,remainingArgs) <- splitCommandLine2 argv'
(mode,localOptions) <- parseIndicatedCommand modes first
params2 <- extractor (Just mode) localOptions remainingArgs
return (Parameters (Just mode) ((<>) params1 params2) emptyMap)
where
extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue)
extractor mode options args =
let
(possibles,arguments) = List.partition isOption args
valids = extractValidNames options
shorts = extractShortNames options
needed = extractRequiredArguments options
in do
list1 <- parsePossibleOptions mode valids shorts possibles
list2 <- parseRequiredArguments needed arguments
return ((<>) (intoMap list1) (intoMap list2))
isOption :: String -> Bool
isOption arg = case arg of
('-':_) -> True
_ -> False
parsePossibleOptions
:: Maybe LongName
-> Set LongName
-> Map ShortName LongName
-> [String]
-> Either InvalidCommandLine [(LongName,ParameterValue)]
parsePossibleOptions mode valids shorts args = mapM f args
where
f arg = case arg of
"--help" -> Left (HelpRequest mode)
"-?" -> Left (HelpRequest mode)
"--version" -> Left VersionRequest
('-':'-':name) -> considerLongOption name
('-':c:[]) -> considerShortOption c
_ -> Left (InvalidOption arg)
considerLongOption :: String -> Either InvalidCommandLine (LongName,ParameterValue)
considerLongOption arg =
let
(name,value) = List.span (/= '=') arg
candidate = LongName name
value' = case List.uncons value of
Just (_,remainder) -> Value remainder
Nothing -> Empty
in
if containsElement candidate valids
then Right (candidate,value')
else Left (UnknownOption ("--" ++ name))
considerShortOption :: Char -> Either InvalidCommandLine (LongName,ParameterValue)
considerShortOption c =
case lookupKeyValue c shorts of
Just name -> Right (name,Empty)
Nothing -> Left (UnknownOption ['-',c])
parseRequiredArguments
:: [LongName]
-> [String]
-> Either InvalidCommandLine [(LongName,ParameterValue)]
parseRequiredArguments needed argv = iter needed argv
where
iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName,ParameterValue)]
iter [] [] = Right []
iter [] args = Left (UnexpectedArguments args)
iter (name:_) [] = Left (MissingArgument name)
iter (name:names) (arg:args) =
let
deeper = iter names args
in case deeper of
Left e -> Left e
Right list -> Right ((name,Value arg):list)
parseIndicatedCommand
:: Map LongName [Options]
-> String
-> Either InvalidCommandLine (LongName,[Options])
parseIndicatedCommand modes first =
let
candidate = LongName first
in
case lookupKeyValue candidate modes of
Just options -> Right (candidate,options)
Nothing -> Left (UnknownCommand first)
extractValidNames :: [Options] -> Set LongName
extractValidNames options =
foldr f emptySet options
where
f :: Options -> Set LongName -> Set LongName
f (Option longname _ _ _) valids = insertElement longname valids
f _ valids = valids
extractShortNames :: [Options] -> Map ShortName LongName
extractShortNames options =
foldr g emptyMap options
where
g :: Options -> Map ShortName LongName -> Map ShortName LongName
g (Option longname shortname _ _) shorts = case shortname of
Just shortchar -> insertKeyValue shortchar longname shorts
Nothing -> shorts
g _ shorts = shorts
extractRequiredArguments :: [Options] -> [LongName]
extractRequiredArguments arguments =
foldr h [] arguments
where
h :: Options -> [LongName] -> [LongName]
h (Argument longname _) needed = longname:needed
h _ needed = needed
extractGlobalOptions :: [Commands] -> [Options]
extractGlobalOptions commands =
foldr j [] commands
where
j :: Commands -> [Options] -> [Options]
j (Global options) valids = options ++ valids
j _ valids = valids
extractValidModes :: [Commands] -> Map LongName [Options]
extractValidModes commands =
foldr k emptyMap commands
where
k :: Commands -> Map LongName [Options] -> Map LongName [Options]
k (Command longname _ options) modes = insertKeyValue longname options modes
k _ modes = modes
splitCommandLine1 :: [String] -> Either InvalidCommandLine ([String], [String])
splitCommandLine1 args =
let
(possibles,remainder) = List.span isOption args
in
if null possibles && null remainder
then Left NoCommandFound
else Right (possibles,remainder)
splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String])
splitCommandLine2 argv' =
let
x = List.uncons argv'
in
case x of
Just (mode,remainingArgs) -> Right (mode,remainingArgs)
Nothing -> Left NoCommandFound
extractValidEnvironments :: Maybe LongName -> Config -> Set LongName
extractValidEnvironments mode config = case config of
Blank -> emptySet
Simple options -> extractVariableNames options
Complex commands ->
let
globals = extractGlobalOptions commands
variables1 = extractVariableNames globals
locals = extractLocalVariables commands (fromMaybe "" mode)
variables2 = extractVariableNames locals
in
variables1 <> variables2
extractLocalVariables :: [Commands] -> LongName -> [Options]
extractLocalVariables commands mode =
foldr k [] commands
where
k :: Commands -> [Options] -> [Options]
k (Command name _ options) acc = if name == mode then options else acc
k _ acc = acc
extractVariableNames :: [Options] -> Set LongName
extractVariableNames options =
foldr f emptySet options
where
f :: Options -> Set LongName -> Set LongName
f (Variable longname _) valids = insertElement longname valids
f _ valids = valids
buildUsage :: Config -> Maybe LongName -> Doc ann
buildUsage config mode = case config of
Blank -> emptyDoc
Simple options ->
let
(o,a) = partitionParameters options
in
"Usage:" <> hardline <> hardline
<> indent 4 (nest 4 (fillCat
[ pretty programName
, optionsSummary o
, argumentsSummary a
])) <> hardline
<> optionsHeading o
<> formatParameters o
<> argumentsHeading a
<> formatParameters a
Complex commands ->
let
globalOptions = extractGlobalOptions commands
modes = extractValidModes commands
(oG,_) = partitionParameters globalOptions
in
"Usage:" <> hardline <> hardline <> case mode of
Nothing ->
indent 2 (nest 4 (fillCat
[ pretty programName
, globalSummary oG
, commandSummary modes
])) <> hardline
<> globalHeading oG
<> formatParameters oG
<> commandHeading modes
<> formatCommands commands
Just longname ->
let
(oL,aL) = case lookupKeyValue longname modes of
Just localOptions -> partitionParameters localOptions
Nothing -> error "Illegal State"
in
indent 2 (nest 4 (fillCat
[ pretty programName
, globalSummary oG
, commandSummary modes
, localSummary oL
, argumentsSummary aL
])) <> hardline
<> localHeading oL
<> formatParameters oL
<> argumentsHeading aL
<> formatParameters aL
where
partitionParameters :: [Options] -> ([Options],[Options])
partitionParameters options = foldr f ([],[]) options
optionsSummary :: [Options] -> Doc ann
optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc
optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc
globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc
globalHeading os = if length os > 0
then hardline <> "Global options:" <> hardline
else emptyDoc
localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc
localHeading os = if length os > 0
then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline
else emptyDoc
commandName :: Doc ann
commandName = case mode of
Just (LongName name) -> pretty name
Nothing -> "COMMAND..."
argumentsSummary :: [Options] -> Doc ann
argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as))
argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc
commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc
commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc
f :: Options -> ([Options],[Options]) -> ([Options],[Options])
f o@(Option _ _ _ _) (opts,args) = (o:opts,args)
f a@(Argument _ _) (opts,args) = (opts,a:args)
f (Variable _ _) (opts,args) = (opts,args)
formatParameters :: [Options] -> Doc ann
formatParameters [] = emptyDoc
formatParameters options = hardline <> foldr g emptyDoc options
g :: Options -> Doc ann -> Doc ann
g (Option longname shortname valued description) acc =
let
s = case shortname of
Just shortchar -> " -" <> pretty shortchar <> ", --"
Nothing -> " --"
l = pretty longname
d = fromRope description
in case valued of
Empty ->
fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc
Value label ->
fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc
g (Argument longname description) acc =
let
l = pretty longname
d = fromRope description
in
fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc
g (Variable longname description) acc =
let
l = pretty longname
d = fromRope description
in
fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc
formatCommands :: [Commands] -> Doc ann
formatCommands commands = hardline <> foldr h emptyDoc commands
h :: Commands -> Doc ann -> Doc ann
h (Command longname description _) acc =
let
l = pretty longname
d = fromRope description
in
fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc
h _ acc = acc
buildVersion :: Version -> Doc ann
buildVersion version =
pretty (projectNameFrom version)
<+> "v"
<> pretty (versionNumberFrom version)
<> hardline