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.ByteString as BS
  39 import qualified Data.ByteString.Lazy as BSL
  40 import qualified Data.List as List
  41 import qualified Data.List.NonEmpty as NonEmpty
  42 import qualified Data.Map.Merge.Strict as Map
  43 import qualified Data.Map.Strict as Map
  44 import qualified Data.Set as Set
  45 import qualified Data.Text as Text
  46 import qualified Data.Text.IO as Text
  47 import qualified Data.Text.Lazy as TL
  48 import qualified Data.Text.Lazy.Builder as TLB
  49 import qualified Data.Text.Lazy.IO as TL
  50 import qualified Symantic.Document as Doc
  51 import qualified System.IO as IO
  52 import qualified Text.Megaparsec as P
  53
  54 import Symantic.CLI.API
  55
  56 -- * Type 'Parser'
  57 newtype Parser e d f k = Parser
  58  { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
  59  }
  60
  61 parser ::
  62  P.ShowErrorComponent e =>
  63  Router (Parser e d) handlers (Response (Router (Parser e d))) ->
  64  handlers ->
  65  [Arg] -> IO ()
  66 parser api handlers args = do
  67         P.runParserT
  68          (unParser $ unTrans $ router api)
  69          "" args >>= \case
  70          Left err ->
  71                 forM_ (P.bundleErrors err) $ \e -> do
  72                         IO.putStr $
  73                                 "Error parsing the command at argument #" <>
  74                                 show (P.errorOffset e + 1) <> ":\n" <>
  75                                 parseErrorTextPretty e
  76          Right app -> unResponseParser $ app handlers
  77
  78 -- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
  79 parseErrorTextPretty ::
  80  forall s e.
  81  (P.Stream s, P.ShowErrorComponent e) =>
  82  P.ParseError s e -> String
  83 parseErrorTextPretty (P.TrivialError _ us ps) =
  84         if isNothing us && Set.null ps
  85         then "unknown parse error\n"
  86         else
  87                 messageItemsPretty "unexpected "
  88                  (showErrorItem pxy <$> Set.toAscList (maybe Set.empty Set.singleton us)) <>
  89                 messageItemsPretty "expecting "
  90                  (showErrorItem pxy <$> Set.toAscList ps)
  91         where pxy = Proxy :: Proxy s
  92 parseErrorTextPretty err = P.parseErrorTextPretty err
  93
  94 messageItemsPretty :: String -> [String] -> String
  95 messageItemsPretty prefix ts
  96  | null ts = ""
  97  | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"
  98
  99 orList :: NonEmpty String -> String
 100 orList (x:|[])  = x
 101 orList (x:|[y]) = x <> " or " <> y
 102 orList xs       = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs
 103
 104 showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String
 105 showErrorItem pxy = \case
 106  P.Tokens ts -> P.showTokens pxy ts
 107  P.Label label -> NonEmpty.toList label
 108  P.EndOfInput  -> "end of input"
 109
 110 instance Functor (Parser e d f) where
 111         a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x
 112 instance Applicative (Parser e d f) where
 113         pure = Parser . pure . const
 114         Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
 115 instance Ord e => Alternative (Parser e d f) where
 116         empty = Parser empty
 117         Parser x <|> Parser y = Parser $ x <|> y
 118 instance Ord e => Permutable (Parser e d) where
 119         type Permutation (Parser e d) = ParserPerm e d (Parser e d)
 120         runPermutation (ParserPerm ma p) = Parser $ do
 121                 u2p <- unParser $ optional p
 122                 unParser $
 123                         case u2p () of
 124                          Just perm -> runPermutation perm
 125                          Nothing ->
 126                                 maybe
 127                                  (Parser $ P.token (const Nothing) Set.empty)
 128                                  -- NOTE: not 'empty' so that 'P.TrivialError' has the unexpected token.
 129                                  (Parser . return) ma
 130         toPermutation (Parser x) =
 131                 ParserPerm Nothing
 132                  (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x)
 133         toPermDefault a (Parser x) =
 134                 ParserPerm (Just ($ a))
 135                  (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)
 136 instance App (Parser e d) where
 137         Parser x <.> Parser y = Parser $
 138                 x >>= \a2b -> (. a2b) <$> y
 139 instance Ord e => Alt (Parser e d) where
 140         Parser x <!> Parser y = Parser $
 141                 (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
 142                 (\b2k (_a:!:b) -> b2k b) <$> y
 143         Parser x `alt` Parser y = Parser $ P.try x <|> y
 144         opt (Parser x) = Parser $
 145                 mapCont Just <$> P.try x
 146 instance Ord e => AltApp (Parser e d) where
 147         many0 (Parser x) = Parser $ concatCont <$> many x
 148         many1 (Parser x) = Parser $ concatCont <$> some x
 149 instance Pro (Parser e d) where
 150         dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
 151 instance Ord e => CLI_Command (Parser e d) where
 152         -- type CommandConstraint (Parser e d) a = ()
 153         command "" x = x
 154         command n x = commands Map.empty (Map.singleton n x)
 155 instance Ord e => CLI_Tag (Parser e d) where
 156         type TagConstraint (Parser e d) a = ()
 157         tagged name p = Parser $ P.try $ do
 158                 void $ (`P.token` exp) $ \tok ->
 159                         if lookupTag tok name
 160                         then Just tok
 161                         else Nothing
 162                 unParser p
 163                 where
 164                 exp =
 165                         case name of
 166                          TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t
 167                          TagLong  t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong  t
 168                          Tag s l -> Set.fromList
 169                                  [ P.Tokens $ pure $ ArgTagShort s
 170                                  , P.Tokens $ pure $ ArgTagLong  l
 171                                  ]
 172                 lookupTag (ArgTagShort x) (TagShort y) = x == y
 173                 lookupTag (ArgTagShort x) (Tag y _)    = x == y
 174                 lookupTag (ArgTagLong  x) (TagLong y)  = x == y
 175                 lookupTag (ArgTagLong  x) (Tag _ y)    = x == y
 176                 lookupTag _ _                          = False
 177         endOpts = Parser $ do
 178                 (`P.token` exp) $ \case
 179                  ArgTagLong "" -> Just id
 180                  _ -> Nothing
 181                 where
 182                 exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""
 183 instance Ord e => CLI_Var (Parser e d) where
 184         type VarConstraint (Parser e d) a = (IOType a, FromSegment a)
 185         var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k
 186         var' name = Parser $ do
 187                 seg <- (`P.token` expName) $ \case
 188                  ArgSegment seg -> Just seg
 189                  _ -> Nothing
 190                 lift (fromSegment seg) >>= \case
 191                  Left err -> P.failure got expType
 192                         where
 193                         got = Just $ P.Tokens $ pure $ ArgSegment seg
 194                         expType = Set.singleton $ P.Label $ NonEmpty.fromList $
 195                                 "<"<>name<>"> to be of type "<>ioType @a
 196                                 <> case err of
 197                                  "Prelude.read: no parse" -> ""
 198                                  "" -> ""
 199                                  _ -> ": "<>err
 200                  Right a -> return ($ a)
 201                 where
 202                 expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
 203         just a  = Parser $ return ($ a)
 204         nothing = Parser $ return id
 205 instance Ord e => CLI_Env (Parser e d) where
 206         type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
 207         env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
 208         env' name = Parser $
 209                 lift (lookupEnv name) >>= \case
 210                  Nothing -> P.failure got exp
 211                         where
 212                         got = Nothing
 213                         exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
 214                  Just val ->
 215                         lift (fromSegment val) >>= \case
 216                          Right a -> return ($ a)
 217                          Left err -> P.failure got exp
 218                                 where
 219                                 got = Just $ P.Tokens $ pure $ ArgEnv name val
 220                                 exp = Set.singleton $ P.Label $ NonEmpty.fromList $
 221                                         "${"<>name<>"} to be of type "<>ioType @a
 222                                         <> case err of
 223                                          "Prelude.read: no parse" -> ""
 224                                          "" -> ""
 225                                          _ -> ": "<>err
 226 instance Ord e => CLI_Response (Parser e d) where
 227         type ResponseConstraint (Parser e d) a = Outputable a
 228         type ResponseArgs (Parser e d) a = ParserResponseArgs a
 229         type Response (Parser e d) = ParserResponse
 230         response' = Parser $
 231                 P.eof $> \({-ParserResponseArgs-} io) ->
 232                         ParserResponse $ io >>= output
 233 instance Ord e => CLI_Help (Parser e d) where
 234         type HelpConstraint (Parser e d) d' = d ~ d'
 235         help _msg = id
 236         program n = Parser . P.label n . unParser
 237         rule n    = Parser . P.label n . unParser
 238
 239 concatCont :: [(a->k)->k] -> ([a]->k)->k
 240 concatCont = List.foldr (consCont (:)) ($ [])
 241
 242 consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
 243 consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
 244
 245 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
 246 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
 247
 248 -- ** Type 'ParserResponse'
 249 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
 250 -- ** Type 'ParserResponseArgs'
 251 type ParserResponseArgs = IO
 252
 253 -- * Class 'Outputable'
 254 -- | Output of a CLI.
 255 class IOType a => Outputable a where
 256         output :: a -> IO ()
 257         default output :: Show a => a -> IO ()
 258         output = IO.print
 259
 260 instance Outputable () where
 261         output = return
 262 instance Outputable Bool
 263 instance Outputable Int
 264 instance Outputable Integer
 265 instance Outputable Natural
 266 instance Outputable Char where
 267         output c = IO.putStr [c]
 268 instance Outputable String where
 269         output = IO.putStr
 270 instance Outputable Text.Text where
 271         output = Text.putStr
 272 instance Outputable TL.Text where
 273         output = TL.putStr
 274 instance Outputable BS.ByteString where
 275         output = BS.putStr
 276 instance Outputable BSL.ByteString where
 277         output = BSL.putStr
 278 instance Outputable (Doc.Plain TLB.Builder) where
 279         output =
 280                 TL.putStr .
 281                 TLB.toLazyText .
 282                 Doc.runPlain
 283
 284 -- ** Type 'OnHandle'
 285 data OnHandle a = OnHandle IO.Handle a
 286 instance IOType a => IOType (OnHandle a) where
 287         ioType = ioType @a
 288 instance Outputable (OnHandle ()) where
 289         output _ = return ()
 290 instance Outputable (OnHandle Bool) where
 291         output (OnHandle h a) = IO.hPrint h a
 292 instance Outputable (OnHandle Int) where
 293         output (OnHandle h a) = IO.hPrint h a
 294 instance Outputable (OnHandle Integer) where
 295         output (OnHandle h a) = IO.hPrint h a
 296 instance Outputable (OnHandle Natural) where
 297         output (OnHandle h a) = IO.hPrint h a
 298 instance Outputable (OnHandle Char) where
 299         output (OnHandle h c) = IO.hPutStr h [c]
 300 instance Outputable (OnHandle String) where
 301         output (OnHandle h a) = IO.hPutStr h a
 302 instance Outputable (OnHandle Text.Text) where
 303         output (OnHandle h a) = Text.hPutStr h a
 304 instance Outputable (OnHandle TL.Text) where
 305         output (OnHandle h a) = TL.hPutStr h a
 306 instance Outputable (OnHandle BS.ByteString) where
 307         output (OnHandle h a) = BS.hPutStr h a
 308 instance Outputable (OnHandle BSL.ByteString) where
 309         output (OnHandle h a) = BSL.hPutStr h a
 310 instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where
 311         output (OnHandle h d) =
 312                 TL.hPutStr h $
 313                 TLB.toLazyText $
 314                 Doc.runPlain d
 315 instance
 316  ( Outputable a
 317  , Reflection.Typeable a
 318  ) => Outputable (Maybe a) where
 319         output = \case
 320          Nothing -> return ()
 321          Just a  -> output a
 322 instance
 323  ( Reflection.Typeable e
 324  , Reflection.Typeable a
 325  , Outputable (OnHandle e)
 326  , Outputable a
 327  ) => Outputable (Either e a) where
 328         output = \case
 329          Left e -> output $ OnHandle IO.stderr e
 330          Right a -> output a
 331
 332 -- * Class 'IOType'
 333 -- | Like a MIME type but for input/output of a CLI.
 334 class IOType a where
 335         ioType :: String
 336         default ioType :: Reflection.Typeable a => String
 337         ioType = show (Reflection.typeRep @a)
 338
 339 instance IOType ()
 340 instance IOType Bool
 341 instance IOType Char
 342 instance IOType Int
 343 instance IOType Integer
 344 instance IOType Natural
 345 instance IOType String
 346 instance IOType Text.Text
 347 instance IOType TL.Text
 348 instance IOType BS.ByteString
 349 instance IOType BSL.ByteString
 350 instance IOType (Doc.Plain TLB.Builder)
 351 instance Reflection.Typeable a => IOType (Maybe a)
 352 instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)
 353
 354 -- * Class 'FromSegment'
 355 class FromSegment a where
 356         fromSegment :: Segment -> IO (Either String a)
 357         default fromSegment :: Read a => Segment -> IO (Either String a)
 358         fromSegment = return . readEither
 359 instance FromSegment String where
 360         fromSegment = return . Right
 361 instance FromSegment Text.Text where
 362         fromSegment = return . Right . Text.pack
 363 instance FromSegment TL.Text where
 364         fromSegment = return . Right . TL.pack
 365 instance FromSegment Bool
 366 instance FromSegment Int
 367 instance FromSegment Integer
 368 instance FromSegment Natural
 369
 370 -- ** Type 'ParserPerm'
 371 data ParserPerm e d repr k a = ParserPerm
 372  { permutation_result :: !(Maybe ((a->k)->k))
 373  , permutation_parser :: repr () (ParserPerm e d repr k a)
 374  }
 375
 376 instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
 377         a2b `fmap` ParserPerm a ma = ParserPerm
 378          ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)
 379          ((a2b `fmap`) `fmap` ma)
 380 instance (App repr, Functor (repr ()), Alternative (repr ())) =>
 381          Applicative (ParserPerm e d repr k) where
 382         pure a = ParserPerm (Just ($ a)) empty
 383         lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
 384                 ParserPerm a (lhsAlt <|> rhsAlt)
 385                 where
 386                 a =
 387                  (\a2b2k2k a2k2k -> \b2k ->
 388                         a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
 389                  ) <$> f <*> x
 390                 lhsAlt = (<*> rhs) <$> ma2b
 391                 rhsAlt = (lhs <*>) <$> ma
 392 instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
 393         type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
 394         program _n = id
 395         rule _n = id
 396
 397 noTransParserPerm ::
 398  Trans repr =>
 399  Functor (UnTrans repr ()) =>
 400  ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
 401 noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
 402
 403 unTransParserPerm ::
 404  Trans repr =>
 405  Functor (UnTrans repr ()) =>
 406  ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
 407 unTransParserPerm (ParserPerm a ma) = ParserPerm a (unTransParserPerm <$> unTrans ma)
 408
 409 hoistParserPerm ::
 410  Functor (repr ()) =>
 411  (forall a b. repr a b -> repr a b) ->
 412  ParserPerm e d repr k c -> ParserPerm e d repr k c
 413 hoistParserPerm f (ParserPerm a ma) =
 414         ParserPerm a (hoistParserPerm f <$> f ma)
 415
 416 -- ** Class 'CLI_Routing'
 417 class CLI_Routing repr where
 418         commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k
 419         -- taggeds  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
 420 instance Ord e => CLI_Routing (Parser e d) where
 421         commands preCmds cmds = Parser $
 422                 P.token check exp >>= unParser
 423                 where
 424                 exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
 425                 check = \case
 426                  ArgSegment cmd ->
 427                         Map.lookup cmd cmds <|>
 428                         Map.lookup cmd preCmds
 429                  _ -> Nothing
 430
 431 -- * Type 'Router'
 432 data Router repr a b where
 433  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 434  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 435  Router_Any :: repr a b -> Router repr a b
 436  -- | Represent 'commands'.
 437  Router_Commands ::
 438   Map Name (Router repr a k) ->
 439   Map Name (Router repr a k) ->
 440   Router repr a k
 441  -- | Represent 'tagged'.
 442  Router_Tagged :: Tag -> Router repr f k -> Router repr f k
 443  -- | Represent ('<.>').
 444  Router_App :: Router repr a b -> Router repr b c -> Router repr a c
 445  -- | Represent ('<!>').
 446  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 447  -- | Unify 'Router's which have different 'handlers'.
 448  -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
 449  Router_Union :: (b->a) -> Router repr a k -> Router repr b k
 450
 451 instance Ord e => Functor (Router (Parser e d) f) where
 452         a2b`fmap`x = noTrans (a2b <$> unTrans x)
 453 instance Ord e => Applicative (Router (Parser e d) f) where
 454         pure = noTrans . pure
 455         f <*> x = noTrans (unTrans f <*> unTrans x)
 456 instance Ord e => Alternative (Router (Parser e d) f) where
 457         empty = noTrans empty
 458         f <|> x = noTrans (unTrans f <|> unTrans x)
 459 instance Ord e => Permutable (Router (Parser e d)) where
 460         type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
 461         runPermutation  = noTrans . runPermutation . unTransParserPerm
 462         toPermutation   = noTransParserPerm . toPermutation . unTrans
 463         toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
 464 instance (repr ~ Parser e d) => Show (Router repr a b) where
 465         showsPrec p = \case
 466          Router_Any{} -> showString "X"
 467          Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
 468                 where
 469                 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
 470                 go [] = id
 471                 go ((n, r):xs) =
 472                         (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
 473                         case xs of
 474                          [] -> id
 475                          _ -> showString ", " . go xs
 476          Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
 477          Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
 478          Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
 479          Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
 480
 481 instance Ord e => Trans (Router (Parser e d)) where
 482         type UnTrans (Router (Parser e d)) = Parser e d
 483         noTrans = Router_Any
 484         unTrans (Router_Any x) = x
 485         unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 486         unTrans (Router_App x y) = unTrans x <.> unTrans y
 487         unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
 488         unTrans (Router_Tagged n x) = tagged n (unTrans x)
 489         unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 490
 491 instance Ord e => App (Router (Parser e d)) where
 492         (<.>) = Router_App
 493 instance Ord e => Alt (Router (Parser e d)) where
 494         (<!>) = Router_Alt
 495         alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
 496 instance Ord e => Pro (Router (Parser e d))
 497 instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 498         command "" x = x
 499         command n x =
 500                 let is = List.tail $ List.inits n in
 501                 let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
 502                 Router_Commands
 503                  (Map.fromAscList $ (,x) <$> preCmds)
 504                  (Map.fromAscList $ (,x) <$> cmds)
 505 instance Ord e => CLI_Var (Router (Parser e d))
 506 instance Ord e => CLI_Env (Router (Parser e d))
 507 instance Ord e => CLI_Tag (Router (Parser e d)) where
 508         tagged = Router_Tagged
 509 instance CLI_Help (Router (Parser e d)) where
 510         -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
 511         -- to remove them all, since they are useless for 'Parser'
 512         -- and may prevent patterns to be matched in 'router'.
 513         help _msg  = id
 514         program _n = id
 515         rule _n    = id
 516 instance Ord e => CLI_Response (Router (Parser e d))
 517 instance Ord e => CLI_Routing (Router (Parser e d)) where
 518         -- taggeds  = Router_Taggeds
 519         commands = Router_Commands
 520
 521 router ::
 522  repr ~ Parser e d =>
 523  Router repr a b -> Router repr a b
 524 router = {-debug1 "router" $-} \case
 525  x@Router_Any{} -> x
 526  Router_Tagged n x -> Router_Tagged n (router x)
 527  Router_Alt x y -> router x`router_Alt`router y
 528  Router_Commands preCmds cmds ->
 529         Router_Commands
 530          (router <$> preCmds)
 531          (router <$> cmds)
 532  Router_App xy z ->
 533         case xy of
 534          Router_App x y ->
 535                 -- Associate to the right
 536                 Router_App (router x) $
 537                 Router_App (router y) (router z)
 538          _ -> router xy `Router_App` router z
 539  Router_Union u x -> Router_Union u (router x)
 540
 541 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 542 router_Alt ::
 543  repr ~ Parser e d =>
 544  Router repr a k ->
 545  Router repr b k ->
 546  Router repr (a:!:b) k
 547 router_Alt = {-debug2 "router_Alt"-} go
 548         where
 549         -- Merge alternative commands together.
 550         go (Router_Commands xp xs) (Router_Commands yp ys) =
 551                 Router_Commands
 552                  (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
 553                  (router_Commands True xs ys)
 554
 555         -- Merge left first or right first, depending on which removes 'Router_Alt'.
 556         go x (y`Router_Alt`z) =
 557                 case x`router_Alt`y of
 558                  Router_Alt x' y' ->
 559                         case y'`router_Alt`z of
 560                          yz@(Router_Alt _y z') ->
 561                                 case x'`router_Alt`z' of
 562                                  Router_Alt{} -> router x'`Router_Alt`yz
 563                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
 564                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
 565                          yz -> x'`router_Alt`yz
 566                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
 567         go (x`Router_Alt`y) z =
 568                 case y`router_Alt`z of
 569                  Router_Alt y' z' ->
 570                         case x`router_Alt`y' of
 571                          xy@(Router_Alt x' _y) ->
 572                                 case x'`router_Alt`z' of
 573                                  Router_Alt{} -> xy`Router_Alt`router z'
 574                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
 575                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
 576                          xy -> xy`router_Alt`z'
 577                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
 578
 579         -- Merge through 'Router_Union'.
 580         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
 581         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
 582
 583         -- No merging
 584         go x y = x`Router_Alt`y
 585
 586 router_Commands ::
 587  repr ~ Parser e d =>
 588  Bool ->
 589  Map Segment (Router repr a k) ->
 590  Map Segment (Router repr b k) ->
 591  Map Segment (Router repr (a:!:b) k)
 592 router_Commands allowMerging =
 593         -- NOTE: a little bit more complex than required
 594         -- in order to merge 'Router_Union's instead of nesting them,
 595         -- such that 'unTrans' 'Router_Union' applies them all at once.
 596         Map.merge
 597          (Map.mapMissing $ const keepX)
 598          (Map.mapMissing $ const keepY)
 599          (Map.zipWithMaybeMatched $ const $ \x y ->
 600                 if allowMerging then Just $ mergeFull x y else Nothing)
 601         where
 602         keepX = \case
 603          Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
 604          r                -> Router_Union (\(x:!:_y) -> x) r
 605         keepY = \case
 606          Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
 607          r                -> Router_Union (\(_x:!:y) -> y) r
 608         mergeFull = \case
 609          Router_Union xu xr -> \case
 610                  Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
 611                  yr                 -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
 612          xr -> \case
 613                  Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
 614                  yr                 -> xr`router_Alt`yr
 615
 616 -- ** Type 'Arg'
 617 data Arg
 618  =   ArgSegment Segment
 619  |   ArgTagLong Name
 620  |   ArgTagShort Char
 621  |   ArgEnv Name String -- ^ Here only for error reporting.
 622  deriving (Eq,Ord,Show)
 623
 624 lexer :: [String] -> [Arg]
 625 lexer ss =
 626         join $
 627         (`evalState` False) $
 628         sequence (f <$> ss)
 629         where
 630         f :: String -> StateT Bool Identity [Arg]
 631         f s = do
 632                 skip <- get
 633                 if skip then return [ArgSegment s]
 634                 else case s of
 635                  '-':'-':[] -> do
 636                         put True
 637                         return [ArgTagLong ""]
 638                  '-':'-':cs -> return [ArgTagLong cs]
 639                  '-':cs@(_:_) -> return $ ArgTagShort <$> cs
 640                  seg -> return [ArgSegment seg]
 641
 642 showArg :: Arg -> String
 643 showArg = \case
 644  ArgTagShort t -> '-':[t]
 645  ArgTagLong t -> '-':'-':t
 646  ArgSegment seg -> seg
 647  ArgEnv name val -> name<>"="<>val
 648
 649 showArgs :: [Arg] -> String
 650 showArgs args = List.intercalate " " $ showArg <$> args
 651
 652 instance P.Stream [Arg] where
 653         type Token  [Arg] = Arg
 654         type Tokens [Arg] = [Arg]
 655         tokenToChunk  Proxy = pure
 656         tokensToChunk Proxy = id
 657         chunkToTokens Proxy = id
 658         chunkLength   Proxy = List.length
 659         chunkEmpty    Proxy = List.null
 660         take1_ [] = Nothing
 661         take1_ (t:ts) = Just (t, ts)
 662         takeN_ n s
 663           | n <= 0       = Just ([], s)
 664           | List.null s  = Nothing
 665           | otherwise    = Just (List.splitAt n s)
 666         takeWhile_ = List.span
 667         showTokens Proxy = showArgs . toList
 668         -- NOTE: those make no sense when parsing a command line,
 669         -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
 670         reachOffset = error "BUG: reachOffset must not be used on [Arg]"
 671         reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"