{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HS.CLI.OptParse where
import Control.Applicative
import Data.Char
import Data.Default
import Data.Maybe
import Data.Possibly
import qualified Data.Text as T
import Fmt
import HS.CLI.ToolArgs
import qualified Options.Applicative as OP
import Options.Applicative.Builder
import System.Environment
import Text.Enum.Text
type Psr a = OP.Parser a
opt :: Psr a -> Psr (Maybe a)
opt :: Psr a -> Psr (Maybe a)
opt = Psr a -> Psr (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
OP.optional
mny :: Psr a -> Psr [a]
mny :: Psr a -> Psr [a]
mny = Psr a -> Psr [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
OP.many
parseArgs :: forall a . (ToolArgs->Psr a) -> IO a
parseArgs :: (ToolArgs -> Psr a) -> IO a
parseArgs ToolArgs -> Psr a
psr = [String] -> IO a
prs ([String] -> IO a) -> IO [String] -> IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
getArgs
where
prs :: [String] -> IO a
prs :: [String] -> IO a
prs [String]
as0 = Psr a -> [String] -> IO a
forall a. Psr a -> [String] -> IO a
parseIO (ToolArgs -> Psr a
psr ToolArgs
tas) [String]
as
where
tas :: ToolArgs
tas = [Text] -> ToolArgs
ToolArgs ([Text] -> ToolArgs) -> [Text] -> ToolArgs
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall b. [b] -> [b]
tail' [String]
dd_tas
([String]
as,[String]
dd_tas) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"--") [String]
as0
tail' :: [b] -> [b]
tail' :: [b] -> [b]
tail' [] = []
tail' (b
_:[b]
t) = [b]
t
parserPrefs :: OP.ParserPrefs
parserPrefs :: ParserPrefs
parserPrefs = PrefsMod -> ParserPrefs
OP.prefs PrefsMod
showHelpOnEmpty
parseIO :: Psr a -> [String] -> IO a
parseIO :: Psr a -> [String] -> IO a
parseIO Psr a
psr [String]
as = ParserResult a -> IO a
forall a. ParserResult a -> IO a
OP.handleParseResult (ParserResult a -> IO a) -> ParserResult a -> IO a
forall a b. (a -> b) -> a -> b
$
ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
OP.execParserPure ParserPrefs
parserPrefs (Psr a -> ParserInfo a
forall a. Psr a -> ParserInfo a
hsParserInfo (Psr a -> ParserInfo a) -> Psr a -> ParserInfo a
forall a b. (a -> b) -> a -> b
$ Psr a
psr) [String]
as
pureParse :: Psr a -> [String] -> Maybe a
pureParse :: Psr a -> [String] -> Maybe a
pureParse Psr a
p =
ParserResult a -> Maybe a
forall a. ParserResult a -> Maybe a
OP.getParseResult (ParserResult a -> Maybe a)
-> ([String] -> ParserResult a) -> [String] -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
OP.execParserPure ParserPrefs
parserPrefs (Psr a -> ParserInfo a
forall a. Psr a -> ParserInfo a
hsParserInfo Psr a
p)
testCLI :: Show a => Psr a -> [String] -> IO ()
testCLI :: Psr a -> [String] -> IO ()
testCLI Psr a
psr [String]
ss = do
a
x <- ParserResult a -> IO a
forall a. ParserResult a -> IO a
OP.handleParseResult (ParserResult a -> IO a) -> ParserResult a -> IO a
forall a b. (a -> b) -> a -> b
$
ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
OP.execParserPure ParserPrefs
parserPrefs (Psr a -> ParserInfo a
forall a. Psr a -> ParserInfo a
hsParserInfo Psr a
psr) [String]
ss
a -> IO ()
forall a. Show a => a -> IO ()
print a
x
hsParserInfo :: Psr a -> OP.ParserInfo a
hsParserInfo :: Psr a -> ParserInfo a
hsParserInfo Psr a
p =
Psr a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
OP.info (Parser (a -> a)
forall a. Parser (a -> a)
OP.helper Parser (a -> a) -> Psr a -> Psr a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Psr a
p)
(InfoMod a -> ParserInfo a) -> InfoMod a -> ParserInfo a
forall a b. (a -> b) -> a -> b
$ InfoMod a
forall a. InfoMod a
fullDesc
InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
"GHC installation manager manager"
InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
header String
"towards a unified Haskell Development Environment"
InfoMod a -> InfoMod a -> InfoMod a
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod a
forall a. String -> InfoMod a
footer String
"see --help for details of each sub-command"
cmd :: String -> String -> Psr a -> OP.Mod OP.CommandFields a
cmd :: String -> String -> Psr a -> Mod CommandFields a
cmd String
nme String
dsc Psr a
psr = String -> ParserInfo a -> Mod CommandFields a
forall a. String -> ParserInfo a -> Mod CommandFields a
command String
nme (ParserInfo a -> Mod CommandFields a)
-> ParserInfo a -> Mod CommandFields a
forall a b. (a -> b) -> a -> b
$ Psr a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (a -> a)
forall a. Parser (a -> a)
OP.helper Parser (a -> a) -> Psr a -> Psr a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Psr a
psr) (InfoMod a -> ParserInfo a) -> InfoMod a -> ParserInfo a
forall a b. (a -> b) -> a -> b
$ String -> InfoMod a
forall a. String -> InfoMod a
progDesc String
dsc
cmd_et_p :: EnumText a => String -> (a->String) -> Psr a
cmd_et_p :: String -> (a -> String) -> Psr a
cmd_et_p String
hlp a -> String
c_hlp = Mod CommandFields a -> Psr a
forall a. Mod CommandFields a -> Parser a
subparser (Mod CommandFields a -> Psr a) -> Mod CommandFields a -> Psr a
forall a b. (a -> b) -> a -> b
$ [Mod CommandFields a] -> Mod CommandFields a
forall a. Monoid a => [a] -> a
mconcat ([Mod CommandFields a] -> Mod CommandFields a)
-> [Mod CommandFields a] -> Mod CommandFields a
forall a b. (a -> b) -> a -> b
$
String -> Mod CommandFields a
forall a. String -> Mod CommandFields a
commandGroup String
hlp Mod CommandFields a
-> [Mod CommandFields a] -> [Mod CommandFields a]
forall a. a -> [a] -> [a]
:
[ String -> String -> Psr a -> Mod CommandFields a
forall a. String -> String -> Psr a -> Mod CommandFields a
cmd (Builder -> String
forall b. FromBuilder b => Builder -> b
fmt (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ a -> Builder
forall p. Buildable p => p -> Builder
build a
c) (a -> String
c_hlp a
c) (Psr a -> Mod CommandFields a) -> Psr a -> Mod CommandFields a
forall a b. (a -> b) -> a -> b
$ a -> Psr a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
c
| a
c <- [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound]
]
arg_et_optd :: forall a . EnumText a => String -> a -> Psr a
arg_et_optd :: String -> a -> Psr a
arg_et_optd String
var a
df = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
df (Maybe a -> a) -> Parser (Maybe a) -> Psr a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe a)
ss_p
where
ss_p :: Psr (Maybe a)
ss_p :: Parser (Maybe a)
ss_p = Psr a -> Parser (Maybe a)
forall a. Psr a -> Psr (Maybe a)
opt (Psr a -> Parser (Maybe a)) -> Psr a -> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ String -> Psr a
forall a.
(Bounded a, Enum a, Buildable a, TextParsable a) =>
String -> Psr a
arg_et_p String
var
arg_et_p :: forall a . (Bounded a,Enum a,Buildable a,TextParsable a) => String -> Psr a
arg_et_p :: String -> Psr a
arg_et_p String
var = String -> String -> Psr a
forall a. TextParsable a => String -> String -> Psr a
arg_p String
var String
hlp
where
hlp :: String
hlp = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"|" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
(a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> Text
forall b. FromBuilder b => Builder -> b
fmt (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall p. Buildable p => p -> Builder
build) [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound :: a]
opt_et_p :: forall a . EnumText a => Char -> String -> Psr a
opt_et_p :: Char -> String -> Psr a
opt_et_p Char
c String
var = Char -> String -> String -> Psr a
forall a. TextParsable a => Char -> String -> String -> Psr a
opt_p Char
c String
var String
hlp
where
hlp :: String
hlp = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"|" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
(a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Builder -> Text
forall b. FromBuilder b => Builder -> b
fmt (Builder -> Text) -> (a -> Builder) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall p. Buildable p => p -> Builder
build) [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound :: a]
arg_p :: TextParsable a => String -> String -> Psr a
arg_p :: String -> String -> Psr a
arg_p = (Text -> Possibly a) -> String -> String -> Psr a
forall a. (Text -> Possibly a) -> String -> String -> Psr a
arg_p' Text -> Possibly a
forall a. TextParsable a => Text -> Possibly a
parseText
arg_p' :: (T.Text->Possibly a) -> String -> String -> Psr a
arg_p' :: (Text -> Possibly a) -> String -> String -> Psr a
arg_p' Text -> Possibly a
prs String
var String
hlp = ReadM a -> Mod ArgumentFields a -> Psr a
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument ((String -> Possibly a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
eitherReader ((String -> Possibly a) -> ReadM a)
-> (String -> Possibly a) -> ReadM a
forall a b. (a -> b) -> a -> b
$ Text -> Possibly a
prs (Text -> Possibly a) -> (String -> Text) -> String -> Possibly a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
(Mod ArgumentFields a -> Psr a) -> Mod ArgumentFields a -> Psr a
forall a b. (a -> b) -> a -> b
$ String -> Mod ArgumentFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
var
Mod ArgumentFields a
-> Mod ArgumentFields a -> Mod ArgumentFields a
forall a. Semigroup a => a -> a -> a
<> String -> Mod ArgumentFields a
forall (f :: * -> *) a. String -> Mod f a
help String
hlp
opt_p :: TextParsable a => Char -> String -> String -> Psr a
opt_p :: Char -> String -> String -> Psr a
opt_p Char
ch String
nme String
hlp = ReadM a -> Mod OptionFields a -> Psr a
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either String a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
eitherReader String -> Either String a
forall a. TextParsable a => String -> Possibly a
parseString)
(Mod OptionFields a -> Psr a) -> Mod OptionFields a -> Psr a
forall a b. (a -> b) -> a -> b
$ String -> Mod OptionFields a
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
var
Mod OptionFields a -> Mod OptionFields a -> Mod OptionFields a
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields a
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
ch
Mod OptionFields a -> Mod OptionFields a -> Mod OptionFields a
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields a
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
lng
Mod OptionFields a -> Mod OptionFields a -> Mod OptionFields a
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields a
forall (f :: * -> *) a. String -> Mod f a
help String
hlp
where
var :: String
var = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper String
nme
lng :: String
lng = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
nme
enum_switches_with_def_p :: forall a . (Default a,EnumText a) => Psr a
enum_switches_with_def_p :: Psr a
enum_switches_with_def_p = (Maybe a -> a) -> Parser (Maybe a) -> Psr a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. Default a => a
def) (Parser (Maybe a) -> Psr a) -> Parser (Maybe a) -> Psr a
forall a b. (a -> b) -> a -> b
$ Psr a -> Parser (Maybe a)
forall a. Psr a -> Psr (Maybe a)
opt (Psr a -> Parser (Maybe a)) -> Psr a -> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ (a -> Maybe Char) -> Psr a
forall a. EnumText a => (a -> Maybe Char) -> Psr a
short_enum_switches_p ((a -> Maybe Char) -> Psr a) -> (a -> Maybe Char) -> Psr a
forall a b. (a -> b) -> a -> b
$ Maybe Char -> a -> Maybe Char
forall a b. a -> b -> a
const Maybe Char
forall a. Maybe a
Nothing
enum_switches_p :: forall a . EnumText a => Psr a
enum_switches_p :: Psr a
enum_switches_p = (a -> Maybe Char) -> Psr a
forall a. EnumText a => (a -> Maybe Char) -> Psr a
short_enum_switches_p ((a -> Maybe Char) -> Psr a) -> (a -> Maybe Char) -> Psr a
forall a b. (a -> b) -> a -> b
$ Maybe Char -> a -> Maybe Char
forall a b. a -> b -> a
const Maybe Char
forall a. Maybe a
Nothing
short_enum_switches_p :: forall a . EnumText a => (a->Maybe Char) -> Psr a
short_enum_switches_p :: (a -> Maybe Char) -> Psr a
short_enum_switches_p a -> Maybe Char
sh_f = (Psr a -> Psr a -> Psr a) -> Psr a -> [Psr a] -> Psr a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Psr a -> Psr a -> Psr a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) Psr a
forall (f :: * -> *) a. Alternative f => f a
empty ([Psr a] -> Psr a) -> [Psr a] -> Psr a
forall a b. (a -> b) -> a -> b
$ (a -> Psr a) -> [a] -> [Psr a]
forall a b. (a -> b) -> [a] -> [b]
map a -> Psr a
mk [a
forall a. Bounded a => a
minBound..a
forall a. Bounded a => a
maxBound]
where
mk :: a -> Psr a
mk :: a -> Psr a
mk a
x = a -> Mod FlagFields a -> Psr a
forall a. a -> Mod FlagFields a -> Parser a
OP.flag' a
x (Mod FlagFields a -> Psr a) -> Mod FlagFields a -> Psr a
forall a b. (a -> b) -> a -> b
$ (String -> Mod FlagFields a
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (String -> Mod FlagFields a) -> String -> Mod FlagFields a
forall a b. (a -> b) -> a -> b
$ Builder -> String
forall b. FromBuilder b => Builder -> b
fmt (Builder -> String) -> Builder -> String
forall a b. (a -> b) -> a -> b
$ a -> Builder
forall p. Buildable p => p -> Builder
build a
x) Mod FlagFields a -> Mod FlagFields a -> Mod FlagFields a
forall a. Semigroup a => a -> a -> a
<> Mod FlagFields a
forall a. Mod FlagFields a
shrt
where
shrt :: Mod FlagFields a
shrt = case a -> Maybe Char
sh_f a
x of
Maybe Char
Nothing -> Mod FlagFields a
forall a. Monoid a => a
mempty
Just Char
c -> Char -> Mod FlagFields a
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
c
parseString :: TextParsable a => String -> Possibly a
parseString :: String -> Possibly a
parseString = Text -> Possibly a
forall a. TextParsable a => Text -> Possibly a
parseText (Text -> Possibly a) -> (String -> Text) -> String -> Possibly a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack