{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
module WithCli.Parser where
import Data.Orphans ()
import Prelude ()
import Prelude.Compat
import Control.Arrow
import Control.Monad
import System.Console.GetOpt as Base
import WithCli.Flag
import WithCli.Modifier.Types
import WithCli.Normalize
import WithCli.Result
data NonOptionsParser uninitialized =
NonOptionsParser {
forall uninitialized. NonOptionsParser uninitialized -> String
nonOptionsType :: String,
forall uninitialized. NonOptionsParser uninitialized -> Bool
nonOptionsOptional :: Bool,
forall uninitialized.
NonOptionsParser uninitialized
-> [String] -> Result (uninitialized -> uninitialized, [String])
nonOptionsParser ::
[String] -> Result (uninitialized -> uninitialized, [String])
}
combineNonOptionsParser :: [NonOptionsParser u] -> [NonOptionsParser v]
-> [NonOptionsParser (u, v)]
combineNonOptionsParser :: forall u v.
[NonOptionsParser u]
-> [NonOptionsParser v] -> [NonOptionsParser (u, v)]
combineNonOptionsParser [NonOptionsParser u]
a [NonOptionsParser v]
b =
forall a b. (a -> b) -> [a] -> [b]
map (forall a b.
((a -> a) -> b -> b) -> NonOptionsParser a -> NonOptionsParser b
modMod forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first) [NonOptionsParser u]
a forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (forall a b.
((a -> a) -> b -> b) -> NonOptionsParser a -> NonOptionsParser b
modMod forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second) [NonOptionsParser v]
b
where
modMod :: ((a -> a) -> (b -> b)) -> NonOptionsParser a -> NonOptionsParser b
modMod :: forall a b.
((a -> a) -> b -> b) -> NonOptionsParser a -> NonOptionsParser b
modMod (a -> a) -> b -> b
f (NonOptionsParser String
field Bool
optional [String] -> Result (a -> a, [String])
parser) =
forall uninitialized.
String
-> Bool
-> ([String] -> Result (uninitialized -> uninitialized, [String]))
-> NonOptionsParser uninitialized
NonOptionsParser String
field Bool
optional (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a -> a) -> b -> b
f)) [String] -> Result (a -> a, [String])
parser)
data Parser phase a where
Parser :: {
()
parserDefault :: uninitialized,
()
parserOptions :: [OptDescr (Result (uninitialized -> uninitialized))],
()
parserNonOptions :: [NonOptionsParser uninitialized],
()
parserConvert :: uninitialized -> Result a
} -> Parser phase a
instance Functor (Parser phase) where
fmap :: forall a b. (a -> b) -> Parser phase a -> Parser phase b
fmap a -> b
f (Parser uninitialized
def [OptDescr (Result (uninitialized -> uninitialized))]
options [NonOptionsParser uninitialized]
nonOptions uninitialized -> Result a
convert) =
forall uninitialized a phase.
uninitialized
-> [OptDescr (Result (uninitialized -> uninitialized))]
-> [NonOptionsParser uninitialized]
-> (uninitialized -> Result a)
-> Parser phase a
Parser uninitialized
def [OptDescr (Result (uninitialized -> uninitialized))]
options [NonOptionsParser uninitialized]
nonOptions (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. uninitialized -> Result a
convert)
data Unnormalized
data Normalized
emptyParser :: a -> Parser phase a
emptyParser :: forall a phase. a -> Parser phase a
emptyParser a
a = Parser {
parserDefault :: a
parserDefault = a
a,
parserOptions :: [OptDescr (Result (a -> a))]
parserOptions = [],
parserNonOptions :: [NonOptionsParser a]
parserNonOptions = [],
parserConvert :: a -> Result a
parserConvert = forall (m :: * -> *) a. Monad m => a -> m a
return
}
normalizeParser :: Parser Unnormalized a -> Parser Normalized a
normalizeParser :: forall a. Parser Unnormalized a -> Parser Normalized a
normalizeParser (Parser uninitialized
d [OptDescr (Result (uninitialized -> uninitialized))]
options [NonOptionsParser uninitialized]
nonOptions uninitialized -> Result a
convert) =
forall uninitialized a phase.
uninitialized
-> [OptDescr (Result (uninitialized -> uninitialized))]
-> [NonOptionsParser uninitialized]
-> (uninitialized -> Result a)
-> Parser phase a
Parser uninitialized
d (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (String -> String) -> OptDescr a -> OptDescr a
mapLongOptions String -> String
normalize) [OptDescr (Result (uninitialized -> uninitialized))]
options) [NonOptionsParser uninitialized]
nonOptions uninitialized -> Result a
convert
where
mapLongOptions :: (String -> String) -> OptDescr a -> OptDescr a
mapLongOptions :: forall a. (String -> String) -> OptDescr a -> OptDescr a
mapLongOptions String -> String
f (Option String
shorts [String]
longs ArgDescr a
argDescr String
help) =
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
shorts (forall a b. (a -> b) -> [a] -> [b]
map String -> String
f [String]
longs) ArgDescr a
argDescr String
help
modParserOptions :: (forall x . [OptDescr (Result x)] -> [OptDescr (Result x)])
-> Parser Unnormalized a -> Parser Unnormalized a
modParserOptions :: forall a.
(forall x. [OptDescr (Result x)] -> [OptDescr (Result x)])
-> Parser Unnormalized a -> Parser Unnormalized a
modParserOptions forall x. [OptDescr (Result x)] -> [OptDescr (Result x)]
f (Parser uninitialized
def [OptDescr (Result (uninitialized -> uninitialized))]
options [NonOptionsParser uninitialized]
nonOptions uninitialized -> Result a
convert) =
forall uninitialized a phase.
uninitialized
-> [OptDescr (Result (uninitialized -> uninitialized))]
-> [NonOptionsParser uninitialized]
-> (uninitialized -> Result a)
-> Parser phase a
Parser uninitialized
def (forall x. [OptDescr (Result x)] -> [OptDescr (Result x)]
f [OptDescr (Result (uninitialized -> uninitialized))]
options) [NonOptionsParser uninitialized]
nonOptions uninitialized -> Result a
convert
combine :: forall a b phase .
Result (Parser phase a) -> Result (Parser phase b)
-> Result (Parser phase (a, b))
combine :: forall a b phase.
Result (Parser phase a)
-> Result (Parser phase b) -> Result (Parser phase (a, b))
combine Result (Parser phase a)
a Result (Parser phase b)
b = Parser phase a -> Parser phase b -> Parser phase (a, b)
inner forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Result (Parser phase a)
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Result (Parser phase b)
b
where
inner :: Parser phase a -> Parser phase b -> Parser phase (a, b)
inner :: Parser phase a -> Parser phase b -> Parser phase (a, b)
inner (Parser uninitialized
defaultA [OptDescr (Result (uninitialized -> uninitialized))]
optionsA [NonOptionsParser uninitialized]
nonOptionsA uninitialized -> Result a
convertA) (Parser uninitialized
defaultB [OptDescr (Result (uninitialized -> uninitialized))]
optionsB [NonOptionsParser uninitialized]
nonOptionsB uninitialized -> Result b
convertB) =
Parser {
parserDefault :: (uninitialized, uninitialized)
parserDefault = (uninitialized
defaultA, uninitialized
defaultB),
parserOptions :: [OptDescr
(Result
((uninitialized, uninitialized)
-> (uninitialized, uninitialized)))]
parserOptions =
forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first)) [OptDescr (Result (uninitialized -> uninitialized))]
optionsA forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second)) [OptDescr (Result (uninitialized -> uninitialized))]
optionsB,
parserNonOptions :: [NonOptionsParser (uninitialized, uninitialized)]
parserNonOptions = forall u v.
[NonOptionsParser u]
-> [NonOptionsParser v] -> [NonOptionsParser (u, v)]
combineNonOptionsParser [NonOptionsParser uninitialized]
nonOptionsA [NonOptionsParser uninitialized]
nonOptionsB,
parserConvert :: (uninitialized, uninitialized) -> Result (a, b)
parserConvert =
\ (uninitialized
u, uninitialized
v) -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (uninitialized -> Result a
convertA uninitialized
u) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (uninitialized -> Result b
convertB uninitialized
v)
}
fillInOptions :: [Result (u -> u)] -> u -> Result u
fillInOptions :: forall u. [Result (u -> u)] -> u -> Result u
fillInOptions [] u
u = forall (m :: * -> *) a. Monad m => a -> m a
return u
u
fillInOptions (Result (u -> u)
option : [Result (u -> u)]
options) u
u = do
u -> u
f <- Result (u -> u)
option
forall u. [Result (u -> u)] -> u -> Result u
fillInOptions [Result (u -> u)]
options (u -> u
f u
u)
fillInNonOptions :: [[String] -> Result (u -> u, [String])] -> [String] -> u
-> Result u
fillInNonOptions :: forall u.
[[String] -> Result (u -> u, [String])]
-> [String] -> u -> Result u
fillInNonOptions ([String] -> Result (u -> u, [String])
parser : [[String] -> Result (u -> u, [String])]
parsers) nonOptions :: [String]
nonOptions@(String
_ : [String]
_) u
u = do
(u -> u
p, [String]
rest) <- [String] -> Result (u -> u, [String])
parser [String]
nonOptions
forall u.
[[String] -> Result (u -> u, [String])]
-> [String] -> u -> Result u
fillInNonOptions [[String] -> Result (u -> u, [String])]
parsers [String]
rest (u -> u
p u
u)
fillInNonOptions [] [] u
u =
forall (m :: * -> *) a. Monad m => a -> m a
return u
u
fillInNonOptions [] [String]
nonOptions u
_ =
forall a. String -> Result a
Errors forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (String
"unknown argument: " forall a. [a] -> [a] -> [a]
++) [String]
nonOptions)
fillInNonOptions [[String] -> Result (u -> u, [String])]
_ [] u
u = forall (m :: * -> *) a. Monad m => a -> m a
return u
u
runParser :: String -> Modifiers -> Parser Normalized a -> [String] -> Result a
runParser :: forall a.
String -> Modifiers -> Parser Normalized a -> [String] -> Result a
runParser String
progName Modifiers
modifiers Parser{uninitialized
[OptDescr (Result (uninitialized -> uninitialized))]
[NonOptionsParser uninitialized]
uninitialized -> Result a
parserConvert :: uninitialized -> Result a
parserNonOptions :: [NonOptionsParser uninitialized]
parserOptions :: [OptDescr (Result (uninitialized -> uninitialized))]
parserDefault :: uninitialized
parserConvert :: ()
parserNonOptions :: ()
parserOptions :: ()
parserDefault :: ()
..} [String]
args =
forall a. [NonOptionsParser a] -> Result ()
checkNonOptionParsers [NonOptionsParser uninitialized]
parserNonOptions forall a b. Result a -> Result b -> Result b
|>
let versionOptions :: [OptDescr (Flag (Result (uninitialized -> uninitialized)))]
versionOptions = forall b a. b -> (a -> b) -> Maybe a -> b
maybe []
(\ String
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. String -> OptDescr (Flag a)
versionOption (String
progName forall a. [a] -> [a] -> [a]
++ String
" version " forall a. [a] -> [a] -> [a]
++ String
v))
(Modifiers -> Maybe String
getVersion Modifiers
modifiers)
options :: [OptDescr (Flag (Result (uninitialized -> uninitialized)))]
options = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Flag a
NoHelp) [OptDescr (Result (uninitialized -> uninitialized))]
parserOptions forall a. [a] -> [a] -> [a]
++ [forall a. OptDescr (Flag a)
helpOption] forall a. [a] -> [a] -> [a]
++ [OptDescr (Flag (Result (uninitialized -> uninitialized)))]
versionOptions
([Flag (Result (uninitialized -> uninitialized))]
flags, [String]
nonOptions, [String]
errs) =
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
Base.getOpt forall a. ArgOrder a
Base.Permute [OptDescr (Flag (Result (uninitialized -> uninitialized)))]
options [String]
args
in case forall a. [Flag a] -> Flag [a]
foldFlags [Flag (Result (uninitialized -> uninitialized))]
flags of
Flag [Result (uninitialized -> uninitialized)]
Help -> forall a. String -> Result a
OutputAndExit forall a b. (a -> b) -> a -> b
$
let fields :: [(Bool, String)]
fields = case Modifiers -> Maybe String
getPositionalArgumentType Modifiers
modifiers of
Maybe String
Nothing -> forall a b. (a -> b) -> [a] -> [b]
map (\ NonOptionsParser uninitialized
p -> (forall uninitialized. NonOptionsParser uninitialized -> Bool
nonOptionsOptional NonOptionsParser uninitialized
p, forall uninitialized. NonOptionsParser uninitialized -> String
nonOptionsType NonOptionsParser uninitialized
p)) [NonOptionsParser uninitialized]
parserNonOptions
Just String
typ -> [(Bool
True, String
typ)]
in String -> [(Bool, String)] -> [OptDescr ()] -> String
usage String
progName [(Bool, String)]
fields (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Functor f => f a -> f ()
void [OptDescr (Flag (Result (uninitialized -> uninitialized)))]
options)
Version String
msg -> forall a. String -> Result a
OutputAndExit String
msg
NoHelp [Result (uninitialized -> uninitialized)]
innerFlags ->
[String] -> Result ()
reportErrors [String]
errs forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
(forall u. [Result (u -> u)] -> u -> Result u
fillInOptions [Result (uninitialized -> uninitialized)]
innerFlags uninitialized
parserDefault forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall u.
[[String] -> Result (u -> u, [String])]
-> [String] -> u -> Result u
fillInNonOptions (forall a b. (a -> b) -> [a] -> [b]
map forall uninitialized.
NonOptionsParser uninitialized
-> [String] -> Result (uninitialized -> uninitialized, [String])
nonOptionsParser [NonOptionsParser uninitialized]
parserNonOptions) [String]
nonOptions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
uninitialized -> Result a
parserConvert)
where
reportErrors :: [String] -> Result ()
reportErrors :: [String] -> Result ()
reportErrors = \ case
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[String]
errs -> forall a. String -> Result a
Errors forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
errs
checkNonOptionParsers :: [NonOptionsParser a] -> Result ()
checkNonOptionParsers :: forall a. [NonOptionsParser a] -> Result ()
checkNonOptionParsers [NonOptionsParser a]
parsers =
case forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall uninitialized. NonOptionsParser uninitialized -> Bool
nonOptionsOptional forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall uninitialized. NonOptionsParser uninitialized -> Bool
nonOptionsOptional) [NonOptionsParser a]
parsers of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(NonOptionsParser a
_ : [NonOptionsParser a]
_) -> forall a. String -> Result a
Errors String
"cannot use Maybes for optional arguments before any non-optional arguments"