Parser.hs

{-# 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.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 => 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' 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 = ()
	tagged 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 String where
	output = IO.putStr
instance Outputable Text.Text where
	output = Text.putStr
instance Outputable TL.Text where
	output = TL.putStr
instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where
	output =
		TL.putStr .
		TLB.toLazyText .
		Doc.runPlain .
		Doc.runAnsiText
instance Outputable (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) where
	output (h,d) =
		TL.hPutStr h $
		TLB.toLazyText $
		Doc.runPlain $
		Doc.runAnsiText d

-- * 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 Int
instance IOType Integer
instance IOType Natural
instance IOType String
instance IOType Text.Text
instance IOType TL.Text
instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))
instance IOType (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder))

-- * 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 '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
	 ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)
	 ((a2b `fmap`) `fmap` ma)
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 =
		 (\a2b2k2k a2k2k -> \b2k ->
			a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
		 ) <$> f <*> x
		lhsAlt = (<*> rhs) <$> ma2b
		rhsAlt = (lhs <*>) <$> ma
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
	-- taggeds  :: 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 'tagged'.
 Router_Tagged :: 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 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 (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_Tagged 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_Tagged n x) = tagged 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 => 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
	tagged = Router_Tagged
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
	-- taggeds  = Router_Taggeds
	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_Tagged n x -> Router_Tagged 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 '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]"