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