{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-} -- for Router
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
module Symantic.CLI.Parser where

import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
import Control.Monad (Monad(..), join, sequence, forM_, void)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.State (StateT(..),evalState,get,put)
import Data.Bool
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (null, toList)
import Data.Function (($), (.), id, const)
import Data.Functor (Functor(..), (<$>), ($>))
import Data.Functor.Identity (Identity(..))
import Data.Int (Int)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), maybe, isNothing)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import Numeric.Natural (Natural)
import Prelude (Integer, Num(..), error)
import System.Environment (lookupEnv)
import System.IO (IO)
import Text.Read (Read, readEither)
import Text.Show (Show(..), ShowS, showString, showParen)
import Type.Reflection as Reflection
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.IO as TL
import qualified Symantic.Document as Doc
import qualified System.IO as IO
import qualified Text.Megaparsec as P

import Symantic.CLI.API

-- * Type 'Parser'
newtype Parser e d f k = Parser
 { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
 }

parser ::
 P.ShowErrorComponent e =>
 Router (Parser e d) handlers (Response (Router (Parser e d))) ->
 handlers ->
 [Arg] -> IO ()
parser api handlers args = do
        P.runParserT
         (unParser $ unTrans $ router api)
         "" args >>= \case
         Left err ->
                forM_ (P.bundleErrors err) $ \e -> do
                        IO.putStr $
                                "Error parsing the command at argument #" <>
                                show (P.errorOffset e + 1) <> ":\n" <>
                                parseErrorTextPretty e
         Right app -> unResponseParser $ app handlers

-- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
parseErrorTextPretty ::
 forall s e.
 (P.Stream s, P.ShowErrorComponent e) =>
 P.ParseError s e -> String
parseErrorTextPretty (P.TrivialError _ us ps) =
        if isNothing us && Set.null ps
        then "unknown parse error\n"
        else
                messageItemsPretty "unexpected "
                 (showErrorItem pxy <$> Set.toAscList (maybe Set.empty Set.singleton us)) <>
                messageItemsPretty "expecting "
                 (showErrorItem pxy <$> Set.toAscList ps)
        where pxy = Proxy :: Proxy s
parseErrorTextPretty err = P.parseErrorTextPretty err

messageItemsPretty :: String -> [String] -> String
messageItemsPretty prefix ts
 | null ts = ""
 | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"

orList :: NonEmpty String -> String
orList (x:|[])  = x
orList (x:|[y]) = x <> " or " <> y
orList xs       = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs

showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String
showErrorItem pxy = \case
 P.Tokens ts   -> P.showTokens pxy ts
 P.Label label -> NonEmpty.toList label
 P.EndOfInput  -> "end of input"

instance Functor (Parser e d f) where
        a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x
instance Applicative (Parser e d f) where
        pure = Parser . pure . const
        Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
instance Ord e => Alternative (Parser e d f) where
        empty = Parser empty
        Parser x <|> Parser y = Parser $ x <|> y
instance Ord e => Sequenceable (Parser e d) where
        type Sequence (Parser e d) = ParserSeq e d
        runSequence = unParserSeq
        toSequence  = ParserSeq
instance Ord e => Permutable (Parser e d) where
        type Permutation (Parser e d) = ParserPerm e d (Parser e d)
        runPermutation (ParserPerm ma p) = Parser $ do
                u2p <- unParser $ optional p
                unParser $
                        case u2p () of
                         Just perm -> runPermutation perm
                         Nothing ->
                                maybe
                                 (Parser $ P.token (const Nothing) Set.empty)
                                 -- NOTE: Not 'empty' here so that 'P.TrivialError'
                                 -- has the unexpected token.
                                 (Parser . return) ma
        toPermutation (Parser x) =
                ParserPerm Nothing
                 (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x)
        toPermDefault a (Parser x) =
                ParserPerm (Just ($ a))
                 (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)
instance App (Parser e d) where
        Parser x <.> Parser y = Parser $
                x >>= \a2b -> (. a2b) <$> y
