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