[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / lib / ghc / Regex.lhs
1 \section[regex]{Haskell binding to the GNU regex library}
2
3 What follows is a straightforward binding to the functions
4 provided by the GNU regex library (the GNU group of functions with Perl
5 like syntax)
6
7 \begin{code}
8 module Regex 
9
10         (
11          PatBuffer(..),
12          re_compile_pattern,
13          re_match,
14          re_search,
15          re_match2,
16          re_search2,
17          
18          REmatch(..)
19
20         ) where
21
22 import PreludeGlaST
23
24 \end{code}
25
26 First, the higher level matching structure that the functions herein return:
27
28 \begin{code}
29
30 --
31 -- GroupBounds hold the interval where a group
32 -- matched inside a string, e.g.
33 --
34 -- matching "reg(exp)" "a regexp" returns the pair (5,7) for the
35 -- (exp) group. (_PackedString indices start from 0)
36 --  
37
38 type GroupBounds = (Int, Int)
39
40
41 data REmatch
42  = REmatch (Array Int GroupBounds)  -- for $1, ... $n
43            GroupBounds              -- for $` (everything before match)
44            GroupBounds              -- for $& (entire matched string)
45            GroupBounds              -- for $' (everything after)
46            GroupBounds              -- for $+ (matched by last bracket)
47  {- debugging    deriving Text  -}
48
49 \end{code}
50
51 Prior to any matching (or searching), the regular expression
52 have to compiled into an internal form, the pattern buffer.
53 Represent the pattern buffer as a Haskell heap object:
54
55 \begin{code}
56
57
58 data PatBuffer = PatBuffer# (MutableByteArray# _RealWorld)
59 instance _CCallable PatBuffer
60 instance _CReturnable PatBuffer
61
62 createPatBuffer :: Bool
63                 -> PrimIO PatBuffer
64 createPatBuffer insensitive
65  = _casm_ `` %r = (int)sizeof(struct re_pattern_buffer); '' `thenPrimIO` \ sz ->
66    newCharArray (0,sz)              `thenPrimIO` \ (_MutableByteArray _ pbuf#) ->
67    let
68     pbuf = PatBuffer# pbuf#
69    in
70     (if insensitive then
71        {-
72          See comment re: fastmap below
73        -}
74        ((_casm_ `` %r = (char *)malloc(256*sizeof(char)); '')::PrimIO _Addr) `thenPrimIO` \ tmap ->
75        {-
76          Set up the translate table so that any lowercase
77          char. gets mapped to an uppercase one. Beacuse quoting
78          inside CAsmStrings is Problematic, we pass in the ordinal values
79          of 'a','z' and 'A'
80        -}
81        _casm_ `` { int i;
82
83                   for(i=0; i<256; i++)
84                      ((char *)%0)[i] = (char)i;
85                   for(i=(int)%1;i <=(int)%2;i++)
86                      ((char *)%0)[i] = i - ((int)%1 - (int)%3);
87                   %r = 0; } '' tmap (ord 'a') (ord 'z') (ord 'A')       `seqPrimIO`
88        _casm_ `` { ((struct re_pattern_buffer *)%0)->translate = %1; %r = 0; } '' pbuf tmap
89      else
90        _casm_ `` { ((struct re_pattern_buffer *)%0)->translate = 0; %r = 0; } '' pbuf) `seqPrimIO`
91     {-
92       Use a fastmap to speed things up, would like to have the fastmap
93       in the Haskell heap, but it will get GCed before we can say regexp,
94       as the reference to it is buried inside a ByteArray :-(
95     -}
96     ((_casm_ `` %r = (char *)malloc(256*sizeof(char)); '')::PrimIO _Addr) `thenPrimIO` \ fmap ->
97     _casm_ `` { ((struct re_pattern_buffer *)%0)->fastmap   = %1; %r = 0; } '' pbuf fmap `seqPrimIO`
98     {-
99       We want the compiler of the pattern to alloc. memory
100       for the pattern.
101     -}
102     _casm_ `` { ((struct re_pattern_buffer *)%0)->buffer    = 0; %r = 0;} '' pbuf `seqPrimIO`
103     _casm_ `` { ((struct re_pattern_buffer *)%0)->allocated = 0; %r = 0;} '' pbuf `seqPrimIO`
104     returnPrimIO pbuf
105
106 \end{code}
107
108 @re_compile_pattern@ converts a regular expression into a pattern buffer,
109 GNU style.
110
111 Q: should we lift the syntax bits configuration up to the Haskell
112 programmer level ? 
113
114 \begin{code}
115
116 re_compile_pattern :: _PackedString
117                    -> Bool
118                    -> Bool
119                    -> PrimIO PatBuffer
120 re_compile_pattern str single_line_mode insensitive
121  = createPatBuffer insensitive  `thenPrimIO` \ pbuf ->
122    (if single_line_mode then    -- match a multi-line buffer
123        _casm_ `` %r = re_syntax_options = RE_PERL_SINGLELINE_SYNTAX; ''
124     else
125        _casm_ `` %r = re_syntax_options = RE_PERL_MULTILINE_SYNTAX; '') `seqPrimIO`
126
127    _casm_ `` %r=(int)re_compile_pattern((char *)%0,
128                                         (int)%1,
129                                         (struct re_pattern_buffer *)%2); '' (_unpackPS str)
130                                                                             (_lengthPS str)
131                                                                             pbuf        `thenPrimIO` \ err ->
132    --
133    -- No checking for how the compilation of the pattern went yet.
134    --
135    returnPrimIO pbuf
136
137 \end{code}
138
139 Got a match ?
140
141 \begin{code}
142
143 re_match :: PatBuffer
144          -> _PackedString
145          -> Int
146          -> Bool
147          -> PrimIO (Maybe REmatch)
148 re_match pbuf
149          str
150          start
151          reg
152  = ((if reg then  -- record result of match in registers
153       _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
154      else
155       _casm_ `` %r = (struct re_registers *)NULL; '')::PrimIO _Addr)  `thenPrimIO` \ regs ->
156    _casm_ `` %r=(int)re_match((struct re_pattern_buffer *)%0,
157                               (char *)%1,
158                               (int)%2,
159                               (int)%3,
160                               (struct re_registers *)%4); '' pbuf
161                                                              (_unpackPS str)
162                                                              (_lengthPS str)
163                                                              start
164                                                              regs       `thenPrimIO` \ match_res ->
165   if match_res == (-2) then
166         error "re_match: Internal error"
167   else if match_res < 0 then
168      _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
169      returnPrimIO Nothing
170   else
171      build_re_match start (_lengthPS str) regs  `thenPrimIO` \ arr ->
172      _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs  `seqPrimIO`
173      returnPrimIO (Just arr)
174
175 \end{code}
176
177 Matching on 2 strings is useful when you're dealing with multiple
178 buffers, which is something that could prove useful for PackedStrings,
179 as we don't want to stuff the contents of a file into one massive heap
180 chunk, but load (smaller chunks) on demand.
181
182 \begin{code}
183
184 re_match2 :: PatBuffer
185           -> _PackedString
186           -> _PackedString
187           -> Int
188           -> Int
189           -> Bool
190           -> PrimIO (Maybe REmatch)
191 re_match2 pbuf
192           str1
193           str2
194           start
195           stop
196           reg
197  = ((if reg then  -- record result of match in registers
198       _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
199      else
200       _casm_ `` %r = (struct re_registers *)NULL; '')::PrimIO _Addr)    `thenPrimIO` \ regs ->
201    _casm_ `` %r=(int)re_match_2((struct re_pattern_buffer *)%0,
202                                 (char *)%1,
203                                 (int)%2,
204                                 (char *)%3,
205                                 (int)%4,
206                                 (int)%5,
207                                 (struct re_registers *)%6,
208                                 (int)%7); '' pbuf
209                                              (_unpackPS str1)
210                                              (_lengthPS str1)
211                                              (_unpackPS str2)
212                                              (_lengthPS str2)
213                                              start
214                                              regs
215                                              stop    `thenPrimIO` \ match_res ->
216   if match_res == (-2) then
217         error "re_match2: Internal error"
218   else if match_res < 0 then
219      _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
220      returnPrimIO Nothing
221   else
222      build_re_match start stop regs     `thenPrimIO` \ arr ->
223      _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs  `seqPrimIO`
224      returnPrimIO (Just arr)
225
226
227 \end{code}
228
229 Find all the matches in a string.
230
231 \begin{code}
232
233 re_search :: PatBuffer
234           -> _PackedString
235           -> Int
236           -> Int
237           -> Bool
238           -> PrimIO (Maybe REmatch)
239 re_search pbuf                       -- the compiled regexp
240           str                        -- the string to search
241           start                      -- start index
242           range                      -- stop index
243           reg                        -- record result of match in registers 
244  = (if reg then  -- record result of match in registers
245       _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
246     else
247       _casm_ `` %r = (struct re_registers *)NULL; '')   `thenPrimIO` \ regs ->
248    _casm_ `` %r=(int)re_search((struct re_pattern_buffer *)%0,
249                                (char *)%1,
250                                (int)%2,
251                                (int)%3,
252                                (int)%4,
253                                (struct re_registers *)%5); '' pbuf
254                                                              (_unpackPS str)
255                                                              (_lengthPS str)
256                                                              start
257                                                              range
258                                                              regs       `thenPrimIO` \ match_res ->
259   if match_res== (-1) then
260      _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
261      returnPrimIO Nothing
262   else
263      let
264       (st,en) = if range > start then 
265                    (start,range)
266                 else
267                    (range,start)
268      in
269       build_re_match st en regs                                      `thenPrimIO` \ arr ->
270       _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
271       returnPrimIO (Just arr)
272
273 \end{code}
274
275 Double buffer search
276
277 \begin{code}
278
279 re_search2 :: PatBuffer
280            -> _PackedString
281            -> _PackedString
282            -> Int
283            -> Int
284            -> Int
285            -> Bool
286            -> PrimIO (Maybe REmatch)
287 re_search2 pbuf
288            str1
289            str2
290            start
291            range
292            stop
293            reg
294  = (if reg then  -- record result of match in registers
295       _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
296     else
297       _casm_ `` %r = (struct re_registers *)NULL; '')   `thenPrimIO` \ regs ->
298    _casm_ `` %r=(int)re_search_2((struct re_pattern_buffer *)%0,
299                                  (char *)%1,
300                                  (int)%2,
301                                  (char *)%3,
302                                  (int)%4,
303                                  (int)%5,
304                                  (int)%6,
305                                  (struct re_registers *)%7,
306                                  (int)%8); '' pbuf
307                                               (_unpackPS str1)
308                                               (_lengthPS str1)
309                                               (_unpackPS str2)
310                                               (_lengthPS str2)
311                                               start
312                                               range
313                                               regs
314                                               stop    `thenPrimIO` \ match_res ->
315   if match_res== (-1) then
316      _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
317      returnPrimIO Nothing
318   else
319      let
320       (st,en) = if range > start then 
321                    (start,range)
322                 else
323                    (range,start)
324      in
325       build_re_match st en regs                                      `thenPrimIO` \ arr ->
326       _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
327       returnPrimIO (Just arr)
328
329 \end{code}
330
331 \begin{code}
332
333 build_re_match :: Int
334                -> Int
335                -> _Addr 
336                -> PrimIO REmatch
337 build_re_match str_start 
338                str_end 
339                regs
340  = _casm_ `` %r=(int)(*(struct re_registers *)%0).num_regs; '' regs  `thenPrimIO` \ len ->
341    match_reg_to_array regs len  `thenPrimIO` \ (match_start,match_end,arr) ->
342    let
343     (1,x) = bounds arr
344
345     bef  = (str_start,match_start)  -- $'
346     aft  = (match_end,str_end)      -- $`
347     lst  = arr!x                    -- $+
348     mtch = (match_start,match_end)  -- $&
349    in
350     returnPrimIO (REmatch arr
351                           bef
352                           mtch
353                           aft
354                           lst)
355    where
356     match_reg_to_array regs len
357      = trundleIO regs (0,[]) len  `thenPrimIO` \ (no,ls) ->
358        let
359         (st,end,ls')
360          = case ls of
361              [] -> (0,0,[])
362              [(a,b)] -> (a,b,ls)
363              ((a,b):xs) -> (a,b,xs)
364        in        
365         returnPrimIO 
366            (st,
367             end,
368             array (1,max 1 (no-1)) 
369                   [ i := x | (i,x) <- zip [1..] ls'])
370
371     trundleIO :: _Addr 
372              -> (Int,[(Int,Int)])
373              -> Int 
374              -> PrimIO (Int,[(Int,Int)])
375     trundleIO regs (i,acc) len
376      | i==len = returnPrimIO (i,reverse acc)
377      | otherwise          
378        = _casm_ ``%r = (int)(((struct re_registers *)%0)->start)[(int)%1]; '' regs i `thenPrimIO` \ start ->
379          _casm_ ``%r = (int)(((struct re_registers *)%0)->end)[(int)%1]; '' regs i `thenPrimIO` \ end ->
380          let
381           acc' = (start,end):acc
382          in
383           if (start == (-1)) && (end == (-1)) then
384              returnPrimIO (i,reverse acc)
385           else
386              trundleIO regs (i+1,acc') len
387
388 \end{code}
389