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

-- phases:
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"