Parser.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
module Symantic.CLI.Parser where

import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
import Control.Arrow (first)
import Control.Monad (Monad(..), join, sequence, unless)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT(..),throwE,runExceptT)
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.Function (($), (.), id, const)
import Data.Functor (Functor(..), (<$>))
import Data.Functor.Identity (Identity(..))
import Data.Int (Int)
import Data.Map.Strict (Map)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String)
import System.Environment (lookupEnv)
import System.IO (IO)
import Text.Read (readEither)
import Text.Show (Show(..), ShowS, showString, showParen)
import Type.Reflection as Reflection
import qualified Data.List as List
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Map.Merge.Strict as Map
import qualified Data.Map.Strict as Map
import qualified Symantic.Document as Doc
import qualified System.IO as IO
-- import qualified Debug.Trace as Debug

import Symantic.CLI.API

-- * Type 'Parser'
newtype Parser d f k = Parser
 { unParser :: StateT ParserState
               (ParserCheckT [ParserError] IO)
               (f -> k) -- Reader f k
 }
instance Functor (Parser d f) where
	a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x
instance Applicative (Parser d f) where
	pure = Parser . pure . const
	Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
instance Alternative (Parser d f) where
	empty = Parser $ do
		StateT $ \st ->
			throwE $ Fail st [ParserError_Alt]
	Parser x <|> Parser y = Parser $
		StateT $ \st -> do
			lift (runExceptT (runStateT x st)) >>= \case
			 Left xe | FailFatal{} <- xe -> throwE xe
			         | otherwise ->
				lift (runExceptT (runStateT y st)) >>= \case
				 Left ye -> throwE (xe<>ye)
				 Right yr -> ExceptT $ return $ Right yr
			 Right xr ->
				return xr
instance Permutable (Parser d) where
	type Permutation (Parser d) = ParserPerm d (Parser d)
	runPermutation (ParserPerm ma p) = Parser $ do
		u2p <- unParser $ optional p
		unParser $
			case u2p () of
			 Nothing -> maybe empty (Parser . return) ma
			 Just perm -> runPermutation perm
	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)

parser ::
 -- d ~ String => -- dummy d
 Router (Parser d) handlers (Response (Router (Parser d))) ->
 handlers ->
 [Arg] -> IO ()
parser api handlers args = do
	lrApp <-
		runExceptT $ runStateT
		 (unParser $ unTrans $ router api)
		 ParserState
		 { parserState_args = args
		 }
	case lrApp of
	 Left err -> IO.print err
	 Right (app, _st) -> unResponseParser $ app handlers

-- | Helper to parse the current argument.
popArg ::
 ParserError ->
 (Arg ->
  StateT ParserState (ParserCheckT [ParserError] IO) a) ->
  StateT ParserState (ParserCheckT [ParserError] IO) a
popArg errEnd f = do
	st <- get
	case parserState_args st of
	 [] -> lift $ throwE $ Fail st [errEnd]
	 curr:next -> do
		lift (lift (runExceptT (runStateT (f curr) (ParserState next)))) >>= \case
		 Left err -> lift $ throwE err
		 Right (a,st') -> do
			put st'
			return a

-- ** Type 'Arg'
data Arg
 =   ArgTagShort Char
 |   ArgTagLong Name
 |   ArgSegment Segment
 deriving (Eq,Show)

parseArgs :: [String] -> [Arg]
parseArgs 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]

-- ** Type 'ParserState'
newtype ParserState = ParserState
 { parserState_args :: [Arg]
 } deriving (Show)

-- ** Type 'Router'
type ParserCheckT e = ExceptT (Fail e)

-- ** Type 'ParserError'
data ParserError
 =   ParserError_Alt -- ^ When there is no alternative.
 |   ParserError_Arg { expectedArg :: Name,   gotArg :: Maybe Arg }
 |   ParserError_Env { expectedEnv :: Name,   gotEnv :: Maybe String }
 |   ParserError_Tag { expectedTag :: Tag,    gotArg :: Maybe Arg }
 |   ParserError_Cmd { expectedCmd :: [Name], gotCmd :: Maybe Arg }
 |   ParserError_Var { expectedVar :: Name,   gotVar :: Maybe Arg }
 |   ParserError_End {                        gotEnd :: Arg }
 deriving (Eq,Show)

-- *** Type 'RouteResult'
type RouteResult e = Either (Fail e)

-- *** Type 'Fail'
data Fail e
 =   Fail ParserState e -- ^ Keep trying other paths.
 |   FailFatal !ParserState !e -- ^ Don't try other paths.
 deriving (Show)
