Symantic/CLI/Parser.hs

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