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