failState :: Fail e -> ParserState
failState (Fail st _)      = st
failState (FailFatal st _) = st
failError :: Fail e -> e
failError (Fail _st e)      = e
failError (FailFatal _st e) = e
instance Semigroup e => Semigroup (Fail e) where
	Fail _ x      <> Fail st y      = Fail      st (x<>y)
	FailFatal _ x <> Fail st _y     = FailFatal st (x{-<>y-})
	Fail _ _x     <> FailFatal st y = FailFatal st ({-x<>-}y)
	FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
instance Monoid e => Monoid (Fail e) where
	mempty = Fail (ParserState []) mempty
	mappend = (<>)

-- * Class 'FromSegment'
class FromSegment a where
	fromSegment :: Segment -> Either String a
instance FromSegment String where
	fromSegment = Right
instance FromSegment Int where
	fromSegment = readEither
instance FromSegment Bool where
	fromSegment = readEither

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

instance (App repr, Functor (repr ())) => Functor (ParserPerm 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 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 d repr) where
	type HelpConstraint (ParserPerm d repr) d' = HelpConstraint (Parser d) d'
	program _n = id
	rule _n = id

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

unTransParserPerm ::
 Trans repr =>
 Functor (UnTrans repr ()) =>
 ParserPerm d repr k a -> ParserPerm 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 d repr k c -> ParserPerm d repr k c
hoistParserPerm f (ParserPerm a ma) =
	ParserPerm a (hoistParserPerm f <$> f ma)

instance App (Parser d) where
	Parser x <.> Parser y = Parser $
		x >>= \a2b -> (. a2b) <$> y
instance Alt (Parser d) where
	Parser x <!> Parser y = Parser $
		StateT $ \st -> do
			lift (runExceptT (runStateT x st)) >>= \case
			 Left xe | FailFatal{} <- xe -> throwE xe
			         | otherwise ->
				lift (runExceptT (runStateT y st)) >>= \case
				 Left ye -> throwE (xe<>ye)
				 Right yr -> ExceptT $ return $ Right $
					first (\b2k (_a:!:b) -> b2k b) yr
			 Right xr ->
				return $ first (\a2k (a:!:_b) -> a2k a) xr
	opt (Parser x) = Parser $ do
		st <- get
		lift (lift (runExceptT $ runStateT x st)) >>= \case
		 Left err -> return ($ Nothing)
		 Right (a,st') -> do
			put st'
			return (mapCont Just a)
instance AltApp (Parser d) where
	many0 (Parser x) = Parser $ concatCont <$> many x
	many1 (Parser x) = Parser $ concatCont <$> some x
instance Pro (Parser d) where
	dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
instance CLI_Command (Parser d) where
	-- type CommandConstraint (Parser d) a = ()
	command "" x = x
	command n x = commands $ Map.singleton n x
instance CLI_Var (Parser d) where
	type VarConstraint (Parser d) a = FromSegment a
	var' :: forall a k. VarConstraint (Parser d) a => Name -> Parser d (a->k) k
	var' name = Parser $ do
		popArg (ParserError_Var name Nothing) $ \curr -> do
			st@ParserState{..} <- get
			case curr of
			 ArgSegment seg ->
				case fromSegment seg of
				 Left err -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]
				 Right a -> return ($ a)
			 _ -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]
	just a  = Parser $ return ($ a)
	nothing = Parser $ return id
instance CLI_Env (Parser d) where
	type EnvConstraint (Parser d) a = FromSegment a
	env' :: forall a k. EnvConstraint (Parser d) a => Name -> Parser d (a->k) k
	env' name = Parser $ do
		st <- get
		lift (lift (lookupEnv name)) >>= \case
		 Nothing -> lift $ throwE $ Fail st [ParserError_Env name Nothing]
		 Just raw ->
				case fromSegment raw of
				 Left err -> lift $ throwE $ Fail st [ParserError_Env name (Just raw)]
				 Right a -> return ($ a)

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)

