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