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 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
55 import Symantic.CLI.API
58 newtype Parser e d f k = Parser
59 { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
63 P.ShowErrorComponent e =>
64 Router (Parser e d) handlers (Response (Router (Parser e d))) ->
67 parser api handlers args = do
69 (unParser $ unTrans $ router api)
72 forM_ (P.bundleErrors err) $ \e -> do
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
80 -- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
81 parseErrorTextPretty ::
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"
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
96 messageItemsPretty :: String -> [String] -> String
97 messageItemsPretty prefix ts
99 | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"
101 orList :: NonEmpty String -> String
103 orList (x:|[y]) = x <> " or " <> y
104 orList xs = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs
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"
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
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
130 Just perm -> runPermutation perm
133 (Parser $ P.token (const Nothing) Set.empty)
134 -- NOTE: Not 'empty' here so that 'P.TrivialError'
135 -- has the unexpected token.
137 toPermutation (Parser x) =
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 = ()
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
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
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
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
197 lift (fromSegment seg) >>= \case
198 Left err -> P.failure got expType
200 got = Just $ P.Tokens $ pure $ ArgSegment seg
201 expType = Set.singleton $ P.Label $ NonEmpty.fromList $
202 "<"<>name<>"> to be of type "<>ioType @a
204 "Prelude.read: no parse" -> ""
207 Right a -> return ($ a)
209 expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
210 just a = Parser $ return ($ a)
211 nothing = Parser $ return id
212 instance Ord e => CLI_Env (Parser e d) where
213 type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
214 env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
216 lift (lookupEnv name) >>= \case
217 Nothing -> P.failure got exp
220 exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
222 lift (fromSegment val) >>= \case
223 Right a -> return ($ a)
224 Left err -> P.failure got exp
226 got = Just $ P.Tokens $ pure $ ArgEnv name val
227 exp = Set.singleton $ P.Label $ NonEmpty.fromList $
228 "${"<>name<>"} to be of type "<>ioType @a
230 "Prelude.read: no parse" -> ""
233 instance Ord e => CLI_Response (Parser e d) where
234 type ResponseConstraint (Parser e d) a = Outputable a
235 type ResponseArgs (Parser e d) a = ParserResponseArgs a
236 type Response (Parser e d) = ParserResponse
238 P.eof $> \({-ParserResponseArgs-} io) ->
239 ParserResponse $ io >>= output
240 instance Ord e => CLI_Help (Parser e d) where
241 type HelpConstraint (Parser e d) d' = d ~ d'
243 program n = Parser . P.label n . unParser
244 rule n = Parser . P.label n . unParser
246 concatCont :: [(a->k)->k] -> ([a]->k)->k
247 concatCont = List.foldr (consCont (:)) ($ [])
249 consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
250 consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
252 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
253 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
255 -- ** Type 'ParserResponse'
256 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
257 -- ** Type 'ParserResponseArgs'
258 type ParserResponseArgs = IO
260 -- * Class 'Outputable'
261 -- | Output of a CLI.
262 class IOType a => Outputable a where
264 default output :: Show a => a -> IO ()
267 instance Outputable () where
269 instance Outputable Bool
270 instance Outputable Int
271 instance Outputable Integer
272 instance Outputable Natural
273 instance Outputable Char where
274 output c = IO.putStr [c]
275 instance Outputable String where
277 instance Outputable Text.Text where
279 instance Outputable TL.Text where
281 instance Outputable BS.ByteString where
283 instance Outputable BSL.ByteString where
285 instance Outputable (Doc.Plain TLB.Builder) where
291 -- ** Type 'OnHandle'
292 data OnHandle a = OnHandle IO.Handle a
293 instance IOType a => IOType (OnHandle a) where
295 instance Outputable (OnHandle ()) where
297 instance Outputable (OnHandle Bool) where
298 output (OnHandle h a) = IO.hPrint h a
299 instance Outputable (OnHandle Int) where
300 output (OnHandle h a) = IO.hPrint h a
301 instance Outputable (OnHandle Integer) where
302 output (OnHandle h a) = IO.hPrint h a
303 instance Outputable (OnHandle Natural) where
304 output (OnHandle h a) = IO.hPrint h a
305 instance Outputable (OnHandle Char) where
306 output (OnHandle h c) = IO.hPutStr h [c]
307 instance Outputable (OnHandle String) where
308 output (OnHandle h a) = IO.hPutStr h a
309 instance Outputable (OnHandle Text.Text) where
310 output (OnHandle h a) = Text.hPutStr h a
311 instance Outputable (OnHandle TL.Text) where
312 output (OnHandle h a) = TL.hPutStr h a
313 instance Outputable (OnHandle BS.ByteString) where
314 output (OnHandle h a) = BS.hPutStr h a
315 instance Outputable (OnHandle BSL.ByteString) where
316 output (OnHandle h a) = BSL.hPutStr h a
317 instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where
318 output (OnHandle h d) =
324 , Reflection.Typeable a
325 ) => Outputable (Maybe a) where
327 Nothing -> System.exitWith (System.ExitFailure 1)
330 ( Reflection.Typeable e
331 , Reflection.Typeable a
332 , Outputable (OnHandle e)
334 ) => Outputable (Either e a) where
337 output (OnHandle IO.stderr e)
338 System.exitWith (System.ExitFailure 1)
342 -- | Like a MIME type but for input/output of a CLI.
345 default ioType :: Reflection.Typeable a => String
346 ioType = show (Reflection.typeRep @a)
352 instance IOType Integer
353 instance IOType Natural
354 instance IOType String
355 instance IOType Text.Text
356 instance IOType TL.Text
357 instance IOType BS.ByteString
358 instance IOType BSL.ByteString
359 instance IOType (Doc.Plain TLB.Builder)
360 instance Reflection.Typeable a => IOType (Maybe a)
361 instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)
363 -- * Class 'FromSegment'
364 class FromSegment a where
365 fromSegment :: Segment -> IO (Either String a)
366 default fromSegment :: Read a => Segment -> IO (Either String a)
367 fromSegment = return . readEither
368 instance FromSegment String where
369 fromSegment = return . Right
370 instance FromSegment Text.Text where
371 fromSegment = return . Right . Text.pack
372 instance FromSegment TL.Text where
373 fromSegment = return . Right . TL.pack
374 instance FromSegment Bool
375 instance FromSegment Int
376 instance FromSegment Integer
377 instance FromSegment Natural
379 -- ** Type 'ParserSeq'
380 -- | Lift a 'Parser' to something working with 'Functor' and 'Applicative'.
381 -- Used to gather collected values into a single one,
382 -- which is for instance needed for using 'many0' on multiple 'var's.
383 newtype ParserSeq e d k a = ParserSeq
384 { unParserSeq :: Parser e d (a->k) k }
385 instance Functor (ParserSeq e d k) where
386 a2b `fmap` ParserSeq (Parser x) = ParserSeq $ Parser $ merge <$> x
387 where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
388 instance Applicative (ParserSeq e d k) where
389 pure a = ParserSeq $ Parser $ pure ($ a)
390 ParserSeq (Parser f) <*> ParserSeq (Parser x) =
391 ParserSeq $ Parser $ merge <$> f <*> x
392 where merge a2b2k2k a2k2k b2k =
393 a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
395 -- ** Type 'ParserPerm'
396 data ParserPerm e d repr k a = ParserPerm
397 { permutation_result :: !(Maybe ((a->k)->k))
398 , permutation_parser :: repr () (ParserPerm e d repr k a)
401 instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
402 a2b `fmap` ParserPerm a ma =
403 ParserPerm (merge <$> a) ((a2b `fmap`) `fmap` ma)
404 where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
405 instance (App repr, Functor (repr ()), Alternative (repr ())) =>
406 Applicative (ParserPerm e d repr k) where
407 pure a = ParserPerm (Just ($ a)) empty
408 lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
409 ParserPerm a (lhsAlt <|> rhsAlt)
411 a = merge <$> f <*> x
412 lhsAlt = (<*> rhs) <$> ma2b
413 rhsAlt = (lhs <*>) <$> ma
414 merge a2b2k2k a2k2k b2k =
415 a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
416 instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
417 type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
423 Functor (UnTrans repr ()) =>
424 ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
425 noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
429 Functor (UnTrans repr ()) =>
430 ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
431 unTransParserPerm (ParserPerm a ma) =
432 ParserPerm a (unTransParserPerm <$> unTrans ma)
436 (forall a b. repr a b -> repr a b) ->
437 ParserPerm e d repr k c -> ParserPerm e d repr k c
438 hoistParserPerm f (ParserPerm a ma) =
439 ParserPerm a (hoistParserPerm f <$> f ma)
441 -- ** Class 'CLI_Routing'
442 class CLI_Routing repr where
443 commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k
444 -- tags :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
445 instance Ord e => CLI_Routing (Parser e d) where
446 commands preCmds cmds = Parser $
447 P.token check exp >>= unParser
449 exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
452 Map.lookup cmd cmds <|>
453 Map.lookup cmd preCmds
457 data Router repr a b where
458 -- | Lift any @(repr)@ into 'Router', those not useful to segregate
459 -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
460 Router_Any :: repr a b -> Router repr a b
461 -- | Represent 'commands'.
463 Map Name (Router repr a k) ->
464 Map Name (Router repr a k) ->
466 -- | Represent 'tag'.
467 Router_Tag :: Tag -> Router repr f k -> Router repr f k
468 -- | Represent ('<.>').
469 Router_App :: Router repr a b -> Router repr b c -> Router repr a c
470 -- | Represent ('<!>').
471 Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
472 -- | Unify 'Router's which have different 'handlers'.
473 -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
474 Router_Union :: (b->a) -> Router repr a k -> Router repr b k
476 instance Ord e => Functor (Router (Parser e d) f) where
477 a2b`fmap`x = noTrans (a2b <$> unTrans x)
478 instance Ord e => Applicative (Router (Parser e d) f) where
479 pure = noTrans . pure
480 f <*> x = noTrans (unTrans f <*> unTrans x)
481 instance Ord e => Alternative (Router (Parser e d) f) where
482 empty = noTrans empty
483 f <|> x = noTrans (unTrans f <|> unTrans x)
484 instance (repr ~ Parser e d) => Show (Router repr a b) where
486 Router_Any{} -> showString "X"
487 Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
489 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
492 (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
495 _ -> showString ", " . go xs
496 Router_Tag n x -> showsPrec 10 n . showString " " . showsPrec p x
497 Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
498 Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
499 Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
500 instance Ord e => Trans (Router (Parser e d)) where
501 type UnTrans (Router (Parser e d)) = Parser e d
503 unTrans (Router_Any x) = x
504 unTrans (Router_Alt x y) = unTrans x <!> unTrans y
505 unTrans (Router_App x y) = unTrans x <.> unTrans y
506 unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
507 unTrans (Router_Tag n x) = tag n (unTrans x)
508 unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
510 instance Ord e => App (Router (Parser e d)) where
512 instance Ord e => Alt (Router (Parser e d)) where
514 alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
515 instance Ord e => AltApp (Router (Parser e d))
516 instance Ord e => Sequenceable (Router (Parser e d)) where
517 type Sequence (Router (Parser e d)) = RouterParserSeq (ParserSeq e d)
518 runSequence = noTrans . runSequence . unRouterParserSeq
519 toSequence = RouterParserSeq . toSequence . unTrans
520 instance Ord e => Permutable (Router (Parser e d)) where
521 type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
522 runPermutation = noTrans . runPermutation . unTransParserPerm
523 toPermutation = noTransParserPerm . toPermutation . unTrans
524 toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
525 instance Ord e => Pro (Router (Parser e d))
526 instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
529 let is = List.tail $ List.inits n in
530 let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
532 (Map.fromAscList $ (,x) <$> preCmds)
533 (Map.fromAscList $ (,x) <$> cmds)
534 instance Ord e => CLI_Var (Router (Parser e d))
535 instance Ord e => CLI_Env (Router (Parser e d))
536 instance Ord e => CLI_Tag (Router (Parser e d)) where
538 instance CLI_Help (Router (Parser e d)) where
539 -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
540 -- to remove them all, since they are useless for 'Parser'
541 -- and may prevent patterns to be matched in 'router'.
545 instance Ord e => CLI_Response (Router (Parser e d))
546 instance Ord e => CLI_Routing (Router (Parser e d)) where
547 -- tags = Router_Tags
548 commands = Router_Commands
552 Router repr a b -> Router repr a b
553 router = {-debug1 "router" $-} \case
555 Router_Tag n x -> Router_Tag n (router x)
556 Router_Alt x y -> router x`router_Alt`router y
557 Router_Commands preCmds cmds ->
564 -- Associate to the right
565 Router_App (router x) $
566 Router_App (router y) (router z)
567 _ -> router xy `Router_App` router z
568 Router_Union u x -> Router_Union u (router x)
570 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
575 Router repr (a:!:b) k
576 router_Alt = {-debug2 "router_Alt"-} go
578 -- Merge alternative commands together.
579 go (Router_Commands xp xs) (Router_Commands yp ys) =
581 (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
582 (router_Commands True xs ys)
584 -- Merge left first or right first, depending on which removes 'Router_Alt'.
585 go x (y`Router_Alt`z) =
586 case x`router_Alt`y of
588 case y'`router_Alt`z of
589 yz@(Router_Alt _y z') ->
590 case x'`router_Alt`z' of
591 Router_Alt{} -> router x'`Router_Alt`yz
592 xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
593 -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
594 yz -> x'`router_Alt`yz
595 xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
596 go (x`Router_Alt`y) z =
597 case y`router_Alt`z of
599 case x`router_Alt`y' of
600 xy@(Router_Alt x' _y) ->
601 case x'`router_Alt`z' of
602 Router_Alt{} -> xy`Router_Alt`router z'
603 xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
604 -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
605 xy -> xy`router_Alt`z'
606 yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
608 -- Merge through 'Router_Union'.
609 go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
610 go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
613 go x y = x`Router_Alt`y
618 Map Segment (Router repr a k) ->
619 Map Segment (Router repr b k) ->
620 Map Segment (Router repr (a:!:b) k)
621 router_Commands allowMerging =
622 -- NOTE: a little bit more complex than required
623 -- in order to merge 'Router_Union's instead of nesting them,
624 -- such that 'unTrans' 'Router_Union' applies them all at once.
626 (Map.mapMissing $ const keepX)
627 (Map.mapMissing $ const keepY)
628 (Map.zipWithMaybeMatched $ const $ \x y ->
629 if allowMerging then Just $ mergeFull x y else Nothing)
632 Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
633 r -> Router_Union (\(x:!:_y) -> x) r
635 Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
636 r -> Router_Union (\(_x:!:y) -> y) r
638 Router_Union xu xr -> \case
639 Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
640 yr -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
642 Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
643 yr -> xr`router_Alt`yr
645 -- ** Type 'RouterParserSeq'
646 newtype RouterParserSeq repr k a = RouterParserSeq
647 { unRouterParserSeq :: repr k a }
648 deriving (Functor, Applicative)
655 | ArgEnv Name String -- ^ Here only for error reporting.
656 deriving (Eq,Ord,Show)
658 lexer :: [String] -> [Arg]
661 (`evalState` False) $
664 f :: String -> StateT Bool Identity [Arg]
667 if skip then return [ArgSegment s]
671 return [ArgTagLong ""]
672 '-':'-':cs -> return [ArgTagLong cs]
673 '-':cs@(_:_) -> return $ ArgTagShort <$> cs
674 seg -> return [ArgSegment seg]
676 showArg :: Arg -> String
678 ArgTagShort t -> '-':[t]
679 ArgTagLong t -> '-':'-':t
680 ArgSegment seg -> seg
681 ArgEnv name val -> name<>"="<>val
683 showArgs :: [Arg] -> String
684 showArgs args = List.intercalate " " $ showArg <$> args
686 instance P.Stream [Arg] where
687 type Token [Arg] = Arg
688 type Tokens [Arg] = [Arg]
689 tokenToChunk Proxy = pure
690 tokensToChunk Proxy = id
691 chunkToTokens Proxy = id
692 chunkLength Proxy = List.length
693 chunkEmpty Proxy = List.null
695 take1_ (t:ts) = Just (t, ts)
697 | n <= 0 = Just ([], s)
698 | List.null s = Nothing
699 | otherwise = Just (List.splitAt n s)
700 takeWhile_ = List.span
701 showTokens Proxy = showArgs . toList
702 -- NOTE: those make no sense when parsing a command line,
703 -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
704 reachOffset = error "BUG: reachOffset must not be used on [Arg]"
705 reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"