]> Git — Sourcephile - haskell/symantic-cli.git/blob - Symantic/CLI/Parser.hs
cabal: use latest symantic-document
[haskell/symantic-cli.git] / Symantic / CLI / Parser.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE DefaultSignatures #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 {-# LANGUAGE InstanceSigs #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE Rank2Types #-}
9 module Symantic.CLI.Parser where
10
11 import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
12 import Control.Arrow (first)
13 import Control.Monad (Monad(..), join, sequence, unless)
14 import Control.Monad.Trans.Class (MonadTrans(..))
15 import Control.Monad.Trans.Except (ExceptT(..),throwE,runExceptT)
16 import Control.Monad.Trans.State (StateT(..),evalState,get,put)
17 import Data.Bool
18 import Data.Char (Char)
19 import Data.Either (Either(..))
20 import Data.Eq (Eq(..))
21 import Data.Function (($), (.), id, const)
22 import Data.Functor (Functor(..), (<$>))
23 import Data.Functor.Identity (Identity(..))
24 import Data.Int (Int)
25 import Data.Map.Strict (Map)
26 import Data.Maybe (Maybe(..), maybe)
27 import Data.Monoid (Monoid(..))
28 import Data.Ord (Ord(..))
29 import Data.Semigroup (Semigroup(..))
30 import Data.String (String)
31 import System.Environment (lookupEnv)
32 import System.IO (IO)
33 import Text.Read (readEither)
34 import Text.Show (Show(..), ShowS, showString, showParen)
35 import Type.Reflection as Reflection
36 import qualified Data.List as List
37 import qualified Data.Text.Lazy.IO as TL
38 import qualified Data.Text.Lazy.Builder as TLB
39 import qualified Data.Map.Merge.Strict as Map
40 import qualified Data.Map.Strict as Map
41 import qualified Symantic.Document as Doc
42 import qualified System.IO as IO
43 -- import qualified Debug.Trace as Debug
44
45 import Symantic.CLI.API
46
47 -- * Type 'Parser'
48 newtype Parser d f k = Parser
49 { unParser :: StateT ParserState
50 (ParserCheckT [ParserError] IO)
51 (f -> k) -- Reader f k
52 }
53 instance Functor (Parser d f) where
54 a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x
55 instance Applicative (Parser d f) where
56 pure = Parser . pure . const
57 Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
58 instance Alternative (Parser d f) where
59 empty = Parser $ do
60 StateT $ \st ->
61 throwE $ Fail st [ParserError_Alt]
62 Parser x <|> Parser y = Parser $
63 StateT $ \st -> do
64 lift (runExceptT (runStateT x st)) >>= \case
65 Left xe | FailFatal{} <- xe -> throwE xe
66 | otherwise ->
67 lift (runExceptT (runStateT y st)) >>= \case
68 Left ye -> throwE (xe<>ye)
69 Right yr -> ExceptT $ return $ Right yr
70 Right xr ->
71 return xr
72 instance Permutable (Parser d) where
73 type Permutation (Parser d) = ParserPerm d (Parser d)
74 runPermutation (ParserPerm ma p) = Parser $ do
75 u2p <- unParser $ optional p
76 unParser $
77 case u2p () of
78 Nothing -> maybe empty (Parser . return) ma
79 Just perm -> runPermutation perm
80 toPermutation (Parser x) =
81 ParserPerm Nothing
82 (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x)
83 toPermDefault a (Parser x) =
84 ParserPerm (Just ($ a))
85 (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)
86
87 parser ::
88 -- d ~ String => -- dummy d
89 Router (Parser d) handlers (Response (Router (Parser d))) ->
90 handlers ->
91 [Arg] -> IO ()
92 parser api handlers args = do
93 lrApp <-
94 runExceptT $ runStateT
95 (unParser $ unTrans $ router api)
96 ParserState
97 { parserState_args = args
98 }
99 case lrApp of
100 Left err -> IO.print err
101 Right (app, _st) -> unResponseParser $ app handlers
102
103 -- | Helper to parse the current argument.
104 popArg ::
105 ParserError ->
106 (Arg ->
107 StateT ParserState (ParserCheckT [ParserError] IO) a) ->
108 StateT ParserState (ParserCheckT [ParserError] IO) a
109 popArg errEnd f = do
110 st <- get
111 case parserState_args st of
112 [] -> lift $ throwE $ Fail st [errEnd]
113 curr:next -> do
114 lift (lift (runExceptT (runStateT (f curr) (ParserState next)))) >>= \case
115 Left err -> lift $ throwE err
116 Right (a,st') -> do
117 put st'
118 return a
119
120 -- ** Type 'Arg'
121 data Arg
122 = ArgTagShort Char
123 | ArgTagLong Name
124 | ArgSegment Segment
125 deriving (Eq,Show)
126
127 parseArgs :: [String] -> [Arg]
128 parseArgs ss =
129 join $
130 (`evalState` False) $
131 sequence (f <$> ss)
132 where
133 f :: String -> StateT Bool Identity [Arg]
134 f s = do
135 skip <- get
136 if skip then return [ArgSegment s]
137 else case s of
138 '-':'-':[] -> do
139 put True
140 return [ArgTagLong ""]
141 '-':'-':cs -> return [ArgTagLong cs]
142 '-':cs@(_:_) -> return $ ArgTagShort <$> cs
143 seg -> return [ArgSegment seg]
144
145 -- ** Type 'ParserState'
146 newtype ParserState = ParserState
147 { parserState_args :: [Arg]
148 } deriving (Show)
149
150 -- ** Type 'Router'
151 type ParserCheckT e = ExceptT (Fail e)
152
153 -- ** Type 'ParserError'
154 data ParserError
155 = ParserError_Alt -- ^ When there is no alternative.
156 | ParserError_Arg { expectedArg :: Name, gotArg :: Maybe Arg }
157 | ParserError_Env { expectedEnv :: Name, gotEnv :: Maybe String }
158 | ParserError_Tag { expectedTag :: Tag, gotArg :: Maybe Arg }
159 | ParserError_Cmd { expectedCmd :: [Name], gotCmd :: Maybe Arg }
160 | ParserError_Var { expectedVar :: Name, gotVar :: Maybe Arg }
161 | ParserError_End { gotEnd :: Arg }
162 deriving (Eq,Show)
163
164 -- *** Type 'RouteResult'
165 type RouteResult e = Either (Fail e)
166
167 -- *** Type 'Fail'
168 data Fail e
169 = Fail ParserState e -- ^ Keep trying other paths.
170 | FailFatal !ParserState !e -- ^ Don't try other paths.
171 deriving (Show)
172 failState :: Fail e -> ParserState
173 failState (Fail st _) = st
174 failState (FailFatal st _) = st
175 failError :: Fail e -> e
176 failError (Fail _st e) = e
177 failError (FailFatal _st e) = e
178 instance Semigroup e => Semigroup (Fail e) where
179 Fail _ x <> Fail st y = Fail st (x<>y)
180 FailFatal _ x <> Fail st _y = FailFatal st (x{-<>y-})
181 Fail _ _x <> FailFatal st y = FailFatal st ({-x<>-}y)
182 FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
183 instance Monoid e => Monoid (Fail e) where
184 mempty = Fail (ParserState []) mempty
185 mappend = (<>)
186
187 -- * Class 'FromSegment'
188 class FromSegment a where
189 fromSegment :: Segment -> Either String a
190 instance FromSegment String where
191 fromSegment = Right
192 instance FromSegment Int where
193 fromSegment = readEither
194 instance FromSegment Bool where
195 fromSegment = readEither
196
197 -- ** Type 'ParserPerm'
198 data ParserPerm d repr k a = ParserPerm
199 { permutation_result :: !(Maybe ((a->k)->k))
200 , permutation_parser :: repr () (ParserPerm d repr k a)
201 }
202
203 instance (App repr, Functor (repr ())) => Functor (ParserPerm d repr k) where
204 a2b `fmap` ParserPerm a ma = ParserPerm
205 ((\a2k2k b2k -> a2k2k $ b2k . a2b) <$> a)
206 ((a2b `fmap`) `fmap` ma)
207 instance (App repr, Functor (repr ()), Alternative (repr ())) => Applicative (ParserPerm d repr k) where
208 pure a = ParserPerm (Just ($ a)) empty
209 lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
210 ParserPerm a (lhsAlt <|> rhsAlt)
211 where
212 a =
213 (\a2b2k2k a2k2k -> \b2k ->
214 a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
215 ) <$> f <*> x
216 lhsAlt = (<*> rhs) <$> ma2b
217 rhsAlt = (lhs <*>) <$> ma
218 instance CLI_Help repr => CLI_Help (ParserPerm d repr) where
219 type HelpConstraint (ParserPerm d repr) d' = HelpConstraint (Parser d) d'
220 program _n = id
221 rule _n = id
222
223 noTransParserPerm ::
224 Trans repr =>
225 Functor (UnTrans repr ()) =>
226 ParserPerm d (UnTrans repr) k a -> ParserPerm d repr k a
227 noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
228
229 unTransParserPerm ::
230 Trans repr =>
231 Functor (UnTrans repr ()) =>
232 ParserPerm d repr k a -> ParserPerm d (UnTrans repr) k a
233 unTransParserPerm (ParserPerm a ma) = ParserPerm a (unTransParserPerm <$> unTrans ma)
234
235 hoistParserPerm ::
236 Functor (repr ()) =>
237 (forall a b. repr a b -> repr a b) ->
238 ParserPerm d repr k c -> ParserPerm d repr k c
239 hoistParserPerm f (ParserPerm a ma) =
240 ParserPerm a (hoistParserPerm f <$> f ma)
241
242 instance App (Parser d) where
243 Parser x <.> Parser y = Parser $
244 x >>= \a2b -> (. a2b) <$> y
245 instance Alt (Parser d) where
246 Parser x <!> Parser y = Parser $
247 StateT $ \st -> do
248 lift (runExceptT (runStateT x st)) >>= \case
249 Left xe | FailFatal{} <- xe -> throwE xe
250 | otherwise ->
251 lift (runExceptT (runStateT y st)) >>= \case
252 Left ye -> throwE (xe<>ye)
253 Right yr -> ExceptT $ return $ Right $
254 first (\b2k (_a:!:b) -> b2k b) yr
255 Right xr ->
256 return $ first (\a2k (a:!:_b) -> a2k a) xr
257 opt (Parser x) = Parser $ do
258 st <- get
259 lift (lift (runExceptT $ runStateT x st)) >>= \case
260 Left err -> return ($ Nothing)
261 Right (a,st') -> do
262 put st'
263 return (mapCont Just a)
264 instance AltApp (Parser d) where
265 many0 (Parser x) = Parser $ concatCont <$> many x
266 many1 (Parser x) = Parser $ concatCont <$> some x
267 instance Pro (Parser d) where
268 dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
269 instance CLI_Command (Parser d) where
270 -- type CommandConstraint (Parser d) a = ()
271 command "" x = x
272 command n x = commands $ Map.singleton n x
273 instance CLI_Var (Parser d) where
274 type VarConstraint (Parser d) a = FromSegment a
275 var' :: forall a k. VarConstraint (Parser d) a => Name -> Parser d (a->k) k
276 var' name = Parser $ do
277 popArg (ParserError_Var name Nothing) $ \curr -> do
278 st@ParserState{..} <- get
279 case curr of
280 ArgSegment seg ->
281 case fromSegment seg of
282 Left err -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]
283 Right a -> return ($ a)
284 _ -> lift $ throwE $ Fail st [ParserError_Var name (Just curr)]
285 just a = Parser $ return ($ a)
286 nothing = Parser $ return id
287 instance CLI_Env (Parser d) where
288 type EnvConstraint (Parser d) a = FromSegment a
289 env' :: forall a k. EnvConstraint (Parser d) a => Name -> Parser d (a->k) k
290 env' name = Parser $ do
291 st <- get
292 lift (lift (lookupEnv name)) >>= \case
293 Nothing -> lift $ throwE $ Fail st [ParserError_Env name Nothing]
294 Just raw ->
295 case fromSegment raw of
296 Left err -> lift $ throwE $ Fail st [ParserError_Env name (Just raw)]
297 Right a -> return ($ a)
298
299 concatCont :: [(a->k)->k] -> ([a]->k)->k
300 concatCont = List.foldr (consCont (:)) ($ [])
301
302 consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
303 consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
304
305 mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
306 mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
307
308 instance CLI_Tag (Parser d) where
309 type TagConstraint (Parser d) a = ()
310 tagged name p = Parser $ do
311 popArg (ParserError_Tag name Nothing) $ \curr -> do
312 st <- get
313 case lookupTag curr name of
314 False -> lift $ throwE $ Fail st [ParserError_Tag name (Just curr)]
315 True ->
316 lift (lift (runExceptT (runStateT (unParser p) st))) >>= \case
317 Left (Fail st' e) -> lift $ throwE $ FailFatal st' e
318 Left e -> lift $ throwE e
319 Right (a,st') -> do
320 put st'
321 return a
322 where
323 lookupTag (ArgTagShort x) (TagShort y) = x == y
324 lookupTag (ArgTagShort x) (Tag y _) = x == y
325 lookupTag (ArgTagLong x) (TagLong y) = x == y
326 lookupTag (ArgTagLong x) (Tag _ y) = x == y
327 lookupTag _ _ = False
328 endOpts = Parser $ do
329 popArg (ParserError_Tag (TagLong "") Nothing) $ \curr -> do
330 st@ParserState{..} <- get
331 case curr of
332 ArgTagLong "" -> return id
333 _ -> return id -- TODO: raise an error and use option?
334
335 -- ** Type 'ParserResponse'
336 newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
337 -- ** Type 'ParserResponseArgs'
338 newtype ParserResponseArgs a = ParserResponseArgs (IO a)
339 deriving (Functor,Applicative,Monad)
340
341 instance CLI_Response (Parser d) where
342 type ResponseConstraint (Parser d) a = Outputable a
343 type ResponseArgs (Parser d) a = ParserResponseArgs a
344 type Response (Parser d) = ParserResponse
345 response' = Parser $ do
346 st <- get
347 unless (List.null $ parserState_args st) $ do
348 lift $ throwE $ Fail st [ParserError_End $
349 List.head $ parserState_args st]
350 return $ \(ParserResponseArgs io) ->
351 ParserResponse $ io >>= output
352
353 -- * Class 'Outputable'
354 -- | Output of a CLI.
355 class IOType a => Outputable a where
356 output :: a -> IO ()
357 default output :: Show a => a -> IO ()
358 output = IO.print
359 instance Outputable String where
360 output = IO.putStrLn
361
362 instance Outputable (Doc.AnsiText (Doc.Plain TLB.Builder)) where
363 output =
364 TL.putStr .
365 TLB.toLazyText .
366 Doc.runPlain .
367 Doc.runAnsiText
368
369 {-
370 instance Outputable (Doc.Reorg Doc.Term) where
371 output = TL.hPutStrLn IO.stdout . Doc.textTerm
372 instance Outputable (Doc.Reorg DocIO.TermIO) where
373 output = DocIO.runTermIO IO.stdout
374 instance Outputable (IO.Handle, (Doc.Reorg DocIO.TermIO)) where
375 output = uncurry DocIO.runTermIO
376 -}
377
378 -- * Class 'IOType'
379 -- | Like a MIME type but for input/output of a CLI.
380 class IOType a where
381 ioType :: String
382 default ioType :: Reflection.Typeable a => String
383 ioType = show (Reflection.typeRep @a)
384
385 instance IOType String
386 instance IOType (Doc.AnsiText (Doc.Plain TLB.Builder))
387 {-
388 instance IOType (Doc.Reorg Doc.Term) where
389 instance IOType (Doc.Reorg DocIO.TermIO) where
390 instance IOType (IO.Handle, Doc.Reorg DocIO.TermIO)
391 -}
392
393 instance CLI_Help (Parser d) where
394 type HelpConstraint (Parser d) d' = d ~ d'
395 help _msg = id
396 program _n = id
397 rule _n = id
398
399
400 -- ** Class 'CLI_Routing'
401 class CLI_Routing repr where
402 commands :: Map Name (repr a k) -> repr a k
403 -- taggeds :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
404 instance CLI_Routing (Parser d) where
405 commands cmds = Parser $ do
406 st@ParserState{..} <- get
407 let exp = Map.keys cmds
408 popArg (ParserError_Cmd exp Nothing) $ \curr ->
409 case curr of
410 ArgSegment cmd ->
411 case Map.lookup cmd cmds of
412 Nothing -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]
413 Just x -> unParser x
414 _ -> lift $ throwE $ Fail st [ParserError_Cmd exp (Just curr)]
415 {-
416 taggeds ms = Parser $ do
417 st@ParserState{..} <- get
418 case parserState_args of
419 [] -> lift $ throwE $ Fail st [ParserError "empty path segment"]
420 curr:next ->
421 case lookupTag curr of
422 Nothing -> lift $ throwE $ Fail st [ParserError $ "expected: "<>fromString (show (Map.keys ms))<>" but got: "<>fromString (show curr)]
423 Just x -> do
424 put st{parserState_args=next}
425 unParser x
426 where
427 lookupTag (ArgTagShort x) = Map.lookup (Left x) ms
428 lookupTag (ArgTagLong x) = Map.lookup (Right x) ms
429 lookupTag _ = Nothing
430 -}
431
432 data Router repr a b where
433 -- | Lift any @(repr)@ into 'Router', those not useful to segregate
434 -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
435 Router_Any :: repr a b -> Router repr a b
436 -- | Represent 'commands'.
437 Router_Commands :: Map Name (Router repr a k) -> Router repr a k
438 -- | Represent 'tagged'.
439 Router_Tagged :: Tag -> Router repr f k -> Router repr f k
440 -- | Represent 'taggeds'.
441 {-
442 Router_Taggeds :: TagConstraint repr a =>
443 Map (Either Char Name) (Router repr (a -> k) k) ->
444 Router repr (a -> k) k
445 -}
446 -- | Represent ('<.>').
447 Router_App :: Router repr a b -> Router repr b c -> Router repr a c
448 -- | Represent ('<!>').
449 Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
450 -- | Unify 'Router's which have different 'handlers'.
451 -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
452 Router_Union :: (b->a) -> Router repr a k -> Router repr b k
453
454 instance Functor (Router (Parser d) f) where
455 a2b`fmap`x = noTrans (a2b <$> unTrans x)
456 instance Applicative (Router (Parser d) f) where
457 pure = noTrans . pure
458 f <*> x = noTrans (unTrans f <*> unTrans x)
459 instance Alternative (Router (Parser d) f) where
460 empty = noTrans empty
461 f <|> x = noTrans (unTrans f <|> unTrans x)
462 instance Permutable (Router (Parser d)) where
463 type Permutation (Router (Parser d)) = ParserPerm d (Router (Parser d))
464 runPermutation = noTrans . runPermutation . unTransParserPerm
465 toPermutation = noTransParserPerm . toPermutation . unTrans
466 toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
467 instance (repr ~ Parser d) => Show (Router repr a b) where
468 showsPrec p = \case
469 Router_Any{} -> showString "X"
470 Router_Commands ms -> showParen (p>=10) $ showString "Commands [" . go (Map.toList ms) . showString "]"
471 where
472 go :: forall h k. [(Segment, Router repr h k)] -> ShowS
473 go [] = id
474 go ((n, r):xs) =
475 (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
476 case xs of
477 [] -> id
478 _ -> showString ", " . go xs
479 -- Router_Command n os x -> showString n . showString " " . showsPrec 10 (permutation_parser os) . showString " " . showsPrec p x
480 Router_Tagged n x -> showsPrec 10 n . showString " " . showsPrec p x
481 {-
482 Router_Taggeds ms -> showParen (p>=10) $
483 showString "taggeds [" . go (Map.toList ms) . showString "]"
484 where
485 go :: forall h k. [(Either Char Name, Router repr h k)] -> ShowS
486 go [] = id
487 go ((n, r):xs) =
488 (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
489 case xs of
490 [] -> id
491 _ -> showString ", " . go xs
492 -}
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
497 instance Trans (Router (Parser d)) where
498 type UnTrans (Router (Parser d)) = Parser d
499 noTrans = Router_Any
500 unTrans (Router_Any x) = x
501 unTrans (Router_Alt x y) = unTrans x <!> unTrans y
502 unTrans (Router_App x y) = unTrans x <.> unTrans y
503 -- unTrans (Router_Command n os x) = command n (unTransParserPerm os) (unTrans x)
504 unTrans (Router_Commands ms) = commands (unTrans <$> ms)
505 unTrans (Router_Tagged n x) = tagged n (unTrans x)
506 -- unTrans (Router_Taggeds ms) = taggeds (unTrans <$> ms)
507 unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
508
509 instance App (Router (Parser d)) where
510 (<.>) = Router_App
511 instance Alt (Router (Parser d)) where
512 (<!>) = Router_Alt
513 instance Pro (Router (Parser d))
514 instance repr ~ (Parser d) => CLI_Command (Router repr) where
515 -- command = Router_Command
516 command "" x = x
517 command n x = Router_Commands $ Map.singleton n x
518 instance CLI_Var (Router (Parser d))
519 instance CLI_Env (Router (Parser d))
520 instance CLI_Tag (Router (Parser d)) where
521 tagged = Router_Tagged
522 instance CLI_Help (Router (Parser d)) where
523 -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
524 -- to remove them all, since they are useless for 'Parser'
525 -- and may prevent patterns to be matched in 'router'.
526 help _msg = id
527 program _n = id
528 rule _n = id
529 instance CLI_Response (Router (Parser d))
530 instance CLI_Routing (Router (Parser d)) where
531 -- taggeds = Router_Taggeds
532 commands = Router_Commands
533
534 router ::
535 repr ~ Parser d =>
536 Router repr a b -> Router repr a b
537 router = {-debug1 "router" $-} \case
538 x@Router_Any{} -> x
539 -- Router_Command n os x -> Router_Command n (hoistParserPerm router os) (router x)
540 Router_Tagged n x -> Router_Tagged n (router x)
541 {-
542 Router_Tagged n x -> Router_Taggeds $
543 case n of
544 Tag c s -> Map.fromList [(Left c, r), (Right s, r)]
545 TagShort c -> Map.singleton (Left c) r
546 TagLong s -> Map.singleton (Right s) r
547 where r = router x
548 -}
549 {-
550 Router_Taggeds xs `Router_App` Router_Taggeds ys ->
551 Router_Taggeds $ router <$> (xs <> ys)
552 -}
553 Router_Alt x y -> router x`router_Alt`router y
554 Router_Commands xs -> Router_Commands $ router <$> xs
555 -- Router_Taggeds xs -> Router_Taggeds $ router <$> xs
556 Router_App xy z ->
557 case xy of
558 Router_App x y ->
559 -- Associate to the right
560 Router_App (router x) $
561 Router_App (router y) (router z)
562 _ -> router xy `Router_App` router z
563 Router_Union u x -> Router_Union u (router x)
564 -- Router_Merge x -> Router_Merge (router x)
565
566 -- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
567 router_Alt ::
568 repr ~ Parser d =>
569 Router repr a k ->
570 Router repr b k ->
571 Router repr (a:!:b) k
572 router_Alt = {-debug2 "router_Alt"-} go
573 where
574 -- Merge alternative commands together.
575 {- NOTE: useless because 'command' is already a 'Router_Commands'.
576 go (Router_Command x xo xt) (Router_Command y yo yt) =
577 Map.singleton x (router (runPermutation xo <.> xt))
578 `router_Commands`
579 Map.singleton y (router (runPermutation yo <.> yt))
580 go (Router_Command x xo xt) (Router_Commands ys) =
581 Map.singleton x (router (runPermutation xo <.> xt))
582 `router_Commands` ys
583 go (Router_Commands xs) (Router_Command y yo yt) =
584 xs `router_Commands`
585 Map.singleton y (router (runPermutation yo <.> yt))
586 -}
587 go (Router_Commands xs) (Router_Commands ys) =
588 xs`router_Commands`ys
589
590 -- Merge left first or right first, depending on which removes 'Router_Alt'.
591 go x (y`Router_Alt`z) =
592 case x`router_Alt`y of
593 Router_Alt x' y' ->
594 case y'`router_Alt`z of
595 yz@(Router_Alt _y z') ->
596 case x'`router_Alt`z' of
597 Router_Alt{} -> router x'`Router_Alt`yz
598 xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
599 -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
600 yz -> x'`router_Alt`yz
601 xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
602 go (x`Router_Alt`y) z =
603 case y`router_Alt`z of
604 Router_Alt y' z' ->
605 case x`router_Alt`y' of
606 xy@(Router_Alt x' _y) ->
607 case x'`router_Alt`z' of
608 Router_Alt{} -> xy`Router_Alt`router z'
609 xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
610 -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
611 xy -> xy`router_Alt`z'
612 yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
613
614 -- Merge through 'Router_Union'.
615 go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
616 go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
617
618 -- No merging
619 go x y = x`Router_Alt`y
620
621 router_Commands ::
622 repr ~ Parser d =>
623 Map Segment (Router repr a k) ->
624 Map Segment (Router repr b k) ->
625 Router repr (a:!:b) k
626 router_Commands xs ys =
627 -- NOTE: a little bit more complex than required
628 -- in order to merge 'Router_Union's instead of nesting them,
629 -- such that 'unTrans' 'Router_Union' applies them all at once.
630 Router_Commands $
631 Map.merge
632 (Map.traverseMissing $ const $ \case
633 Router_Union u r ->
634 return $ Router_Union (\(x:!:_y) -> u x) r
635 r -> return $ Router_Union (\(x:!:_y) -> x) r)
636 (Map.traverseMissing $ const $ \case
637 Router_Union u r ->
638 return $ Router_Union (\(_x:!:y) -> u y) r
639 r -> return $ Router_Union (\(_x:!:y) -> y) r)
640 (Map.zipWithAMatched $ const $ \case
641 Router_Union xu xr -> \case
642 Router_Union yu yr ->
643 return $ Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
644 yr ->
645 return $ Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
646 xr -> \case
647 Router_Union yu yr ->
648 return $ Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
649 yr -> return $ xr`router_Alt`yr)
650 xs ys
651
652 {-
653 debug0 :: Show a => String -> a -> a
654 debug0 n a = Debug.trace (" {"<>n<>": "<>show a) a
655 debug1 :: Show a => Show b => String -> (a->b) -> (a->b)
656 debug1 n a2b a = Debug.trace ("} "<>n<>": r: "<>show b) b
657 where b = a2b $ Debug.trace ("{ "<>n<>": a: "<>show a) a
658 debug2 :: Show a => Show b => Show c => String -> (a->b->c) -> (a->b->c)
659 debug2 n a2b2c a b = Debug.trace ("} "<>n<>": r: "<>show c) c
660 where
661 b2c = a2b2c $ Debug.trace ("{ "<>n<>": a: "<>show a) a
662 c = b2c $ Debug.trace (n<>": b: "<>show b) b
663 -}