instance CLI_Tag (Parser d) where
	type TagConstraint (Parser d) a = ()
	tagged name p = Parser $ do
		popArg (ParserError_Tag name Nothing) $ \curr -> do
			st <- get
			case lookupTag curr name of
			 False -> lift $ throwE $ Fail st [ParserError_Tag name (Just curr)]
			 True ->
				lift (lift (runExceptT (runStateT (unParser p) st))) >>= \case
				 Left (Fail st' e) -> lift $ throwE $ FailFatal st' e
				 Left e -> lift $ throwE e
				 Right (a,st') -> do
					put st'
					return a
		where
		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
		popArg (ParserError_Tag (TagLong "") Nothing) $ \curr -> do
			st@ParserState{..} <- get
			case curr of
			 ArgTagLong "" -> return id
			 _ -> return id -- TODO: raise an error and use option?

-- ** Type 'ParserResponse'
newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
-- ** Type 'ParserResponseArgs'
newtype ParserResponseArgs a = ParserResponseArgs (IO a)
 deriving (Functor,Applicative,Monad)

instance CLI_Response (Parser d) where
	type ResponseConstraint (Parser d) a = Outputable a
	type ResponseArgs (Parser d) a = ParserResponseArgs a
	type Response (Parser d) = ParserResponse
	response' = Parser $ do
		st <- get
		unless (List.null $ parserState_args st) $ do
			lift $ throwE $ Fail st [ParserError_End $
			 List.head $ parserState_args st]
		return $ \(ParserResponseArgs io) ->
			ParserResponse $ io >>= output

-- * 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 String where
	output = IO.putStrLn

instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where
	output =
		TL.putStr .
		TLB.toLazyText .
		Doc.runPlain .
		Doc.runAnsiText

{-
instance Outputable (Doc.Reorg Doc.Term) where
	output = TL.hPutStrLn IO.stdout . Doc.textTerm
instance Outputable (Doc.Reorg DocIO.TermIO) where
	output = DocIO.runTermIO IO.stdout
instance Outputable (IO.Handle, (Doc.Reorg DocIO.TermIO)) where
	output = uncurry DocIO.runTermIO
-}

-- * 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 String
instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))
{-
instance IOType (Doc.Reorg Doc.Term) where
instance IOType (Doc.Reorg DocIO.TermIO) where
instance IOType (IO.Handle, Doc.Reorg DocIO.TermIO)
-}

instance CLI_Help (Parser d) where
	type HelpConstraint (Parser d) d' = d ~ d'
	help _msg  = id
	program _n = id
	rule _n    = id


