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
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)
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(..))
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)
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
54 import Symantic.CLI.API
57 newtype Parser e d f k = Parser
58 { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
62 P.ShowErrorComponent e =>
63 Router (Parser e d) handlers (Response (Router (Parser e d))) ->
66 parser api handlers args = do
68 (unParser $ unTrans $ router api)
71 forM_ (P.bundleErrors err) $ \e -> do
73 "Error parsing the command at argument #" <>
74 show (P.errorOffset e + 1) <> ":\n" <>
75 parseErrorTextPretty e
76 Right app -> unResponseParser $ app handlers
78 -- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
79 parseErrorTextPretty ::
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"
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
94 messageItemsPretty :: String -> [String] -> String
95 messageItemsPretty prefix ts
97 | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"
99 orList :: NonEmpty String -> String
101 orList (x:|[y]) = x <> " or " <> y
102 orList xs = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs
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"
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
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
128 Just perm -> runPermutation perm
131 (Parser $ P.token (const Nothing) Set.empty)
132 -- NOTE: Not 'empty' here so that 'P.TrivialError'
133 -- has the unexpected token.
135 toPermutation (Parser x) =
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 = ()
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
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
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
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
195 lift (fromSegment seg) >>= \case
196 Left err -> P.failure got expType
198 got = Just $ P.Tokens $ pure $ ArgSegment seg
199 expType = Set.singleton $ P.Label $ NonEmpty.fromList $
200 "<"<>name<>"> to be of type "<>ioType @a
202 "Prelude.read: no parse" -> ""
205 Right a -> return ($ a)
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
214 lift (lookupEnv name) >>= \case
215 Nothing -> P.failure got exp
218 exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
220 lift (fromSegment val) >>= \case
221 Right a -> return ($ a)
222 Left err -> P.failure got exp
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
228 "Prelude.read: no parse" -> ""
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
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'
241 program n = Parser . P.label n . unParser
242 rule n = Parser . P.label n . unParser
244 concatCont :: [(a->k)->k] -> ([a]->k)->k
245 concatCont = List.foldr (consCont (:)) ($ [])
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)
250 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
251 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
253 -- ** Type 'ParserResponse'
254 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
255 -- ** Type 'ParserResponseArgs'
256 type ParserResponseArgs = IO
258 -- * Class 'Outputable'
259 -- | Output of a CLI.
260 class IOType a => Outputable a where
262 default output :: Show a => a -> IO ()
265 instance Outputable () where
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
275 instance Outputable Text.Text where
277 instance Outputable TL.Text where
279 instance Outputable BS.ByteString where
281 instance Outputable BSL.ByteString where
283 instance Outputable (Doc.Plain TLB.Builder) where
289 -- ** Type 'OnHandle'
290 data OnHandle a = OnHandle IO.Handle a
291 instance IOType a => IOType (OnHandle a) where
293 instance Outputable (OnHandle ()) where
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) =
322 , Reflection.Typeable a
323 ) => Outputable (Maybe a) where
328 ( Reflection.Typeable e
329 , Reflection.Typeable a
330 , Outputable (OnHandle e)
332 ) => Outputable (Either e a) where
334 Left e -> output $ OnHandle IO.stderr e
338 -- | Like a MIME type but for input/output of a CLI.
341 default ioType :: Reflection.Typeable a => String
342 ioType = show (Reflection.typeRep @a)
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)
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
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)
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)
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)
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'
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)
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)
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)
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
445 exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
448 Map.lookup cmd cmds <|>
449 Map.lookup cmd preCmds
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'.
459 Map Name (Router repr a k) ->
460 Map Name (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
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
482 Router_Any{} -> showString "X"
483 Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
485 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
488 (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
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
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)
506 instance Ord e => App (Router (Parser e d)) where
508 instance Ord e => Alt (Router (Parser e d)) where
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
525 let is = List.tail $ List.inits n in
526 let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
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'.
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
548 Router repr a b -> Router repr a b
549 router = {-debug1 "router" $-} \case
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 ->
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)
566 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
571 Router repr (a:!:b) k
572 router_Alt = {-debug2 "router_Alt"-} go
574 -- Merge alternative commands together.
575 go (Router_Commands xp xs) (Router_Commands yp ys) =
577 (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
578 (router_Commands True xs ys)
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
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
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
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)
609 go x y = x`Router_Alt`y
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.
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)
628 Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
629 r -> Router_Union (\(x:!:_y) -> x) r
631 Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
632 r -> Router_Union (\(_x:!:y) -> y) r
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
638 Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
639 yr -> xr`router_Alt`yr
641 -- ** Type 'RouterParserSeq'
642 newtype RouterParserSeq repr k a = RouterParserSeq
643 { unRouterParserSeq :: repr k a }
644 deriving (Functor, Applicative)
651 | ArgEnv Name String -- ^ Here only for error reporting.
652 deriving (Eq,Ord,Show)
654 lexer :: [String] -> [Arg]
657 (`evalState` False) $
660 f :: String -> StateT Bool Identity [Arg]
663 if skip then return [ArgSegment s]
667 return [ArgTagLong ""]
668 '-':'-':cs -> return [ArgTagLong cs]
669 '-':cs@(_:_) -> return $ ArgTagShort <$> cs
670 seg -> return [ArgSegment seg]
672 showArg :: Arg -> String
674 ArgTagShort t -> '-':[t]
675 ArgTagLong t -> '-':'-':t
676 ArgSegment seg -> seg
677 ArgEnv name val -> name<>"="<>val
679 showArgs :: [Arg] -> String
680 showArgs args = List.intercalate " " $ showArg <$> args
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
691 take1_ (t:ts) = Just (t, ts)
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]"