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         just a  = Parser $ return ($ a)
 211         nothing = Parser $ return id
 212 instance Ord e => CLI_Env (Parser e d) where
 213         type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
 214         env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
 215         env' name = Parser $
 216                 lift (lookupEnv name) >>= \case
 217                  Nothing -> P.failure got exp
 218                         where
 219                         got = Nothing
 220                         exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
 221                  Just val ->
 222                         lift (fromSegment val) >>= \case
 223                          Right a -> return ($ a)
 224                          Left err -> P.failure got exp
 225                                 where
 226                                 got = Just $ P.Tokens $ pure $ ArgEnv name val
 227                                 exp = Set.singleton $ P.Label $ NonEmpty.fromList $
 228                                         "${"<>name<>"} to be of type "<>ioType @a
 229                                         <> case err of
 230                                          "Prelude.read: no parse" -> ""
 231                                          "" -> ""
 232                                          _ -> ": "<>err
 233 instance Ord e => CLI_Response (Parser e d) where
 234         type ResponseConstraint (Parser e d) a = Outputable a
 235         type ResponseArgs (Parser e d) a = ParserResponseArgs a
 236         type Response (Parser e d) = ParserResponse
 237         response' = Parser $
 238                 P.eof $> \({-ParserResponseArgs-} io) ->
 239                         ParserResponse $ io >>= output
 240 instance Ord e => CLI_Help (Parser e d) where
 241         type HelpConstraint (Parser e d) d' = d ~ d'
 242         help _msg = id
 243         program n = Parser . P.label n . unParser
 244         rule n    = Parser . P.label n . unParser
 245
 246 concatCont :: [(a->k)->k] -> ([a]->k)->k
 247 concatCont = List.foldr (consCont (:)) ($ [])
 248
 249 consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
 250 consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
 251
 252 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
 253 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
 254
 255 -- ** Type 'ParserResponse'
 256 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
 257 -- ** Type 'ParserResponseArgs'
 258 type ParserResponseArgs = IO
 259
 260 -- * Class 'Outputable'
 261 -- | Output of a CLI.
 262 class IOType a => Outputable a where
 263         output :: a -> IO ()
 264         default output :: Show a => a -> IO ()
 265         output = IO.print
 266
 267 instance Outputable () where
 268         output = return
 269 instance Outputable Bool
 270 instance Outputable Int
 271 instance Outputable Integer
 272 instance Outputable Natural
 273 instance Outputable Char where
 274         output c = IO.putStr [c]
 275 instance Outputable String where
 276         output = IO.putStr
 277 instance Outputable Text.Text where
 278         output = Text.putStr
 279 instance Outputable TL.Text where
 280         output = TL.putStr
 281 instance Outputable BS.ByteString where
 282         output = BS.putStr
 283 instance Outputable BSL.ByteString where
 284         output = BSL.putStr
 285 instance Outputable (Doc.Plain TLB.Builder) where
 286         output =
 287                 TL.putStr .
 288                 TLB.toLazyText .
 289                 Doc.runPlain
 290
 291 -- ** Type 'OnHandle'
 292 data OnHandle a = OnHandle IO.Handle a
 293 instance IOType a => IOType (OnHandle a) where
 294         ioType = ioType @a
 295 instance Outputable (OnHandle ()) where
 296         output _ = return ()
 297 instance Outputable (OnHandle Bool) where
 298         output (OnHandle h a) = IO.hPrint h a
 299 instance Outputable (OnHandle Int) where
 300         output (OnHandle h a) = IO.hPrint h a
 301 instance Outputable (OnHandle Integer) where
 302         output (OnHandle h a) = IO.hPrint h a
 303 instance Outputable (OnHandle Natural) where
 304         output (OnHandle h a) = IO.hPrint h a
 305 instance Outputable (OnHandle Char) where
 306         output (OnHandle h c) = IO.hPutStr h [c]
 307 instance Outputable (OnHandle String) where
 308         output (OnHandle h a) = IO.hPutStr h a
 309 instance Outputable (OnHandle Text.Text) where
 310         output (OnHandle h a) = Text.hPutStr h a
 311 instance Outputable (OnHandle TL.Text) where
 312         output (OnHandle h a) = TL.hPutStr h a
 313 instance Outputable (OnHandle BS.ByteString) where
 314         output (OnHandle h a) = BS.hPutStr h a
 315 instance Outputable (OnHandle BSL.ByteString) where
 316         output (OnHandle h a) = BSL.hPutStr h a
 317 instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where
 318         output (OnHandle h d) =
 319                 TL.hPutStr h $
 320                 TLB.toLazyText $
 321                 Doc.runPlain d
 322 instance
 323  ( Outputable a
 324  , Reflection.Typeable a
 325  ) => Outputable (Maybe a) where
 326         output = \case
 327          Nothing -> System.exitWith (System.ExitFailure 1)
 328          Just a  -> output a
 329 instance
 330  ( Reflection.Typeable e
 331  , Reflection.Typeable a
 332  , Outputable (OnHandle e)
 333  , Outputable a
 334  ) => Outputable (Either e a) where
 335         output = \case
 336          Left e -> do
 337                 output (OnHandle IO.stderr e)
 338                 System.exitWith (System.ExitFailure 1)
 339          Right a -> output a
 340
 341 -- * Class 'IOType'
 342 -- | Like a MIME type but for input/output of a CLI.
 343 class IOType a where
 344         ioType :: String
 345         default ioType :: Reflection.Typeable a => String
 346         ioType = show (Reflection.typeRep @a)
 347
 348 instance IOType ()
 349 instance IOType Bool
 350 instance IOType Char
 351 instance IOType Int
 352 instance IOType Integer
 353 instance IOType Natural
 354 instance IOType String
 355 instance IOType Text.Text
 356 instance IOType TL.Text
 357 instance IOType BS.ByteString
 358 instance IOType BSL.ByteString
 359 instance IOType (Doc.Plain TLB.Builder)
 360 instance Reflection.Typeable a => IOType (Maybe a)
 361 instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)
 362
 363 -- * Class 'FromSegment'
 364 class FromSegment a where
 365         fromSegment :: Segment -> IO (Either String a)
 366         default fromSegment :: Read a => Segment -> IO (Either String a)
 367         fromSegment = return . readEither
 368 instance FromSegment String where
 369         fromSegment = return . Right
 370 instance FromSegment Text.Text where
 371         fromSegment = return . Right . Text.pack
 372 instance FromSegment TL.Text where
 373         fromSegment = return . Right . TL.pack
 374 instance FromSegment Bool
 375 instance FromSegment Int
 376 instance FromSegment Integer
 377 instance FromSegment Natural
 378
 379 -- ** Type 'ParserSeq'
 380 -- | Lift a 'Parser' to something working with 'Functor' and 'Applicative'.
 381 -- Used to gather collected values into a single one,
 382 -- which is for instance needed for using 'many0' on multiple 'var's.
 383 newtype ParserSeq e d k a = ParserSeq
 384  { unParserSeq :: Parser e d (a->k) k }
 385 instance Functor (ParserSeq e d k) where
 386         a2b `fmap` ParserSeq (Parser x) = ParserSeq $ Parser $ merge <$> x
 387                 where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
 388 instance Applicative (ParserSeq e d k) where
 389         pure a = ParserSeq $ Parser $ pure ($ a)
 390         ParserSeq (Parser f) <*> ParserSeq (Parser x) =
 391                 ParserSeq $ Parser $ merge <$> f <*> x
 392                 where merge a2b2k2k a2k2k b2k =
 393                         a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
 394
 395 -- ** Type 'ParserPerm'
 396 data ParserPerm e d repr k a = ParserPerm
 397  { permutation_result :: !(Maybe ((a->k)->k))
 398  , permutation_parser :: repr () (ParserPerm e d repr k a)
 399  }
 400
 401 instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
 402         a2b `fmap` ParserPerm a ma =
 403                 ParserPerm (merge <$> a) ((a2b `fmap`) `fmap` ma)
 404                 where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
 405 instance (App repr, Functor (repr ()), Alternative (repr ())) =>
 406          Applicative (ParserPerm e d repr k) where
 407         pure a = ParserPerm (Just ($ a)) empty
 408         lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
 409                 ParserPerm a (lhsAlt <|> rhsAlt)
 410                 where
 411                 a = merge <$> f <*> x
 412                 lhsAlt = (<*> rhs) <$> ma2b
 413                 rhsAlt = (lhs <*>) <$> ma
 414                 merge a2b2k2k a2k2k b2k =
 415                         a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
 416 instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
 417         type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
 418         program _n = id
 419         rule _n = id
 420
 421 noTransParserPerm ::
 422  Trans repr =>
 423  Functor (UnTrans repr ()) =>
 424  ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
 425 noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
 426
 427 unTransParserPerm ::
 428  Trans repr =>
 429  Functor (UnTrans repr ()) =>
 430  ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
 431 unTransParserPerm (ParserPerm a ma) =
 432         ParserPerm a (unTransParserPerm <$> unTrans ma)
 433
 434 hoistParserPerm ::
 435  Functor (repr ()) =>
 436  (forall a b. repr a b -> repr a b) ->
 437  ParserPerm e d repr k c -> ParserPerm e d repr k c
 438 hoistParserPerm f (ParserPerm a ma) =
 439         ParserPerm a (hoistParserPerm f <$> f ma)
 440
 441 -- ** Class 'CLI_Routing'
 442 class CLI_Routing repr where
 443         commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k
 444         -- tags  :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
 445 instance Ord e => CLI_Routing (Parser e d) where
 446         commands preCmds cmds = Parser $
 447                 P.token check exp >>= unParser
 448                 where
 449                 exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
 450                 check = \case
 451                  ArgSegment cmd ->
 452                         Map.lookup cmd cmds <|>
 453                         Map.lookup cmd preCmds
 454                  _ -> Nothing
 455
 456 -- * Type 'Router'
 457 data Router repr a b where
 458  -- | Lift any @(repr)@ into 'Router', those not useful to segregate
 459  -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
 460  Router_Any :: repr a b -> Router repr a b
 461  -- | Represent 'commands'.
 462  Router_Commands ::
 463   Map Name (Router repr a k) ->
 464   Map Name (Router repr a k) ->
 465   Router repr a k
 466  -- | Represent 'tag'.
 467  Router_Tag :: Tag -> Router repr f k -> Router repr f k
 468  -- | Represent ('<.>').
 469  Router_App :: Router repr a b -> Router repr b c -> Router repr a c
 470  -- | Represent ('<!>').
 471  Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
 472  -- | Unify 'Router's which have different 'handlers'.
 473  -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
 474  Router_Union :: (b->a) -> Router repr a k -> Router repr b k
 475
 476 instance Ord e => Functor (Router (Parser e d) f) where
 477         a2b`fmap`x = noTrans (a2b <$> unTrans x)
 478 instance Ord e => Applicative (Router (Parser e d) f) where
 479         pure = noTrans . pure
 480         f <*> x = noTrans (unTrans f <*> unTrans x)
 481 instance Ord e => Alternative (Router (Parser e d) f) where
 482         empty = noTrans empty
 483         f <|> x = noTrans (unTrans f <|> unTrans x)
 484 instance (repr ~ Parser e d) => Show (Router repr a b) where
 485         showsPrec p = \case
 486          Router_Any{} -> showString "X"
 487          Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
 488                 where
 489                 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
 490                 go [] = id
 491                 go ((n, r):xs) =
 492                         (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
 493                         case xs of
 494                          [] -> id
 495                          _ -> showString ", " . go xs
 496          Router_Tag n x -> showsPrec 10 n . showString " " . showsPrec p x
 497          Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
 498          Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
 499          Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
 500 instance Ord e => Trans (Router (Parser e d)) where
 501         type UnTrans (Router (Parser e d)) = Parser e d
 502         noTrans = Router_Any
 503         unTrans (Router_Any x) = x
 504         unTrans (Router_Alt x y) = unTrans x <!> unTrans y
 505         unTrans (Router_App x y) = unTrans x <.> unTrans y
 506         unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
 507         unTrans (Router_Tag n x) = tag n (unTrans x)
 508         unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
 509
 510 instance Ord e => App (Router (Parser e d)) where
 511         (<.>) = Router_App
 512 instance Ord e => Alt (Router (Parser e d)) where
 513         (<!>) = Router_Alt
 514         alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
 515 instance Ord e => AltApp (Router (Parser e d))
 516 instance Ord e => Sequenceable (Router (Parser e d)) where
 517         type Sequence (Router (Parser e d)) = RouterParserSeq (ParserSeq e d)
 518         runSequence = noTrans . runSequence . unRouterParserSeq
 519         toSequence  = RouterParserSeq . toSequence . unTrans
 520 instance Ord e => Permutable (Router (Parser e d)) where
 521         type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
 522         runPermutation  = noTrans . runPermutation . unTransParserPerm
 523         toPermutation   = noTransParserPerm . toPermutation . unTrans
 524         toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
 525 instance Ord e => Pro (Router (Parser e d))
 526 instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
 527         command "" x = x
 528         command n x =
 529                 let is = List.tail $ List.inits n in
 530                 let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
 531                 Router_Commands
 532                  (Map.fromAscList $ (,x) <$> preCmds)
 533                  (Map.fromAscList $ (,x) <$> cmds)
 534 instance Ord e => CLI_Var (Router (Parser e d))
 535 instance Ord e => CLI_Env (Router (Parser e d))
 536 instance Ord e => CLI_Tag (Router (Parser e d)) where
 537         tag = Router_Tag
 538 instance CLI_Help (Router (Parser e d)) where
 539         -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
 540         -- to remove them all, since they are useless for 'Parser'
 541         -- and may prevent patterns to be matched in 'router'.
 542         help _msg  = id
 543         program _n = id
 544         rule _n    = id
 545 instance Ord e => CLI_Response (Router (Parser e d))
 546 instance Ord e => CLI_Routing (Router (Parser e d)) where
 547         -- tags  = Router_Tags
 548         commands = Router_Commands
 549
 550 router ::
 551  repr ~ Parser e d =>
 552  Router repr a b -> Router repr a b
 553 router = {-debug1 "router" $-} \case
 554  x@Router_Any{} -> x
 555  Router_Tag n x -> Router_Tag n (router x)
 556  Router_Alt x y -> router x`router_Alt`router y
 557  Router_Commands preCmds cmds ->
 558         Router_Commands
 559          (router <$> preCmds)
 560          (router <$> cmds)
 561  Router_App xy z ->
 562         case xy of
 563          Router_App x y ->
 564                 -- Associate to the right
 565                 Router_App (router x) $
 566                 Router_App (router y) (router z)
 567          _ -> router xy `Router_App` router z
 568  Router_Union u x -> Router_Union u (router x)
 569
 570 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
 571 router_Alt ::
 572  repr ~ Parser e d =>
 573  Router repr a k ->
 574  Router repr b k ->
 575  Router repr (a:!:b) k
 576 router_Alt = {-debug2 "router_Alt"-} go
 577         where
 578         -- Merge alternative commands together.
 579         go (Router_Commands xp xs) (Router_Commands yp ys) =
 580                 Router_Commands
 581                  (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
 582                  (router_Commands True xs ys)
 583
 584         -- Merge left first or right first, depending on which removes 'Router_Alt'.
 585         go x (y`Router_Alt`z) =
 586                 case x`router_Alt`y of
 587                  Router_Alt x' y' ->
 588                         case y'`router_Alt`z of
 589                          yz@(Router_Alt _y z') ->
 590                                 case x'`router_Alt`z' of
 591                                  Router_Alt{} -> router x'`Router_Alt`yz
 592                                  xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
 593                                         -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
 594                          yz -> x'`router_Alt`yz
 595                  xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
 596         go (x`Router_Alt`y) z =
 597                 case y`router_Alt`z of
 598                  Router_Alt y' z' ->
 599                         case x`router_Alt`y' of
 600                          xy@(Router_Alt x' _y) ->
 601                                 case x'`router_Alt`z' of
 602                                  Router_Alt{} -> xy`Router_Alt`router z'
 603                                  xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
 604                                         -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
 605                          xy -> xy`router_Alt`z'
 606                  yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
 607
 608         -- Merge through 'Router_Union'.
 609         go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
 610         go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
 611
 612         -- No merging
 613         go x y = x`Router_Alt`y
 614
 615 router_Commands ::
 616  repr ~ Parser e d =>
 617  Bool ->
 618  Map Segment (Router repr a k) ->
 619  Map Segment (Router repr b k) ->
 620  Map Segment (Router repr (a:!:b) k)
 621 router_Commands allowMerging =
 622         -- NOTE: a little bit more complex than required
 623         -- in order to merge 'Router_Union's instead of nesting them,
 624         -- such that 'unTrans' 'Router_Union' applies them all at once.
 625         Map.merge
 626          (Map.mapMissing $ const keepX)
 627          (Map.mapMissing $ const keepY)
 628          (Map.zipWithMaybeMatched $ const $ \x y ->
 629                 if allowMerging then Just $ mergeFull x y else Nothing)
 630         where
 631         keepX = \case
 632          Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
 633          r                -> Router_Union (\(x:!:_y) -> x) r
 634         keepY = \case
 635          Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
 636          r                -> Router_Union (\(_x:!:y) -> y) r
 637         mergeFull = \case
 638          Router_Union xu xr -> \case
 639                  Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
 640                  yr                 -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
 641          xr -> \case
 642                  Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
 643                  yr                 -> xr`router_Alt`yr
 644
 645 -- ** Type 'RouterParserSeq'
 646 newtype RouterParserSeq repr k a = RouterParserSeq
 647  { unRouterParserSeq :: repr k a }
 648  deriving (Functor, Applicative)
 649
 650 -- * Type 'Arg'
 651 data Arg
 652  =   ArgSegment Segment
 653  |   ArgTagLong Name
 654  |   ArgTagShort Char
 655  |   ArgEnv Name String -- ^ Here only for error reporting.
 656  deriving (Eq,Ord,Show)
 657
 658 lexer :: [String] -> [Arg]
 659 lexer ss =
 660         join $
 661         (`evalState` False) $
 662         sequence (f <$> ss)
 663         where
 664         f :: String -> StateT Bool Identity [Arg]
 665         f s = do
 666                 skip <- get
 667                 if skip then return [ArgSegment s]
 668                 else case s of
 669                  '-':'-':[] -> do
 670                         put True
 671                         return [ArgTagLong ""]
 672                  '-':'-':cs -> return [ArgTagLong cs]
 673                  '-':cs@(_:_) -> return $ ArgTagShort <$> cs
 674                  seg -> return [ArgSegment seg]
 675
 676 showArg :: Arg -> String
 677 showArg = \case
 678  ArgTagShort t -> '-':[t]
 679  ArgTagLong t -> '-':'-':t
 680  ArgSegment seg -> seg
 681  ArgEnv name val -> name<>"="<>val
 682
 683 showArgs :: [Arg] -> String
 684 showArgs args = List.intercalate " " $ showArg <$> args
 685
 686 instance P.Stream [Arg] where
 687         type Token  [Arg] = Arg
 688         type Tokens [Arg] = [Arg]
 689         tokenToChunk  Proxy = pure
 690         tokensToChunk Proxy = id
 691         chunkToTokens Proxy = id
 692         chunkLength   Proxy = List.length
 693         chunkEmpty    Proxy = List.null
 694         take1_ [] = Nothing
 695         take1_ (t:ts) = Just (t, ts)
 696         takeN_ n s
 697           | n <= 0       = Just ([], s)
 698           | List.null s  = Nothing
 699           | otherwise    = Just (List.splitAt n s)
 700         takeWhile_ = List.span
 701         showTokens Proxy = showArgs . toList
 702         -- NOTE: those make no sense when parsing a command line,
 703         -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
 704         reachOffset = error "BUG: reachOffset must not be used on [Arg]"
 705         reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"