{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Regex.Posix.Sequence
-- Copyright   :  (c) Chris Kuklewicz 2006
-- License     :  BSD-3-Clause
--
-- Maintainer  :  hvr@gnu.org, Andreas Abel
-- Stability   :  stable
-- Portability :  non-portable (regex-base needs MPTC+FD)
--
-- This provides 'String' instances for 'RegexMaker' and 'RegexLike' based
-- on "Text.Regex.Posix.Wrap", and a ('RegexContext' 'Regex' 'String' 'String')
-- instance.
--
-- To use these instance, you would normally import
-- "Text.Regex.Posix".  You only need to import this module to use
-- the medium level API of the compile, regexec, and execute
-- functions.  All of these report error by returning Left values
-- instead of undefined or error or fail.
--
-----------------------------------------------------------------------------

module Text.Regex.Posix.Sequence(
  -- ** Types
  Regex,
  MatchOffset,
  MatchLength,
  ReturnCode,
  WrapError,
  -- ** Miscellaneous
  unusedOffset,
  -- ** Medium level API functions
  compile,
  regexec,
  execute,
  -- ** Compilation options
  CompOption(CompOption),
  compBlank,
  compExtended,   -- use extended regex syntax
  compIgnoreCase, -- ignore case when matching
  compNoSub,      -- no substring matching needed
  compNewline,    -- '.' doesn't match newline

  ExecOption(ExecOption),
  execBlank,
  execNotBOL,     -- not at begining of line
  execNotEOL     -- not at end of line
  ) where

import Prelude hiding (fail)
import Control.Monad.Fail (MonadFail(fail))

import Data.Array(listArray, Array)
import System.IO.Unsafe(unsafePerformIO)
import Text.Regex.Base.RegexLike(RegexContext(..),RegexMaker(..),RegexLike(..),MatchOffset,MatchLength,Extract(..))
import Text.Regex.Posix.Wrap
import Text.Regex.Base.Impl(polymatch,polymatchM)
import Data.Sequence as S hiding (length)
import qualified Data.Sequence as S (length)
import Foreign.C.String
import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Storable

instance RegexContext Regex (Seq Char) (Seq Char) where
  match :: Regex -> Seq Char -> Seq Char
match = forall a b. RegexLike a b => a -> b -> b
polymatch
  matchM :: forall (m :: * -> *).
MonadFail m =>
Regex -> Seq Char -> m (Seq Char)
matchM = forall a b (m :: * -> *).
(RegexLike a b, MonadFail m) =>
a -> b -> m b
polymatchM

unusedOffset :: Int
unusedOffset :: Int
unusedOffset = forall a b. (Integral a, Num b) => a -> b
fromIntegral RegOffset
unusedRegOffset

unwrap :: (Show e) => Either e v -> IO v
unwrap :: forall e v. Show e => Either e v -> IO v
unwrap Either e v
x = case Either e v
x of Left e
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Text.Regex.Posix.Sequence died: "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show e
err)
                     Right v
v -> forall (m :: * -> *) a. Monad m => a -> m a
return v
v

instance RegexMaker Regex CompOption ExecOption (Seq Char) where
  makeRegexOpts :: CompOption -> ExecOption -> Seq Char -> Regex
makeRegexOpts CompOption
c ExecOption
e Seq Char
pattern = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
    (CompOption -> ExecOption -> Seq Char -> IO (Either WrapError Regex)
compile CompOption
c ExecOption
e Seq Char
pattern forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e v. Show e => Either e v -> IO v
unwrap)
  makeRegexOptsM :: forall (m :: * -> *).
MonadFail m =>
CompOption -> ExecOption -> Seq Char -> m Regex
makeRegexOptsM CompOption
c ExecOption
e Seq Char
pattern = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => String -> m a
failforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
    (CompOption -> ExecOption -> Seq Char -> IO (Either WrapError Regex)
compile CompOption
c ExecOption
e Seq Char
pattern)

instance RegexLike Regex (Seq Char) where
  matchTest :: Regex -> Seq Char -> Bool
matchTest Regex
regex Seq Char
str = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    forall a. Seq Char -> (CString -> IO a) -> IO a
withSeq Seq Char
str (Regex -> CString -> IO (Either WrapError Bool)
wrapTest Regex
regex) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e v. Show e => Either e v -> IO v
unwrap
  matchOnce :: Regex -> Seq Char -> Maybe MatchArray
