-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE GADTs #-} -- for Router
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-} -- for hoistParserPerm (which is no longer used)
-module Symantic.CLI.Parser where
-
-import Control.Applicative (Applicative(..), Alternative(..), optional, many, some)
-import Control.Monad (Monad(..), join, sequence, forM_, void)
-import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.State (StateT(..),evalState,get,put)
-import Data.Bool
-import Data.Char (Char)
-import Data.Either (Either(..))
-import Data.Eq (Eq(..))
-import Data.Foldable (null, toList)
-import Data.Function (($), (.), id, const)
-import Data.Functor (Functor(..), (<$>), ($>))
-import Data.Functor.Identity (Identity(..))
-import Data.Int (Int)
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
-import Data.Maybe (Maybe(..), maybe, isNothing)
-import Data.Ord (Ord(..))
-import Data.Proxy (Proxy(..))
-import Data.Semigroup (Semigroup(..))
-import Data.String (String)
-import Numeric.Natural (Natural)
-import Prelude (Integer, Num(..), error)
-import System.Environment (lookupEnv)
-import System.IO (IO)
-import Text.Read (Read, readEither)
-import Text.Show (Show(..), ShowS, showString, showParen)
-import Type.Reflection as Reflection
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.List as List
-import qualified Data.List.NonEmpty as NonEmpty
-import qualified Data.Map.Merge.Strict as Map
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified System.Exit as System
-import qualified Data.Text as Text
-import qualified Data.Text.IO as Text
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TLB
-import qualified Data.Text.Lazy.IO as TL
-import qualified Symantic.Document as Doc
-import qualified System.IO as IO
-import qualified Text.Megaparsec as P
-
-import Symantic.CLI.API
-
--- * Type 'Parser'
-newtype Parser e d f k = Parser
- { unParser :: P.ParsecT e [Arg] IO (f->k) -- Reader f k
- }
-
-parser ::
- P.ShowErrorComponent e =>
- Router (Parser e d) handlers (Response (Router (Parser e d))) ->
- handlers ->
- [Arg] -> IO ()
-parser api handlers args = do
- P.runParserT
- (unParser $ unTrans $ router api)
- "" args >>= \case
- Left err ->
- forM_ (P.bundleErrors err) $ \e -> do
- IO.putStr $
- "Error parsing the command at argument #" <>
- show (P.errorOffset e + 1) <> ":\n" <>
- parseErrorTextPretty e
- System.exitWith (System.ExitFailure 2)
- Right app -> unResponseParser $ app handlers
-
--- | Rewrite 'P.parseErrorTextPretty' to keep 'Ord' of 'Arg'.
-parseErrorTextPretty ::
- forall s e.
- (P.Stream s, P.ShowErrorComponent e) =>
- P.ParseError s e -> String
-parseErrorTextPretty (P.TrivialError _ us ps) =
- if isNothing us && Set.null ps
- then "unknown parse error\n"
- else
- messageItemsPretty "unexpected "
- (showErrorItem pxy <$> Set.toAscList (maybe Set.empty Set.singleton us)) <>
- messageItemsPretty "expecting "
- (showErrorItem pxy <$> Set.toAscList ps)
- where pxy = Proxy :: Proxy s
-parseErrorTextPretty err = P.parseErrorTextPretty err
-
-messageItemsPretty :: String -> [String] -> String
-messageItemsPretty prefix ts
- | null ts = ""
- | otherwise = prefix <> (orList . NonEmpty.fromList) ts <> "\n"
-
-orList :: NonEmpty String -> String
-orList (x:|[]) = x
-orList (x:|[y]) = x <> " or " <> y
-orList xs = List.intercalate ", " (NonEmpty.init xs) <> ", or " <> NonEmpty.last xs
-
-showErrorItem :: P.Stream s => Proxy s -> P.ErrorItem (P.Token s) -> String
-showErrorItem pxy = \case
- P.Tokens ts -> P.showTokens pxy ts
- P.Label label -> NonEmpty.toList label
- P.EndOfInput -> "end of input"
-
-instance Functor (Parser e d f) where
- a2b`fmap`Parser x = Parser $ (a2b <$>) <$> x
-instance Applicative (Parser e d f) where
- pure = Parser . pure . const
- Parser f <*> Parser x = Parser $ (<*>) <$> f <*> x
-instance Ord e => Alternative (Parser e d f) where
- empty = Parser empty
- Parser x <|> Parser y = Parser $ x <|> y
-instance Ord e => Sequenceable (Parser e d) where
- type Sequence (Parser e d) = ParserSeq e d
- runSequence = unParserSeq
- toSequence = ParserSeq
-instance Ord e => Permutable (Parser e d) where
- type Permutation (Parser e d) = ParserPerm e d (Parser e d)
- runPermutation (ParserPerm ma p) = Parser $ do
- u2p <- unParser $ optional p
- unParser $
- case u2p () of
- Just perm -> runPermutation perm
- Nothing ->
- maybe
- (Parser $ P.token (const Nothing) Set.empty)
- -- NOTE: Not 'empty' here so that 'P.TrivialError'
- -- has the unexpected token.
- (Parser . return) ma
- toPermutation (Parser x) =
- ParserPerm Nothing
- (Parser $ (\a () -> ParserPerm (Just a) empty) <$> x)
- toPermDefault a (Parser x) =
- ParserPerm (Just ($ a))
- (Parser $ (\d () -> ParserPerm (Just d) empty) <$> x)
-instance App (Parser e d) where
- Parser x <.> Parser y = Parser $
- x >>= \a2b -> (. a2b) <$> y
-instance Ord e => Alt (Parser e d) where
- Parser x <!> Parser y = Parser $
- (\a2k (a:!:_b) -> a2k a) <$> P.try x <|>
- (\b2k (_a:!:b) -> b2k b) <$> y
- Parser x `alt` Parser y = Parser $ P.try x <|> y
- opt (Parser x) = Parser $
- mapCont Just <$> P.try x
-instance Ord e => AltApp (Parser e d) where
- many0 (Parser x) = Parser $ concatCont <$> many x
- many1 (Parser x) = Parser $ concatCont <$> some x
-instance Pro (Parser e d) where
- dimap a2b _b2a (Parser r) = Parser $ (\k b2k -> k (b2k . a2b)) <$> r
-instance Ord e => CLI_Command (Parser e d) where
- -- type CommandConstraint (Parser e d) a = ()
- command "" x = x
- command n x = commands Map.empty (Map.singleton n x)
-instance Ord e => CLI_Tag (Parser e d) where
- type TagConstraint (Parser e d) a = ()
- tag name p = Parser $ P.try $ do
- void $ (`P.token` exp) $ \tok ->
- if lookupTag tok name
- then Just tok
- else Nothing
- unParser p
- where
- exp =
- case name of
- TagShort t -> Set.singleton $ P.Tokens $ pure $ ArgTagShort t
- TagLong t -> Set.singleton $ P.Tokens $ pure $ ArgTagLong t
- Tag s l -> Set.fromList
- [ P.Tokens $ pure $ ArgTagShort s
- , P.Tokens $ pure $ ArgTagLong l
- ]
- lookupTag (ArgTagShort x) (TagShort y) = x == y
- lookupTag (ArgTagShort x) (Tag y _) = x == y
- lookupTag (ArgTagLong x) (TagLong y) = x == y
- lookupTag (ArgTagLong x) (Tag _ y) = x == y
- lookupTag _ _ = False
- endOpts = Parser $ do
- (`P.token` exp) $ \case
- ArgTagLong "" -> Just id
- _ -> Nothing
- where
- exp = Set.singleton $ P.Tokens $ pure $ ArgTagLong ""
-instance Ord e => CLI_Var (Parser e d) where
- type VarConstraint (Parser e d) a = (IOType a, FromSegment a)
- var' :: forall a k. VarConstraint (Parser e d) a => Name -> Parser e d (a->k) k
- var' name = Parser $ do
- seg <- (`P.token` expName) $ \case
- ArgSegment seg -> Just seg
- _ -> Nothing
- lift (fromSegment seg) >>= \case
- Left err -> P.failure got expType
- where
- got = Just $ P.Tokens $ pure $ ArgSegment seg
- expType = Set.singleton $ P.Label $ NonEmpty.fromList $
- "<"<>name<>"> to be of type "<>ioType @a
- <> case err of
- "Prelude.read: no parse" -> ""
- "" -> ""
- _ -> ": "<>err
- Right a -> return ($ a)
- where
- expName = Set.singleton $ P.Label $ NonEmpty.fromList $ "<"<>name<>">"
-instance Ord e => CLI_Constant (Parser e d) where
- constant "" a = just a
- constant c a = commands Map.empty (Map.singleton c (just a))
- just a = Parser $ return ($ a)
- nothing = Parser $ return id
-instance Ord e => CLI_Env (Parser e d) where
- type EnvConstraint (Parser e d) a = (IOType a, FromSegment a)
- env' :: forall a k. EnvConstraint (Parser e d) a => Name -> Parser e d (a->k) k
- env' name = Parser $
- lift (lookupEnv name) >>= \case
- Nothing -> P.failure got exp
- where
- got = Nothing
- exp = Set.singleton $ P.Label $ NonEmpty.fromList $ "${"<>name<>"}"
- Just val ->
- lift (fromSegment val) >>= \case
- Right a -> return ($ a)
- Left err -> P.failure got exp
- where
- got = Just $ P.Tokens $ pure $ ArgEnv name val
- exp = Set.singleton $ P.Label $ NonEmpty.fromList $
- "${"<>name<>"} to be of type "<>ioType @a
- <> case err of
- "Prelude.read: no parse" -> ""
- "" -> ""
- _ -> ": "<>err
-instance Ord e => CLI_Response (Parser e d) where
- type ResponseConstraint (Parser e d) a = Outputable a
- type ResponseArgs (Parser e d) a = ParserResponseArgs a
- type Response (Parser e d) = ParserResponse
- response' = Parser $
- P.eof $> \({-ParserResponseArgs-} io) ->
- ParserResponse $ io >>= output
-instance Ord e => CLI_Help (Parser e d) where
- type HelpConstraint (Parser e d) d' = d ~ d'
- help _msg = id
- program n = Parser . P.label n . unParser
- rule n = Parser . P.label n . unParser
-
-concatCont :: [(a->k)->k] -> ([a]->k)->k
-concatCont = List.foldr (consCont (:)) ($ [])
-
-consCont :: (a->b->c) -> ((a->k)->k) -> ((b->k)->k) -> (c->k)->k
-consCont ab2c a2k2k b2k2k = \c2k -> a2k2k $ \a -> b2k2k $ \b -> c2k (ab2c a b)
-
-mapCont :: (a->b) -> ((a->k)->k) -> ((b->k)->k)
-mapCont a2b a2k2k = \b2k -> a2k2k (b2k . a2b)
-
--- ** Type 'ParserResponse'
-newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
--- ** Type 'ParserResponseArgs'
-type ParserResponseArgs = IO
-
--- * Class 'Outputable'
--- | Output of a CLI.
-class IOType a => Outputable a where
- output :: a -> IO ()
- default output :: Show a => a -> IO ()
- output = IO.print
-
-instance Outputable () where
- output = return
-instance Outputable Bool
-instance Outputable Int
-instance Outputable Integer
-instance Outputable Natural
-instance Outputable Char where
- output c = IO.putStr [c]
-instance Outputable String where
- output = IO.putStr
-instance Outputable Text.Text where
- output = Text.putStr
-instance Outputable TL.Text where
- output = TL.putStr
-instance Outputable BS.ByteString where
- output = BS.putStr
-instance Outputable BSL.ByteString where
- output = BSL.putStr
-instance Outputable (Doc.Plain TLB.Builder) where
- output =
- TL.putStr .
- TLB.toLazyText .
- Doc.runPlain
-
--- ** Type 'OnHandle'
-data OnHandle a = OnHandle IO.Handle a
-instance Functor OnHandle where
- fmap f (OnHandle h a) = OnHandle h (f a)
-instance IOType a => IOType (OnHandle a) where
- ioType = ioType @a
-instance Outputable (OnHandle ()) where
- output _ = return ()
-instance Outputable (OnHandle Bool) where
- output (OnHandle h a) = IO.hPrint h a
-instance Outputable (OnHandle Int) where
- output (OnHandle h a) = IO.hPrint h a
-instance Outputable (OnHandle Integer) where
- output (OnHandle h a) = IO.hPrint h a
-instance Outputable (OnHandle Natural) where
- output (OnHandle h a) = IO.hPrint h a
-instance Outputable (OnHandle Char) where
- output (OnHandle h c) = IO.hPutStr h [c]
-instance Outputable (OnHandle String) where
- output (OnHandle h a) = IO.hPutStr h a
-instance Outputable (OnHandle Text.Text) where
- output (OnHandle h a) = Text.hPutStr h a
-instance Outputable (OnHandle TL.Text) where
- output (OnHandle h a) = TL.hPutStr h a
-instance Outputable (OnHandle BS.ByteString) where
- output (OnHandle h a) = BS.hPutStr h a
-instance Outputable (OnHandle BSL.ByteString) where
- output (OnHandle h a) = BSL.hPutStr h a
-instance Outputable (OnHandle (Doc.Plain TLB.Builder)) where
- output (OnHandle h d) =
- TL.hPutStr h $
- TLB.toLazyText $
- Doc.runPlain d
-instance
- ( Outputable a
- , Reflection.Typeable a
- ) => Outputable (Maybe a) where
- output = \case
- Nothing -> System.exitWith (System.ExitFailure 1)
- Just a -> output a
-instance
- ( Reflection.Typeable e
- , Reflection.Typeable a
- , Outputable (OnHandle e)
- , Outputable a
- ) => Outputable (Either e a) where
- output = \case
- Left e -> do
- output (OnHandle IO.stderr e)
- System.exitWith (System.ExitFailure 1)
- Right a -> output a
-
--- * Class 'IOType'
--- | Like a MIME type but for input/output of a CLI.
-class IOType a where
- ioType :: String
- default ioType :: Reflection.Typeable a => String
- ioType = show (Reflection.typeRep @a)
-
-instance IOType ()
-instance IOType Bool
-instance IOType Char
-instance IOType Int
-instance IOType Integer
-instance IOType Natural
-instance IOType String
-instance IOType Text.Text
-instance IOType TL.Text
-instance IOType BS.ByteString
-instance IOType BSL.ByteString
-instance IOType (Doc.Plain TLB.Builder)
-instance Reflection.Typeable a => IOType (Maybe a)
-instance (Reflection.Typeable e, Reflection.Typeable a) => IOType (Either e a)
-
--- * Class 'FromSegment'
-class FromSegment a where
- fromSegment :: Segment -> IO (Either String a)
- default fromSegment :: Read a => Segment -> IO (Either String a)
- fromSegment = return . readEither
-instance FromSegment String where
- fromSegment = return . Right
-instance FromSegment Text.Text where
- fromSegment = return . Right . Text.pack
-instance FromSegment TL.Text where
- fromSegment = return . Right . TL.pack
-instance FromSegment Bool
-instance FromSegment Int
-instance FromSegment Integer
-instance FromSegment Natural
-
--- ** Type 'ParserSeq'
--- | Lift a 'Parser' to something working with 'Functor' and 'Applicative'.
--- Used to gather collected values into a single one,
--- which is for instance needed for using 'many0' on multiple 'var's.
-newtype ParserSeq e d k a = ParserSeq
- { unParserSeq :: Parser e d (a->k) k }
-instance Functor (ParserSeq e d k) where
- a2b `fmap` ParserSeq (Parser x) = ParserSeq $ Parser $ merge <$> x
- where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
-instance Applicative (ParserSeq e d k) where
- pure a = ParserSeq $ Parser $ pure ($ a)
- ParserSeq (Parser f) <*> ParserSeq (Parser x) =
- ParserSeq $ Parser $ merge <$> f <*> x
- where merge a2b2k2k a2k2k b2k =
- a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
-
--- ** Type 'ParserPerm'
-data ParserPerm e d repr k a = ParserPerm
- { permutation_result :: !(Maybe ((a->k)->k))
- , permutation_parser :: repr () (ParserPerm e d repr k a)
- }
-
-instance (App repr, Functor (repr ())) => Functor (ParserPerm e d repr k) where
- a2b `fmap` ParserPerm a ma =
- ParserPerm (merge <$> a) ((a2b `fmap`) `fmap` ma)
- where merge = \a2k2k b2k -> a2k2k $ b2k . a2b
-instance (App repr, Functor (repr ()), Alternative (repr ())) =>
- Applicative (ParserPerm e d repr k) where
- pure a = ParserPerm (Just ($ a)) empty
- lhs@(ParserPerm f ma2b) <*> rhs@(ParserPerm x ma) =
- ParserPerm a (lhsAlt <|> rhsAlt)
- where
- a = merge <$> f <*> x
- lhsAlt = (<*> rhs) <$> ma2b
- rhsAlt = (lhs <*>) <$> ma
- merge a2b2k2k a2k2k b2k =
- a2b2k2k $ \a2b -> a2k2k (b2k . a2b)
-instance CLI_Help repr => CLI_Help (ParserPerm e d repr) where
- type HelpConstraint (ParserPerm e d repr) d' = HelpConstraint (Parser e d) d'
- program _n = id
- rule _n = id
-
-noTransParserPerm ::
- Trans repr =>
- Functor (UnTrans repr ()) =>
- ParserPerm e d (UnTrans repr) k a -> ParserPerm e d repr k a
-noTransParserPerm (ParserPerm a ma) = ParserPerm a (noTrans $ noTransParserPerm <$> ma)
-
-unTransParserPerm ::
- Trans repr =>
- Functor (UnTrans repr ()) =>
- ParserPerm e d repr k a -> ParserPerm e d (UnTrans repr) k a
-unTransParserPerm (ParserPerm a ma) =
- ParserPerm a (unTransParserPerm <$> unTrans ma)
-
-hoistParserPerm ::
- Functor (repr ()) =>
- (forall a b. repr a b -> repr a b) ->
- ParserPerm e d repr k c -> ParserPerm e d repr k c
-hoistParserPerm f (ParserPerm a ma) =
- ParserPerm a (hoistParserPerm f <$> f ma)
-
--- ** Class 'CLI_Routing'
-class CLI_Routing repr where
- commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a k
- -- tags :: TagConstraint repr a => Map (Either Char Name) (repr (a -> k) k) -> repr (a -> k) k
-instance Ord e => CLI_Routing (Parser e d) where
- commands preCmds cmds = Parser $
- P.token check exp >>= unParser
- where
- exp = Set.fromList $ P.Tokens . pure . ArgSegment <$> Map.keys cmds
- check = \case
- ArgSegment cmd ->
- Map.lookup cmd cmds <|>
- Map.lookup cmd preCmds
- _ -> Nothing
-
--- * Type 'Router'
-data Router repr a b where
- -- | Lift any @(repr)@ into 'Router', those not useful to segregate
- -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
- Router_Any :: repr a b -> Router repr a b
- -- | Represent 'commands'.
- Router_Commands ::
- Map Name (Router repr a k) ->
- Map Name (Router repr a k) ->
- Router repr a k
- -- | Represent 'tag'.
- Router_Tag :: Tag -> Router repr f k -> Router repr f k
- -- | Represent ('<.>').
- Router_App :: Router repr a b -> Router repr b c -> Router repr a c
- -- | Represent ('<!>').
- Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
- -- | Unify 'Router's which have different 'handlers'.
- -- Useful to put alternative 'Router's in a 'Map' as in 'Router_Commands'.
- Router_Union :: (b->a) -> Router repr a k -> Router repr b k
-
-instance Ord e => Functor (Router (Parser e d) f) where
- a2b`fmap`x = noTrans (a2b <$> unTrans x)
-instance Ord e => Applicative (Router (Parser e d) f) where
- pure = noTrans . pure
- f <*> x = noTrans (unTrans f <*> unTrans x)
-instance Ord e => Alternative (Router (Parser e d) f) where
- empty = noTrans empty
- f <|> x = noTrans (unTrans f <|> unTrans x)
-instance (repr ~ Parser e d) => Show (Router repr a b) where
- showsPrec p = \case
- Router_Any{} -> showString "X"
- Router_Commands _preCmds cmds -> showParen (p>=10) $ showString "Commands [" . go (Map.toList cmds) . showString "]"
- where
- go :: forall h k. [(Segment, Router repr h k)] -> ShowS
- go [] = id
- go ((n, r):xs) =
- (showParen True $ showString (show n<>", ") . showsPrec 0 r) .
- case xs of
- [] -> id
- _ -> showString ", " . go xs
- Router_Tag n x -> showsPrec 10 n . showString " " . showsPrec p x
- Router_App x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y
- Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " <!> " . showsPrec 3 y
- Router_Union _u x -> showString "Union [" . showsPrec 0 x . showString "]"
-instance Ord e => Trans (Router (Parser e d)) where
- type UnTrans (Router (Parser e d)) = Parser e d
- noTrans = Router_Any
- unTrans (Router_Any x) = x
- unTrans (Router_Alt x y) = unTrans x <!> unTrans y
- unTrans (Router_App x y) = unTrans x <.> unTrans y
- unTrans (Router_Commands preCmds cmds) = commands (unTrans <$> preCmds) (unTrans <$> cmds)
- unTrans (Router_Tag n x) = tag n (unTrans x)
- unTrans (Router_Union u x) = Parser $ (. u) <$> unParser (unTrans x)
-
-instance Ord e => App (Router (Parser e d)) where
- (<.>) = Router_App
-instance Ord e => Alt (Router (Parser e d)) where
- (<!>) = Router_Alt
- alt x y = Router_Union (\a -> a:!:a) $ Router_Alt x y
-instance Ord e => AltApp (Router (Parser e d))
-instance Ord e => Sequenceable (Router (Parser e d)) where
- type Sequence (Router (Parser e d)) = RouterParserSeq (ParserSeq e d)
- runSequence = noTrans . runSequence . unRouterParserSeq
- toSequence = RouterParserSeq . toSequence . unTrans
-instance Ord e => Permutable (Router (Parser e d)) where
- type Permutation (Router (Parser e d)) = ParserPerm e d (Router (Parser e d))
- runPermutation = noTrans . runPermutation . unTransParserPerm
- toPermutation = noTransParserPerm . toPermutation . unTrans
- toPermDefault a = noTransParserPerm . toPermDefault a . unTrans
-instance Ord e => Pro (Router (Parser e d))
-instance (repr ~ (Parser e d)) => CLI_Command (Router repr) where
- command "" x = x
- command n x =
- let is = List.tail $ List.inits n in
- let (preCmds, cmds) = List.splitAt (List.length is - 1) is in
- Router_Commands
- (Map.fromAscList $ (,x) <$> preCmds)
- (Map.fromAscList $ (,x) <$> cmds)
-instance Ord e => CLI_Var (Router (Parser e d))
-instance Ord e => CLI_Constant (Router (Parser e d))
-instance Ord e => CLI_Env (Router (Parser e d))
-instance Ord e => CLI_Tag (Router (Parser e d)) where
- tag = Router_Tag
-instance CLI_Help (Router (Parser e d)) where
- -- NOTE: set manually (instead of the 'Trans' default 'Router_Any')
- -- to remove them all, since they are useless for 'Parser'
- -- and may prevent patterns to be matched in 'router'.
- help _msg = id
- program _n = id
- rule _n = id
-instance Ord e => CLI_Response (Router (Parser e d))
-instance Ord e => CLI_Routing (Router (Parser e d)) where
- -- tags = Router_Tags
- commands = Router_Commands
-
-router ::
- repr ~ Parser e d =>
- Router repr a b -> Router repr a b
-router = {-debug1 "router" $-} \case
- x@Router_Any{} -> x
- Router_Tag n x -> Router_Tag n (router x)
- Router_Alt x y -> router x`router_Alt`router y
- Router_Commands preCmds cmds ->
- Router_Commands
- (router <$> preCmds)
- (router <$> cmds)
- Router_App xy z ->
- case xy of
- Router_App x y ->
- -- Associate to the right
- Router_App (router x) $
- Router_App (router y) (router z)
- _ -> router xy `Router_App` router z
- Router_Union u x -> Router_Union u (router x)
-
--- | Merge/reorder alternatives if possible or default to a 'Router_Alt'.
-router_Alt ::
- repr ~ Parser e d =>
- Router repr a k ->
- Router repr b k ->
- Router repr (a:!:b) k
-router_Alt = {-debug2 "router_Alt"-} go
- where
- -- Merge alternative commands together.
- go (Router_Commands xp xs) (Router_Commands yp ys) =
- Router_Commands
- (router_Commands False xp yp) -- NOTE: conflicting prefixes are dropped.
- (router_Commands True xs ys)
-
- -- Merge left first or right first, depending on which removes 'Router_Alt'.
- go x (y`Router_Alt`z) =
- case x`router_Alt`y of
- Router_Alt x' y' ->
- case y'`router_Alt`z of
- yz@(Router_Alt _y z') ->
- case x'`router_Alt`z' of
- Router_Alt{} -> router x'`Router_Alt`yz
- xz -> Router_Union (\(a:!:(b:!:c)) -> (a:!:c):!:b) $ xz`router_Alt`y
- -- NOTE: prioritize the merged router 'xz' over over the non-mergeable 'y'.
- yz -> x'`router_Alt`yz
- xy -> Router_Union (\(a:!:(b:!:c)) -> (a:!:b):!:c) $ xy`router_Alt`z
- go (x`Router_Alt`y) z =
- case y`router_Alt`z of
- Router_Alt y' z' ->
- case x`router_Alt`y' of
- xy@(Router_Alt x' _y) ->
- case x'`router_Alt`z' of
- Router_Alt{} -> xy`Router_Alt`router z'
- xz -> Router_Union (\((a:!:b):!:c) -> (a:!:c):!:b) $ xz`router_Alt`y
- -- NOTE: prioritize the merged router 'xz' over the non-mergeable 'y'.
- xy -> xy`router_Alt`z'
- yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
-
- -- Merge through 'Router_Union'.
- go (Router_Union u x) y = Router_Union (\(a:!:b) -> u a:!:b) (x`router_Alt`y)
- go x (Router_Union u y) = Router_Union (\(a:!:b) -> a:!:u b) (x`router_Alt`y)
-
- -- No merging
- go x y = x`Router_Alt`y
-
-router_Commands ::
- repr ~ Parser e d =>
- Bool ->
- Map Segment (Router repr a k) ->
- Map Segment (Router repr b k) ->
- Map Segment (Router repr (a:!:b) k)
-router_Commands allowMerging =
- -- NOTE: a little bit more complex than required
- -- in order to merge 'Router_Union's instead of nesting them,
- -- such that 'unTrans' 'Router_Union' applies them all at once.
- Map.merge
- (Map.mapMissing $ const keepX)
- (Map.mapMissing $ const keepY)
- (Map.zipWithMaybeMatched $ const $ \x y ->
- if allowMerging then Just $ mergeFull x y else Nothing)
- where
- keepX = \case
- Router_Union u r -> Router_Union (\(x:!:_y) -> u x) r
- r -> Router_Union (\(x:!:_y) -> x) r
- keepY = \case
- Router_Union u r -> Router_Union (\(_x:!:y) -> u y) r
- r -> Router_Union (\(_x:!:y) -> y) r
- mergeFull = \case
- Router_Union xu xr -> \case
- Router_Union yu yr -> Router_Union (\(x:!:y) -> xu x:!:yu y) $ xr`router_Alt`yr
- yr -> Router_Union (\(a:!:b) -> xu a:!:b) $ xr`router_Alt`yr
- xr -> \case
- Router_Union yu yr -> Router_Union (\(a:!:b) -> a:!:yu b) $ xr`router_Alt`yr
- yr -> xr`router_Alt`yr
-
--- ** Type 'RouterParserSeq'
-newtype RouterParserSeq repr k a = RouterParserSeq
- { unRouterParserSeq :: repr k a }
- deriving (Functor, Applicative)
-
--- * Type 'Arg'
-data Arg
- = ArgSegment Segment
- | ArgTagLong Name
- | ArgTagShort Char
- | ArgEnv Name String -- ^ Here only for error reporting.
- deriving (Eq,Ord,Show)
-
-lexer :: [String] -> [Arg]
-lexer ss =
- join $
- (`evalState` False) $
- sequence (f <$> ss)
- where
- f :: String -> StateT Bool Identity [Arg]
- f s = do
- skip <- get
- if skip then return [ArgSegment s]
- else case s of
- '-':'-':[] -> do
- put True
- return [ArgTagLong ""]
- '-':'-':cs -> return [ArgTagLong cs]
- '-':cs@(_:_) -> return $ ArgTagShort <$> cs
- seg -> return [ArgSegment seg]
-
-showArg :: Arg -> String
-showArg = \case
- ArgTagShort t -> '-':[t]
- ArgTagLong t -> '-':'-':t
- ArgSegment seg -> seg
- ArgEnv name val -> name<>"="<>val
-
-showArgs :: [Arg] -> String
-showArgs args = List.intercalate " " $ showArg <$> args
-
-instance P.Stream [Arg] where
- type Token [Arg] = Arg
- type Tokens [Arg] = [Arg]
- tokenToChunk Proxy = pure
- tokensToChunk Proxy = id
- chunkToTokens Proxy = id
- chunkLength Proxy = List.length
- chunkEmpty Proxy = List.null
- take1_ [] = Nothing
- take1_ (t:ts) = Just (t, ts)
- takeN_ n s
- | n <= 0 = Just ([], s)
- | List.null s = Nothing
- | otherwise = Just (List.splitAt n s)
- takeWhile_ = List.span
- showTokens Proxy = showArgs . toList
- -- NOTE: those make no sense when parsing a command line,
- -- and should not be called since 'P.errorBundlePretty' is not used in 'parser'.
- reachOffset = error "BUG: reachOffset must not be used on [Arg]"
- reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"
sourcephile / git / haskell / symantic-cli.git / commitdiff