{-# LINE 1 "Data/Text/ICU/Regex/Internal.hsc" #-}
{-# LANGUAGE BangPatterns, DeriveDataTypeable, EmptyDataDecls,
    ForeignFunctionInterface, MagicHash, RecordWildCards,
    ScopedTypeVariables #-}

-- |
-- Module      : Data.Text.ICU.Regex.Internal
-- Copyright   : (c) 2010 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Regular expression support for Unicode, implemented as bindings to
-- the International Components for Unicode (ICU) libraries.
--
-- The syntax and behaviour of ICU regular expressions are Perl-like.
-- For complete details, see the ICU User Guide entry at
-- <http://userguide.icu-project.org/strings/regexp>.

module Data.Text.ICU.Regex.Internal
    (
    -- * Types
      MatchOption(..)
    , Regex(..)
    , URegularExpression
    -- * Functions
    , regex
    , uregex_clone
    , uregex_close
    , uregex_end
    , uregex_find
    , uregex_findNext
    , uregex_getText
    , uregex_group
    , uregex_groupCount
    , uregex_pattern
    , uregex_setUText
    , uregex_start
    ) where

import Control.Monad (when)
import Data.IORef (IORef, newIORef)
import Data.Int (Int32)
import Data.Text (Text)
import Data.Text.ICU.Internal (UBool, UChar, UTextPtr, UText, useAsUCharPtr, withUTextPtr, emptyUTextPtr, newICUPtr)
import Data.Text.ICU.Error (isRegexError)
import Data.Text.ICU.Error.Internal (UParseError, UErrorCode,
                                     handleError, handleParseError)
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Foreign.ForeignPtr (ForeignPtr)
import Foreign.Ptr (FunPtr, Ptr)



-- | Options for controlling matching behaviour.
data MatchOption
    = CaseInsensitive
    -- ^ Enable case insensitive matching.
    | Comments
    -- ^ Allow comments and white space within patterns.
    | DotAll
    -- ^ If set, @\'.\'@ matches line terminators. Otherwise @\'.\'@
    -- matching stops at line end.
    | Literal
    -- ^ If set, treat the entire pattern as a literal string.
    --  Metacharacters or escape sequences in the input sequence will
    --  be given no special meaning.
    --
    --  The option 'CaseInsensitive' retains its meanings on matching
    --  when used in conjunction with this option.  Other options
    --  become superfluous.
    | Multiline
    -- ^ Control behaviour of @\'$\'@ and @\'^\'@. If set, recognize
    -- line terminators within string, Otherwise, match only at start
    -- and end of input string.
    | HaskellLines
    -- ^ Haskell-only line endings.  When this mode is enabled, only
    -- @\'\\n\'@ is recognized as a line ending in the behavior of
    -- @\'.\'@, @\'^\'@, and @\'$\'@.
    | UnicodeWord
    -- ^ Unicode word boundaries.  If set, @\'\\\\b\'@ uses the
    -- Unicode TR 29 definition of word boundaries.
    --
    -- /Warning/: Unicode word boundaries are quite different from
    -- traditional regular expression word boundaries.  See
    -- <http://unicode.org/reports/tr29/#Word_Boundaries>.
    | ErrorOnUnknownEscapes
    -- ^ Throw an error on unrecognized backslash escapes.  If set,
    -- fail with an error on patterns that contain backslash-escaped
    -- ASCII letters without a known special meaning.  If this flag is
    -- not set, these escaped letters represent themselves.
    | WorkLimit Int
    -- ^ Set a processing limit for match operations.
    --
    -- Some patterns, when matching certain strings, can run in
    -- exponential time.  For practical purposes, the match operation
    -- may appear to be in an infinite loop.  When a limit is set a
    -- match operation will fail with an error if the limit is
    -- exceeded.
    --
    -- The units of the limit are steps of the match engine.
    -- Correspondence with actual processor time will depend on the
    -- speed of the processor and the details of the specific pattern,
    -- but will typically be on the order of milliseconds.
    --
    -- By default, the matching time is not limited.
    | StackLimit Int
    -- ^ Set the amount of heap storage available for use by the match
    -- backtracking stack.
    --
    -- ICU uses a backtracking regular expression engine, with the
    -- backtrack stack maintained on the heap.  This function sets the
    -- limit to the amount of memory that can be used for this
    -- purpose.  A backtracking stack overflow will result in an error
    -- from the match operation that caused it.
    --
    -- A limit is desirable because a malicious or poorly designed
    -- pattern can use excessive memory, potentially crashing the
    -- process.  A limit is enabled by default.
      deriving (MatchOption -> MatchOption -> Bool
(MatchOption -> MatchOption -> Bool)
-> (MatchOption -> MatchOption -> Bool) -> Eq MatchOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MatchOption -> MatchOption -> Bool
$c/= :: MatchOption -> MatchOption -> Bool
== :: MatchOption -> MatchOption -> Bool
$c== :: MatchOption -> MatchOption -> Bool
Eq, Int -> MatchOption -> ShowS
[MatchOption] -> ShowS
MatchOption -> String
(Int -> MatchOption -> ShowS)
-> (MatchOption -> String)
-> ([MatchOption] -> ShowS)
-> Show MatchOption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatchOption] -> ShowS
$cshowList :: [MatchOption] -> ShowS
show :: MatchOption -> String
$cshow :: MatchOption -> String
showsPrec :: Int -> MatchOption -> ShowS
$cshowsPrec :: Int -> MatchOption -> ShowS
Show, Typeable)

-- | A compiled regular expression.
--
-- 'Regex' values are usually constructed using the 'regex' or
-- 'regex'' functions.  This type is also an instance of 'IsString',
-- so if you have the @OverloadedStrings@ language extension enabled,
-- you can construct a 'Regex' by simply writing the pattern in
-- quotes (though this does not allow you to specify any 'Option's).
data Regex = Regex {
      Regex -> ForeignPtr URegularExpression
reRe :: ForeignPtr URegularExpression
    , Regex -> IORef UTextPtr
reText :: IORef UTextPtr
    }

-- | Compile a regular expression with the given options.  This
-- function throws a 'ParseError' if the pattern is invalid.
--
-- The 'Regex' is initialized with empty text to search against.
regex :: [MatchOption] -> Text -> IO Regex
regex :: [MatchOption] -> Text -> IO Regex
regex [MatchOption]
opts Text
pat = Text -> (Ptr UChar -> I16 -> IO Regex) -> IO Regex
forall a. Text -> (Ptr UChar -> I16 -> IO a) -> IO a
useAsUCharPtr Text
pat ((Ptr UChar -> I16 -> IO Regex) -> IO Regex)
-> (Ptr UChar -> I16 -> IO Regex) -> IO Regex
forall a b. (a -> b) -> a -> b
$ \Ptr UChar
pptr I16
plen ->
  (ForeignPtr URegularExpression -> IORef UTextPtr -> Regex)
-> FinalizerPtr URegularExpression
-> IO (Ptr URegularExpression)
-> IO (IORef UTextPtr -> Regex)
forall a i.
(ForeignPtr a -> i) -> FinalizerPtr a -> IO (Ptr a) -> IO i
newICUPtr ForeignPtr URegularExpression -> IORef UTextPtr -> Regex
Regex FinalizerPtr URegularExpression
uregex_close (do
    Ptr URegularExpression
ptr <- (ICUError -> Bool)
-> (Ptr UParseError
    -> Ptr UErrorCode -> IO (Ptr URegularExpression))
-> IO (Ptr URegularExpression)
forall a.
(ICUError -> Bool)
-> (Ptr UParseError -> Ptr UErrorCode -> IO a) -> IO a
handleParseError ICUError -> Bool
isRegexError ((Ptr UParseError -> Ptr UErrorCode -> IO (Ptr URegularExpression))
 -> IO (Ptr URegularExpression))
-> (Ptr UParseError
    -> Ptr UErrorCode -> IO (Ptr URegularExpression))
-> IO (Ptr URegularExpression)
forall a b. (a -> b) -> a -> b
$
           Ptr UChar
-> Int32
-> URegexpFlag
-> Ptr UParseError
-> Ptr UErrorCode
-> IO (Ptr URegularExpression)
uregex_open Ptr UChar
pptr (I16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral I16
plen) URegexpFlag
flags
    UTextPtr -> (Ptr UText -> IO ()) -> IO ()
forall a. UTextPtr -> (Ptr UText -> IO a) -> IO a
withUTextPtr UTextPtr
hayfp ((Ptr UText -> IO ()) -> IO ()) -> (Ptr UText -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr UText
hayPtr -> (Ptr UErrorCode -> IO ()) -> IO ()
forall a. (Ptr UErrorCode -> IO a) -> IO a
handleError ((Ptr UErrorCode -> IO ()) -> IO ())
-> (Ptr UErrorCode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      Ptr URegularExpression -> Ptr UText -> Ptr UErrorCode -> IO ()
uregex_setUText Ptr URegularExpression
ptr Ptr UText
hayPtr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
workLimit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -Int
1) (IO () -> IO ())
-> ((Ptr UErrorCode -> IO ()) -> IO ())
-> (Ptr UErrorCode -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (Ptr UErrorCode -> IO ()) -> IO ()
forall a. (Ptr UErrorCode -> IO a) -> IO a
handleError ((Ptr UErrorCode -> IO ()) -> IO ())
-> (Ptr UErrorCode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr URegularExpression -> Int32 -> Ptr UErrorCode -> IO ()
uregex_setTimeLimit Ptr URegularExpression
ptr (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
workLimit)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
stackLimit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> -Int
1) (IO () -> IO ())
-> ((Ptr UErrorCode -> IO ()) -> IO ())
-> (Ptr UErrorCode -> IO ())
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (Ptr UErrorCode -> IO ()) -> IO ()
forall a. (Ptr UErrorCode -> IO a) -> IO a
handleError ((Ptr UErrorCode -> IO ()) -> IO ())
-> (Ptr UErrorCode -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr URegularExpression -> Int32 -> Ptr UErrorCode -> IO ()
uregex_setStackLimit Ptr URegularExpression
ptr (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stackLimit)
    Ptr URegularExpression -> IO (Ptr URegularExpression)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr URegularExpression
ptr)
  IO (IORef UTextPtr -> Regex) -> IO (IORef UTextPtr) -> IO Regex
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTextPtr -> IO (IORef UTextPtr)
forall a. a -> IO (IORef a)
newIORef UTextPtr
hayfp
  where (URegexpFlag
flags,Int
workLimit,Int
stackLimit) = [MatchOption] -> (URegexpFlag, Int, Int)
toURegexpOpts [MatchOption]
opts
        hayfp :: UTextPtr
hayfp = UTextPtr
emptyUTextPtr

data URegularExpression

type URegexpFlag = Word32

toURegexpOpts :: [MatchOption] -> (URegexpFlag,Int,Int)
toURegexpOpts :: [MatchOption] -> (URegexpFlag, Int, Int)
toURegexpOpts = ((URegexpFlag, Int, Int) -> MatchOption -> (URegexpFlag, Int, Int))
-> (URegexpFlag, Int, Int)
-> [MatchOption]
-> (URegexpFlag, Int, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (URegexpFlag, Int, Int) -> MatchOption -> (URegexpFlag, Int, Int)
forall {a}. Num a => (a, Int, Int) -> MatchOption -> (a, Int, Int)
go (URegexpFlag
0,-Int
1,-Int
1)
  where
    go :: (a, Int, Int) -> MatchOption -> (a, Int, Int)
go (!a
flag,Int
work,Int
stack) MatchOption
opt = (a
flaga -> a -> a
forall a. Num a => a -> a -> a
+a
flag',Int
work',Int
stack')
     where
      flag' :: a
flag' = case MatchOption
opt of
                MatchOption
CaseInsensitive       -> a
2
{-# LINE 167 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
Comments              -> a
4
{-# LINE 168 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
DotAll                -> a
32
{-# LINE 169 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
Literal               -> a
16
{-# LINE 170 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
Multiline             -> a
8
{-# LINE 171 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
HaskellLines          -> a
1
{-# LINE 172 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
UnicodeWord           -> a
256
{-# LINE 173 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
ErrorOnUnknownEscapes -> a
512
{-# LINE 174 "Data/Text/ICU/Regex/Internal.hsc" #-}
                MatchOption
_                     -> a
0
      work' :: Int
work' = case MatchOption
opt of
                WorkLimit Int
limit       -> Int
limit
                MatchOption
_                     -> Int
work
      stack' :: Int
stack' = case MatchOption
opt of
                 StackLimit Int
limit     -> Int
limit
                 MatchOption
_                    -> Int
stack

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_open" uregex_open
    :: Ptr UChar -> Int32 -> Word32 -> Ptr UParseError -> Ptr UErrorCode
    -> IO (Ptr URegularExpression)

foreign import ccall unsafe "hs_text_icu.h &__hs_uregex_close" uregex_close
    :: FunPtr (Ptr URegularExpression -> IO ())

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_clone" uregex_clone
    :: Ptr URegularExpression -> Ptr UErrorCode
    -> IO (Ptr URegularExpression)

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_pattern" uregex_pattern
    :: Ptr URegularExpression -> Ptr Int32 -> Ptr UErrorCode
    -> IO (Ptr UChar)

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_setUText" uregex_setUText
    :: Ptr URegularExpression -> Ptr UText -> Ptr UErrorCode -> IO ()

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_getText" uregex_getText
    :: Ptr URegularExpression -> Ptr Int32 -> Ptr UErrorCode -> IO (Ptr UChar)

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_find" uregex_find
    :: Ptr URegularExpression -> Int32 -> Ptr UErrorCode -> IO UBool

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_findNext" uregex_findNext
    :: Ptr URegularExpression -> Ptr UErrorCode -> IO UBool

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_start" uregex_start
    :: Ptr URegularExpression -> Int32 -> Ptr UErrorCode -> IO Int32

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_end" uregex_end
    :: Ptr URegularExpression -> Int32 -> Ptr UErrorCode -> IO Int32

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_groupCount" uregex_groupCount
    :: Ptr URegularExpression -> Ptr UErrorCode -> IO Int32

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_group" uregex_group
    :: Ptr URegularExpression -> Int32 -> Ptr UChar -> Int32 -> Ptr UErrorCode
    -> IO Int32

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_setTimeLimit" uregex_setTimeLimit
    :: Ptr URegularExpression -> Int32 -> Ptr UErrorCode -> IO ()

foreign import ccall unsafe "hs_text_icu.h __hs_uregex_setStackLimit" uregex_setStackLimit
    :: Ptr URegularExpression -> Int32 -> Ptr UErrorCode -> IO ()