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@(C# x#) = _headPS repl
 268           xs        = _tailPS' repl
 269          in
 270           case x# of
 271             '\\'# ->
 272                if escaped then
 273                   replace' acc xs True
 274                else
 275                   replace' ((single x):acc) xs (not escaped)
 276             '$'#  ->
 277               if (not escaped) then
 278                let
 279                 x'           = _headPS xs
 280                 xs'          = _tailPS' xs
 281                 ith_ival     = arr!num
 282                 (num,xs_num) = getNumber ((ord x') - ord '0') xs'
 283                in
 284                 if (isDigit x') && (num<=b) then
 285                   replace' ((_chunkPS str ith_ival):acc) xs_num escaped
 286                 else if x' == '&' then
 287                   replace' ((_chunkPS str match):acc) xs' escaped
 288                 else if x' == '+' then
 289                   replace' ((_chunkPS str lst):acc) xs' escaped
 290                 else if x' == '`' then
 291                   replace' ((_chunkPS str (0,b_end)):acc) xs' escaped
 292                 else if x' == '\'' then
 293                   replace' ((_chunkPS str after):acc) xs' escaped
 294                 else -- ignore
 295                   replace' acc xs escaped
 296               else
 297                 replace' ((single x):acc) xs False
 298
 299             _ -> if escaped then
 300                    (case x# of
 301                      'n'# ->   -- newline
 302                          replace' ((single '\n'):acc)
 303                      'f'# ->   -- formfeed
 304                          replace' ((single '\f'):acc)
 305                      'r'# ->   -- carriage return
 306                          replace' ((single '\r'):acc)
 307                      't'# ->   -- (horiz) tab
 308                          replace' ((single '\t'):acc)
 309                      'v'# ->   -- vertical tab
 310                          replace' ((single '\v'):acc)
 311                      'a'# ->   -- alarm bell
 312                          replace' ((single '\a'):acc)
 313                      'e'# ->   -- escape
 314                          replace' ((single '\033'):acc)
 315                      _    ->
 316                          replace' ((single x):acc))    xs False
 317                  else
 318                    replace' ((single x):acc) xs False
 319
 320
 321 getNumber :: Int -> _PackedString -> (Int,_PackedString)
 322 getNumber acc ps
 323  = if _nullPS ps then
 324       (acc,ps)
 325    else
 326      let
 327       x = _headPS ps
 328       xs = _tailPS ps
 329      in
 330       if (isDigit x) then
 331          getNumber (acc*10+(ord x - ord '0')) xs
 332       else
 333          (acc,ps)
 334
 335 \end{code}
 336
 337 Just like substPS, but no prefix and suffix.
 338
 339 \begin{code}
 340
 341 replacePS :: _PackedString   -- reg. exp
 342           -> _PackedString   -- replacement
 343           -> [Char]        -- flags
 344           -> _PackedString   -- string
 345           -> _PackedString
 346 replacePS rexp
 347           repl
 348           flags
 349           str
 350  = search str
 351    where
 352     global = 'g' `elem` flags
 353     case_insensitive = 'i' `elem` flags
 354     mode = 's' `elem` flags     -- single-line mode
 355     pat  = unsafePerformPrimIO (
 356               re_compile_pattern rexp mode case_insensitive)
 357
 358     search str
 359      = let
 360         search_res
 361          = unsafePerformPrimIO (re_search pat str 0 (_lengthPS str) True)
 362        in
 363         case search_res of
 364           Nothing  -> str
 365           Just matcher@(REmatch arr before match after lst) ->
 366              replace matcher repl str
 367
 368 \end{code}
 369
 370 Picking matched groups out of string
 371
 372 \begin{code}
 373
 374 getMatchesNo :: REmatch
 375              -> Int
 376 getMatchesNo (REmatch arr _ _ _ _)
 377  = snd (bounds arr)
 378
 379 getMatchedGroup :: REmatch
 380                 -> Int
 381                 -> _PackedString
 382                 -> _PackedString
 383 getMatchedGroup (REmatch arr bef mtch after lst) nth str
 384  = let
 385     (1,grps) = bounds arr
 386    in
 387     if (nth >= 1) && (nth <= grps) then
 388        _chunkPS str (arr!nth)
 389     else
 390        error "getMatchedGroup: group out of range"
 391
 392 getWholeMatch :: REmatch
 393               -> _PackedString
 394               -> _PackedString
 395 getWholeMatch (REmatch _ _  mtch _ _) str
 396  = _chunkPS str mtch
 397
 398 getLastMatch :: REmatch
 399               -> _PackedString
 400               -> _PackedString
 401 getLastMatch (REmatch _ _ _ _ lst) str
 402  = _chunkPS str lst
 403
 404 getAfterMatch :: REmatch
 405               -> _PackedString
 406               -> _PackedString
 407 getAfterMatch (REmatch _ _ _ aft _) str
 408  = _chunkPS str aft
 409
 410 \end{code}
 411
 412
 413 More or less straight translation of a brute-force string matching
 414 function written in C. (Sedgewick ch. 18)
 415
 416 This is intended to provide much the same facilities as index/rindex in perl.
 417
 418 \begin{code}
 419
 420
 421 findPS :: _PackedString
 422        -> _PackedString
 423        -> Maybe Int
 424 findPS str substr
 425  = let
 426     m = _lengthPS substr
 427     n = _lengthPS str
 428
 429     loop i j
 430      | j>=m || i>=n = if j==m then (Just (i-m)) else Nothing
 431      | otherwise
 432         = inner_loop i j
 433
 434     inner_loop i j
 435      = if j<m && i<n && (_indexPS str i /= _indexPS substr j) then
 436           inner_loop (i-j+1) 0
 437        else
 438           loop (i+1) (j+1)
 439    in
 440     loop 0 0
 441
 442 rfindPS :: _PackedString
 443         -> _PackedString
 444         -> Maybe Int
 445 rfindPS str substr
 446  = let
 447     m = _lengthPS substr - 1
 448     n = _lengthPS str - 1
 449
 450     loop i j
 451      | j<0 || i<0 = if j<0 then (Just (i+1)) else Nothing
 452      | otherwise
 453         = inner_loop i j
 454
 455     inner_loop i j
 456      = if j>=0 && i>=0 && (_indexPS str i /= _indexPS substr j) then
 457           inner_loop (i+(m-j)-1) m
 458        else
 459           loop (i-1) (j-1)
 460    in
 461     loop n m
 462
 463
 464 \end{code}
 465
 466 \begin{code}
 467
 468 chopPS :: _PackedString -> _PackedString
 469 chopPS str = if _nullPS str then
 470                 _nilPS
 471              else
 472                 _chunkPS  str (0,_lengthPS str-1)
 473
 474 \end{code}
 475
 476 Tries to match as much as possible of strA starting from the beginning of strB
 477 (handy when matching fancy literals in parsers)
 478
 479 \begin{code}
 480 matchPrefixPS :: _PackedString
 481               -> _PackedString
 482               -> Int
 483 matchPrefixPS pref str
 484  = matchPrefixPS' pref str 0
 485    where
 486     matchPrefixPS' pref str n
 487      = if (_nullPS pref) || (_nullPS str) then
 488           n
 489        else if (_headPS pref) == (_headPS str) then
 490           matchPrefixPS' (_tailPS pref) (_tailPS str) (n+1)
 491        else
 492           n
 493
 494 \end{code}