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