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.empty (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) -> 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 preCmds 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 ->
 374                         Map.lookup cmd cmds <|>
 375                         Map.lookup cmd preCmds
 376                  _ -> Nothing
 377
 378 -- * Type 'Router'
 379 data Router repr a b where
 380  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 381  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 382  Router_Any :: repr a b -> Router repr a b
 383  -- | Represent 'commands'.
 384  Router_Commands ::
 385   Map Name (Router repr a k) ->
 386   Map Name (Router repr a k) ->
 387   Router repr a k
 388  -- | Represent 'tagged'.
 389  Router_Tagged :: Tag -> Router repr f k -> Router repr f k
 390  -- | Represent ('<.>').
 391  Router_App :: Router repr a b -> Router repr b c -> Router repr a c
 392  -- | Represent ('<!>').
 393  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 394  -- | Unify 'Router's which have different 'handlers'.
 395  -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
 396  Router_Union :: (b->a) -> Router repr a k -> Router repr b k
 397
 398 instance Ord e => Functor (Router (Parser e d) f) where
 399         a2b`fmap`x = noTrans (a2b <$> unTrans x)
 400 instance Ord e => Applicative (Router (Parser e d) f) where
 401         pure = noTrans . pure
 402         f <*> x = noTrans (unTrans f <*> unTrans x)
 403 instance Ord e => Alternative (Router (Parser e d) f) where
 404         empty = noTrans empty
 405         f <|> x = noTrans (unTrans f <|> unTrans x)
 406 instance Ord e => Permutable (Router (Parser e d)) where
 407         type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
 408         runPermutation  = noTrans . runPermutation . unTransParserPerm
 409         toPermutation   = noTransParserPerm . toPermutation . unTrans
 410         toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
 411 instance (repr ~ Parser e d) => Show (Router repr a b) where
 412         showsPrec p = \case
 413          Router_Any{} -> showString "X"
 414          Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
 415                 where
 416                 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
 417                 go [] = id
 418                 go ((n, r):xs) =
 419                         (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
 420                         case xs of
 421                          [] -> id
 422                          _ -> showString ", " . go xs
 423          Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
 424          Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
 425          Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
 426          Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
 427
 428 instance Ord e => Trans (Router (Parser e d)) where
 429         type UnTrans (Router (Parser e d)) = Parser e d
 430         noTrans = Router_Any
 431         unTrans (Router_Any x) = x
 432         unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 433         unTrans (Router_App x y) = unTrans x <.> unTrans y
 434         unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
 435         unTrans (Router_Tagged n x) = tagged n (unTrans x)
 436         unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 437
 438 instance Ord e => App (Router (Parser e d)) where
 439         (<.>) = Router_App
 440 instance Ord e => Alt (Router (Parser e d)) where
 441         (<!>) = Router_Alt
 442 instance Ord e => Pro (Router (Parser e d))
 443 instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 444         command "" x = x
 445         command n x =
 446                 let is = List.tail $ List.inits n in
 447                 let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
 448                 Router_Commands
 449                  (Map.fromAscList $ (,x) <$> preCmds)
 450                  (Map.fromAscList $ (,x) <$> cmds)
 451 instance Ord e => CLI_Var (Router (Parser e d))
 452 instance Ord e => CLI_Env (Router (Parser e d))
 453 instance Ord e => CLI_Tag (Router (Parser e d)) where
 454         tagged = Router_Tagged
 455 instance CLI_Help (Router (Parser e d)) where
 456         -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
 457         -- to remove them all, since they are useless for 'Parser'
 458         -- and may prevent patterns to be matched in 'router'.
 459         help _msg  = id
 460         program _n = id
 461         rule _n    = id
 462 instance Ord e => CLI_Response (Router (Parser e d))
 463 instance Ord e => CLI_Routing (Router (Parser e d)) where
 464         -- taggeds  = Router_Taggeds
 465         commands = Router_Commands
 466
 467 router ::
 468  repr ~ Parser e d =>
 469  Router repr a b -> Router repr a b
 470 router = {-debug1 "router" $-} \case
 471  x@Router_Any{} -> x
 472  Router_Tagged n x -> Router_Tagged n (router x)
 473  Router_Alt x y -> router x`router_Alt`router y
 474  Router_Commands preCmds cmds ->
 475         Router_Commands
 476          (router <$> preCmds)
 477          (router <$> cmds)
 478  Router_App xy z ->
 479         case xy of
 480          Router_App x y ->
 481                 -- Associate to the right
 482                 Router_App (router x) $
 483                 Router_App (router y) (router z)
 484          _ -> router xy `Router_App` router z
 485  Router_Union u x -> Router_Union u (router x)
 486
 487 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 488 router_Alt ::
 489  repr ~ Parser e d =>
 490  Router repr a k ->
 491  Router repr b k ->
 492  Router repr (a:!:b) k
 493 router_Alt = {-debug2 "router_Alt"-} go
 494         where
 495         -- Merge alternative commands together.
 496         go (Router_Commands xp xs) (Router_Commands yp ys) =
 497                 Router_Commands
 498                  (xp`router_Commands`yp)
 499                  (xs`router_Commands`ys)
 500
 501         -- Merge left first or right first, depending on which removes 'Router_Alt'.
 502         go x (y`Router_Alt`z) =
 503                 case x`router_Alt`y of
 504                  Router_Alt x' y' ->
 505                         case y'`router_Alt`z of
 506                          yz@(Router_Alt _y z') ->
 507                                 case x'`router_Alt`z' of
 508                                  Router_Alt{} -> router x'`Router_Alt`yz
 509                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
 510                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
 511                          yz -> x'`router_Alt`yz
 512                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
 513         go (x`Router_Alt`y) z =
 514                 case y`router_Alt`z of
 515                  Router_Alt y' z' ->
 516                         case x`router_Alt`y' of
 517                          xy@(Router_Alt x' _y) ->
 518                                 case x'`router_Alt`z' of
 519                                  Router_Alt{} -> xy`Router_Alt`router z'
 520                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
 521                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
 522                          xy -> xy`router_Alt`z'
 523                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
 524
 525         -- Merge through 'Router_Union'.
 526         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
 527         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
 528
 529         -- No merging
 530         go x y = x`Router_Alt`y
 531
 532 router_Commands ::
 533  repr ~ Parser e d =>
 534  Map Segment (Router repr a k) ->
 535  Map Segment (Router repr b k) ->
 536  Map Segment (Router repr (a:!:b) k)
 537 router_Commands =
 538         -- NOTE: a little bit more complex than required
 539         -- in order to merge 'Router_Union's instead of nesting them,
 540         -- such that 'unTrans' 'Router_Union' applies them all at once.
 541         Map.merge
 542          (Map.mapMissing $ const keepX)
 543          (Map.mapMissing $ const keepY)
 544          (Map.zipWithMatched $ const mergeFull)
 545         where
 546         keepX = \case
 547          Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
 548          r                -> Router_Union (\(x:!:_y) -> x) r
 549         keepY = \case
 550          Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
 551          r                -> Router_Union (\(_x:!:y) -> y) r
 552         mergeFull = \case
 553          Router_Union xu xr -> \case
 554                  Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
 555                  yr                 -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
 556          xr -> \case
 557                  Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
 558                  yr                 -> xr`router_Alt`yr
 559
 560 -- ** Type 'Arg'
 561 data Arg
 562  =   ArgSegment Segment
 563  |   ArgTagLong Name
 564  |   ArgTagShort Char
 565  |   ArgEnv Name String -- ^ Here only for error reporting.
 566  deriving (Eq,Ord,Show)
 567
 568 lexer :: [String] -> [Arg]
 569 lexer ss =
 570         join $
 571         (`evalState` False) $
 572         sequence (f <$> ss)
 573         where
 574         f :: String -> StateT Bool Identity [Arg]
 575         f s = do
 576                 skip <- get
 577                 if skip then return [ArgSegment s]
 578                 else case s of
 579                  '-':'-':[] -> do
 580                         put True
 581                         return [ArgTagLong ""]
 582                  '-':'-':cs -> return [ArgTagLong cs]
 583                  '-':cs@(_:_) -> return $ ArgTagShort <$> cs
 584                  seg -> return [ArgSegment seg]
 585
 586 showArg :: Arg -> String
 587 showArg = \case
 588  ArgTagShort t -> '-':[t]
 589  ArgTagLong t -> '-':'-':t
 590  ArgSegment seg -> seg
 591  ArgEnv name val -> name<>"="<>val
 592
 593 showArgs :: [Arg] -> String
 594 showArgs args = List.intercalate " " $ showArg <$> args
 595
 596 instance P.Stream [Arg] where
 597         type Token  [Arg] = Arg
 598         type Tokens [Arg] = [Arg]
 599         tokenToChunk  Proxy = pure
 600         tokensToChunk Proxy = id
 601         chunkToTokens Proxy = id
 602         chunkLength   Proxy = List.length
 603         chunkEmpty    Proxy = List.null
 604         take1_ [] = Nothing
 605         take1_ (t:ts) = Just (t, ts)
 606         takeN_ n s
 607           | n <= 0       = Just ([], s)
 608           | List.null s  = Nothing
 609           | otherwise    = Just (List.splitAt n s)
 610         takeWhile_ = List.span
 611         showTokens Proxy = showArgs . toList
 612         -- NOTE: those make no sense when parsing a command line,
 613         -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
 614         reachOffset = error "BUG: reachOffset must not be used on [Arg]"
 615         reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"