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