ghc/lib/ghc/MatchPS.lhs

   1 \section[match]{PackedString functions for matching}
   2
   3 This module provides regular expression matching and substitution
   4 at the PackedString level. It is built on top of the GNU Regex
   5 library modified to handle perl regular expression syntax.
   6 For a complete description of the perl syntax, do `man perlre`
   7 or have a gander in (Programming|Learning) Perl. Here's
   8 a short summary:
   9
  10 ^     matches the beginning of line
  11 $     matches end of line
  12 \b    matches word boundary
  13 \B    matches non-word boundary
  14 \w    matches a word(alpha-numeric) character
  15 \W    matches a non-word character
  16 \d    matches a digit
  17 \D    matches a non-digit
  18 \s    matches whitespace
  19 \S    matches non-whitespace
  20 \A    matches beginning of buffer
  21 \Z    matches end-of-buffer
  22 .     matches any (bar newline in single-line mode)
  23 +     matches 1 or more times
  24 *     matches 0 or more times
  25 ?     matches 0 or 1
  26 {n,m} matches >=n and <=m atoms
  27 {n,}  matches at least n times
  28 {n}   matches n times
  29 [..]  matches any character member of char class.
  30 (..)  if pattern inside parens match, then the ith group is bound
  31       to the matched string
  32 \digit matches whatever the ith group matched.
  33
  34 Backslashed letters
  35 \n      newline
  36 \r      carriage return
  37 \t      tab
  38 \f      formfeed
  39 \v      vertical tab
  40 \a      alarm bell
  41 \e      escape
  42
  43
  44 \begin{code}
  45 module MatchPS
  46
  47       (
  48         matchPS,
  49         searchPS,
  50         substPS,
  51         replacePS,
  52
  53         match2PS,
  54         search2PS,
  55
  56         getMatchesNo,
  57         getMatchedGroup,
  58         getWholeMatch,
  59         getLastMatch,
  60         getAfterMatch,
  61
  62         findPS,
  63         rfindPS,
  64         chopPS,
  65
  66         matchPrefixPS,
  67
  68         REmatch(..)
  69       ) where
  70
  71 import PreludeGlaST
  72
  73 import Regex
  74
  75 \end{code}
  76
  77 _tailPS and _dropPS in PS.lhs are not to my liking, use
  78 these instead.
  79
  80 \begin{code}
  81
  82 _dropPS' x str = _substrPS str x (_lengthPS str)
  83
  84 _tailPS' x
  85  = if _nullPS x then
  86      error "_tailPS []"
  87    else
  88      _substrPS x 1 (_lengthPS x)
  89
  90
  91 \end{code}
  92
  93 \subsection[ps-matching]{PackedString matching}
  94
  95 Posix matching, returning an array of the the intervals that
  96 the individual groups matched within the string.
  97
  98 \begin{code}
  99
 100 matchPS :: _PackedString                -- reg. exp
 101         -> _PackedString                -- string to match
 102         -> [Char]                       -- flags
 103         -> Maybe REmatch
 104 matchPS reg str flags
 105  = let
 106     insensitive = 'i' `elem` flags
 107     mode = 's' `elem` flags
 108    in
 109     unsafePerformPrimIO (
 110       re_compile_pattern reg mode insensitive   `thenPrimIO` \ pat ->
 111       re_match pat str 0 True)
 112
 113
 114 match2PS :: _PackedString               -- reg. exp
 115          -> _PackedString               -- string1 to match
 116          -> _PackedString               -- string2 to match
 117          -> [Char]                      -- flags
 118          -> Maybe REmatch
 119 match2PS reg str1 str2 flags
 120  = let
 121     insensitive = 'i' `elem` flags
 122     mode = 's' `elem` flags
 123     len1 = _lengthPS str1
 124     len2 = _lengthPS str2
 125    in
 126     unsafePerformPrimIO (
 127       re_compile_pattern reg mode insensitive   `thenPrimIO` \ pat ->
 128       re_match2 pat str1 str2 0 (len1+len2) True)
 129
 130 \end{code}
 131
 132 PackedString front-end to searching with GNU Regex
 133
 134 \begin{code}
 135
 136 searchPS :: _PackedString               -- reg. exp
 137          -> _PackedString               -- string to match
 138          -> [Char]                      -- flags
 139          -> Maybe REmatch
 140 searchPS reg str flags
 141  = let
 142     insensitive = 'i' `elem` flags
 143     mode = 's' `elem` flags
 144    in
 145     unsafePerformPrimIO (
 146       re_compile_pattern reg mode insensitive   `thenPrimIO` \ pat ->
 147       re_search pat str
 148                     0
 149                     (_lengthPS str)
 150                     True)
 151
 152
 153
 154 search2PS :: _PackedString              -- reg. exp
 155           -> _PackedString              -- string to match
 156           -> _PackedString              -- string to match
 157           -> [Char]                     -- flags
 158           -> Maybe REmatch
 159 search2PS reg str1 str2 flags
 160  = let
 161     insensitive = 'i' `elem` flags
 162     mode = 's' `elem` flags
 163     len1 = _lengthPS str1
 164     len2 = _lengthPS str2
 165     len  = len1+len2
 166    in
 167     unsafePerformPrimIO (
 168       re_compile_pattern reg mode insensitive   `thenPrimIO` \ pat ->
 169       re_search2 pat
 170                  str1
 171                  str2
 172                  0
 173                  len
 174                  len
 175                  True)
 176
 177
 178
 179 \end{code}
 180
 181 @_substrPS s st end@ cuts out the chunk in \tr{s} between \tr{st} and \tr{end}, inclusive.
 182 The \tr{Regex} registers represent substrings by storing the start and the end point plus
 183 one( st==end => empty string) , so we use @chunkPS@ instead.
 184
 185
 186 \begin{code}
 187
 188 _chunkPS :: _PackedString
 189          -> (Int,Int)
 190          -> _PackedString
 191 _chunkPS str (st,end)
 192  = if st==end then
 193       _nilPS
 194    else
 195       _substrPS str st (max 0 (end-1))
 196
 197 \end{code}
 198
 199 Perl-like match and substitute
 200
 201 \begin{code}
 202
 203 substPS :: _PackedString   -- reg. exp
 204         -> _PackedString   -- replacement
 205         -> [Char]          -- flags
 206         -> _PackedString   -- string
 207         -> _PackedString
 208 substPS rexp
 209         repl
 210         flags
 211         str
 212  = search str
 213    where
 214     global = 'g' `elem` flags
 215     case_insensitive = 'i' `elem` flags
 216     mode = 's' `elem` flags     -- single-line mode
 217     pat  = unsafePerformPrimIO (
 218               re_compile_pattern rexp mode case_insensitive)
 219
 220     search str
 221      = let
 222         search_res
 223          = unsafePerformPrimIO (re_search pat str 0 (_lengthPS str) True)
 224        in
 225         case search_res of
 226           Nothing  -> str
 227           Just matcher@(REmatch arr before match after lst) ->
 228             let
 229              (st,en) = match
 230              prefix = _chunkPS str before
 231              suffix
 232               = if global && (st /= en) then
 233                    search (_dropPS' en str)
 234                 else
 235                    _chunkPS str after
 236             in
 237              _concatPS [prefix,
 238                         replace matcher repl str,
 239                         suffix]
 240
 241
 242 replace :: REmatch
 243         -> _PackedString
 244         -> _PackedString
 245         -> _PackedString
 246 replace (REmatch arr before@(_,b_end) match after lst)
 247         replacement
 248         str
 249  = _concatPS (reverse acc) -- ToDo: write a `reversed' version of concatPS
 250    where
 251     (_,b) = bounds arr
 252
 253     acc = replace' [] replacement False
 254
 255     single :: Char -> _PackedString
 256     single x = _consPS x _nilPS
 257
 258     replace' :: [_PackedString]
 259              -> _PackedString
 260              -> Bool
 261              -> [_PackedString]
 262     replace' acc repl escaped
 263      = if (_nullPS repl) then
 264          acc
 265        else
 266          let
 267           x  = _headPS repl
 268           x# = case x of { C# c -> c }
 269           xs = _tailPS' repl
 270          in
 271           case x# of
 272             '\\'# ->
 273                if escaped then
 274                   replace' acc xs True
 275                else
 276                   replace' ((single x):acc) xs (not escaped)
 277             '$'#  ->
 278               if (not escaped) then
 279                let
 280                 x'           = _headPS xs
 281                 xs'          = _tailPS' xs
 282                 ith_ival     = arr!num
 283                 (num,xs_num) = getNumber ((ord x') - ord '0') xs'
 284                in
 285                 if (isDigit x') && (num<=b) then
 286                   replace' ((_chunkPS str ith_ival):acc) xs_num escaped
 287                 else if x' == '&' then
 288                   replace' ((_chunkPS str match):acc) xs' escaped
 289                 else if x' == '+' then
 290                   replace' ((_chunkPS str lst):acc) xs' escaped
 291                 else if x' == '`' then
 292                   replace' ((_chunkPS str (0,b_end)):acc) xs' escaped
 293                 else if x' == '\'' then
 294                   replace' ((_chunkPS str after):acc) xs' escaped
 295                 else -- ignore
 296                   replace' acc xs escaped
 297               else
 298                 replace' ((single x):acc) xs False
 299
 300             _ -> if escaped then
 301                    (case x# of
 302                      'n'# ->   -- newline
 303                          replace' ((single '\n'):acc)
 304                      'f'# ->   -- formfeed
 305                          replace' ((single '\f'):acc)
 306                      'r'# ->   -- carriage return
 307                          replace' ((single '\r'):acc)
 308                      't'# ->   -- (horiz) tab
 309                          replace' ((single '\t'):acc)
 310                      'v'# ->   -- vertical tab
 311                          replace' ((single '\v'):acc)
 312                      'a'# ->   -- alarm bell
 313                          replace' ((single '\a'):acc)
 314                      'e'# ->   -- escape
 315                          replace' ((single '\033'):acc)
 316                      _    ->
 317                          replace' ((single x):acc))    xs False
 318                  else
 319                    replace' ((single x):acc) xs False
 320
 321
 322 getNumber :: Int -> _PackedString -> (Int,_PackedString)
 323 getNumber acc ps
 324  = if _nullPS ps then
 325       (acc,ps)
 326    else
 327      let
 328       x = _headPS ps
 329       xs = _tailPS ps
 330      in
 331       if (isDigit x) then
 332          getNumber (acc*10+(ord x - ord '0')) xs
 333       else
 334          (acc,ps)
 335
 336 \end{code}
 337
 338 Just like substPS, but no prefix and suffix.
 339
 340 \begin{code}
 341
 342 replacePS :: _PackedString   -- reg. exp
 343           -> _PackedString   -- replacement
 344           -> [Char]        -- flags
 345           -> _PackedString   -- string
 346           -> _PackedString
 347 replacePS rexp
 348           repl
 349           flags
 350           str
 351  = search str
 352    where
 353     global = 'g' `elem` flags
 354     case_insensitive = 'i' `elem` flags
 355     mode = 's' `elem` flags     -- single-line mode
 356     pat  = unsafePerformPrimIO (
 357               re_compile_pattern rexp mode case_insensitive)
 358
 359     search str
 360      = let
 361         search_res
 362          = unsafePerformPrimIO (re_search pat str 0 (_lengthPS str) True)
 363        in
 364         case search_res of
 365           Nothing  -> str
 366           Just matcher@(REmatch arr before match after lst) ->
 367              replace matcher repl str
 368
 369 \end{code}
 370
 371 Picking matched groups out of string
 372
 373 \begin{code}
 374
 375 getMatchesNo :: REmatch
 376              -> Int
 377 getMatchesNo (REmatch arr _ _ _ _)
 378  = snd (bounds arr)
 379
 380 getMatchedGroup :: REmatch
 381                 -> Int
 382                 -> _PackedString
 383                 -> _PackedString
 384 getMatchedGroup (REmatch arr bef mtch after lst) nth str
 385  = let
 386     (1,grps) = bounds arr
 387    in
 388     if (nth >= 1) && (nth <= grps) then
 389        _chunkPS str (arr!nth)
 390     else
 391        error "getMatchedGroup: group out of range"
 392
 393 getWholeMatch :: REmatch
 394               -> _PackedString
 395               -> _PackedString
 396 getWholeMatch (REmatch _ _  mtch _ _) str
 397  = _chunkPS str mtch
 398
 399 getLastMatch :: REmatch
 400               -> _PackedString
 401               -> _PackedString
 402 getLastMatch (REmatch _ _ _ _ lst) str
 403  = _chunkPS str lst
 404
 405 getAfterMatch :: REmatch
 406               -> _PackedString
 407               -> _PackedString
 408 getAfterMatch (REmatch _ _ _ aft _) str
 409  = _chunkPS str aft
 410
 411 \end{code}
 412
 413
 414 More or less straight translation of a brute-force string matching
 415 function written in C. (Sedgewick ch. 18)
 416
 417 This is intended to provide much the same facilities as index/rindex in perl.
 418
 419 \begin{code}
 420
 421
 422 findPS :: _PackedString
 423        -> _PackedString
 424        -> Maybe Int
 425 findPS str substr
 426  = let
 427     m = _lengthPS substr
 428     n = _lengthPS str
 429
 430     loop i j
 431      | j>=m || i>=n = if j==m then (Just (i-m)) else Nothing
 432      | otherwise
 433         = inner_loop i j
 434
 435     inner_loop i j
 436      = if j<m && i<n && (_indexPS str i /= _indexPS substr j) then
 437           inner_loop (i-j+1) 0
 438        else
 439           loop (i+1) (j+1)
 440    in
 441     loop 0 0
 442
 443 rfindPS :: _PackedString
 444         -> _PackedString
 445         -> Maybe Int
 446 rfindPS str substr
 447  = let
 448     m = _lengthPS substr - 1
 449     n = _lengthPS str - 1
 450
 451     loop i j
 452      | j<0 || i<0 = if j<0 then (Just (i+1)) else Nothing
 453      | otherwise
 454         = inner_loop i j
 455
 456     inner_loop i j
 457      = if j>=0 && i>=0 && (_indexPS str i /= _indexPS substr j) then
 458           inner_loop (i+(m-j)-1) m
 459        else
 460           loop (i-1) (j-1)
 461    in
 462     loop n m
 463
 464
 465 \end{code}
 466
 467 \begin{code}
 468
 469 chopPS :: _PackedString -> _PackedString
 470 chopPS str = if _nullPS str then
 471                 _nilPS
 472              else
 473                 _chunkPS  str (0,_lengthPS str-1)
 474
 475 \end{code}
 476
 477 Tries to match as much as possible of strA starting from the beginning of strB
 478 (handy when matching fancy literals in parsers)
 479
 480 \begin{code}
 481 matchPrefixPS :: _PackedString
 482               -> _PackedString
 483               -> Int
 484 matchPrefixPS pref str
 485  = matchPrefixPS' pref str 0
 486    where
 487     matchPrefixPS' pref str n
 488      = if (_nullPS pref) || (_nullPS str) then
 489           n
 490        else if (_headPS pref) == (_headPS str) then
 491           matchPrefixPS' (_tailPS pref) (_tailPS str) (n+1)
 492        else
 493           n
 494
 495 \end{code}