-- | This module is a subset of the defunct regex-compat-tdfa.
{-# LANGUAGE CPP #-}
module Darcs.Util.Regex
    ( Regex
    , mkRegex
    , mkRegexWithOpts
    , matchRegex
    ) where

import Darcs.Prelude

import Control.Exception ( throw )
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif
import Text.Regex.Base
    ( RegexContext(matchM)
    , RegexMaker(makeRegexOptsM)
    , defaultCompOpt
    , defaultExecOpt
    )
import Text.Regex.TDFA ( Regex, caseSensitive, multiline, newSyntax )

-- | The "sane" API for regex ('makeRegexOptM') requires 'MonadFail'
-- but we want a pure one for compatibility with e.g. "Darcs.Patch.Match".
newtype RegexFail a = RegexFail { forall a. RegexFail a -> Either String a
runRegexFail :: Either String a }
  -- The subtlety here is that only in base-4.13.0 the fail method
  -- in class Monad was removed. For earlier versions, regex-tdfa
  -- calls the fail from class Monad, not the one from class MonadFail.
#if MIN_VERSION_base(4,13,0)
  deriving ((forall a b. (a -> b) -> RegexFail a -> RegexFail b)
-> (forall a b. a -> RegexFail b -> RegexFail a)
-> Functor RegexFail
forall a b. a -> RegexFail b -> RegexFail a
forall a b. (a -> b) -> RegexFail a -> RegexFail b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> RegexFail a -> RegexFail b
fmap :: forall a b. (a -> b) -> RegexFail a -> RegexFail b
$c<$ :: forall a b. a -> RegexFail b -> RegexFail a
<$ :: forall a b. a -> RegexFail b -> RegexFail a
Functor, Functor RegexFail
Functor RegexFail =>
(forall a. a -> RegexFail a)
-> (forall a b. RegexFail (a -> b) -> RegexFail a -> RegexFail b)
-> (forall a b c.
    (a -> b -> c) -> RegexFail a -> RegexFail b -> RegexFail c)
-> (forall a b. RegexFail a -> RegexFail b -> RegexFail b)
-> (forall a b. RegexFail a -> RegexFail b -> RegexFail a)
-> Applicative RegexFail
forall a. a -> RegexFail a
forall a b. RegexFail a -> RegexFail b -> RegexFail a
forall a b. RegexFail a -> RegexFail b -> RegexFail b
forall a b. RegexFail (a -> b) -> RegexFail a -> RegexFail b
forall a b c.
(a -> b -> c) -> RegexFail a -> RegexFail b -> RegexFail c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> RegexFail a
pure :: forall a. a -> RegexFail a
$c<*> :: forall a b. RegexFail (a -> b) -> RegexFail a -> RegexFail b
<*> :: forall a b. RegexFail (a -> b) -> RegexFail a -> RegexFail b
$cliftA2 :: forall a b c.
(a -> b -> c) -> RegexFail a -> RegexFail b -> RegexFail c
liftA2 :: forall a b c.
(a -> b -> c) -> RegexFail a -> RegexFail b -> RegexFail c
$c*> :: forall a b. RegexFail a -> RegexFail b -> RegexFail b
*> :: forall a b. RegexFail a -> RegexFail b -> RegexFail b
$c<* :: forall a b. RegexFail a -> RegexFail b -> RegexFail a
<* :: forall a b. RegexFail a -> RegexFail b -> RegexFail a
Applicative, Applicative RegexFail
Applicative RegexFail =>
(forall a b. RegexFail a -> (a -> RegexFail b) -> RegexFail b)
-> (forall a b. RegexFail a -> RegexFail b -> RegexFail b)
-> (forall a. a -> RegexFail a)
-> Monad RegexFail
forall a. a -> RegexFail a
forall a b. RegexFail a -> RegexFail b -> RegexFail b
forall a b. RegexFail a -> (a -> RegexFail b) -> RegexFail b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. RegexFail a -> (a -> RegexFail b) -> RegexFail b
>>= :: forall a b. RegexFail a -> (a -> RegexFail b) -> RegexFail b
$c>> :: forall a b. RegexFail a -> RegexFail b -> RegexFail b
>> :: forall a b. RegexFail a -> RegexFail b -> RegexFail b
$creturn :: forall a. a -> RegexFail a
return :: forall a. a -> RegexFail a
Monad)
#else
  deriving (Functor, Applicative)

instance Monad RegexFail where
  RegexFail (Left e) >>= _ = RegexFail (Left e)
  RegexFail (Right r) >>= k = k r
  fail = RegexFail . Left
#endif

instance MonadFail RegexFail where
  fail :: forall a. String -> RegexFail a
fail = Either String a -> RegexFail a
forall a. Either String a -> RegexFail a
RegexFail (Either String a -> RegexFail a)
-> (String -> Either String a) -> String -> RegexFail a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left

-- | Makes a regular expression with the default options (multi-line,
-- case-sensitive).  The syntax of regular expressions is
-- otherwise that of @egrep@ (i.e. POSIX \"extended\" regular
-- expressions).
mkRegex :: String -> Regex
mkRegex :: String -> Regex
mkRegex String
s = CompOption -> String -> Regex
forall p compOpt execOpt.
RegexMaker p compOpt execOpt String =>
compOpt -> String -> p
mkRegexInternal CompOption
opt String
s
  where
    opt :: CompOption
opt = CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt {newSyntax = True, multiline = True}

-- | Makes a regular expression, where the multi-line and
-- case-sensitive options can be changed from the default settings.
mkRegexWithOpts
   :: String  -- ^ The regular expression to compile
   -> Bool    -- ^ 'True' @\<=>@ @\'^\'@ and @\'$\'@ match the beginning and 
              -- end of individual lines respectively, and @\'.\'@ does /not/
              -- match the newline character.
   -> Bool    -- ^ 'True' @\<=>@ matching is case-sensitive
   -> Regex   -- ^ Returns: the compiled regular expression
mkRegexWithOpts :: String -> Bool -> Bool -> Regex
mkRegexWithOpts String
s Bool
single_line Bool
case_sensitive
  = let opt :: CompOption
opt = CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
defaultCompOpt
                { multiline    = (if single_line then True else False)
                , caseSensitive = (if case_sensitive then True else False)
                , newSyntax     = True }
    in CompOption -> String -> Regex
forall p compOpt execOpt.
RegexMaker p compOpt execOpt String =>
compOpt -> String -> p
mkRegexInternal CompOption
opt String
s

mkRegexInternal :: RegexMaker p compOpt execOpt String => compOpt -> String -> p
mkRegexInternal :: forall p compOpt execOpt.
RegexMaker p compOpt execOpt String =>
compOpt -> String -> p
mkRegexInternal compOpt
opt String
s =
  case RegexFail p -> Either String p
forall a. RegexFail a -> Either String a
runRegexFail (compOpt -> execOpt -> String -> RegexFail p
forall regex compOpt execOpt source (m :: * -> *).
(RegexMaker regex compOpt execOpt source, MonadFail m) =>
compOpt -> execOpt -> source -> m regex
forall (m :: * -> *).
MonadFail m =>
compOpt -> execOpt -> String -> m p
makeRegexOptsM compOpt
opt execOpt
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
defaultExecOpt String
s) of
    Left String
e -> IOError -> p
forall a e. Exception e => e -> a
throw (String -> IOError
userError (String
"Invalid regular expression:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e))
    Right p
r -> p
r

-- | Match a regular expression against a string
matchRegex ::
     Regex -- ^ The regular expression
  -> String -- ^ The string to match against
  -> Maybe [String] -- ^ Returns: @'Just' strs@ if the match succeeded
                      -- (and @strs@ is the list of subexpression matches),
                      -- or 'Nothing' otherwise.
matchRegex :: Regex -> String -> Maybe [String]
matchRegex Regex
p String
str = ((String, String, String, [String]) -> [String])
-> Maybe (String, String, String, [String]) -> Maybe [String]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, String, String, [String]) -> [String]
go (Regex -> String -> Maybe (String, String, String, [String])
forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
forall (m :: * -> *).
MonadFail m =>
Regex -> String -> m (String, String, String, [String])
matchM Regex
p String
str)
  where
    go :: (String, String, String, [String]) -> [String]
    go :: (String, String, String, [String]) -> [String]
go (String
_, String
_, String
_, [String]
ss) = [String]
ss