src/Symantic/CLI/Parser.hs

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