matchOnce Regex
regex Seq Char
str = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
    Regex -> Seq Char -> IO (Either WrapError (Maybe MatchArray))
execute Regex
regex Seq Char
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e v. Show e => Either e v -> IO v
unwrap
  matchAll :: Regex -> Seq Char -> [MatchArray]
matchAll Regex
regex Seq Char
str = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
    forall a. Seq Char -> (CString -> IO a) -> IO a
withSeq Seq Char
str (Regex -> CString -> IO (Either WrapError [MatchArray])
wrapMatchAll Regex
regex) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e v. Show e => Either e v -> IO v
unwrap
  matchCount :: Regex -> Seq Char -> Int
matchCount Regex
regex Seq Char
str = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$
    forall a. Seq Char -> (CString -> IO a) -> IO a
withSeq Seq Char
str (Regex -> CString -> IO (Either WrapError Int)
wrapCount Regex
regex) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e v. Show e => Either e v -> IO v
unwrap

-- compile
compile  :: CompOption -- ^ Flags (summed together)
         -> ExecOption -- ^ Flags (summed together)
         -> Seq Char   -- ^ The regular expression to compile (ASCII only, no null bytes)
         -> IO (Either WrapError Regex) -- ^ Returns: the compiled regular expression
compile :: CompOption -> ExecOption -> Seq Char -> IO (Either WrapError Regex)
compile CompOption
flags ExecOption
e Seq Char
pattern =  forall a. Seq Char -> (CString -> IO a) -> IO a
withSeq Seq Char
pattern (CompOption -> ExecOption -> CString -> IO (Either WrapError Regex)
wrapCompile CompOption
flags ExecOption
e)

-- -----------------------------------------------------------------------------
-- regexec

-- | Matches a regular expression against a string
execute :: Regex      -- ^ Compiled regular expression
        -> Seq Char   -- ^ Text to match against
        -> IO (Either WrapError (Maybe (Array Int (MatchOffset,MatchLength))))
                -- ^ Returns: 'Nothing' if the regex did not match the
                -- string, or:
                --
                -- @
                --   'Just' (array of offset length pairs)
                -- @
execute :: Regex -> Seq Char -> IO (Either WrapError (Maybe MatchArray))
execute Regex
regex Seq Char
str = do
  Either WrapError (Maybe [(RegOffset, RegOffset)])
maybeStartEnd <- forall a. Seq Char -> (CString -> IO a) -> IO a
withSeq Seq Char
str (Regex
-> CString
-> IO (Either WrapError (Maybe [(RegOffset, RegOffset)]))
wrapMatch Regex
regex)
  case Either WrapError (Maybe [(RegOffset, RegOffset)])
maybeStartEnd of
    Right Maybe [(RegOffset, RegOffset)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a. Maybe a
Nothing)
--  Right (Just []) ->  fail "got [] back!" -- return wierd array instead
    Right (Just [(RegOffset, RegOffset)]
parts) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0,forall a. Enum a => a -> a
pred (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(RegOffset, RegOffset)]
parts))
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\(RegOffset
s,RegOffset
e)->(forall a b. (Integral a, Num b) => a -> b
fromIntegral RegOffset
s, forall a b. (Integral a, Num b) => a -> b
fromIntegral (RegOffset
eforall a. Num a => a -> a -> a
-RegOffset
s)))
       forall a b. (a -> b) -> a -> b
$ [(RegOffset, RegOffset)]
parts
    Left WrapError
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left WrapError
err)

-- -----------------------------------------------------------------------------
-- regexec

-- | Matches a regular expression against a string
regexec :: Regex      -- ^ Compiled regular expression
        -> Seq Char   -- ^ Text to match against
        -> IO (Either WrapError (Maybe (Seq Char, Seq Char, Seq Char, [Seq Char])))
                -- ^ Returns: 'Nothing' if the regex did not match the
                -- string, or:
                --
                -- @
                --   'Just' (everything before match,
                --         matched portion,
                --         everything after match,
                --         subexpression matches)
                -- @
regexec :: Regex
-> Seq Char
-> IO
     (Either
        WrapError (Maybe (Seq Char, Seq Char, Seq Char, [Seq Char])))
