module Sos.Rule
( Rule(..)
, RawRule(..)
, RawPattern
, buildRule
, buildRawRule
) where
import Sos.Exception
import Sos.Template
import Control.Applicative
import Control.Monad.Catch (MonadThrow, throwM)
import Data.Aeson.Compat ((.:), FromJSON(..), Parser, Value(..))
import Data.Aeson.Types (typeMismatch)
import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w)
import Data.Either
import Data.Text (Text)
import Text.Regex.TDFA
import Text.Regex.TDFA.ByteString (compile)
import qualified Data.ByteString as ByteString (intercalate, singleton)
import qualified Data.Text.Encoding as Text
type RawPattern = ByteString
data Rule = Rule
{ Rule -> Regex
rulePattern :: Regex
, Rule -> Maybe Regex
ruleExclude :: Maybe Regex
, Rule -> [Template]
ruleTemplates :: [Template]
}
buildRule
:: forall m.
MonadThrow m
=> RawPattern -> [RawPattern] -> [RawTemplate] -> m Rule
buildRule :: forall (m :: * -> *).
MonadThrow m =>
RawPattern -> [RawPattern] -> [RawPattern] -> m Rule
buildRule RawPattern
pattrn [RawPattern]
excludes [RawPattern]
templates0 = do
[Template]
templates <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *). MonadThrow m => RawPattern -> m Template
parseTemplate [RawPattern]
templates0
Regex
regex <-
case forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. [Either a b] -> [a]
lefts [Template]
templates of
[] ->
CompOption -> ExecOption -> RawPattern -> m Regex
compileRegex
(CompOption
{ caseSensitive :: Bool
caseSensitive = Bool
True
, multiline :: Bool
multiline = Bool
False
, rightAssoc :: Bool
rightAssoc = Bool
True
, newSyntax :: Bool
newSyntax = Bool
True
, lastStarGreedy :: Bool
lastStarGreedy = Bool
True
})
(ExecOption
{ captureGroups :: Bool
captureGroups = Bool
False })
RawPattern
pattrn
[Int]
_ -> CompOption -> ExecOption -> RawPattern -> m Regex
compileRegex forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt RawPattern
pattrn
case [RawPattern]
excludes of
[] ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rule
{ rulePattern :: Regex
rulePattern = Regex
regex
, ruleExclude :: Maybe Regex
ruleExclude = forall a. Maybe a
Nothing
, ruleTemplates :: [Template]
ruleTemplates = [Template]
templates
})
[RawPattern]
_ -> do
Regex
exclude <-
CompOption -> ExecOption -> RawPattern -> m Regex
compileRegex forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt
(RawPattern -> [RawPattern] -> RawPattern
ByteString.intercalate (Word8 -> RawPattern
ByteString.singleton (Char -> Word8
c2w Char
'|')) [RawPattern]
excludes)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rule
{ rulePattern :: Regex
rulePattern = Regex
regex
, ruleExclude :: Maybe Regex
ruleExclude = forall a. a -> Maybe a
Just Regex
exclude
, ruleTemplates :: [Template]
ruleTemplates = [Template]
templates
})
where
compileRegex :: CompOption -> ExecOption -> RawPattern -> m Regex
compileRegex :: CompOption -> ExecOption -> RawPattern -> m Regex
compileRegex CompOption
co ExecOption
eo RawPattern
patt =
case CompOption -> ExecOption -> RawPattern -> Either String Regex
compile CompOption
co ExecOption
eo RawPattern
patt of
Left String
err -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (RawPattern -> String -> SosException
SosRegexException RawPattern
patt String
err)
Right Regex
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Regex
x
data RawRule = RawRule [RawPattern] [RawPattern] [RawTemplate]
instance FromJSON RawRule where
parseJSON :: Value -> Parser RawRule
parseJSON (Object Object
o) =
[RawPattern] -> [RawPattern] -> [RawPattern] -> RawRule
RawRule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [RawPattern]
parsePatterns forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [RawPattern]
parseExcludes forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [RawPattern]
parseCommands
where
parsePatterns :: Parser [RawPattern]
parsePatterns :: Parser [RawPattern]
parsePatterns = [Text] -> Parser [RawPattern]
go [Text
"pattern", Text
"patterns"]
parseExcludes :: Parser [RawPattern]
parseExcludes :: Parser [RawPattern]
parseExcludes = [Text] -> Parser [RawPattern]
go [Text
"exclude", Text
"excludes", Text
"excluding"] forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
parseCommands :: Parser [RawTemplate]
parseCommands :: Parser [RawPattern]
parseCommands = [Text] -> Parser [RawPattern]
go [Text
"command", Text
"commands"]
go :: [Text] -> Parser [ByteString]
go :: [Text] -> Parser [RawPattern]
go = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map Text -> RawPattern
Text.encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OneOrList a -> [a]
listify) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Object
o forall a. FromJSON a => Object -> Text -> Parser a
.:)
parseJSON Value
v = forall a. String -> Value -> Parser a
typeMismatch String
"command" Value
v
buildRawRule :: MonadThrow m => RawRule -> m [Rule]
buildRawRule :: forall (m :: * -> *). MonadThrow m => RawRule -> m [Rule]
buildRawRule (RawRule [RawPattern]
patterns [RawPattern]
excludes [RawPattern]
templates) =
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\RawPattern
pattrn -> forall (m :: * -> *).
MonadThrow m =>
RawPattern -> [RawPattern] -> [RawPattern] -> m Rule
buildRule RawPattern
pattrn [RawPattern]
excludes [RawPattern]
templates) [RawPattern]
patterns
data OneOrList a
= One a
| List [a]
deriving forall a b. a -> OneOrList b -> OneOrList a
forall a b. (a -> b) -> OneOrList a -> OneOrList b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> OneOrList b -> OneOrList a
$c<$ :: forall a b. a -> OneOrList b -> OneOrList a
fmap :: forall a b. (a -> b) -> OneOrList a -> OneOrList b
$cfmap :: forall a b. (a -> b) -> OneOrList a -> OneOrList b
Functor
instance FromJSON a => FromJSON (OneOrList a) where
parseJSON :: Value -> Parser (OneOrList a)
parseJSON v :: Value
v@(String Text
_) = forall a. a -> OneOrList a
One forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
parseJSON v :: Value
v@(Array Array
_) = forall a. [a] -> OneOrList a
List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
parseJSON Value
v = forall a. String -> Value -> Parser a
typeMismatch String
"element or list of elements" Value
v
listify :: OneOrList a -> [a]
listify :: forall a. OneOrList a -> [a]
listify (One a
x) = [a
x]
listify (List [a]
xs) = [a]
xs