{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Registry.Options.Lexemes where
import Data.List qualified as L
import Data.Map.Strict qualified as Map
import Data.MultiMap (MultiMap)
import Data.MultiMap qualified as M
import Data.Text qualified as T
import Protolude as P
import Prelude (show)
data Lexemes = Lexemes
{
Lexemes -> MultiMap Text Text
lexedOptions :: MultiMap Text Text,
Lexemes -> [Text]
lexedFlags :: [Text],
Lexemes -> [Text]
lexedArguments :: [Text],
Lexemes -> Maybe (Text, [Text])
lexedAmbiguous :: Maybe (Text, [Text])
}
deriving (Lexemes -> Lexemes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lexemes -> Lexemes -> Bool
$c/= :: Lexemes -> Lexemes -> Bool
== :: Lexemes -> Lexemes -> Bool
$c== :: Lexemes -> Lexemes -> Bool
Eq, Int -> Lexemes -> ShowS
[Lexemes] -> ShowS
Lexemes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lexemes] -> ShowS
$cshowList :: [Lexemes] -> ShowS
show :: Lexemes -> String
$cshow :: Lexemes -> String
showsPrec :: Int -> Lexemes -> ShowS
$cshowsPrec :: Int -> Lexemes -> ShowS
Show)
instance Semigroup Lexemes where
<> :: Lexemes -> Lexemes -> Lexemes
(<>) = Lexemes -> Lexemes -> Lexemes
union
instance Monoid Lexemes where
mempty :: Lexemes
mempty = MultiMap Text Text
-> [Text] -> [Text] -> Maybe (Text, [Text]) -> Lexemes
Lexemes forall k a. MultiMap k a
M.empty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Maybe a
Nothing
mappend :: Lexemes -> Lexemes -> Lexemes
mappend = forall a. Semigroup a => a -> a -> a
(<>)
union :: Lexemes -> Lexemes -> Lexemes
union :: Lexemes -> Lexemes -> Lexemes
union (Lexemes MultiMap Text Text
m1 [Text]
fs1 [Text]
as1 Maybe (Text, [Text])
am1) (Lexemes MultiMap Text Text
m2 [Text]
fs2 [Text]
as2 Maybe (Text, [Text])
am2) =
MultiMap Text Text
-> [Text] -> [Text] -> Maybe (Text, [Text]) -> Lexemes
Lexemes
(forall k a. Ord k => [(k, a)] -> MultiMap k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall k a. MultiMap k a -> [(k, a)]
M.toList MultiMap Text Text
m1 forall a. Semigroup a => a -> a -> a
<> forall k a. MultiMap k a -> [(k, a)]
M.toList MultiMap Text Text
m2)
([Text]
fs1 forall a. Semigroup a => a -> a -> a
<> [Text]
fs2)
([Text]
as1 forall a. Semigroup a => a -> a -> a
<> [Text]
as2)
(Maybe (Text, [Text])
am1 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Text, [Text])
am2)
override :: Lexemes -> Lexemes -> Lexemes
override :: Lexemes -> Lexemes -> Lexemes
override (Lexemes MultiMap Text Text
m1 [Text]
fs1 [Text]
as1 Maybe (Text, [Text])
am1) (Lexemes MultiMap Text Text
m2 [Text]
fs2 [Text]
as2 Maybe (Text, [Text])
am2) =
MultiMap Text Text
-> [Text] -> [Text] -> Maybe (Text, [Text]) -> Lexemes
Lexemes
MultiMap Text Text
mergeOptions
([Text] -> [Text] -> [Text]
mergeMax [Text]
fs1 [Text]
fs2)
([Text]
as1 forall a. Semigroup a => a -> a -> a
<> [Text]
as2)
Maybe (Text, [Text])
mergeAmbiguous
where
mergeMax :: [Text] -> [Text] -> [Text]
mergeMax :: [Text] -> [Text] -> [Text]
mergeMax [Text]
vs1 [Text]
vs2 = do
let g1 :: Map Text [Text]
g1 = forall a. Ord a => [a] -> Map a [a]
groupByEq [Text]
vs1
let g2 :: Map Text [Text]
g2 = forall a. Ord a => [a] -> Map a [a]
groupByEq [Text]
vs2
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\[Text]
v1 [Text]
v2 -> if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
v1 forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
v2 then [Text]
v1 else [Text]
v2) Map Text [Text]
g1 Map Text [Text]
g2
groupByEq :: Ord a => [a] -> Map a [a]
groupByEq :: forall a. Ord a => [a] -> Map a [a]
groupByEq = forall k a. MultiMap k a -> Map k [a]
M.toMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> MultiMap k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
a -> (a
a, a
a))
mergeOptions :: MultiMap Text Text
mergeOptions = do
let allOptions :: MultiMap Text Text
allOptions = forall k a. Map k [a] -> MultiMap k a
M.fromMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall k a. MultiMap k a -> [(k, [a])]
M.assocs MultiMap Text Text
m1 forall a. Semigroup a => a -> a -> a
<> forall k a. MultiMap k a -> [(k, [a])]
M.assocs MultiMap Text Text
m2
case (Maybe (Text, [Text])
am1, Maybe (Text, [Text])
am2) of
(Maybe (Text, [Text])
Nothing, Maybe (Text, [Text])
Nothing) -> MultiMap Text Text
allOptions
(Just (Text, [Text])
_, Maybe (Text, [Text])
Nothing) -> MultiMap Text Text
allOptions
(Maybe (Text, [Text])
_, Just (Text
t2, [Text]
v2)) ->
if Text
t2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall k a. MultiMap k a -> [k]
M.keys MultiMap Text Text
allOptions then forall k a. Map k [a] -> MultiMap k a
M.fromMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall k a. MultiMap k a -> [(k, [a])]
M.assocs MultiMap Text Text
allOptions forall a. Semigroup a => a -> a -> a
<> [(Text
t2, [Text]
v2)]) else MultiMap Text Text
allOptions
mergeAmbiguous :: Maybe (Text, [Text])
mergeAmbiguous =
case (Maybe (Text, [Text])
am1, Maybe (Text, [Text])
am2) of
(Maybe (Text, [Text])
Nothing, Maybe (Text, [Text])
Nothing) -> forall a. Maybe a
Nothing
(Just (Text, [Text])
_, Just (Text
t2, [Text]
vs2)) -> forall a. a -> Maybe a
Just (Text
t2, [Text]
vs2)
(Just (Text
t1, [Text]
vs1), Maybe (Text, [Text])
Nothing) ->
if Text
t1 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall k a. MultiMap k a -> [k]
M.keys MultiMap Text Text
m2 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Text
t1, [Text]
vs1)
(Maybe (Text, [Text])
Nothing, Just (Text
t2, [Text]
vs2)) ->
if Text
t2 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall k a. MultiMap k a -> [k]
M.keys MultiMap Text Text
m1 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Text
t2, [Text]
vs2)
lexArgs :: [Text] -> Lexemes
lexArgs :: [Text] -> Lexemes
lexArgs = [Text] -> Lexemes
mkLexemes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Text
T.strip
mkLexemes :: [Text] -> Lexemes
mkLexemes :: [Text] -> Lexemes
mkLexemes [] = forall a. Monoid a => a
mempty
mkLexemes (Text
"--" : [Text]
rest) = [Text] -> Lexemes
argsLexemes [Text]
rest
mkLexemes [Text
t] =
if Text -> Bool
isDashed Text
t
then
if Text
"=" Text -> Text -> Bool
`T.isInfixOf` Text
t
then Text -> Lexemes
makeEqualOptionLexeme Text
t
else Text -> Lexemes
makeFlagsLexeme Text
t
else Text -> Lexemes
argLexemes (Text -> Text
dropDashed Text
t)
mkLexemes (Text
t : [Text]
rest) =
if Text -> Bool
isDashed Text
t
then
if Text
"=" Text -> Text -> Bool
`T.isInfixOf` Text
t
then Text -> Lexemes
makeEqualOptionLexeme Text
t forall a. Semigroup a => a -> a -> a
<> [Text] -> Lexemes
mkLexemes [Text]
rest
else
do
let key :: Text
key = Text -> Text
dropDashed Text
t
let ([Text]
vs, [Text]
others) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Text -> Bool
isDashed [Text]
rest
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
vs
then Text -> Lexemes
makeFlagsLexeme Text
t forall a. Semigroup a => a -> a -> a
<> [Text] -> Lexemes
mkLexemes [Text]
others
else
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Text -> Bool
isDashed [Text]
others
then Text -> [Text] -> Lexemes
optionsLexemes Text
key [Text]
vs forall a. Semigroup a => a -> a -> a
<> [Text] -> Lexemes
mkLexemes [Text]
others
else
Text -> [Text] -> Lexemes
ambiguousLexemes Text
key [Text]
rest
else Text -> Lexemes
argLexemes Text
t forall a. Semigroup a => a -> a -> a
<> [Text] -> Lexemes
mkLexemes [Text]
rest
optionLexemes :: Text -> Text -> Lexemes
optionLexemes :: Text -> Text -> Lexemes
optionLexemes Text
k = Text -> [Text] -> Lexemes
optionsLexemes Text
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
optionsLexemes :: Text -> [Text] -> Lexemes
optionsLexemes :: Text -> [Text] -> Lexemes
optionsLexemes Text
k [Text]
vs = MultiMap Text Text
-> [Text] -> [Text] -> Maybe (Text, [Text]) -> Lexemes
Lexemes (forall k a. Ord k => [(k, a)] -> MultiMap k a
M.fromList ((Text
k,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
vs)) forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Maybe a
Nothing
makeEqualOptionLexeme :: Text -> Lexemes
makeEqualOptionLexeme :: Text -> Lexemes
makeEqualOptionLexeme Text
t = do
case Text -> Text -> [Text]
T.splitOn Text
"=" (Text -> Text
dropDashed Text
t) of
[Text
optionName, Text
optionValue] -> Text -> Text -> Lexemes
optionLexemes Text
optionName Text
optionValue
[Text]
_ -> forall a. Monoid a => a
mempty
makeFlagsLexeme :: Text -> Lexemes
makeFlagsLexeme :: Text -> Lexemes
makeFlagsLexeme Text
t =
( if Text -> Bool
isSingleDashed Text
t
then
[Text] -> Lexemes
flagsLexemes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Text
T.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
else Text -> Lexemes
flagLexemes
)
(Text -> Text
dropDashed Text
t)
flagLexemes :: Text -> Lexemes
flagLexemes :: Text -> Lexemes
flagLexemes = [Text] -> Lexemes
flagsLexemes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
flagsLexemes :: [Text] -> Lexemes
flagsLexemes :: [Text] -> Lexemes
flagsLexemes [Text]
fs = MultiMap Text Text
-> [Text] -> [Text] -> Maybe (Text, [Text]) -> Lexemes
Lexemes forall k a. MultiMap k a
M.empty [Text]
fs forall a. Monoid a => a
mempty forall a. Maybe a
Nothing
argLexemes :: Text -> Lexemes
argLexemes :: Text -> Lexemes
argLexemes = [Text] -> Lexemes
argsLexemes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
argsLexemes :: [Text] -> Lexemes
argsLexemes :: [Text] -> Lexemes
argsLexemes [Text]
ts = MultiMap Text Text
-> [Text] -> [Text] -> Maybe (Text, [Text]) -> Lexemes
Lexemes forall k a. MultiMap k a
M.empty forall a. Monoid a => a
mempty [Text]
ts forall a. Maybe a
Nothing
ambiguousLexemes :: Text -> [Text] -> Lexemes
ambiguousLexemes :: Text -> [Text] -> Lexemes
ambiguousLexemes Text
t [Text]
ts = MultiMap Text Text
-> [Text] -> [Text] -> Maybe (Text, [Text]) -> Lexemes
Lexemes forall k a. MultiMap k a
M.empty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall a. a -> Maybe a
Just (Text
t, [Text]
ts))
getArguments :: Lexemes -> [Text]
getArguments :: Lexemes -> [Text]
getArguments (Lexemes MultiMap Text Text
_ [Text]
_ [Text]
as Maybe (Text, [Text])
Nothing) = [Text]
as
getArguments (Lexemes MultiMap Text Text
_ [Text]
_ [Text]
as1 (Just (Text
_, [Text]
as2))) = [Text]
as1 forall a. Semigroup a => a -> a -> a
<> [Text]
as2
getFlagNames :: Lexemes -> [Text]
getFlagNames :: Lexemes -> [Text]
getFlagNames (Lexemes MultiMap Text Text
m [Text]
fs [Text]
_ Maybe (Text, [Text])
am) = forall k a. MultiMap k a -> [k]
M.keys MultiMap Text Text
m forall a. Semigroup a => a -> a -> a
<> [Text]
fs forall a. Semigroup a => a -> a -> a
<> (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe (Text, [Text])
am)
getValue :: Text -> Lexemes -> Maybe (Maybe Text)
getValue :: Text -> Lexemes -> Maybe (Maybe Text)
getValue Text
key (Lexemes MultiMap Text Text
options [Text]
flags [Text]
_ Maybe (Text, [Text])
ambiguous) =
case forall a. [a] -> Maybe a
headMay (forall k a. Ord k => k -> MultiMap k a -> [a]
M.lookup Text
key MultiMap Text Text
options) of
Just Text
v -> forall a. a -> Maybe a
Just (forall a. a -> Maybe a
Just Text
v)
Maybe Text
Nothing ->
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
== Text
key) [Text]
flags of
Just Text
_ -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
Maybe Text
Nothing -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, [Text]) -> Maybe Text
getAmbiguousValue Maybe (Text, [Text])
ambiguous
where
getAmbiguousValue :: Maybe (Text, [Text]) -> Maybe Text
getAmbiguousValue Maybe (Text, [Text])
Nothing = forall a. Maybe a
Nothing
getAmbiguousValue (Just (Text
k, [Text]
vs)) =
if Text
k forall a. Eq a => a -> a -> Bool
== Text
key
then forall a. [a] -> Maybe a
headMay [Text]
vs
else forall a. Maybe a
Nothing
popOptionValue :: Text -> Lexemes -> Lexemes
popOptionValue :: Text -> Lexemes -> Lexemes
popOptionValue Text
key Lexemes
ls =
Lexemes
ls
{ lexedOptions :: MultiMap Text Text
lexedOptions = forall k v. Ord k => k -> MultiMap k v -> MultiMap k v
pop Text
key forall a b. (a -> b) -> a -> b
$ Lexemes -> MultiMap Text Text
lexedOptions Lexemes
ls,
lexedFlags :: [Text]
lexedFlags = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Text
key) forall a b. (a -> b) -> a -> b
$ Lexemes -> [Text]
lexedFlags Lexemes
ls,
lexedAmbiguous :: Maybe (Text, [Text])
lexedAmbiguous = case Lexemes -> Maybe (Text, [Text])
lexedAmbiguous Lexemes
ls of
Just (Text
k, []) | Text
k forall a. Eq a => a -> a -> Bool
== Text
key -> forall a. Maybe a
Nothing
Just (Text
k, Text
_ : [Text]
as) | Text
k forall a. Eq a => a -> a -> Bool
== Text
key -> forall a. a -> Maybe a
Just (Text
k, [Text]
as)
Maybe (Text, [Text])
other -> Maybe (Text, [Text])
other
}
popArgumentValue :: Lexemes -> Lexemes
popArgumentValue :: Lexemes -> Lexemes
popArgumentValue Lexemes
ls =
case Lexemes -> [Text]
lexedArguments Lexemes
ls of
(Text
_ : [Text]
as) -> Lexemes
ls {lexedArguments :: [Text]
lexedArguments = [Text]
as}
[] ->
Lexemes
ls
{ lexedAmbiguous :: Maybe (Text, [Text])
lexedAmbiguous = case Lexemes -> Maybe (Text, [Text])
lexedAmbiguous Lexemes
ls of
Maybe (Text, [Text])
Nothing -> forall a. Maybe a
Nothing
Just (Text
_, []) -> forall a. Maybe a
Nothing
Just (Text
k, Text
_ : [Text]
as) -> forall a. a -> Maybe a
Just (Text
k, [Text]
as)
}
popFlag :: Text -> Lexemes -> Lexemes
popFlag :: Text -> Lexemes -> Lexemes
popFlag Text
f Lexemes
ls = do
let ([Text]
before, [Text]
after) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break (forall a. Eq a => a -> a -> Bool
== Text
f) forall a b. (a -> b) -> a -> b
$ Lexemes -> [Text]
lexedFlags Lexemes
ls
let ([Text]
args, Maybe (Text, [Text])
amb) =
case Lexemes -> Maybe (Text, [Text])
lexedAmbiguous Lexemes
ls of
Just (Text
k, [Text]
vs) | Text
f forall a. Eq a => a -> a -> Bool
== Text
k -> ([Text]
vs forall a. Semigroup a => a -> a -> a
<> Lexemes -> [Text]
lexedArguments Lexemes
ls, forall a. Maybe a
Nothing)
Maybe (Text, [Text])
other -> (Lexemes -> [Text]
lexedArguments Lexemes
ls, Maybe (Text, [Text])
other)
Lexemes
ls
{ lexedFlags :: [Text]
lexedFlags = [Text]
before forall a. Semigroup a => a -> a -> a
<> forall a. Int -> [a] -> [a]
drop Int
1 [Text]
after,
lexedArguments :: [Text]
lexedArguments = [Text]
args,
lexedAmbiguous :: Maybe (Text, [Text])
lexedAmbiguous = Maybe (Text, [Text])
amb
}
isDashed :: Text -> Bool
isDashed :: Text -> Bool
isDashed = Text -> Text -> Bool
T.isPrefixOf Text
"-"
isSingleDashed :: Text -> Bool
isSingleDashed :: Text -> Bool
isSingleDashed Text
t = Text -> Text -> Bool
T.isPrefixOf Text
"-" Text
t Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Text -> Bool
T.isPrefixOf Text
"-" (Int -> Text -> Text
T.drop Int
1 Text
t))
dropDashed :: Text -> Text
dropDashed :: Text -> Text
dropDashed = (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'-')
instance (Show k, Show v) => Show (MultiMap k v) where
show :: MultiMap k v -> String
show = forall a b. (Show a, StringConv String b) => a -> b
P.show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. MultiMap k a -> [(k, [a])]
M.assocs
instance (Eq k, Eq v) => Eq (MultiMap k v) where
MultiMap k v
m1 == :: MultiMap k v -> MultiMap k v -> Bool
== MultiMap k v
m2 = forall k a. MultiMap k a -> [(k, [a])]
M.assocs MultiMap k v
m1 forall a. Eq a => a -> a -> Bool
== forall k a. MultiMap k a -> [(k, [a])]
M.assocs MultiMap k v
m2
pop :: (Ord k) => k -> MultiMap k v -> MultiMap k v
pop :: forall k v. Ord k => k -> MultiMap k v -> MultiMap k v
pop k
key MultiMap k v
m =
forall k a. Map k [a] -> MultiMap k a
M.fromMap forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ (\(k
k, [v]
vs) -> if k
k forall a. Eq a => a -> a -> Bool
== k
key then (k
k, forall a. Int -> [a] -> [a]
drop Int
1 [v]
vs) else (k
k, [v]
vs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. MultiMap k a -> [(k, [a])]
M.assocs MultiMap k v
m