1 -- -*- Mode: Haskell -*- 2 -- StringMatch.hs --- translate regular expression into a string match function 3 -- Author : Peter Thiemann 4 -- Created On : Thu Dec 23 11:16:26 1993 5 -- Last Modified By: Peter Thiemann 6 -- Last Modified On: Thu Dec 23 12:32:39 1993 7 -- Update Count : 18 8 -- Status : Unknown, Use with caution! 9 -- 10 -- $Locker: $ 11 -- $Log: StringMatch.hs,v $ 12 -- Revision 1.1 1996/01/08 20:02:55 partain 13 -- Initial revision 14 -- 15 -- Revision 1.1 1994/03/15 15:34:53 thiemann 16 -- Initial revision 17 -- 18 -- 19 20 module StringMatch {-(stringMatch)-} where 21 22 import Parsers 23 24 infixr 8 +.+ , +.. , ..+ 25 infixl 7 <<< , <<* 26 infixr 6 ||| 27 28 (+.+) = thn 29 (..+) = xthn 30 (+..) = thnx 31 (|||) = alt 32 (<<<) = using 33 (<<*) = using2 34 lit :: Eq a => a -> Parser a a 35 lit = literal 36 star = rpt 37 anyC = satisfy (const True) 38 butC cs = satisfy (not.(`elem` cs)) 39 noC "" = [("","")] 40 noC _ = [] 41 unitL = \x -> [x] 42 43 -- 44 -- grammar for regular expressions: 45 -- 46 {- 47 Atom = character | "\\" character | "." | "\\(" Regexp "\\) . 48 ExtAtom = Atom ["*" | "+" | "?"] . 49 Factor = ExtAtom + . 50 Regexp = Factor / "\\|" ["$"]. 51 -} 52 53 type ParseRegexp = Parser Char String 54 55 rrAtom :: Parser Char ParseRegexp 56 rrAtom = 57 lit '\\' ..+ lit '(' ..+ rrRegexp +.. lit '\\' +.. lit ')' 58 ||| 59 ( lit '\\' ..+ butC "|()" <<< lit 60 ||| lit '.' <<< const anyC 61 ||| butC "\\.$" <<< lit 62 ||| lit '$' `followedBy` anyC <<< lit 63 ) <<< (<<< unitL) 64 65 rrExtAtom :: Parser Char ParseRegexp 66 rrExtAtom = 67 rrAtom +.+ opt (lit '*' <<< const star 68 ||| lit '+' <<< const plus 69 ||| lit '?' <<< const opt) 70 <<< helper 71 where 72 helper (ea, []) = ea 73 helper (ea, [f]) = f ea <<< concat 74 75 rrFactor :: Parser Char ParseRegexp 76 rrFactor = 77 plus rrExtAtom <<< foldr (\ p1 p2 -> p1 +.+ p2 <<* (++)) (succeed "") 78 79 rrRegexp = 80 rrFactor +.+ star (lit '\\' ..+ lit '|' ..+ rrFactor) +.+ opt (lit '$') 81 <<< helper 82 where 83 helper (ef, (efs, [])) = foldl (|||) ef efs +.. star anyC 84 helper (ef, (efs, _ )) = foldl (|||) ef efs +.. noC 85 86 regexp0 :: Parser Char (Parser Char String) 87 regexp0 = 88 lit '^' ..+ rrRegexp 89 ||| rrRegexp 90 <<< (\p -> let p' = p ||| anyC ..+ p' in p') 91 92 stringMatch :: String -> String -> Bool 93 stringMatch re subject = wellformed && not (null (filter (null . snd) (match subject))) 94 where matches = regexp0 re 95 wellformed = not (null matches) && null rest 96 (match,rest) = head matches