Symantic/CLI/Parser.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE DefaultSignatures #-}
   4 {-# LANGUAGE GADTs #-} -- for Router
   5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   6 {-# LANGUAGE InstanceSigs #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
   9 module Symantic.CLI.Parser where
  10
  11 import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
  12 import Control.Monad (Monad(..), join, sequence, forM_, void)
  13 import Control.Monad.Trans.Class (MonadTrans(..))
  14 import Control.Monad.Trans.State (StateT(..),evalState,get,put)
  15 import Data.Bool
  16 import Data.Char (Char)
  17 import Data.Either (Either(..))
  18 import Data.Eq (Eq(..))
  19 import Data.Foldable (null, toList)
  20 import Data.Function (($), (.), id, const)
  21 import Data.Functor (Functor(..), (<$>), ($>))
  22 import Data.Functor.Identity (Identity(..))
  23 import Data.Int (Int)
  24 import Data.List.NonEmpty (NonEmpty(..))
  25 import Data.Map.Strict (Map)
  26 import Data.Maybe (Maybe(..), maybe, isNothing)
  27 import Data.Ord (Ord(..))
  28 import Data.Proxy (Proxy(..))
  29 import Data.Semigroup (Semigroup(..))
  30 import Data.String (String)
  31 import Numeric.Natural (Natural)
  32 import Prelude (Integer, Num(..), error)
  33 import System.Environment (lookupEnv)
  34 import System.IO (IO)
  35 import Text.Read (Read, readEither)
  36 import Text.Show (Show(..), ShowS, showString, showParen)
  37 import Type.Reflection as Reflection
  38 import qualified Data.List as List
  39 import qualified Data.List.NonEmpty as NonEmpty
  40 import qualified Data.Map.Merge.Strict as Map
  41 import qualified Data.Map.Strict as Map
  42 import qualified Data.Set as Set
  43 import qualified Data.Text as Text
  44 import qualified Data.Text.IO as Text
  45 import qualified Data.Text.Lazy as TL
  46 import qualified Data.Text.Lazy.Builder as TLB
  47 import qualified Data.Text.Lazy.IO as TL
  48 import qualified Symantic.Document as Doc
  49 import qualified System.IO as IO
  50 import qualified Text.Megaparsec as P
  51
  52 import Symantic.CLI.API
  53
  54 -- * Type 'Parser'
  55 newtype Parser e d f k = Parser
  56  { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
  57  }
  58
  59 parser ::
  60  P.ShowErrorComponent e =>
  61  Router (Parser e d) handlers (Response (Router (Parser e d))) ->
  62  handlers ->
  63  [Arg] -> IO ()
  64 parser api handlers args = do
  65         P.runParserT
  66          (unParser $ unTrans $ router api)
  67          "" args >>= \case
  68          Left err ->
  69                 forM_ (P.bundleErrors err) $ \e -> do
  70                         IO.putStr $
  71                                 "Error parsing the command at argument #" <>
  72                                 show (P.errorOffset e + 1) <> ":\n" <>
  73                                 parseErrorTextPretty e
  74          Right app -> unResponseParser $ app handlers
  75
  76 -- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
  77 parseErrorTextPretty ::
  78  forall s e.
  79  (P.Stream s, P.ShowErrorComponent e) =>
  80  P.ParseError s e -> String
  81 parseErrorTextPretty (P.TrivialError _ us ps) =
  82         if isNothing us && Set.null ps
  83         then "unknown parse error\n"
  84         else
  85                 messageItemsPretty "unexpected "
  86                  (showErrorItem pxy <$> Set.toAscList (maybe Set.empty Set.singleton us)) <>
  87                 messageItemsPretty "expecting "
  88                  (showErrorItem pxy <$> Set.toAscList ps)
  89         where pxy = Proxy :: Proxy s
  90 parseErrorTextPretty err = P.parseErrorTextPretty err
  91
  92 messageItemsPretty :: String -> [String] -> String
  93 messageItemsPretty prefix ts
  94  | null ts = ""
  95  | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"
  96
  97 orList :: NonEmpty String -> String
  98 orList (x:|[])  = x
  99 orList (x:|[y]) = x <> " or " <> y
 100 orList xs       = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs
 101
 102 showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String
 103 showErrorItem pxy = \case
 104  P.Tokens ts -> P.showTokens pxy ts
 105  P.Label label -> NonEmpty.toList label
 106  P.EndOfInput  -> "end of input"
 107
 108
 109 instance Functor (Parser e d f) where
 110         a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x
 111 instance Applicative (Parser e d f) where
 112         pure = Parser . pure . const
 113         Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
 114 instance Ord e => Alternative (Parser e d f) where
 115         empty = Parser empty
 116         Parser x <|> Parser y = Parser $ x <|> y
 117 instance Ord e => Permutable (Parser e d) where
 118         type Permutation (Parser e d) = ParserPerm e d (Parser e d)
 119         runPermutation (ParserPerm ma p) = Parser $ do
 120                 u2p <- unParser $ optional p
 121                 unParser $
 122                         case u2p () of
 123                          Just perm -> runPermutation perm
 124                          Nothing ->
 125                                 maybe
 126                                  (Parser $ P.token (const Nothing) Set.empty)
 127                                  -- NOTE: not 'empty' so that 'P.TrivialError' has the unexpected token.
 128                                  (Parser . return) ma
 129         toPermutation (Parser x) =
 130                 ParserPerm Nothing
 131                  (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x)
 132         toPermDefault a (Parser x) =
 133                 ParserPerm (Just ($ a))
 134                  (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)
 135 instance App (Parser e d) where
 136         Parser x <.> Parser y = Parser $
 137                 x >>= \a2b -> (. a2b) <$> y
 138 instance Ord e => Alt (Parser e d) where
 139         Parser x <!> Parser y = Parser $
 140                 (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
 141                 (\b2k (_a:!:b) -> b2k b) <$> y
 142         opt (Parser x) = Parser $
 143                 mapCont Just <$> P.try x
 144 instance Ord e => AltApp (Parser e d) where
 145         many0 (Parser x) = Parser $ concatCont <$> many x
 146         many1 (Parser x) = Parser $ concatCont <$> some x
 147 instance Pro (Parser e d) where
 148         dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
 149 instance Ord e => CLI_Command (Parser e d) where
 150         -- type CommandConstraint (Parser e d) a = ()
 151         command "" x = x
 152         command n x = commands $ Map.singleton n x
 153 instance Ord e => CLI_Tag (Parser e d) where
 154         type TagConstraint (Parser e d) a = ()
 155         tagged name p = Parser $ P.try $ do
 156                 void $ (`P.token` exp) $ \tok ->
 157                         if lookupTag tok name
 158                         then Just tok
 159                         else Nothing
 160                 unParser p
 161                 where
 162                 exp =
 163                         case name of
 164                          TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t
 165                          TagLong  t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong  t
 166                          Tag s l -> Set.fromList
 167                                  [ P.Tokens $ pure $ ArgTagShort s
 168                                  , P.Tokens $ pure $ ArgTagLong  l
 169                                  ]
 170                 lookupTag (ArgTagShort x) (TagShort y) = x == y
 171                 lookupTag (ArgTagShort x) (Tag y _)    = x == y
 172                 lookupTag (ArgTagLong  x) (TagLong y)  = x == y
 173                 lookupTag (ArgTagLong  x) (Tag _ y)    = x == y
 174                 lookupTag _ _                          = False
 175         endOpts = Parser $ do
 176                 (`P.token` exp) $ \case
 177                  ArgTagLong "" -> Just id
 178                  _ -> Nothing
 179                 where
 180                 exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""
 181 instance Ord e => CLI_Var (Parser e d) where
 182         type VarConstraint (Parser e d) a = (IOType a, FromSegment a)
 183         var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k
 184         var' name = Parser $ do
 185                 seg <- (`P.token` expName) $ \case
 186                  ArgSegment seg -> Just seg
 187                  _ -> Nothing
 188                 lift (fromSegment seg) >>= \case
 189                  Left err -> P.failure got expType
 190                         where
 191                         got = Just $ P.Tokens $ pure $ ArgSegment seg
 192                         expType = Set.singleton $ P.Label $ NonEmpty.fromList $
 193                                 "<"<>name<>"> to be of type "<>ioType @a
 194                                 <> case err of
 195                                  "Prelude.read: no parse" -> ""
 196                                  "" -> ""
 197                                  _ -> ": "<>err
 198                  Right a -> return ($ a)
 199                 where
 200                 expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
 201         just a  = Parser $ return ($ a)
 202         nothing = Parser $ return id
 203 instance Ord e => CLI_Env (Parser e d) where
 204         type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
 205         env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
 206         env' name = Parser $
 207                 lift (lookupEnv name) >>= \case
 208                  Nothing -> P.failure got exp
 209                         where
 210                         got = Nothing
 211                         exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
 212                  Just val ->
 213                         lift (fromSegment val) >>= \case
 214                          Right a -> return ($ a)
 215                          Left err -> P.failure got exp
 216                                 where
 217                                 got = Just $ P.Tokens $ pure $ ArgEnv name val
 218                                 exp = Set.singleton $ P.Label $ NonEmpty.fromList $
 219                                         "${"<>name<>"} to be of type "<>ioType @a
 220                                         <> case err of
 221                                          "Prelude.read: no parse" -> ""
 222                                          "" -> ""
 223                                          _ -> ": "<>err
 224 instance Ord e => CLI_Response (Parser e d) where
 225         type ResponseConstraint (Parser e d) a = Outputable a
 226         type ResponseArgs (Parser e d) a = ParserResponseArgs a
 227         type Response (Parser e d) = ParserResponse
 228         response' = Parser $
 229                 P.eof $> \({-ParserResponseArgs-} io) ->
 230                         ParserResponse $ io >>= output
 231 instance Ord e => CLI_Help (Parser e d) where
 232         type HelpConstraint (Parser e d) d' = d ~ d'
 233         help _msg = id
 234         program n = Parser . P.label n . unParser
 235         rule n    = Parser . P.label n . unParser
 236
 237 concatCont :: [(a->k)->k] -> ([a]->k)->k
 238 concatCont = List.foldr (consCont (:)) ($ [])
 239
 240 consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
 241 consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
 242
 243 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
 244 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
 245
 246 -- ** Type 'ParserResponse'
 247 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
 248 -- ** Type 'ParserResponseArgs'
 249 type ParserResponseArgs = IO
 250
 251 -- * Class 'Outputable'
 252 -- | Output of a CLI.
 253 class IOType a => Outputable a where
 254         output :: a -> IO ()
 255         default output :: Show a => a -> IO ()
 256         output = IO.print
 257
 258 instance Outputable () where
 259         output = return
 260 instance Outputable Bool
 261 instance Outputable Int
 262 instance Outputable Integer
 263 instance Outputable Natural
 264 instance Outputable String where
 265         output = IO.putStr
 266 instance Outputable Text.Text where
 267         output = Text.putStr
 268 instance Outputable TL.Text where
 269         output = TL.putStr
 270 instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where
 271         output =
 272                 TL.putStr .
 273                 TLB.toLazyText .
 274                 Doc.runPlain .
 275                 Doc.runAnsiText
 276 instance Outputable (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) where
 277         output (h,d) =
 278                 TL.hPutStr h $
 279                 TLB.toLazyText $
 280                 Doc.runPlain $
 281                 Doc.runAnsiText d
 282
 283 -- * Class 'IOType'
 284 -- | Like a MIME type but for input/output of a CLI.
 285 class IOType a where
 286         ioType :: String
 287         default ioType :: Reflection.Typeable a => String
 288         ioType = show (Reflection.typeRep @a)
 289
 290 instance IOType ()
 291 instance IOType Bool
 292 instance IOType Int
 293 instance IOType Integer
 294 instance IOType Natural
 295 instance IOType String
 296 instance IOType Text.Text
 297 instance IOType TL.Text
 298 instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))
 299 instance IOType (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder))
 300
 301 -- * Class 'FromSegment'
 302 class FromSegment a where
 303         fromSegment :: Segment -> IO (Either String a)
 304         default fromSegment :: Read a => Segment -> IO (Either String a)
 305         fromSegment = return . readEither
 306 instance FromSegment String where
 307         fromSegment = return . Right
 308 instance FromSegment Text.Text where
 309         fromSegment = return . Right . Text.pack
 310 instance FromSegment TL.Text where
 311         fromSegment = return . Right . TL.pack
 312 instance FromSegment Bool
 313 instance FromSegment Int
 314 instance FromSegment Integer
 315 instance FromSegment Natural
 316
 317 -- ** Type 'ParserPerm'
 318 data ParserPerm e d repr k a = ParserPerm
 319  { permutation_result :: !(Maybe ((a->k)->k))
 320  , permutation_parser :: repr () (ParserPerm e d repr k a)
 321  }
 322
 323 instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
 324         a2b `fmap` ParserPerm a ma = ParserPerm
 325          ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)
 326          ((a2b `fmap`) `fmap` ma)
 327 instance (App repr, Functor (repr ()), Alternative (repr ())) =>
 328          Applicative (ParserPerm e d repr k) where
 329         pure a = ParserPerm (Just ($ a)) empty
 330         lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
 331                 ParserPerm a (lhsAlt <|> rhsAlt)
 332                 where
 333                 a =
 334                  (\a2b2k2k a2k2k -> \b2k ->
 335                         a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
 336                  ) <$> f <*> x
 337                 lhsAlt = (<*> rhs) <$> ma2b
 338                 rhsAlt = (lhs <*>) <$> ma
 339 instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
 340         type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
 341         program _n = id
 342         rule _n = id
 343
 344 noTransParserPerm ::
 345  Trans repr =>
 346  Functor (UnTrans repr ()) =>
 347  ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
 348 noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
 349
 350 unTransParserPerm ::
 351  Trans repr =>
 352  Functor (UnTrans repr ()) =>
 353  ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
 354 unTransParserPerm (ParserPerm a ma) = ParserPerm a (unTransParserPerm <$> unTrans ma)
 355
 356 hoistParserPerm ::
 357  Functor (repr ()) =>
 358  (forall a b. repr a b -> repr a b) ->
 359  ParserPerm e d repr k c -> ParserPerm e d repr k c
 360 hoistParserPerm f (ParserPerm a ma) =
 361         ParserPerm a (hoistParserPerm f <$> f ma)
 362
 363 -- ** Class 'CLI_Routing'
 364 class CLI_Routing repr where
 365         commands :: Map Name (repr a k) -> repr a k
 366         -- taggeds  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
 367 instance Ord e => CLI_Routing (Parser e d) where
 368         commands cmds = Parser $
 369                 P.token check exp >>= unParser
 370                 where
 371                 exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
 372                 check = \case
 373                  ArgSegment cmd -> Map.lookup cmd cmds
 374                  _ -> Nothing
 375
 376 -- * Type 'Router'
 377 data Router repr a b where
 378  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 379  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 380  Router_Any :: repr a b -> Router repr a b
 381  -- | Represent 'commands'.
 382  Router_Commands :: Map Name (Router repr a k) -> Router repr a k
 383  -- | Represent 'tagged'.
 384  Router_Tagged :: Tag -> Router repr f k -> Router repr f k
 385  -- | Represent ('<.>').
 386  Router_App :: Router repr a b -> Router repr b c -> Router repr a c
 387  -- | Represent ('<!>').
 388  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 389  -- | Unify 'Router's which have different 'handlers'.
 390  -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
 391  Router_Union :: (b->a) -> Router repr a k -> Router repr b k
 392
 393 instance Ord e => Functor (Router (Parser e d) f) where
 394         a2b`fmap`x = noTrans (a2b <$> unTrans x)
 395 instance Ord e => Applicative (Router (Parser e d) f) where
 396         pure = noTrans . pure
 397         f <*> x = noTrans (unTrans f <*> unTrans x)
 398 instance Ord e => Alternative (Router (Parser e d) f) where
 399         empty = noTrans empty
 400         f <|> x = noTrans (unTrans f <|> unTrans x)
 401 instance Ord e => Permutable (Router (Parser e d)) where
 402         type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
 403         runPermutation  = noTrans . runPermutation . unTransParserPerm
 404         toPermutation   = noTransParserPerm . toPermutation . unTrans
 405         toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
 406 instance (repr ~ Parser e d) => Show (Router repr a b) where
 407         showsPrec p = \case
 408          Router_Any{} -> showString "X"
 409          Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go (Map.toList ms) . showString "]"
 410                 where
 411                 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
 412                 go [] = id
 413                 go ((n, r):xs) =
 414                         (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
 415                         case xs of
 416                          [] -> id
 417                          _ -> showString ", " . go xs
 418          Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
 419          Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
 420          Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
 421          Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
 422
 423 instance Ord e => Trans (Router (Parser e d)) where
 424         type UnTrans (Router (Parser e d)) = Parser e d
 425         noTrans = Router_Any
 426         unTrans (Router_Any x) = x
 427         unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 428         unTrans (Router_App x y) = unTrans x <.> unTrans y
 429         unTrans (Router_Commands ms) = commands (unTrans <$> ms)
 430         unTrans (Router_Tagged n x) = tagged n (unTrans x)
 431         unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 432
 433 instance Ord e => App (Router (Parser e d)) where
 434         (<.>) = Router_App
 435 instance Ord e => Alt (Router (Parser e d)) where
 436         (<!>) = Router_Alt
 437 instance Ord e => Pro (Router (Parser e d))
 438 instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 439         command "" x = x
 440         command n x = Router_Commands $ Map.singleton n x
 441 instance Ord e => CLI_Var (Router (Parser e d))
 442 instance Ord e => CLI_Env (Router (Parser e d))
 443 instance Ord e => CLI_Tag (Router (Parser e d)) where
 444         tagged = Router_Tagged
 445 instance CLI_Help (Router (Parser e d)) where
 446         -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
 447         -- to remove them all, since they are useless for 'Parser'
 448         -- and may prevent patterns to be matched in 'router'.
 449         help _msg  = id
 450         program _n = id
 451         rule _n    = id
 452 instance Ord e => CLI_Response (Router (Parser e d))
 453 instance Ord e => CLI_Routing (Router (Parser e d)) where
 454         -- taggeds  = Router_Taggeds
 455         commands = Router_Commands
 456
 457 router ::
 458  repr ~ Parser e d =>
 459  Router repr a b -> Router repr a b
 460 router = {-debug1 "router" $-} \case
 461  x@Router_Any{} -> x
 462  Router_Tagged n x -> Router_Tagged n (router x)
 463  Router_Alt x y -> router x`router_Alt`router y
 464  Router_Commands xs -> Router_Commands $ router <$> xs
 465  Router_App xy z ->
 466         case xy of
 467          Router_App x y ->
 468                 -- Associate to the right
 469                 Router_App (router x) $
 470                 Router_App (router y) (router z)
 471          _ -> router xy `Router_App` router z
 472  Router_Union u x -> Router_Union u (router x)
 473
 474 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 475 router_Alt ::
 476  repr ~ Parser e d =>
 477  Router repr a k ->
 478  Router repr b k ->
 479  Router repr (a:!:b) k
 480 router_Alt = {-debug2 "router_Alt"-} go
 481         where
 482         -- Merge alternative commands together.
 483         go (Router_Commands xs) (Router_Commands ys) =
 484                 xs`router_Commands`ys
 485
 486         -- Merge left first or right first, depending on which removes 'Router_Alt'.
 487         go x (y`Router_Alt`z) =
 488                 case x`router_Alt`y of
 489                  Router_Alt x' y' ->
 490                         case y'`router_Alt`z of
 491                          yz@(Router_Alt _y z') ->
 492                                 case x'`router_Alt`z' of
 493                                  Router_Alt{} -> router x'`Router_Alt`yz
 494                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
 495                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
 496                          yz -> x'`router_Alt`yz
 497                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
 498         go (x`Router_Alt`y) z =
 499                 case y`router_Alt`z of
 500                  Router_Alt y' z' ->
 501                         case x`router_Alt`y' of
 502                          xy@(Router_Alt x' _y) ->
 503                                 case x'`router_Alt`z' of
 504                                  Router_Alt{} -> xy`Router_Alt`router z'
 505                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
 506                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
 507                          xy -> xy`router_Alt`z'
 508                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
 509
 510         -- Merge through 'Router_Union'.
 511         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
 512         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
 513
 514         -- No merging
 515         go x y = x`Router_Alt`y
 516
 517 router_Commands ::
 518  repr ~ Parser e d =>
 519  Map Segment (Router repr a k) ->
 520  Map Segment (Router repr b k) ->
 521  Router repr (a:!:b) k
 522 router_Commands xs ys =
 523         -- NOTE: a little bit more complex than required
 524         -- in order to merge 'Router_Union's instead of nesting them,
 525         -- such that 'unTrans' 'Router_Union' applies them all at once.
 526         Router_Commands $
 527         Map.merge
 528          (Map.traverseMissing $ const $ \case
 529                  Router_Union u r ->
 530                         return $ Router_Union (\(x:!:_y) -> u x) r
 531                  r -> return $ Router_Union (\(x:!:_y) -> x) r)
 532          (Map.traverseMissing $ const $ \case
 533                  Router_Union u r ->
 534                         return $ Router_Union (\(_x:!:y) -> u y) r
 535                  r -> return $ Router_Union (\(_x:!:y) -> y) r)
 536          (Map.zipWithAMatched $ const $ \case
 537                  Router_Union xu xr -> \case
 538                          Router_Union yu yr ->
 539                                 return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
 540                          yr ->
 541                                 return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
 542                  xr -> \case
 543                          Router_Union yu yr ->
 544                                 return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
 545                          yr -> return $ xr`router_Alt`yr)
 546          xs ys
 547
 548 -- ** Type 'Arg'
 549 data Arg
 550  =   ArgSegment Segment
 551  |   ArgTagLong Name
 552  |   ArgTagShort Char
 553  |   ArgEnv Name String -- ^ Here only for error reporting.
 554  deriving (Eq,Ord,Show)
 555
 556 lexer :: [String] -> [Arg]
 557 lexer ss =
 558         join $
 559         (`evalState` False) $
 560         sequence (f <$> ss)
 561         where
 562         f :: String -> StateT Bool Identity [Arg]
 563         f s = do
 564                 skip <- get
 565                 if skip then return [ArgSegment s]
 566                 else case s of
 567                  '-':'-':[] -> do
 568                         put True
 569                         return [ArgTagLong ""]
 570                  '-':'-':cs -> return [ArgTagLong cs]
 571                  '-':cs@(_:_) -> return $ ArgTagShort <$> cs
 572                  seg -> return [ArgSegment seg]
 573
 574 showArg :: Arg -> String
 575 showArg = \case
 576  ArgTagShort t -> '-':[t]
 577  ArgTagLong t -> '-':'-':t
 578  ArgSegment seg -> seg
 579  ArgEnv name val -> name<>"="<>val
 580
 581 showArgs :: [Arg] -> String
 582 showArgs args = List.intercalate " " $ showArg <$> args
 583
 584 instance P.Stream [Arg] where
 585         type Token  [Arg] = Arg
 586         type Tokens [Arg] = [Arg]
 587         tokenToChunk  Proxy = pure
 588         tokensToChunk Proxy = id
 589         chunkToTokens Proxy = id
 590         chunkLength   Proxy = List.length
 591         chunkEmpty    Proxy = List.null
 592         take1_ [] = Nothing
 593         take1_ (t:ts) = Just (t, ts)
 594         takeN_ n s
 595           | n <= 0       = Just ([], s)
 596           | List.null s  = Nothing
 597           | otherwise    = Just (List.splitAt n s)
 598         takeWhile_ = List.span
 599         showTokens Proxy = showArgs . toList
 600         -- NOTE: those make no sense when parsing a command line,
 601         -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
 602         reachOffset = error "BUG: reachOffset must not be used on [Arg]"
 603         reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"