{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
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
newtype Parser e d f k = Parser
{ unParser :: P.ParsecT e [Arg] IO (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
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)
(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
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 $> \( 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)
newtype ParserResponse = ParserResponse { unResponseParser :: IO () }
type ParserResponseArgs = IO
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
data OnHandle a = OnHandle IO.Handle 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 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 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
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)
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 repr where
commands :: Map Name (repr a k) -> Map Name (repr a k) -> repr a 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
data Router repr a b where
Router_Any :: repr a b -> Router repr a b
Router_Commands ::
Map Name (Router repr a k) ->
Map Name (Router repr a k) ->
Router repr a k
Router_Tag :: Tag -> Router repr f k -> Router repr f k
Router_App :: Router repr a b -> Router repr b c -> Router repr a c
Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
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
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
commands = Router_Commands
router ::
repr ~ Parser e d =>
Router repr a b -> Router repr a b
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 ->
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)
router_Alt ::
repr ~ Parser e d =>
Router repr a k ->
Router repr b k ->
Router repr (a:!:b) k
router_Alt = go
where
go (Router_Commands xp xs) (Router_Commands yp ys) =
Router_Commands
(router_Commands False xp yp)
(router_Commands True xs ys)
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
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
xy -> xy`router_Alt`z'
yz -> Router_Union (\((a:!:b):!:c) -> a:!:(b:!:c)) $ x`router_Alt`yz
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)
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 =
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
newtype RouterParserSeq repr k a = RouterParserSeq
{ unRouterParserSeq :: repr k a }
deriving (Functor, Applicative)
data Arg
= ArgSegment Segment
| ArgTagLong Name
| ArgTagShort Char
| ArgEnv Name String
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
reachOffset = error "BUG: reachOffset must not be used on [Arg]"
reachOffsetNoLine = error "BUG: reachOffsetNoLine must not be used on [Arg]"