instance Ord e => Alt (Parser e d) where
        Parser x <!> Parser y = Parser $
                (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
                (\b2k (_a:!:b) -> b2k b) <$> y
        Parser x `alt` Parser y = Parser $ P.try x <|> y
        opt (Parser x) = Parser $
                mapCont Just <$> P.try x
instance Ord e => AltApp (Parser e d) where
        many0 (Parser x) = Parser $ concatCont <$> many x
        many1 (Parser x) = Parser $ concatCont <$> some x
instance Pro (Parser e d) where
        dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
instance Ord e => CLI_Command (Parser e d) where
        -- type CommandConstraint (Parser e d) a = ()
        command "" x = x
        command n x = commands Map.empty (Map.singleton n x)
instance Ord e => CLI_Tag (Parser e d) where
        type TagConstraint (Parser e d) a = ()
        tag name p = Parser $ P.try $ do
                void $ (`P.token` exp) $ \tok ->
                        if lookupTag tok name
                        then Just tok
                        else Nothing
                unParser p
                where
                exp =
                        case name of
                         TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t
                         TagLong  t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong  t
                         Tag s l -> Set.fromList
                                 [ P.Tokens $ pure $ ArgTagShort s
                                 , P.Tokens $ pure $ ArgTagLong  l
                                 ]
                lookupTag (ArgTagShort x) (TagShort y) = x == y
                lookupTag (ArgTagShort x) (Tag y _)    = x == y
                lookupTag (ArgTagLong  x) (TagLong y)  = x == y
                lookupTag (ArgTagLong  x) (Tag _ y)    = x == y
                lookupTag _ _                          = False
        endOpts = Parser $ do
                (`P.token` exp) $ \case
                 ArgTagLong "" -> Just id
                 _ -> Nothing
                where
                exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""
instance Ord e => CLI_Var (Parser e d) where
        type VarConstraint (Parser e d) a = (IOType a, FromSegment a)
        var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k
        var' name = Parser $ do
                seg <- (`P.token` expName) $ \case
                 ArgSegment seg -> Just seg
                 _ -> Nothing
                lift (fromSegment seg) >>= \case
                 Left err -> P.failure got expType
                        where
                        got = Just $ P.Tokens $ pure $ ArgSegment seg
                        expType = Set.singleton $ P.Label $ NonEmpty.fromList $
                                "<"<>name<>"> to be of type "<>ioType @a
                                <> case err of
                                 "Prelude.read: no parse" -> ""
                                 "" -> ""
                                 _ -> ": "<>err
                 Right a -> return ($ a)
                where
                expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
        just a  = Parser $ return ($ a)
        nothing = Parser $ return id
instance Ord e => CLI_Env (Parser e d) where
        type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
        env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
        env' name = Parser $
                lift (lookupEnv name) >>= \case
                 Nothing -> P.failure got exp
                        where
                        got = Nothing
                        exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
                 Just val ->
                        lift (fromSegment val) >>= \case
                         Right a -> return ($ a)
                         Left err -> P.failure got exp
                                where
                                got = Just $ P.Tokens $ pure $ ArgEnv name val
                                exp = Set.singleton $ P.Label $ NonEmpty.fromList $
                                        "${"<>name<>"} to be of type "<>ioType @a
                                        <> case err of
                                         "Prelude.read: no parse" -> ""
                                         "" -> ""
                                         _ -> ": "<>err
instance Ord e => CLI_Response (Parser e d) where
        type ResponseConstraint (Parser e d) a = Outputable a
        type ResponseArgs (Parser e d) a = ParserResponseArgs a
        type Response (Parser e d) = ParserResponse
        response' = Parser $
                P.eof $> \({-ParserResponseArgs-} io) ->
                        ParserResponse $ io >>= output
instance Ord e => CLI_Help (Parser e d) where
        type HelpConstraint (Parser e d) d' = d ~ d'
        help _msg = id
        program n = Parser . P.label n . unParser
        rule n    = Parser . P.label n . unParser

concatCont :: [(a->k)->k] -> ([a]->k)->k
concatCont = List.foldr (consCont (:)) ($ [])

consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)

mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)

-- ** Type 'ParserResponse'
newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
-- ** Type 'ParserResponseArgs'
type ParserResponseArgs = IO

-- * Class 'Outputable'
-- | Output of a CLI.
class IOType a => Outputable a where
        output :: a -> IO ()
        default output :: Show a => a -> IO ()
        output = IO.print

instance Outputable () where
        output = return
instance Outputable Bool
instance Outputable Int
instance Outputable Integer
instance Outputable Natural
instance Outputable Char where
        output c = IO.putStr [c]
instance Outputable String where
        output = IO.putStr
instance Outputable Text.Text where
        output = Text.putStr
instance Outputable TL.Text where
        output = TL.putStr
instance Outputable BS.ByteString where
        output = BS.putStr
instance Outputable BSL.ByteString where
        output = BSL.putStr
instance Outputable (Doc.Plain TLB.Builder) where
        output =
                TL.putStr .
                TLB.toLazyText .
                Doc.runPlain

-- ** Type 'OnHandle'
data OnHandle a = OnHandle IO.Handle a
instance IOType a => IOType (OnHandle a) where
        ioType = ioType @a
instance Outputable (OnHandle ()) where
        output _ = return ()
instance Outputable (OnHandle Bool) where
        output (OnHandle h a) = IO.hPrint h a
instance Outputable (OnHandle Int) where
        output (OnHandle h a) = IO.hPrint h a
instance Outputable (OnHandle Integer) where
        output (OnHandle h a) = IO.hPrint h a
instance Outputable (OnHandle Natural) where
        output (OnHandle h a) = IO.hPrint h a
instance Outputable (OnHandle Char) where
        output (OnHandle h c) = IO.hPutStr h [c]
instance Outputable (OnHandle String) where
        output (OnHandle h a) = IO.hPutStr h a
instance Outputable (OnHandle Text.Text) where
        output (OnHandle h a) = Text.hPutStr h a
instance Outputable (OnHandle TL.Text) where
        output (OnHandle h a) = TL.hPutStr h a
instance Outputable (OnHandle BS.ByteString) where
        output (OnHandle h a) = BS.hPutStr h a
instance Outputable (OnHandle BSL.ByteString) where
        output (OnHandle h a) = BSL.hPutStr h a
instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where
        output (OnHandle h d) =
                TL.hPutStr h $
                TLB.toLazyText $
                Doc.runPlain d
instance
 ( Outputable a
 , Reflection.Typeable a
 ) => Outputable (Maybe a) where
        output = \case
         Nothing -> return ()
         Just a  -> output a
instance
 ( Reflection.Typeable e
 , Reflection.Typeable a
 , Outputable (OnHandle e)
 , Outputable a
 ) => Outputable (Either e a) where
        output = \case
         Left e -> output $ OnHandle IO.stderr e
         Right a -> output a

-- * Class 'IOType'
-- | Like a MIME type but for input/output of a CLI.
class IOType a where
        ioType :: String
        default ioType :: Reflection.Typeable a => String
        ioType = show (Reflection.typeRep @a)

instance IOType ()
instance IOType Bool
instance IOType Char
instance IOType Int
instance IOType Integer
instance IOType Natural
instance IOType String
instance IOType Text.Text
instance IOType TL.Text
instance IOType BS.ByteString
instance IOType BSL.ByteString
instance IOType (Doc.Plain TLB.Builder)
instance Reflection.Typeable a => IOType (Maybe a)
instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)

-- * Class 'FromSegment'
class FromSegment a where
        fromSegment :: Segment -> IO (Either String a)
        default fromSegment :: Read a => Segment -> IO (Either String a)
        fromSegment = return . readEither
instance FromSegment String where
        fromSegment = return . Right
instance FromSegment Text.Text where
        fromSegment = return . Right . Text.pack
