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 instance Outputable (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder)) where
 278         output (h,d) =
 279                 TL.hPutStr h $
 280                 TLB.toLazyText $
 281                 Doc.runPlain $
 282                 Doc.runAnsiText d
 283
 284 -- * Class 'IOType'
 285 -- | Like a MIME type but for input/output of a CLI.
 286 class IOType a where
 287         ioType :: String
 288         default ioType :: Reflection.Typeable a => String
 289         ioType = show (Reflection.typeRep @a)
 290
 291 instance IOType ()
 292 instance IOType Bool
 293 instance IOType Int
 294 instance IOType Integer
 295 instance IOType Natural
 296 instance IOType String
 297 instance IOType Text.Text
 298 instance IOType TL.Text
 299 instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))
 300 instance IOType (IO.Handle, Doc.AnsiText (Doc.Plain TLB.Builder))
 301
 302 -- * Class 'FromSegment'
 303 class FromSegment a where
 304         fromSegment :: Segment -> IO (Either String a)
 305         default fromSegment :: Read a => Segment -> IO (Either String a)
 306         fromSegment = return . readEither
 307 instance FromSegment String where
 308         fromSegment = return . Right
 309 instance FromSegment Text.Text where
 310         fromSegment = return . Right . Text.pack
 311 instance FromSegment TL.Text where
 312         fromSegment = return . Right . TL.pack
 313 instance FromSegment Bool
 314 instance FromSegment Int
 315 instance FromSegment Integer
 316 instance FromSegment Natural
 317
 318 -- ** Type 'ParserPerm'
 319 data ParserPerm e d repr k a = ParserPerm
 320  { permutation_result :: !(Maybe ((a->k)->k))
 321  , permutation_parser :: repr () (ParserPerm e d repr k a)
 322  }
 323
 324 instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
 325         a2b `fmap` ParserPerm a ma = ParserPerm
 326          ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)
 327          ((a2b `fmap`) `fmap` ma)
 328 instance (App repr, Functor (repr ()), Alternative (repr ())) =>
 329          Applicative (ParserPerm e d repr k) where
 330         pure a = ParserPerm (Just ($ a)) empty
 331         lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
 332                 ParserPerm a (lhsAlt <|> rhsAlt)
 333                 where
 334                 a =
 335                  (\a2b2k2k a2k2k -> \b2k ->
 336                         a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
 337                  ) <$> f <*> x
 338                 lhsAlt = (<*> rhs) <$> ma2b
 339                 rhsAlt = (lhs <*>) <$> ma
 340 instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
 341         type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
 342         program _n = id
 343         rule _n = id
 344
 345 noTransParserPerm ::
 346  Trans repr =>
 347  Functor (UnTrans repr ()) =>
 348  ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
 349 noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
 350
 351 unTransParserPerm ::
 352  Trans repr =>
 353  Functor (UnTrans repr ()) =>
 354  ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
 355 unTransParserPerm (ParserPerm a ma) = ParserPerm a (unTransParserPerm <$> unTrans ma)
 356
 357 hoistParserPerm ::
 358  Functor (repr ()) =>
 359  (forall a b. repr a b -> repr a b) ->
 360  ParserPerm e d repr k c -> ParserPerm e d repr k c
 361 hoistParserPerm f (ParserPerm a ma) =
 362         ParserPerm a (hoistParserPerm f <$> f ma)
 363
 364 -- ** Class 'CLI_Routing'
 365 class CLI_Routing repr where
 366         commands :: Map Name (repr a k) -> repr a k
 367         -- taggeds  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
 368 instance Ord e => CLI_Routing (Parser e d) where
 369         commands cmds = Parser $
 370                 P.token check exp >>= unParser
 371                 where
 372                 exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
 373                 check = \case
 374                  ArgSegment cmd -> Map.lookup cmd cmds
 375                  _ -> Nothing
 376
 377 -- * Type 'Router'
 378 data Router repr a b where
 379  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 380  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 381  Router_Any :: repr a b -> Router repr a b
 382  -- | Represent 'commands'.
 383  Router_Commands :: Map Name (Router repr a k) -> Router repr a k
 384  -- | Represent 'tagged'.
 385  Router_Tagged :: Tag -> Router repr f k -> Router repr f k
 386  -- | Represent ('<.>').
 387  Router_App :: Router repr a b -> Router repr b c -> Router repr a c
 388  -- | Represent ('<!>').
 389  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 390  -- | Unify 'Router's which have different 'handlers'.
 391  -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
 392  Router_Union :: (b->a) -> Router repr a k -> Router repr b k
 393
 394 instance Ord e => Functor (Router (Parser e d) f) where
 395         a2b`fmap`x = noTrans (a2b <$> unTrans x)
 396 instance Ord e => Applicative (Router (Parser e d) f) where
 397         pure = noTrans . pure
 398         f <*> x = noTrans (unTrans f <*> unTrans x)
 399 instance Ord e => Alternative (Router (Parser e d) f) where
 400         empty = noTrans empty
 401         f <|> x = noTrans (unTrans f <|> unTrans x)
 402 instance Ord e => Permutable (Router (Parser e d)) where
 403         type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
 404         runPermutation  = noTrans . runPermutation . unTransParserPerm
 405         toPermutation   = noTransParserPerm . toPermutation . unTrans
 406         toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
 407 instance (repr ~ Parser e d) => Show (Router repr a b) where
 408         showsPrec p = \case
 409          Router_Any{} -> showString "X"
 410          Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go (Map.toList ms) . showString "]"
 411                 where
 412                 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
 413                 go [] = id
 414                 go ((n, r):xs) =
 415                         (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
 416                         case xs of
 417                          [] -> id
 418                          _ -> showString ", " . go xs
 419          Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
 420          Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
 421          Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
 422          Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
 423
 424 instance Ord e => Trans (Router (Parser e d)) where
 425         type UnTrans (Router (Parser e d)) = Parser e d
 426         noTrans = Router_Any
 427         unTrans (Router_Any x) = x
 428         unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 429         unTrans (Router_App x y) = unTrans x <.> unTrans y
 430         unTrans (Router_Commands ms) = commands (unTrans <$> ms)
 431         unTrans (Router_Tagged n x) = tagged n (unTrans x)
 432         unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 433
 434 instance Ord e => App (Router (Parser e d)) where
 435         (<.>) = Router_App
 436 instance Ord e => Alt (Router (Parser e d)) where
 437         (<!>) = Router_Alt
 438 instance Ord e => Pro (Router (Parser e d))
 439 instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 440         command "" x = x
 441         command n x = Router_Commands $ Map.singleton n x
 442 instance Ord e => CLI_Var (Router (Parser e d))
 443 instance Ord e => CLI_Env (Router (Parser e d))
 444 instance Ord e => CLI_Tag (Router (Parser e d)) where
 445         tagged = Router_Tagged
 446 instance CLI_Help (Router (Parser e d)) where
 447         -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
 448         -- to remove them all, since they are useless for 'Parser'
 449         -- and may prevent patterns to be matched in 'router'.
 450         help _msg  = id
 451         program _n = id
 452         rule _n    = id
 453 instance Ord e => CLI_Response (Router (Parser e d))
 454 instance Ord e => CLI_Routing (Router (Parser e d)) where
 455         -- taggeds  = Router_Taggeds
 456         commands = Router_Commands
 457
 458 router ::
 459  repr ~ Parser e d =>
 460  Router repr a b -> Router repr a b
 461 router = {-debug1 "router" $-} \case
 462  x@Router_Any{} -> x
 463  Router_Tagged n x -> Router_Tagged n (router x)
 464  Router_Alt x y -> router x`router_Alt`router y
 465  Router_Commands xs -> Router_Commands $ router <$> xs
 466  Router_App xy z ->
 467         case xy of
 468          Router_App x y ->
 469                 -- Associate to the right
 470                 Router_App (router x) $
 471                 Router_App (router y) (router z)
 472          _ -> router xy `Router_App` router z
 473  Router_Union u x -> Router_Union u (router x)
 474
 475 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 476 router_Alt ::
 477  repr ~ Parser e d =>
 478  Router repr a k ->
 479  Router repr b k ->
 480  Router repr (a:!:b) k
 481 router_Alt = {-debug2 "router_Alt"-} go
 482         where
 483         -- Merge alternative commands together.
 484         go (Router_Commands xs) (Router_Commands ys) =
 485                 xs`router_Commands`ys
 486
 487         -- Merge left first or right first, depending on which removes 'Router_Alt'.
 488         go x (y`Router_Alt`z) =
 489                 case x`router_Alt`y of
 490                  Router_Alt x' y' ->
 491                         case y'`router_Alt`z of
 492                          yz@(Router_Alt _y z') ->
 493                                 case x'`router_Alt`z' of
 494                                  Router_Alt{} -> router x'`Router_Alt`yz
 495                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
 496                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
 497                          yz -> x'`router_Alt`yz
 498                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
 499         go (x`Router_Alt`y) z =
 500                 case y`router_Alt`z of
 501                  Router_Alt y' z' ->
 502                         case x`router_Alt`y' of
 503                          xy@(Router_Alt x' _y) ->
 504                                 case x'`router_Alt`z' of
 505                                  Router_Alt{} -> xy`Router_Alt`router z'
 506                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
 507                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
 508                          xy -> xy`router_Alt`z'
 509                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
 510
 511         -- Merge through 'Router_Union'.
 512         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
 513         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
 514
 515         -- No merging
 516         go x y = x`Router_Alt`y
 517
 518 router_Commands ::
 519  repr ~ Parser e d =>
 520  Map Segment (Router repr a k) ->
 521  Map Segment (Router repr b k) ->
 522  Router repr (a:!:b) k
 523 router_Commands xs ys =
 524         -- NOTE: a little bit more complex than required
 525         -- in order to merge 'Router_Union's instead of nesting them,
 526         -- such that 'unTrans' 'Router_Union' applies them all at once.
 527         Router_Commands $
 528         Map.merge
 529          (Map.traverseMissing $ const $ \case
 530                  Router_Union u r ->
 531                         return $ Router_Union (\(x:!:_y) -> u x) r
 532                  r -> return $ Router_Union (\(x:!:_y) -> x) r)
 533          (Map.traverseMissing $ const $ \case
 534                  Router_Union u r ->
 535                         return $ Router_Union (\(_x:!:y) -> u y) r
 536                  r -> return $ Router_Union (\(_x:!:y) -> y) r)
 537          (Map.zipWithAMatched $ const $ \case
 538                  Router_Union xu xr -> \case
 539                          Router_Union yu yr ->
 540                                 return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
 541                          yr ->
 542                                 return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
 543                  xr -> \case
 544                          Router_Union yu yr ->
 545                                 return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
 546                          yr -> return $ xr`router_Alt`yr)
 547          xs ys
 548
 549 -- ** Type 'Arg'
 550 data Arg
 551  =   ArgSegment Segment
 552  |   ArgTagLong Name
 553  |   ArgTagShort Char
 554  |   ArgEnv Name String -- ^ Here only for error reporting.
 555  deriving (Eq,Ord,Show)
 556
 557 lexer :: [String] -> [Arg]
 558 lexer ss =
 559         join $
 560         (`evalState` False) $
 561         sequence (f <$> ss)
 562         where
 563         f :: String -> StateT Bool Identity [Arg]
 564         f s = do
 565                 skip <- get
 566                 if skip then return [ArgSegment s]
 567                 else case s of
 568                  '-':'-':[] -> do
 569                         put True
 570                         return [ArgTagLong ""]
 571                  '-':'-':cs -> return [ArgTagLong cs]
 572                  '-':cs@(_:_) -> return $ ArgTagShort <$> cs
 573                  seg -> return [ArgSegment seg]
 574
 575 showArg :: Arg -> String
 576 showArg = \case
 577  ArgTagShort t -> '-':[t]
 578  ArgTagLong t -> '-':'-':t
 579  ArgSegment seg -> seg
 580  ArgEnv name val -> name<>"="<>val
 581
 582 showArgs :: [Arg] -> String
 583 showArgs args = List.intercalate " " $ showArg <$> args
 584
 585 instance P.Stream [Arg] where
 586         type Token  [Arg] = Arg
 587         type Tokens [Arg] = [Arg]
 588         tokenToChunk  Proxy = pure
 589         tokensToChunk Proxy = id
 590         chunkToTokens Proxy = id
 591         chunkLength   Proxy = List.length
 592         chunkEmpty    Proxy = List.null
 593         take1_ [] = Nothing
 594         take1_ (t:ts) = Just (t, ts)
 595         takeN_ n s
 596           | n <= 0       = Just ([], s)
 597           | List.null s  = Nothing
 598           | otherwise    = Just (List.splitAt n s)
 599         takeWhile_ = List.span
 600         showTokens Proxy = showArgs . toList
 601         -- NOTE: those make no sense when parsing a command line,
 602         -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
 603         reachOffset = error "BUG: reachOffset must not be used on [Arg]"
 604         reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"