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