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         Parser x `alt` Parser y = Parser $ P.try x <|> y
 143         opt (Parser x) = Parser $
 144                 mapCont Just <$> P.try x
 145 instance Ord e => AltApp (Parser e d) where
 146         many0 (Parser x) = Parser $ concatCont <$> many x
 147         many1 (Parser x) = Parser $ concatCont <$> some x
 148 instance Pro (Parser e d) where
 149         dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
 150 instance Ord e => CLI_Command (Parser e d) where
 151         -- type CommandConstraint (Parser e d) a = ()
 152         command "" x = x
 153         command n x = commands Map.empty (Map.singleton n x)
 154 instance Ord e => CLI_Tag (Parser e d) where
 155         type TagConstraint (Parser e d) a = ()
 156         tagged name p = Parser $ P.try $ do
 157                 void $ (`P.token` exp) $ \tok ->
 158                         if lookupTag tok name
 159                         then Just tok
 160                         else Nothing
 161                 unParser p
 162                 where
 163                 exp =
 164                         case name of
 165                          TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t
 166                          TagLong  t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong  t
 167                          Tag s l -> Set.fromList
 168                                  [ P.Tokens $ pure $ ArgTagShort s
 169                                  , P.Tokens $ pure $ ArgTagLong  l
 170                                  ]
 171                 lookupTag (ArgTagShort x) (TagShort y) = x == y
 172                 lookupTag (ArgTagShort x) (Tag y _)    = x == y
 173                 lookupTag (ArgTagLong  x) (TagLong y)  = x == y
 174                 lookupTag (ArgTagLong  x) (Tag _ y)    = x == y
 175                 lookupTag _ _                          = False
 176         endOpts = Parser $ do
 177                 (`P.token` exp) $ \case
 178                  ArgTagLong "" -> Just id
 179                  _ -> Nothing
 180                 where
 181                 exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""
 182 instance Ord e => CLI_Var (Parser e d) where
 183         type VarConstraint (Parser e d) a = (IOType a, FromSegment a)
 184         var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k
 185         var' name = Parser $ do
 186                 seg <- (`P.token` expName) $ \case
 187                  ArgSegment seg -> Just seg
 188                  _ -> Nothing
 189                 lift (fromSegment seg) >>= \case
 190                  Left err -> P.failure got expType
 191                         where
 192                         got = Just $ P.Tokens $ pure $ ArgSegment seg
 193                         expType = Set.singleton $ P.Label $ NonEmpty.fromList $
 194                                 "<"<>name<>"> to be of type "<>ioType @a
 195                                 <> case err of
 196                                  "Prelude.read: no parse" -> ""
 197                                  "" -> ""
 198                                  _ -> ": "<>err
 199                  Right a -> return ($ a)
 200                 where
 201                 expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
 202         just a  = Parser $ return ($ a)
 203         nothing = Parser $ return id
 204 instance Ord e => CLI_Env (Parser e d) where
 205         type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
 206         env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
 207         env' name = Parser $
 208                 lift (lookupEnv name) >>= \case
 209                  Nothing -> P.failure got exp
 210                         where
 211                         got = Nothing
 212                         exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
 213                  Just val ->
 214                         lift (fromSegment val) >>= \case
 215                          Right a -> return ($ a)
 216                          Left err -> P.failure got exp
 217                                 where
 218                                 got = Just $ P.Tokens $ pure $ ArgEnv name val
 219                                 exp = Set.singleton $ P.Label $ NonEmpty.fromList $
 220                                         "${"<>name<>"} to be of type "<>ioType @a
 221                                         <> case err of
 222                                          "Prelude.read: no parse" -> ""
 223                                          "" -> ""
 224                                          _ -> ": "<>err
 225 instance Ord e => CLI_Response (Parser e d) where
 226         type ResponseConstraint (Parser e d) a = Outputable a
 227         type ResponseArgs (Parser e d) a = ParserResponseArgs a
 228         type Response (Parser e d) = ParserResponse
 229         response' = Parser $
 230                 P.eof $> \({-ParserResponseArgs-} io) ->
 231                         ParserResponse $ io >>= output
 232 instance Ord e => CLI_Help (Parser e d) where
 233         type HelpConstraint (Parser e d) d' = d ~ d'
 234         help _msg = id
 235         program n = Parser . P.label n . unParser
 236         rule n    = Parser . P.label n . unParser
 237
 238 concatCont :: [(a->k)->k] -> ([a]->k)->k
 239 concatCont = List.foldr (consCont (:)) ($ [])
 240
 241 consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
 242 consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
 243
 244 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
 245 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
 246
 247 -- ** Type 'ParserResponse'
 248 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
 249 -- ** Type 'ParserResponseArgs'
 250 type ParserResponseArgs = IO
 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) -> 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 preCmds 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 ->
 375                         Map.lookup cmd cmds <|>
 376                         Map.lookup cmd preCmds
 377                  _ -> Nothing
 378
 379 -- * Type 'Router'
 380 data Router repr a b where
 381  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 382  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 383  Router_Any :: repr a b -> Router repr a b
 384  -- | Represent 'commands'.
 385  Router_Commands ::
 386   Map Name (Router repr a k) ->
 387   Map Name (Router repr a k) ->
 388   Router repr a k
 389  -- | Represent 'tagged'.
 390  Router_Tagged :: Tag -> Router repr f k -> Router repr f k
 391  -- | Represent ('<.>').
 392  Router_App :: Router repr a b -> Router repr b c -> Router repr a c
 393  -- | Represent ('<!>').
 394  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 395  -- | Unify 'Router's which have different 'handlers'.
 396  -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
 397  Router_Union :: (b->a) -> Router repr a k -> Router repr b k
 398
 399 instance Ord e => Functor (Router (Parser e d) f) where
 400         a2b`fmap`x = noTrans (a2b <$> unTrans x)
 401 instance Ord e => Applicative (Router (Parser e d) f) where
 402         pure = noTrans . pure
 403         f <*> x = noTrans (unTrans f <*> unTrans x)
 404 instance Ord e => Alternative (Router (Parser e d) f) where
 405         empty = noTrans empty
 406         f <|> x = noTrans (unTrans f <|> unTrans x)
 407 instance Ord e => Permutable (Router (Parser e d)) where
 408         type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
 409         runPermutation  = noTrans . runPermutation . unTransParserPerm
 410         toPermutation   = noTransParserPerm . toPermutation . unTrans
 411         toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
 412 instance (repr ~ Parser e d) => Show (Router repr a b) where
 413         showsPrec p = \case
 414          Router_Any{} -> showString "X"
 415          Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
 416                 where
 417                 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
 418                 go [] = id
 419                 go ((n, r):xs) =
 420                         (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
 421                         case xs of
 422                          [] -> id
 423                          _ -> showString ", " . go xs
 424          Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
 425          Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
 426          Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
 427          Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
 428
 429 instance Ord e => Trans (Router (Parser e d)) where
 430         type UnTrans (Router (Parser e d)) = Parser e d
 431         noTrans = Router_Any
 432         unTrans (Router_Any x) = x
 433         unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 434         unTrans (Router_App x y) = unTrans x <.> unTrans y
 435         unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
 436         unTrans (Router_Tagged n x) = tagged n (unTrans x)
 437         unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 438
 439 instance Ord e => App (Router (Parser e d)) where
 440         (<.>) = Router_App
 441 instance Ord e => Alt (Router (Parser e d)) where
 442         (<!>) = Router_Alt
 443         alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
 444 instance Ord e => Pro (Router (Parser e d))
 445 instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 446         command "" x = x
 447         command n x =
 448                 let is = List.tail $ List.inits n in
 449                 let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
 450                 Router_Commands
 451                  (Map.fromAscList $ (,x) <$> preCmds)
 452                  (Map.fromAscList $ (,x) <$> cmds)
 453 instance Ord e => CLI_Var (Router (Parser e d))
 454 instance Ord e => CLI_Env (Router (Parser e d))
 455 instance Ord e => CLI_Tag (Router (Parser e d)) where
 456         tagged = Router_Tagged
 457 instance CLI_Help (Router (Parser e d)) where
 458         -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
 459         -- to remove them all, since they are useless for 'Parser'
 460         -- and may prevent patterns to be matched in 'router'.
 461         help _msg  = id
 462         program _n = id
 463         rule _n    = id
 464 instance Ord e => CLI_Response (Router (Parser e d))
 465 instance Ord e => CLI_Routing (Router (Parser e d)) where
 466         -- taggeds  = Router_Taggeds
 467         commands = Router_Commands
 468
 469 router ::
 470  repr ~ Parser e d =>
 471  Router repr a b -> Router repr a b
 472 router = {-debug1 "router" $-} \case
 473  x@Router_Any{} -> x
 474  Router_Tagged n x -> Router_Tagged n (router x)
 475  Router_Alt x y -> router x`router_Alt`router y
 476  Router_Commands preCmds cmds ->
 477         Router_Commands
 478          (router <$> preCmds)
 479          (router <$> cmds)
 480  Router_App xy z ->
 481         case xy of
 482          Router_App x y ->
 483                 -- Associate to the right
 484                 Router_App (router x) $
 485                 Router_App (router y) (router z)
 486          _ -> router xy `Router_App` router z
 487  Router_Union u x -> Router_Union u (router x)
 488
 489 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 490 router_Alt ::
 491  repr ~ Parser e d =>
 492  Router repr a k ->
 493  Router repr b k ->
 494  Router repr (a:!:b) k
 495 router_Alt = {-debug2 "router_Alt"-} go
 496         where
 497         -- Merge alternative commands together.
 498         go (Router_Commands xp xs) (Router_Commands yp ys) =
 499                 Router_Commands
 500                  (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
 501                  (router_Commands True xs ys)
 502
 503         -- Merge left first or right first, depending on which removes 'Router_Alt'.
 504         go x (y`Router_Alt`z) =
 505                 case x`router_Alt`y of
 506                  Router_Alt x' y' ->
 507                         case y'`router_Alt`z of
 508                          yz@(Router_Alt _y z') ->
 509                                 case x'`router_Alt`z' of
 510                                  Router_Alt{} -> router x'`Router_Alt`yz
 511                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
 512                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
 513                          yz -> x'`router_Alt`yz
 514                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
 515         go (x`Router_Alt`y) z =
 516                 case y`router_Alt`z of
 517                  Router_Alt y' z' ->
 518                         case x`router_Alt`y' of
 519                          xy@(Router_Alt x' _y) ->
 520                                 case x'`router_Alt`z' of
 521                                  Router_Alt{} -> xy`Router_Alt`router z'
 522                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
 523                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
 524                          xy -> xy`router_Alt`z'
 525                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
 526
 527         -- Merge through 'Router_Union'.
 528         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
 529         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
 530
 531         -- No merging
 532         go x y = x`Router_Alt`y
 533
 534 router_Commands ::
 535  repr ~ Parser e d =>
 536  Bool ->
 537  Map Segment (Router repr a k) ->
 538  Map Segment (Router repr b k) ->
 539  Map Segment (Router repr (a:!:b) k)
 540 router_Commands allowMerging =
 541         -- NOTE: a little bit more complex than required
 542         -- in order to merge 'Router_Union's instead of nesting them,
 543         -- such that 'unTrans' 'Router_Union' applies them all at once.
 544         Map.merge
 545          (Map.mapMissing $ const keepX)
 546          (Map.mapMissing $ const keepY)
 547          (Map.zipWithMaybeMatched $ const $ \x y ->
 548                 if allowMerging then Just $ mergeFull x y else Nothing)
 549         where
 550         keepX = \case
 551          Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
 552          r                -> Router_Union (\(x:!:_y) -> x) r
 553         keepY = \case
 554          Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
 555          r                -> Router_Union (\(_x:!:y) -> y) r
 556         mergeFull = \case
 557          Router_Union xu xr -> \case
 558                  Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
 559                  yr                 -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
 560          xr -> \case
 561                  Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
 562                  yr                 -> xr`router_Alt`yr
 563
 564 -- ** Type 'Arg'
 565 data Arg
 566  =   ArgSegment Segment
 567  |   ArgTagLong Name
 568  |   ArgTagShort Char
 569  |   ArgEnv Name String -- ^ Here only for error reporting.
 570  deriving (Eq,Ord,Show)
 571
 572 lexer :: [String] -> [Arg]
 573 lexer ss =
 574         join $
 575         (`evalState` False) $
 576         sequence (f <$> ss)
 577         where
 578         f :: String -> StateT Bool Identity [Arg]
 579         f s = do
 580                 skip <- get
 581                 if skip then return [ArgSegment s]
 582                 else case s of
 583                  '-':'-':[] -> do
 584                         put True
 585                         return [ArgTagLong ""]
 586                  '-':'-':cs -> return [ArgTagLong cs]
 587                  '-':cs@(_:_) -> return $ ArgTagShort <$> cs
 588                  seg -> return [ArgSegment seg]
 589
 590 showArg :: Arg -> String
 591 showArg = \case
 592  ArgTagShort t -> '-':[t]
 593  ArgTagLong t -> '-':'-':t
 594  ArgSegment seg -> seg
 595  ArgEnv name val -> name<>"="<>val
 596
 597 showArgs :: [Arg] -> String
 598 showArgs args = List.intercalate " " $ showArg <$> args
 599
 600 instance P.Stream [Arg] where
 601         type Token  [Arg] = Arg
 602         type Tokens [Arg] = [Arg]
 603         tokenToChunk  Proxy = pure
 604         tokensToChunk Proxy = id
 605         chunkToTokens Proxy = id
 606         chunkLength   Proxy = List.length
 607         chunkEmpty    Proxy = List.null
 608         take1_ [] = Nothing
 609         take1_ (t:ts) = Just (t, ts)
 610         takeN_ n s
 611           | n <= 0       = Just ([], s)
 612           | List.null s  = Nothing
 613           | otherwise    = Just (List.splitAt n s)
 614         takeWhile_ = List.span
 615         showTokens Proxy = showArgs . toList
 616         -- NOTE: those make no sense when parsing a command line,
 617         -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
 618         reachOffset = error "BUG: reachOffset must not be used on [Arg]"
 619         reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"