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