-- ** Class 'CLI_Routing'
class CLI_Routing repr where
	commands :: 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 CLI_Routing (Parser d) where
	commands cmds = Parser $ do
		st@ParserState{..} <- get
		let exp = Map.keys cmds
		popArg (ParserError_Cmd exp Nothing) $ \curr ->
			case curr of
			 ArgSegment cmd ->
				case Map.lookup cmd cmds of
				 Nothing -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]
				 Just x -> unParser x
			 _ -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]
	{-
	taggeds ms = Parser $ do
		st@ParserState{..} <- get
		case parserState_args of
		 [] -> lift $ throwE $ Fail st [ParserError "empty path segment"]
		 curr:next ->
			case lookupTag curr of
			 Nothing -> lift $ throwE $ Fail st [ParserError $ "expected: "<>fromString (show (Map.keys ms))<>" but got: "<>fromString (show curr)]
			 Just x -> do
				put st{parserState_args=next}
				unParser x
		where
		lookupTag (ArgTagShort x) = Map.lookup (Left x) ms
		lookupTag (ArgTagLong x) = Map.lookup (Right x) ms
		lookupTag _ = Nothing
	-}

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) -> Router repr a k
 -- | Represent 'tagged'.
 Router_Tagged :: Tag -> Router repr f k -> Router repr f k
 -- | Represent 'taggeds'.
 {-
 Router_Taggeds :: TagConstraint repr a =>
                  Map (Either Char Name) (Router repr (a -> k) k) ->
                  Router repr (a -> k) 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 Functor (Router (Parser d) f) where
	a2b`fmap`x = noTrans (a2b <$> unTrans x)
instance Applicative (Router (Parser d) f) where
	pure = noTrans . pure
	f <*> x = noTrans (unTrans f <*> unTrans x)
instance Alternative (Router (Parser d) f) where
	empty = noTrans empty
	f <|> x = noTrans (unTrans f <|> unTrans x)
instance Permutable (Router (Parser d)) where
	type Permutation (Router (Parser d)) = ParserPerm d (Router (Parser d))
	runPermutation  = noTrans . runPermutation . unTransParserPerm
	toPermutation   = noTransParserPerm . toPermutation . unTrans
	toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
instance (repr ~ Parser d) => Show (Router repr a b) where
	showsPrec p = \case
	 Router_Any{} -> showString "X"
	 Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go (Map.toList ms) . 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_Command n os x -> showString n . showString " " . showsPrec 10 (permutation_parser os) . showString " " . showsPrec p x
	 Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
	 {-
	 Router_Taggeds ms -> showParen (p>=10) $
		showString "taggeds [" . go (Map.toList ms) . showString "]"
		where
		go :: forall h k. [(Either Char Name, 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_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 Trans (Router (Parser d)) where
	type UnTrans (Router (Parser d)) = Parser 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_Command n os x) = command n (unTransParserPerm os) (unTrans x)
	unTrans (Router_Commands ms) = commands (unTrans <$> ms)
	unTrans (Router_Tagged n x) = tagged n (unTrans x)
	-- unTrans (Router_Taggeds ms) = taggeds (unTrans <$> ms)
	unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)

instance App (Router (Parser d)) where
	(<.>) = Router_App
instance Alt (Router (Parser d)) where
	(<!>) = Router_Alt
instance Pro (Router (Parser d))
instance repr ~ (Parser d) => CLI_Command (Router repr) where
	-- command = Router_Command
	command "" x = x
	command n x = Router_Commands $ Map.singleton n x
instance CLI_Var (Router (Parser d))
instance CLI_Env (Router (Parser d))
instance CLI_Tag (Router (Parser d)) where
	tagged = Router_Tagged
instance CLI_Help (Router (Parser 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 CLI_Response (Router (Parser d))
instance CLI_Routing (Router (Parser d)) where
	-- taggeds  = Router_Taggeds
	commands = Router_Commands

router ::
 repr ~ Parser d =>
 Router repr a b -> Router repr a b
router = {-debug1 "router" $-} \case
 x@Router_Any{} -> x
 -- Router_Command n os x -> Router_Command n (hoistParserPerm router os) (router x)
 Router_Tagged n x -> Router_Tagged n (router x)
 {-
 Router_Tagged n x -> Router_Taggeds $
	case n of
	 Tag c s -> Map.fromList [(Left c, r), (Right s, r)]
	 TagShort c -> Map.singleton (Left c) r
	 TagLong s -> Map.singleton (Right s) r
	 where r = router x
 -}
 {-
 Router_Taggeds xs `Router_App` Router_Taggeds ys ->
	Router_Taggeds $ router <$> (xs <> ys)
 -}
 Router_Alt x y -> router x`router_Alt`router y
 Router_Commands xs -> Router_Commands $ router <$> xs
 -- Router_Taggeds xs -> Router_Taggeds $ router <$> xs
 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)
 -- Router_Merge x -> Router_Merge (router x)

-- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
router_Alt ::
 repr ~ Parser 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.
	{- NOTE: useless because 'command' is already a 'Router_Commands'.
	go (Router_Command x xo xt) (Router_Command y yo yt) =
		Map.singleton x (router (runPermutation xo <.> xt))
		`router_Commands`
		Map.singleton y (router (runPermutation yo <.> yt))
	go (Router_Command x xo xt) (Router_Commands ys) =
		Map.singleton x (router (runPermutation xo <.> xt))
		`router_Commands` ys
	go (Router_Commands xs) (Router_Command y yo yt) =
		xs `router_Commands`
		Map.singleton y (router (runPermutation yo <.> yt))
	-}
	go (Router_Commands xs) (Router_Commands ys) =
		xs`router_Commands`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 d =>
 Map Segment (Router repr a k) ->
 Map Segment (Router repr b k) ->
 Router repr (a:!:b) k
router_Commands xs ys =
	-- 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.
	Router_Commands $
	Map.merge
	 (Map.traverseMissing $ const $ \case
		 Router_Union u r ->
			return $ Router_Union (\(x:!:_y) -> u x) r
		 r -> return $ Router_Union (\(x:!:_y) -> x) r)
	 (Map.traverseMissing $ const $ \case
		 Router_Union u r ->
			return $ Router_Union (\(_x:!:y) -> u y) r
		 r -> return $ Router_Union (\(_x:!:y) -> y) r)
	 (Map.zipWithAMatched $ const $ \case
		 Router_Union xu xr -> \case
			 Router_Union yu yr ->
				return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
			 yr ->
				return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
		 xr -> \case
			 Router_Union yu yr ->
				return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
			 yr -> return $ xr`router_Alt`yr)
	 xs ys

{-
debug0 :: Show a => String -> a -> a
debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a
debug1 :: Show a => Show b => String -> (a->b) -> (a->b)
debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b
	where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a
debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)
debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c
	where
	b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a
	c   = b2c   $ Debug.trace (n<>": b: "<>show b) b
-}