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