{-# 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


-- | the OA parser
type Psr a = OP.Parser a

-- | the OA optional operator
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

-- | the OA Kleene closure operator
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
--------------------------------------------------------------------------------

-- | main OA driver function
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


--------------------------------------------------------------------------------
-- the low-level drivers
--------------------------------------------------------------------------------

parserPrefs :: OP.ParserPrefs
parserPrefs :: ParserPrefs
parserPrefs = PrefsMod -> ParserPrefs
OP.prefs PrefsMod
showHelpOnEmpty

-- | making an IO parser
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

-- | making a functional parser
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)

-- | testing CLI parsers
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
--------------------------------------------------------------------------------

-- | given a 'Psr' makes up a corresponding @ParserInfo@
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
--------------------------------------------------------------------------------

-- | construct a sub-command parser from command name, description and parser
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


--------------------------------------------------------------------------------
-- parser builders
--------------------------------------------------------------------------------

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]
        ]

-- | parsing an argument EnumText argument
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

-- | parsing an argument EnumText argument
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]

-- | pasring an EnumText option
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]

-- | pasring a TextParsable argument
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

-- | pasring an argument ParseText, when passed the parser explicitly
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

-- | parsing a TextParsable option
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