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


-- | A 'ByteString' representing a pattern, e.g. "foo\.hs" or ".*\.c"
type RawPattern = ByteString


-- A Rule is a pattern to match, optional pattern to exclude, and a list of
-- templates to execute on files that match the regex.
--
-- Any mismatching of captured variables with the associated templates will be
-- caught at runtime. For example, this definition from a .sosrc yaml file is
-- incorrect:
--
--     - pattern: .*.c
--     - commands:
--       - gcc -c \1
--
-- because there is only one capture variable, and it has with index 0.
--
data Rule = Rule
  { Rule -> Regex
rulePattern   :: Regex       -- Compiled regex of file pattern.
  , Rule -> Maybe Regex
ruleExclude   :: Maybe Regex -- Compiled regex of file patterns to exclude.
  , Rule -> [Template]
ruleTemplates :: [Template]  -- Command template.
  }

-- Build a 'Rule' from a 'RawPattern', a list of 'RawPattern' (patterns to
-- exclude), and a list of 'RawTemplate' by:
--
-- - Compiling the pattern regex
-- - Compiling the exclude regexes combined with ||
-- - Parsing each 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 <-
    -- Improve performance for patterns with no capture groups.
    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

-- A "raw" Rule that is post-processed after being parsed from a yaml
-- file.
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