instance FromSegment TL.Text where
        fromSegment = return . Right . TL.pack
instance FromSegment Bool
instance FromSegment Int
instance FromSegment Integer
instance FromSegment Natural

-- ** Type 'ParserSeq'
-- | Lift a 'Parser' to something working with 'Functor' and 'Applicative'.
-- Used to gather collected values into a single one,
-- which is for instance needed for using 'many0' on multiple 'var's.
newtype ParserSeq e d k a = ParserSeq
 { unParserSeq :: Parser e d (a->k) k }
instance Functor (ParserSeq e d k) where
        a2b `fmap` ParserSeq (Parser x) = ParserSeq $ Parser $ merge <$> x
                where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
instance Applicative (ParserSeq e d k) where
        pure a = ParserSeq $ Parser $ pure ($ a)
        ParserSeq (Parser f) <*> ParserSeq (Parser x) =
                ParserSeq $ Parser $ merge <$> f <*> x
                where merge a2b2k2k a2k2k b2k =
                        a2b2k2k $ \a2b -> a2k2k (b2k . a2b)

-- ** Type 'ParserPerm'
data ParserPerm e d repr k a = ParserPerm
 { permutation_result :: !(Maybe ((a->k)->k))
 , permutation_parser :: repr () (ParserPerm e d repr k a)
 }

instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
        a2b `fmap` ParserPerm a ma =
                ParserPerm (merge <$> a) ((a2b `fmap`) `fmap` ma)
                where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
instance (App repr, Functor (repr ()), Alternative (repr ())) =>
         Applicative (ParserPerm e d repr k) where
        pure a = ParserPerm (Just ($ a)) empty
        lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
                ParserPerm a (lhsAlt <|> rhsAlt)
                where
                a = merge <$> f <*> x
                lhsAlt = (<*> rhs) <$> ma2b
                rhsAlt = (lhs <*>) <$> ma
                merge a2b2k2k a2k2k b2k =
                        a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
        type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
        program _n = id
        rule _n = id

noTransParserPerm ::
 Trans repr =>
 Functor (UnTrans repr ()) =>
 ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)

unTransParserPerm ::
 Trans repr =>
 Functor (UnTrans repr ()) =>
 ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
unTransParserPerm (ParserPerm a ma) =
        ParserPerm a (unTransParserPerm <$> unTrans ma)

hoistParserPerm ::
 Functor (repr ()) =>
 (forall a b. repr a b -> repr a b) ->
 ParserPerm e d repr k c -> ParserPerm e d repr k c
hoistParserPerm f (ParserPerm a ma) =
        ParserPerm a (hoistParserPerm f <$> f ma)

-- ** Class 'CLI_Routing'
class CLI_Routing repr where
        commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k
        -- tags  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
instance Ord e => CLI_Routing (Parser e d) where
        commands preCmds cmds = Parser $
                P.token check exp >>= unParser
                where
                exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
                check = \case
                 ArgSegment cmd ->
                        Map.lookup cmd cmds <|>
                        Map.lookup cmd preCmds
                 _ -> Nothing

-- * Type 'Router'
data Router repr a b where
 -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 Router_Any :: repr a b -> Router repr a b
 -- | Represent 'commands'.
 Router_Commands ::
  Map Name (Router repr a k) ->
  Map Name (Router repr a k) ->
  Router repr a k
 -- | Represent 'tag'.
 Router_Tag :: Tag -> Router repr f k -> Router repr f k
 -- | Represent ('<.>').
 Router_App :: Router repr a b -> Router repr b c -> Router repr a c
 -- | Represent ('<!>').
 Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 -- | Unify 'Router's which have different 'handlers'.
 -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
 Router_Union :: (b->a) -> Router repr a k -> Router repr b k

instance Ord e => Functor (Router (Parser e d) f) where
        a2b`fmap`x = noTrans (a2b <$> unTrans x)
instance Ord e => Applicative (Router (Parser e d) f) where
        pure = noTrans . pure
        f <*> x = noTrans (unTrans f <*> unTrans x)
