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