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 newtype ParserResponseArgs a = ParserResponseArgs (IO a)
 250  deriving (Functor,Applicative,Monad)
 251
 252 -- * Class 'Outputable'
 253 -- | Output of a CLI.
 254 class IOType a => Outputable a where
 255         output :: a -> IO ()
 256         default output :: Show a => a -> IO ()
 257         output = IO.print
 258
 259 instance Outputable () where
 260         output = return
 261 instance Outputable Bool
 262 instance Outputable Int
 263 instance Outputable Integer
 264 instance Outputable Natural
 265 instance Outputable String where
 266         output = IO.putStr
 267 instance Outputable Text.Text where
 268         output = Text.putStr
 269 instance Outputable TL.Text where
 270         output = TL.putStr
 271 instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where
 272         output =
 273                 TL.putStr .
 274                 TLB.toLazyText .
 275                 Doc.runPlain .
 276                 Doc.runAnsiText
 277
 278 {-
 279 instance Outputable (Doc.Reorg Doc.Term) where
 280         output = TL.hPutStrLn IO.stdout . Doc.textTerm
 281 instance Outputable (Doc.Reorg DocIO.TermIO) where
 282         output = DocIO.runTermIO IO.stdout
 283 instance Outputable (IO.Handle, (Doc.Reorg DocIO.TermIO)) where
 284         output = uncurry DocIO.runTermIO
 285 -}
 286
 287 -- * Class 'IOType'
 288 -- | Like a MIME type but for input/output of a CLI.
 289 class IOType a where
 290         ioType :: String
 291         default ioType :: Reflection.Typeable a => String
 292         ioType = show (Reflection.typeRep @a)
 293
 294 instance IOType ()
 295 instance IOType Bool
 296 instance IOType Int
 297 instance IOType Integer
 298 instance IOType Natural
 299 instance IOType String
 300 instance IOType Text.Text
 301 instance IOType TL.Text
 302 instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))
 303 {-
 304 instance IOType (Doc.Reorg Doc.Term) where
 305 instance IOType (Doc.Reorg DocIO.TermIO) where
 306 instance IOType (IO.Handle, Doc.Reorg DocIO.TermIO)
 307 -}
 308
 309 -- * Class 'FromSegment'
 310 class FromSegment a where
 311         fromSegment :: Segment -> IO (Either String a)
 312         default fromSegment :: Read a => Segment -> IO (Either String a)
 313         fromSegment = return . readEither
 314 instance FromSegment String where
 315         fromSegment = return . Right
 316 instance FromSegment Text.Text where
 317         fromSegment = return . Right . Text.pack
 318 instance FromSegment TL.Text where
 319         fromSegment = return . Right . TL.pack
 320 instance FromSegment Bool
 321 instance FromSegment Int
 322 instance FromSegment Integer
 323 instance FromSegment Natural
 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 (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 -> 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 (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 (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.singleton n x
 449 instance Ord e => CLI_Var (Router (Parser e d))
 450 instance Ord e => CLI_Env (Router (Parser e d))
 451 instance Ord e => CLI_Tag (Router (Parser e d)) where
 452         tagged = Router_Tagged
 453 instance CLI_Help (Router (Parser e d)) where
 454         -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
 455         -- to remove them all, since they are useless for 'Parser'
 456         -- and may prevent patterns to be matched in 'router'.
 457         help _msg  = id
 458         program _n = id
 459         rule _n    = id
 460 instance Ord e => CLI_Response (Router (Parser e d))
 461 instance Ord e => CLI_Routing (Router (Parser e d)) where
 462         -- taggeds  = Router_Taggeds
 463         commands = Router_Commands
 464
 465 router ::
 466  repr ~ Parser e d =>
 467  Router repr a b -> Router repr a b
 468 router = {-debug1 "router" $-} \case
 469  x@Router_Any{} -> x
 470  Router_Tagged n x -> Router_Tagged n (router x)
 471  Router_Alt x y -> router x`router_Alt`router y
 472  Router_Commands xs -> Router_Commands $ router <$> xs
 473  Router_App xy z ->
 474         case xy of
 475          Router_App x y ->
 476                 -- Associate to the right
 477                 Router_App (router x) $
 478                 Router_App (router y) (router z)
 479          _ -> router xy `Router_App` router z
 480  Router_Union u x -> Router_Union u (router x)
 481
 482 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 483 router_Alt ::
 484  repr ~ Parser e d =>
 485  Router repr a k ->
 486  Router repr b k ->
 487  Router repr (a:!:b) k
 488 router_Alt = {-debug2 "router_Alt"-} go
 489         where
 490         -- Merge alternative commands together.
 491         go (Router_Commands xs) (Router_Commands ys) =
 492                 xs`router_Commands`ys
 493
 494         -- Merge left first or right first, depending on which removes 'Router_Alt'.
 495         go x (y`Router_Alt`z) =
 496                 case x`router_Alt`y of
 497                  Router_Alt x' y' ->
 498                         case y'`router_Alt`z of
 499                          yz@(Router_Alt _y z') ->
 500                                 case x'`router_Alt`z' of
 501                                  Router_Alt{} -> router x'`Router_Alt`yz
 502                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
 503                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
 504                          yz -> x'`router_Alt`yz
 505                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
 506         go (x`Router_Alt`y) z =
 507                 case y`router_Alt`z of
 508                  Router_Alt y' z' ->
 509                         case x`router_Alt`y' of
 510                          xy@(Router_Alt x' _y) ->
 511                                 case x'`router_Alt`z' of
 512                                  Router_Alt{} -> xy`Router_Alt`router z'
 513                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
 514                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
 515                          xy -> xy`router_Alt`z'
 516                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
 517
 518         -- Merge through 'Router_Union'.
 519         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
 520         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
 521
 522         -- No merging
 523         go x y = x`Router_Alt`y
 524
 525 router_Commands ::
 526  repr ~ Parser e d =>
 527  Map Segment (Router repr a k) ->
 528  Map Segment (Router repr b k) ->
 529  Router repr (a:!:b) k
 530 router_Commands xs ys =
 531         -- NOTE: a little bit more complex than required
 532         -- in order to merge 'Router_Union's instead of nesting them,
 533         -- such that 'unTrans' 'Router_Union' applies them all at once.
 534         Router_Commands $
 535         Map.merge
 536          (Map.traverseMissing $ const $ \case
 537                  Router_Union u r ->
 538                         return $ Router_Union (\(x:!:_y) -> u x) r
 539                  r -> return $ Router_Union (\(x:!:_y) -> x) r)
 540          (Map.traverseMissing $ const $ \case
 541                  Router_Union u r ->
 542                         return $ Router_Union (\(_x:!:y) -> u y) r
 543                  r -> return $ Router_Union (\(_x:!:y) -> y) r)
 544          (Map.zipWithAMatched $ const $ \case
 545                  Router_Union xu xr -> \case
 546                          Router_Union yu yr ->
 547                                 return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
 548                          yr ->
 549                                 return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
 550                  xr -> \case
 551                          Router_Union yu yr ->
 552                                 return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
 553                          yr -> return $ xr`router_Alt`yr)
 554          xs ys
 555
 556 -- ** Type 'Arg'
 557 data Arg
 558  =   ArgSegment Segment
 559  |   ArgTagLong Name
 560  |   ArgTagShort Char
 561  |   ArgEnv Name String -- ^ Here only for error reporting.
 562  deriving (Eq,Ord,Show)
 563
 564 lexer :: [String] -> [Arg]
 565 lexer ss =
 566         join $
 567         (`evalState` False) $
 568         sequence (f <$> ss)
 569         where
 570         f :: String -> StateT Bool Identity [Arg]
 571         f s = do
 572                 skip <- get
 573                 if skip then return [ArgSegment s]
 574                 else case s of
 575                  '-':'-':[] -> do
 576                         put True
 577                         return [ArgTagLong ""]
 578                  '-':'-':cs -> return [ArgTagLong cs]
 579                  '-':cs@(_:_) -> return $ ArgTagShort <$> cs
 580                  seg -> return [ArgSegment seg]
 581
 582 showArg :: Arg -> String
 583 showArg = \case
 584  ArgTagShort t -> '-':[t]
 585  ArgTagLong t -> '-':'-':t
 586  ArgSegment seg -> seg
 587  ArgEnv name val -> name<>"="<>val
 588
 589 showArgs :: [Arg] -> String
 590 showArgs args = List.intercalate " " $ showArg <$> args
 591
 592 instance P.Stream [Arg] where
 593         type Token  [Arg] = Arg
 594         type Tokens [Arg] = [Arg]
 595         tokenToChunk  Proxy = pure
 596         tokensToChunk Proxy = id
 597         chunkToTokens Proxy = id
 598         chunkLength   Proxy = List.length
 599         chunkEmpty    Proxy = List.null
 600         take1_ [] = Nothing
 601         take1_ (t:ts) = Just (t, ts)
 602         takeN_ n s
 603           | n <= 0       = Just ([], s)
 604           | List.null s  = Nothing
 605           | otherwise    = Just (List.splitAt n s)
 606         takeWhile_ = List.span
 607         showTokens Proxy = showArgs . toList
 608         -- NOTE: those make no sense when parsing a command line,
 609         -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
 610         reachOffset = error "BUG: reachOffset must not be used on [Arg]"
 611         reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"