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 -}