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