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