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