instance Ord e => Alternative (Router (Parser e d) f) where
        empty = noTrans empty
        f <|> x = noTrans (unTrans f <|> unTrans x)
instance (repr ~ Parser e d) => Show (Router repr a b) where
        showsPrec p = \case
         Router_Any{} -> showString "X"
         Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
                where
                go :: forall h k. [(Segment, Router repr h k)] -> ShowS
                go [] = id
                go ((n, r):xs) =
                        (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
                        case xs of
                         [] -> id
                         _ -> showString ", " . go xs
         Router_Tag n x -> showsPrec 10 n . showString " " . showsPrec p x
         Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
         Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
         Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
instance Ord e => Trans (Router (Parser e d)) where
        type UnTrans (Router (Parser e d)) = Parser e d
        noTrans = Router_Any
        unTrans (Router_Any x) = x
        unTrans (Router_Alt x y) = unTrans x <!> unTrans y
        unTrans (Router_App x y) = unTrans x <.> unTrans y
        unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
        unTrans (Router_Tag n x) = tag n (unTrans x)
        unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)

instance Ord e => App (Router (Parser e d)) where
        (<.>) = Router_App
instance Ord e => Alt (Router (Parser e d)) where
        (<!>) = Router_Alt
        alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
instance Ord e => AltApp (Router (Parser e d))
instance Ord e => Sequenceable (Router (Parser e d)) where
        type Sequence (Router (Parser e d)) = RouterParserSeq (ParserSeq e d)
        runSequence = noTrans . runSequence . unRouterParserSeq
        toSequence  = RouterParserSeq . toSequence . unTrans
instance Ord e => Permutable (Router (Parser e d)) where
        type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
        runPermutation  = noTrans . runPermutation . unTransParserPerm
        toPermutation   = noTransParserPerm . toPermutation . unTrans
        toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
instance Ord e => Pro (Router (Parser e d))
instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
        command "" x = x
        command n x =
                let is = List.tail $ List.inits n in
                let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
                Router_Commands
                 (Map.fromAscList $ (,x) <$> preCmds)
                 (Map.fromAscList $ (,x) <$> cmds)
instance Ord e => CLI_Var (Router (Parser e d))
instance Ord e => CLI_Env (Router (Parser e d))
instance Ord e => CLI_Tag (Router (Parser e d)) where
        tag = Router_Tag
instance CLI_Help (Router (Parser e d)) where
        -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
        -- to remove them all, since they are useless for 'Parser'
        -- and may prevent patterns to be matched in 'router'.
        help _msg  = id
        program _n = id
        rule _n    = id
instance Ord e => CLI_Response (Router (Parser e d))
instance Ord e => CLI_Routing (Router (Parser e d)) where
        -- tags  = Router_Tags
        commands = Router_Commands

router ::
 repr ~ Parser e d =>
 Router repr a b -> Router repr a b
router = {-debug1 "router" $-} \case
 x@Router_Any{} -> x
 Router_Tag n x -> Router_Tag n (router x)
 Router_Alt x y -> router x`router_Alt`router y
 Router_Commands preCmds cmds ->
        Router_Commands
         (router <$> preCmds)
         (router <$> cmds)
 Router_App xy z ->
        case xy of
         Router_App x y ->
                -- Associate to the right
                Router_App (router x) $
                Router_App (router y) (router z)
         _ -> router xy `Router_App` router z
 Router_Union u x -> Router_Union u (router x)

-- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
router_Alt ::
 repr ~ Parser e d =>
 Router repr a k ->
 Router repr b k ->
 Router repr (a:!:b) k
