1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
{-# 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(..)
, Haystack(..)
, Regex(..)
, URegularExpression
-- * Functions
, emptyForeignPtr
, regex
, uregex_clone
, uregex_close
, uregex_end
, uregex_find
, uregex_findNext
, uregex_getText
, uregex_group
, uregex_groupCount
, uregex_pattern
, uregex_setText
, uregex_start
) where
import Control.Monad (when)
import Data.IORef (IORef, newIORef)
import Data.Int (Int32)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Foreign as T
import Data.Text.ICU.Internal (UBool, UChar)
import Data.Text.ICU.Error (isRegexError)
import Data.Text.ICU.Error.Internal (UParseError, UErrorCode,
handleError, handleParseError)
import Data.Typeable (Typeable)
import Data.Word (Word16, Word32)
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, touchForeignPtr, withForeignPtr)
import Foreign.Ptr (FunPtr, Ptr)
import System.IO.Unsafe (unsafePerformIO)
#include <unicode/uregex.h>
-- | 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 avaliable 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 (Eq, Show, Typeable)
data Haystack = H (ForeignPtr Word16) {-# UNPACK #-} !T.I16
-- | 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 {
reRe :: ForeignPtr URegularExpression
, reText :: IORef Haystack
}
emptyForeignPtr :: ForeignPtr Word16
emptyForeignPtr = unsafePerformIO $ fst `fmap` T.asForeignPtr T.empty
{-# NOINLINE emptyForeignPtr #-}
-- | 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 opts pat = T.useAsPtr pat $ \pptr plen -> do
let (flags,workLimit,stackLimit) = toURegexpOpts opts
ptr <- handleParseError isRegexError $
uregex_open pptr (fromIntegral plen) flags
refp <- newForeignPtr uregex_close ptr
(hayfp, hayLen) <- T.asForeignPtr T.empty
withForeignPtr refp $ \rePtr ->
withForeignPtr hayfp $ \hayPtr -> handleError $
uregex_setText rePtr hayPtr (fromIntegral hayLen)
when (workLimit > -1) .
handleError $ uregex_setTimeLimit ptr (fromIntegral workLimit)
when (stackLimit > -1) .
handleError $ uregex_setStackLimit ptr (fromIntegral stackLimit)
touchForeignPtr refp
Regex refp `fmap` newIORef (H hayfp 0)
data URegularExpression
type URegexpFlag = Word32
toURegexpOpts :: [MatchOption] -> (URegexpFlag,Int,Int)
toURegexpOpts = foldl go (0,-1,-1)
where
go (!flag,work,stack) opt = (flag+flag',work',stack')
where
flag' = case opt of
CaseInsensitive -> #const UREGEX_CASE_INSENSITIVE
Comments -> #const UREGEX_COMMENTS
DotAll -> #const UREGEX_DOTALL
Literal -> #const UREGEX_LITERAL
Multiline -> #const UREGEX_MULTILINE
HaskellLines -> #const UREGEX_UNIX_LINES
UnicodeWord -> #const UREGEX_UWORD
ErrorOnUnknownEscapes -> #const UREGEX_ERROR_ON_UNKNOWN_ESCAPES
_ -> 0
work' = case opt of
WorkLimit limit -> limit
_ -> work
stack' = case opt of
StackLimit limit -> limit
_ -> 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_setText" uregex_setText
:: Ptr URegularExpression -> Ptr UChar -> Int32 -> 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 ()
|
