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