router_Alt = {-debug2 "router_Alt"-} go
        where
        -- Merge alternative commands together.
        go (Router_Commands xp xs) (Router_Commands yp ys) =
                Router_Commands
                 (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
                 (router_Commands True xs ys)

        -- Merge left first or right first, depending on which removes 'Router_Alt'.
        go x (y`Router_Alt`z) =
                case x`router_Alt`y of
                 Router_Alt x' y' ->
                        case y'`router_Alt`z of
                         yz@(Router_Alt _y z') ->
                                case x'`router_Alt`z' of
                                 Router_Alt{} -> router x'`Router_Alt`yz
                                 xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
                                        -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
                         yz -> x'`router_Alt`yz
                 xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
        go (x`Router_Alt`y) z =
                case y`router_Alt`z of
                 Router_Alt y' z' ->
                        case x`router_Alt`y' of
                         xy@(Router_Alt x' _y) ->
                                case x'`router_Alt`z' of
                                 Router_Alt{} -> xy`Router_Alt`router z'
                                 xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
                                        -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
                         xy -> xy`router_Alt`z'
                 yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz

        -- Merge through 'Router_Union'.
        go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
        go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)

        -- No merging
        go x y = x`Router_Alt`y

router_Commands ::
 repr ~ Parser e d =>
 Bool ->
 Map Segment (Router repr a k) ->
 Map Segment (Router repr b k) ->
 Map Segment (Router repr (a:!:b) k)
router_Commands allowMerging =
        -- NOTE: a little bit more complex than required
        -- in order to merge 'Router_Union's instead of nesting them,
        -- such that 'unTrans' 'Router_Union' applies them all at once.
        Map.merge
         (Map.mapMissing $ const keepX)
         (Map.mapMissing $ const keepY)
         (Map.zipWithMaybeMatched $ const $ \x y ->
                if allowMerging then Just $ mergeFull x y else Nothing)
        where
        keepX = \case
         Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
         r                -> Router_Union (\(x:!:_y) -> x) r
        keepY = \case
         Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
         r                -> Router_Union (\(_x:!:y) -> y) r
        mergeFull = \case
         Router_Union xu xr -> \case
                 Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
                 yr                 -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
         xr -> \case
                 Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
                 yr                 -> xr`router_Alt`yr

-- ** Type 'RouterParserSeq'
newtype RouterParserSeq repr k a = RouterParserSeq
 { unRouterParserSeq :: repr k a }
 deriving (Functor, Applicative)

-- * Type 'Arg'
data Arg
 =   ArgSegment Segment
 |   ArgTagLong Name
 |   ArgTagShort Char
 |   ArgEnv Name String -- ^ Here only for error reporting.
 deriving (Eq,Ord,Show)

lexer :: [String] -> [Arg]
lexer ss =
        join $
        (`evalState` False) $
        sequence (f <$> ss)
        where
        f :: String -> StateT Bool Identity [Arg]
        f s = do
                skip <- get
                if skip then return [ArgSegment s]
                else case s of
                 '-':'-':[] -> do
                        put True
                        return [ArgTagLong ""]
                 '-':'-':cs -> return [ArgTagLong cs]
                 '-':cs@(_:_) -> return $ ArgTagShort <$> cs
                 seg -> return [ArgSegment seg]

showArg :: Arg -> String
showArg = \case
 ArgTagShort t -> '-':[t]
 ArgTagLong t -> '-':'-':t
 ArgSegment seg -> seg
 ArgEnv name val -> name<>"="<>val

showArgs :: [Arg] -> String
showArgs args = List.intercalate " " $ showArg <$> args

instance P.Stream [Arg] where
        type Token  [Arg] = Arg
        type Tokens [Arg] = [Arg]
        tokenToChunk  Proxy = pure
        tokensToChunk Proxy = id
        chunkToTokens Proxy = id
        chunkLength   Proxy = List.length
        chunkEmpty    Proxy = List.null
        take1_ [] = Nothing
        take1_ (t:ts) = Just (t, ts)
        takeN_ n s
          | n <= 0       = Just ([], s)
          | List.null s  = Nothing
          | otherwise    = Just (List.splitAt n s)
        takeWhile_ = List.span
        showTokens Proxy = showArgs . toList
        -- NOTE: those make no sense when parsing a command line,
        -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
        reachOffset = error "BUG: reachOffset must not be used on [Arg]"
        reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"