regexec Regex
regex Seq Char
str = do
  let getSub :: (RegOffset,RegOffset) -> Seq Char
      getSub :: (RegOffset, RegOffset) -> Seq Char
getSub (RegOffset
start,RegOffset
stop) | RegOffset
start forall a. Eq a => a -> a -> Bool
== RegOffset
unusedRegOffset = forall a. Seq a
S.empty
                          | Bool
otherwise =
        forall source. Extract source => (Int, Int) -> source -> source
extract (forall a. Enum a => a -> Int
fromEnum RegOffset
start,forall a. Enum a => a -> Int
fromEnum forall a b. (a -> b) -> a -> b
$ RegOffset
stopforall a. Num a => a -> a -> a
-RegOffset
start) forall a b. (a -> b) -> a -> b
$ Seq Char
str
      matchedParts :: [(RegOffset,RegOffset)] -> (Seq Char, Seq Char, Seq Char, [Seq Char])
      matchedParts :: [(RegOffset, RegOffset)]
-> (Seq Char, Seq Char, Seq Char, [Seq Char])
matchedParts [] = (Seq Char
str,forall a. Seq a
S.empty,forall a. Seq a
S.empty,[]) -- no information
      matchedParts (matchedStartStop :: (RegOffset, RegOffset)
matchedStartStop@(RegOffset
start,RegOffset
stop):[(RegOffset, RegOffset)]
subStartStop) =
        (forall source. Extract source => Int -> source -> source
before (forall a. Enum a => a -> Int
fromEnum RegOffset
start) Seq Char
str
        ,(RegOffset, RegOffset) -> Seq Char
getSub (RegOffset, RegOffset)
matchedStartStop
        ,forall source. Extract source => Int -> source -> source
after (forall a. Enum a => a -> Int
fromEnum RegOffset
stop) Seq Char
str
        ,forall a b. (a -> b) -> [a] -> [b]
map (RegOffset, RegOffset) -> Seq Char
getSub [(RegOffset, RegOffset)]
subStartStop)
  Either WrapError (Maybe [(RegOffset, RegOffset)])
maybeStartEnd <- forall a. Seq Char -> (CString -> IO a) -> IO a
withSeq Seq Char
str (Regex
-> CString
-> IO (Either WrapError (Maybe [(RegOffset, RegOffset)]))
wrapMatch Regex
regex)
  case Either WrapError (Maybe [(RegOffset, RegOffset)])
maybeStartEnd of
    Right Maybe [(RegOffset, RegOffset)]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right forall a. Maybe a
Nothing)
    Right (Just [(RegOffset, RegOffset)]
parts) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RegOffset, RegOffset)]
-> (Seq Char, Seq Char, Seq Char, [Seq Char])
matchedParts forall a b. (a -> b) -> a -> b
$ [(RegOffset, RegOffset)]
parts
    Left WrapError
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left WrapError
err)

withSeq :: Seq Char -> (CString -> IO a) -> IO a
withSeq :: forall a. Seq Char -> (CString -> IO a) -> IO a
withSeq Seq Char
s CString -> IO a
f =
  let -- Ensure null at end of s
      s' :: Seq Char
s' = case forall a. Seq a -> ViewR a
viewr Seq Char
s of                 -- bang !s
             ViewR Char
EmptyR -> forall a. a -> Seq a
singleton Char
'\0'
             Seq Char
_ :> Char
'\0' -> Seq Char
s
             ViewR Char
_ -> Seq Char
s forall a. Seq a -> a -> Seq a
|> Char
'\0'
      pokes :: CString -> Seq Char -> IO ()
pokes CString
p Seq Char
a = case forall a. Seq a -> ViewL a
viewl Seq Char
a of         -- bang pokes !p !a
                    ViewL Char
EmptyL -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Char
c :< Seq Char
a' -> forall a. Storable a => Ptr a -> a -> IO ()
poke CString
p (Char -> CChar
castCharToCChar Char
c) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CString -> Seq Char -> IO ()
pokes (forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr CString
p Int
1) Seq Char
a'
  in forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes (forall a. Seq a -> Int
S.length Seq Char
s') (\CString
ptr -> CString -> Seq Char -> IO ()
pokes CString
ptr Seq Char
s' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CString -> IO a
f CString
ptr)