weighted-regexp (empty) → 0.1.0.0
raw patch · 15 files changed
+1990/−0 lines, 15 filesdep +QuickCheckdep +arraydep +basesetup-changed
Dependencies added: QuickCheck, array, base, criterion
Files
- LICENSE +32/−0
- Setup.hs +4/−0
- dist/build/Text/RegExp/Parser.hs +553/−0
- src/Data/Semiring.hs +105/−0
- src/Data/Semiring/Properties.hs +55/−0
- src/Text/RegExp.hs +102/−0
- src/Text/RegExp/Data.hs +193/−0
- src/Text/RegExp/Matching.hs +57/−0
- src/Text/RegExp/Matching/LeftLong.hs +89/−0
- src/Text/RegExp/Matching/Leftmost.hs +74/−0
- src/Text/RegExp/Matching/Longest.hs +73/−0
- src/Text/RegExp/Parser.y +148/−0
- src/criterion.lhs +78/−0
- src/quickcheck.lhs +328/−0
- weighted-regexp.cabal +99/−0
+ LICENSE view
@@ -0,0 +1,32 @@+Copyright (c) 2010, Thomas Wilke, Frank Huch, Sebastian Fischer++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.++ 3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ dist/build/Text/RegExp/Parser.hs view
@@ -0,0 +1,553 @@+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-missing-signatures #-}++module Text.RegExp.Parser ( parse ) where++import Text.RegExp.Data+ ( eps, char, psym, anySym, alt, seq_, rep, rep1, opt, brep )++import Data.Char ( isSpace, toLower, isAlphaNum, isDigit )+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.18.5++newtype HappyAbsSyn t4 = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn4 :: t4 -> (HappyAbsSyn t4)+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn t4) -> t4+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyInTok :: (Token) -> (HappyAbsSyn t4)+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn t4) -> (Token)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x04\x00\x00\x00\xff\xff\x00\x00\x04\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x16\x00\x19\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x13\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfd\xff\xfe\xff\xf5\xff\xf4\xff\x00\x00\xfc\xff\xfe\xff\xfe\xff\xf8\xff\xf7\xff\xf6\xff\xfa\xff\xfb\xff\xf9\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x02\x00\x03\x00\x04\x00\xff\xff\x01\x00\x07\x00\x08\x00\x09\x00\x05\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x0a\x00\x0b\x00\x02\x00\x03\x00\x04\x00\x00\x00\x06\x00\x07\x00\x08\x00\x09\x00\x02\x00\x03\x00\x04\x00\x02\x00\x03\x00\x07\x00\x08\x00\x09\x00\x07\x00\x08\x00\x09\x00\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x09\x00\x0a\x00\x0b\x00\x00\x00\x04\x00\x0c\x00\x0d\x00\x0e\x00\x05\x00\x0e\x00\xff\xff\x0f\x00\x07\x00\x06\x00\x07\x00\x09\x00\x0a\x00\x0b\x00\x02\x00\x11\x00\x0c\x00\x0d\x00\x0e\x00\x09\x00\x0a\x00\x0b\x00\x09\x00\x0a\x00\x0c\x00\x0d\x00\x0e\x00\x0c\x00\x0d\x00\x0e\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 11) [+ (1 , happyReduce_1),+ (2 , happyReduce_2),+ (3 , happyReduce_3),+ (4 , happyReduce_4),+ (5 , happyReduce_5),+ (6 , happyReduce_6),+ (7 , happyReduce_7),+ (8 , happyReduce_8),+ (9 , happyReduce_9),+ (10 , happyReduce_10),+ (11 , happyReduce_11)+ ]++happy_n_terms = 13 :: Int+happy_n_nonterms = 1 :: Int++happyReduce_1 = happySpecReduce_0 0# happyReduction_1+happyReduction_1 = happyIn4+ (eps+ )++happyReduce_2 = happySpecReduce_1 0# happyReduction_2+happyReduction_2 happy_x_1+ = case happyOutTok happy_x_1 of { (Sym happy_var_1) -> + happyIn4+ (char happy_var_1+ )}++happyReduce_3 = happySpecReduce_2 0# happyReduction_3+happyReduction_3 happy_x_2+ happy_x_1+ = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn4+ (rep happy_var_1+ )}++happyReduce_4 = happySpecReduce_3 0# happyReduction_4+happyReduction_4 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut4 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_3 of { happy_var_3 -> + happyIn4+ (seq_ happy_var_1 happy_var_3+ )}}++happyReduce_5 = happySpecReduce_3 0# happyReduction_5+happyReduction_5 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut4 happy_x_1 of { happy_var_1 -> + case happyOut4 happy_x_3 of { happy_var_3 -> + happyIn4+ (alt happy_var_1 happy_var_3+ )}}++happyReduce_6 = happySpecReduce_3 0# happyReduction_6+happyReduction_6 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut4 happy_x_2 of { happy_var_2 -> + happyIn4+ (happy_var_2+ )}++happyReduce_7 = happySpecReduce_2 0# happyReduction_7+happyReduction_7 happy_x_2+ happy_x_1+ = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn4+ (rep1 happy_var_1+ )}++happyReduce_8 = happySpecReduce_2 0# happyReduction_8+happyReduction_8 happy_x_2+ happy_x_1+ = case happyOut4 happy_x_1 of { happy_var_1 -> + happyIn4+ (opt happy_var_1+ )}++happyReduce_9 = happySpecReduce_2 0# happyReduction_9+happyReduction_9 happy_x_2+ happy_x_1+ = case happyOut4 happy_x_1 of { happy_var_1 -> + case happyOutTok happy_x_2 of { (Bnd happy_var_2) -> + happyIn4+ (brep happy_var_2 happy_var_1+ )}}++happyReduce_10 = happySpecReduce_1 0# happyReduction_10+happyReduction_10 happy_x_1+ = case happyOutTok happy_x_1 of { (Cls happy_var_1) -> + happyIn4+ (uncurry psym happy_var_1+ )}++happyReduce_11 = happySpecReduce_1 0# happyReduction_11+happyReduction_11 happy_x_1+ = happyIn4+ (anySym+ )++happyNewToken action sts stk [] =+ happyDoAction 12# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+ let cont i = happyDoAction i tk action sts stk tks in+ case tk of {+ Sym happy_dollar_dollar -> cont 1#;+ Ast -> cont 2#;+ Seq -> cont 3#;+ Bar -> cont 4#;+ L -> cont 5#;+ R -> cont 6#;+ Pls -> cont 7#;+ Que -> cont 8#;+ Bnd happy_dollar_dollar -> cont 9#;+ Cls happy_dollar_dollar -> cont 10#;+ Dot -> cont 11#;+ _ -> happyError' (tk:tks)+ }++happyError_ tk tks = happyError' (tk:tks)++newtype HappyIdentity a = HappyIdentity a+happyIdentity = HappyIdentity+happyRunIdentity (HappyIdentity a) = a++instance Monad HappyIdentity where+ return = HappyIdentity+ (HappyIdentity p) >>= q = q p++happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b+happyThen = (>>=)+happyReturn :: () => a -> HappyIdentity a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> HappyIdentity a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token)] -> HappyIdentity a+happyError' = HappyIdentity . parseError++parseTokens tks = happyRunIdentity happySomeParser where+ happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++parse = parseTokens . scan++data Token = Seq | Sym Char | Ast | Bar | L | R+ | Pls | Que | Bnd (Int,Int)+ | Cls (String,Char -> Bool) | Dot+++token :: Char -> Token+token '*' = Ast+token '|' = Bar+token '(' = L+token ')' = R+token '?' = Que+token '+' = Pls+token '.' = Dot+token c = Sym c++scan :: String -> [Token]+scan = insertSeqs . process++insertSeqs :: [Token] -> [Token]+insertSeqs [] = []+insertSeqs [t] = [t]+insertSeqs (a:ts@(b:_))+ | lseq a && rseq b = a : Seq : insertSeqs ts+ | otherwise = a : insertSeqs ts++lseq :: Token -> Bool+lseq Bar = False+lseq L = False+lseq _ = True++rseq :: Token -> Bool+rseq (Sym _) = True+rseq L = True+rseq (Cls _) = True+rseq Dot = True+rseq _ = False++process :: String -> [Token]+process [] = []++process ('\\':c:cs) = Cls (['\\',c],symClassPred c) : process cs++process ('{':cs) = case reads cs of+ (n,'}':s1) : _ -> Bnd (n,n) : process s1+ (n,',':s1) : _ ->+ case reads s1 of+ (m,'}':s2) : _ -> Bnd (n,m) : process s2+ _ -> token '{' : process cs+ _ -> token '{' : process cs++process ('[':'^':cs) = Cls (('[':'^':s),not.p) : process xs+ where (s,p,xs) = processCls cs++process ('[' :cs) = Cls ('[':s,p) : process xs+ where (s,p,xs) = processCls cs++process (c:cs) = token c : process cs++processCls :: String -> (String, Char -> Bool, String)++processCls [] = parseError []++processCls (']':cs) = ("]", const False, cs)++processCls ('\\':c:cs)+ | isSymClassChar c = ('\\':c:s, \x -> symClassPred c x || p x, xs)+ where (s,p,xs) = processCls cs++processCls ('\\':c:cs) = ('\\':c:s, \x -> x==c || p x, xs)+ where (s,p,xs) = processCls cs++processCls (c:'-':e:cs) | e /= ']'+ = (c:'-':e:s, \d -> (c<=d && d<=e) || p d, xs)+ where (s,p,xs) = processCls cs++processCls (c:cs) = (c:s, \b -> b==c || p b, xs)+ where (s,p,xs) = processCls cs++isSymClassChar :: Char -> Bool+isSymClassChar = (`elem`"wWdDsS")++symClassPred :: Char -> Char -> Bool+symClassPred 'w' = isWordChar+symClassPred 'd' = isDigit+symClassPred 's' = isSpace+symClassPred 'W' = not . isWordChar+symClassPred 'D' = not . isDigit+symClassPred 'S' = not . isSpace+symClassPred c = (c==)++isWordChar :: Char -> Bool+isWordChar c = c == '_' || isAlphaNum c++parseError :: [Token] -> a+parseError _ = error "cannot parse regular expression"+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 30 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 51 "templates/GenericTemplate.hs" #-}++{-# LINE 61 "templates/GenericTemplate.hs" #-}++{-# LINE 70 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- parse (a %partial parser). We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+ happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+ = {- nothing -}+++ case action of+ 0# -> {- nothing -}+ happyFail i tk st+ -1# -> {- nothing -}+ happyAccept i tk st+ n | (n Happy_GHC_Exts.<# (0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}++ (happyReduceArr Happy_Data_Array.! rule) i tk st+ where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+ n -> {- nothing -}+++ happyShift new_state i tk st+ where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+ where !(off) = indexShortOffAddr happyActOffsets st+ !(off_i) = (off Happy_GHC_Exts.+# i)+ check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))+ then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i)+ else False+ !(action)+ | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st++{-# LINE 130 "templates/GenericTemplate.hs" #-}+++indexShortOffAddr (HappyA# arr) off =+ Happy_GHC_Exts.narrow16Int# i+ where+ !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+ !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+ !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+ !off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 163 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+ let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+-- trace "shifting the error token" $+ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+ happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+ = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+ = let r = fn v1 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+ = let r = fn v1 v2 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+ = let r = fn v1 v2 v3 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+ = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+ sts1@((HappyCons (st1@(action)) (_))) ->+ let r = fn stk in -- it doesn't hurt to always seq here...+ happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))+ where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++happyMonad2Reduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))+ where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++ !(off) = indexShortOffAddr happyGotoOffsets st1+ !(off_i) = (off Happy_GHC_Exts.+# nt)+ !(new_state) = indexShortOffAddr happyTable off_i+++++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = + {- nothing -}+ happyDoAction j tk new_state+ where !(off) = indexShortOffAddr happyGotoOffsets st+ !(off_i) = (off Happy_GHC_Exts.+# nt)+ !(new_state) = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk =+-- trace "failing" $ + happyError_ tk++{- We don't need state discarding for our restricted implementation of+ "error". In fact, it can cause some bogus parses, so I've disabled it+ for now --SDM++-- discard a state+happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) =+-- trace ("discarding state, depth " ++ show (length stk)) $+ happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+-- save the old token and carry on.+happyFail i tk (action) sts stk =+-- trace "entering error recovery" $+ happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq+-- otherwise it emits+-- happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template. GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ src/Data/Semiring.hs view
@@ -0,0 +1,105 @@+-- | +-- Module : Data.Semiring+-- Copyright : Thomas Wilke, Frank Huch, Sebastian Fischer+-- License : BSD3+-- Maintainer : Sebastian Fischer <mailto:mail@sebfisch.de>+-- Stability : experimental+-- +-- This library provides a type class for semirings and instances for+-- standard data types.+-- +module Data.Semiring (++ Semiring(..), fromBool,++ Numeric(..)++ ) where++infixr 6 .+.+infixr 7 .*.++-- |+-- A semiring is an additive commutative monoid with identity 'zero':+-- +-- > a .+. b == b .+. a+-- > zero .+. a == a+-- > (a .+. b) .+. c == a .+. (b .+. c)+-- +-- A semiring is a multiplicative monoid with identity 'one':+-- +-- > one .*. a == a+-- > a .*. one == a+-- > (a .*. b) .*. c == a .*. (b .*. c)+-- +-- Multiplication distributes over addition:+-- +-- > a .*. (b .+. c) == (a .*. b) .+. (a .*. c)+-- > (a .+. b) .*. c == (a .*. c) .+. (b .*. c)+-- +-- 'zero' annihilates a semiring with respect to multiplication:+-- +-- > zero .*. a == zero+-- > a .*. zero == zero+-- +-- All laws should hold with respect to the required `Eq` instance.+-- +-- For example, the Booleans form a semiring.+-- +-- * @False@ is an identity of disjunction which is commutative and+-- associative,+-- +-- * @True@ is an identity of conjunction which is associative,+-- +-- * conjunction distributes over disjunction, and+-- +-- * @False@ annihilates the Booleans with respect to conjunction.+-- +class Eq s => Semiring s where+ zero, one :: s+ (.+.), (.*.) :: s -> s -> s++-- | Auxiliary function to convert Booleans to an arbitrary semiring.+-- +fromBool :: Semiring s => Bool -> s+fromBool False = zero+fromBool True = one++instance Semiring Bool where+ zero = False; one = True; (.+.) = (||); (.*.) = (&&)++-- |+-- Wrapper for numeric types.+-- +-- Every numeric type that satisfies the semiring laws (as all+-- predefined numeric types do) is a semiring.+-- +data Numeric a = Numeric { getNumeric :: a }+ deriving Eq++instance (Num a, Show a) => Show (Numeric a) where+ show = show . getNumeric++lift :: Num a => (a -> a) -> Numeric a -> Numeric a+lift f = Numeric . f . getNumeric++lift2 :: Num a => (a -> a -> a) -> Numeric a -> Numeric a -> Numeric a+lift2 f x y = Numeric (f (getNumeric x) (getNumeric y))++instance Num a => Num (Numeric a) where+ fromInteger = Numeric . fromInteger+ signum = lift signum+ abs = lift abs++ 0 + x = x+ x + 0 = x+ x + y = lift2 (+) x y++ 0 * _ = 0+ _ * 0 = 0+ 1 * x = x+ x * 1 = x+ x * y = lift2 (*) x y++instance Num a => Semiring (Numeric a) where+ zero = 0; one = 1; (.+.) = (+); (.*.) = (*)
+ src/Data/Semiring/Properties.hs view
@@ -0,0 +1,55 @@+-- | +-- Module : Data.Semiring.Properties+-- Copyright : Sebastian Fischer <mailto:mail@sebfisch.de>+-- License : BSD3+-- +-- This library provides properties for the 'Semiring' type class that+-- can be checked using libraries like QuickCheck or SmallCheck.+-- +module Data.Semiring.Properties (++ module Data.Semiring, module Data.Semiring.Properties++ ) where++import Data.Semiring++-- | > a .+. b == b .+. a+plus'comm :: Semiring s => s -> s -> Bool+plus'comm a b = a .+. b == b .+. a++-- | > zero .+. a == a+left'zero :: Semiring s => s -> Bool+left'zero a = zero .+. a == a++-- | > (a .+. b) .+. c == a .+. (b .+. c)+add'assoc :: Semiring s => s -> s -> s -> Bool+add'assoc a b c = (a .+. b) .+. c == a .+. (b .+. c)++-- | > one .*. a == a+left'one :: Semiring s => s -> Bool+left'one a = one .*. a == a++-- | > a .*. one == a+right'one :: Semiring s => s -> Bool+right'one a = a .*. one == a++-- | > (a .*. b) .*. c == a .*. (b .*. c)+mul'assoc :: Semiring s => s -> s -> s -> Bool+mul'assoc a b c = (a .*. b) .*. c == a .*. (b .*. c)++-- | > a .*. (b .+. c) == (a .*. b) .+. (a .*. c)+left'distr :: Semiring s => s -> s -> s -> Bool+left'distr a b c = a .*. (b .+. c) == (a .*. b) .+. (a .*. c)++-- | > (a .+. b) .*. c == (a .*. c) .+. (b .*. c)+right'distr :: Semiring s => s -> s -> s -> Bool+right'distr a b c = (a .+. b) .*. c == (a .*. c) .+. (b .*. c)++-- | > zero .*. a == zero+left'ann :: Semiring s => s -> Bool+left'ann a = zero .*. a == zero++-- | > a .*. zero == zero+right'ann :: Semiring s => s -> Bool+right'ann a = a .*. zero == zero
+ src/Text/RegExp.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS -fno-warn-orphans #-}++-- |+-- Module : Text.RegExp+-- Copyright : Thomas Wilke, Frank Huch, and Sebastian Fischer+-- License : BSD3+-- Maintainer : Sebastian Fischer <mailto:sebf@informatik.uni-kiel.de>+-- Stability : experimental+-- +-- This library provides a simple and fast regular expression matcher+-- that is implemented in Haskell without binding to external+-- libraries.+-- +-- There are different ways to implement regular expression+-- matching. Backtracking algorithms are simple but need bookkeeping+-- overhead for nondeterministic search. One can use deterministic+-- finite automata (DFA, see+-- <http://swtch.com/~rsc/regexp/regexp1.html>) to match regular+-- expressions faster. But for certain regular expressions these DFA+-- are exponentially large which sometimes leads to prohibitive memory+-- requirements.+-- +-- We use a smart and simple algorithm to generate a DFA from a+-- regular expression and do not generate the DFA completely but on+-- the fly while parsing. This leads to a linear-time deterministic+-- algorithm with constant space requirements. More specifically, the+-- run time is limited by the product of the sizes of the regular+-- expression and the string and the memory is limited by the size of+-- the regular expression.+-- +module Text.RegExp (++ module Data.Semiring, Weight(..),++ -- * Constructing regular expressions++ RegExp, fromString,++ eps, char, sym, psym, anySym, alt, seq_, rep, rep1, opt, brep,++ -- * Matching++ (=~), accept, matchingCount, fullMatch, partialMatch++ ) where++import Data.Semiring+import qualified Data.String++import Text.RegExp.Data+import Text.RegExp.Parser+import Text.RegExp.Matching++-- |+-- Parses a regular expression from its string representation. If the+-- 'OverloadedStrings' language extension is enabled, string literals+-- can be used as regular expressions without using 'fromString'+-- explicitly. Implicit conversion is especially useful in combination+-- with functions like '=~' that take a value of type @RegExp Char@ as+-- argument.+-- +-- Here are some examples of supported regular expressions along with+-- an explanation what they mean:+-- +-- * @a@ matches the character @a@+-- +-- * @[abc]@ matches any of the characters @a@, @b@, or @c@. It is+-- equivalent to @(a|b|c)@, but @|@ can be used to specify+-- alternatives between arbitrary regular expressions, not only+-- characters.+-- +-- * @[^abc]@ matches anything but the characters @a@, @b@, or @c@.+-- +-- * @\\d@ matches a digit and is equivalent to @[0-9]@. Moreover,+-- @\\D@ matches any non-digit character, @\\s@ and @\\S@ match+-- space and non-space characters and @\\w@ and @\\W@ match word+-- characters and non-word characters, that is, @\\w@ abbreviates+-- @[a-zA-Z_]@.+-- +-- * @a?@ matches the empty word or the character @a@, @a*@ matches+-- zero or more occurrences of @a@, and @a+@ matches one or more+-- @a@'s.+-- +-- * @.@ (the dot) matches one arbitrary character.+-- +-- * @a{4,7}@ matches four to seven occurrences of @a@, @a{2}@+-- matches two.+-- +fromString :: String -> RegExp Char+fromString = Data.String.fromString++instance Data.String.IsString (RegExp Char) where+ fromString = parse++-- | +-- Alias for 'accept' specialized for Strings. Useful in combination+-- with the 'IsString' instance for 'RegExp' 'Char'+-- +(=~) :: RegExp Char -> String -> Bool+(=~) = accept+
+ src/Text/RegExp/Data.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module Text.RegExp.Data where++import Data.Semiring++-- |+-- Regular expressions are represented as values of type 'RegExp' @c@+-- where @c@ is the character type of the underlying alphabet. Values+-- of type @RegExp@ @c@ can be matched against lists of type @[c]@.+-- +newtype RegExp c = RegExp (forall w . Semiring w => RegW w c)++data RegW w c = RegW { active :: !Bool,+ empty :: !w, + final_ :: !w, + reg :: Reg w c }++final :: Semiring w => RegW w c -> w+final r = if active r then final_ r else zero++data Reg w c = Eps+ | Sym String (c -> w)+ | Alt (RegW w c) (RegW w c)+ | Seq (RegW w c) (RegW w c)+ | Rep (RegW w c)++class Semiring w => Weight a b w where+ symWeight :: (a -> w) -> b -> w++instance Weight c (Int,c) Bool where+ symWeight p = p . snd++instance Num a => Weight c (Int,c) (Numeric a) where+ symWeight p = p . snd++weighted :: Weight a b w => RegW w a -> RegW w b+weighted (RegW a e f r) =+ case r of+ Eps -> RegW a e f Eps+ Sym s p -> RegW a e f (Sym s (symWeight p))+ Alt p q -> RegW a e f (Alt (weighted p) (weighted q))+ Seq p q -> RegW a e f (Seq (weighted p) (weighted q))+ Rep p -> RegW a e f (Rep (weighted p))++-- |+-- Matches the empty word. 'eps' has no direct string representation+-- but is used to implement other constructs such as optional+-- components like @a?@.+-- +eps :: RegExp c+eps = RegExp epsW++epsW :: Semiring w => RegW w c+epsW = RegW False one zero Eps++-- | Matches the given symbol.+-- +sym :: (Eq c, Show c) => c -> RegExp c+sym c = psym (show c) (c==)++-- | Matches the given character.+-- +char :: Char -> RegExp Char+char c = psym (quote c) (c==)++quote :: Char -> String+quote c | c `elem` " \\|*+?.[]{}^" = '\\' : [c]+ | otherwise = [c]++-- | Matches a symbol that satisfies the given predicate.+-- +psym :: String -> (c -> Bool) -> RegExp c+psym s p = RegExp (symW s (fromBool . p))++symW :: Semiring w => String -> (c -> w) -> RegW w c+symW s p = RegW False zero zero $ Sym s p++-- | Matches an arbitrary symbol.+-- +anySym :: RegExp c+anySym = psym "." (const True)++-- |+-- Matches either of two regular expressions. For example @a+b@+-- matches either the character @a@ or the character @b@.+-- +alt :: RegExp c -> RegExp c -> RegExp c+alt (RegExp p) (RegExp q) =+ RegExp (RegW False (empty p .+. empty q) zero (Alt p q))++altW :: Semiring w => RegW w c -> RegW w c -> RegW w c+altW p q = RegW (active p || active q)+ (empty p .+. empty q)+ (final p .+. final q)+ (Alt p q)++-- |+-- Matches the sequence of two regular expressions. For example the+-- regular expressions @ab@ matches the word @ab@.+-- +seq_ :: RegExp c -> RegExp c -> RegExp c+seq_ (RegExp p) (RegExp q) =+ RegExp (RegW False (empty p .*. empty q) zero (Seq p q))++seqW :: Semiring w => RegW w c -> RegW w c -> RegW w c+seqW p q = RegW (active p || active q)+ (empty p .*. empty q)+ (final p .*. empty q .+. final q)+ (Seq p q)++-- | Matches zero or more occurrences of the given regular+-- expression. For example @a*@ matches the character @a@ zero or+-- more times.+-- +rep :: RegExp c -> RegExp c+rep (RegExp r) = RegExp (RegW False one zero (Rep r))++repW :: Semiring w => RegW w c -> RegW w c+repW r = RegW (active r) one (final r) (Rep r)++-- | Matches one or more occurrences of the given regular+-- expression. For example @a+@ matches the character @a@ one or+-- more times.+-- +rep1 :: RegExp c -> RegExp c+rep1 r = r `seq_` rep r++-- |+-- Matches the given regular expression or the empty word. Optional+-- expressions are usually written @a?@ but could also be written+-- @(|a)@, that is, as alternative between 'eps' and @a@.+-- +opt :: RegExp c -> RegExp c+opt r = eps `alt` r++-- |+-- Matches a regular expression a given number of times. For example,+-- the regular expression @a{4,7}@ matches the character @a@ four to+-- seven times. If the minimal and maximal occurences are identical,+-- one can be left out, that is, @a{2}@ matches two occurrences of the+-- character @a@.+-- +-- Numerical bounds are implemented via translation into ordinary+-- regular expressions. For example, @a{4,7}@ is translated into+-- @aaaa(a(a(a)?)?)?@.+-- +brep :: (Int,Int) -> RegExp c -> RegExp c+brep (n,m) r+ | n < 0 || m < 0 || n > m = error msg+ | n == 0 && m == 0 = eps+ | n == m = foldr1 seq_ (replicate n r)+ | otherwise = foldr seq_ rest (replicate n r)+ where+ rest = foldr nestopt (opt r) (replicate (m-n-1) r)+ nestopt p q = opt (seq_ p q)+ msg = "Text.RegExp.brep: invalid repetition bounds: " ++ show (n,m)++regW :: Semiring w => RegExp c -> RegW w c+regW (RegExp r) = r++instance Show (RegExp Char) where+ showsPrec n r = showsPrec n (regW r :: RegW Bool Char)++instance Show (RegW Bool Char) where+ showsPrec n r = showsPrec n (reg r)++instance Show (Reg Bool Char) where+ showsPrec _ Eps = showString "()"+ showsPrec _ (Sym s _) = showString s+ showsPrec n (Alt p q) = showParen (n > 0)+ $ showsPrec 1 p+ . showString "|"+ . shows q+ showsPrec n (Seq p q) = showParen (n > 1)+ $ showsPrec 2 p+ . showsPrec 1 q+ showsPrec _ (Rep r) = showsPrec 2 r . showString "*"++instance Eq (RegExp Char) where+ p == q = regW p == (regW q :: RegW Bool Char)++instance Eq (RegW Bool Char) where+ p == q = reg p == reg q++instance Eq (Reg Bool Char) where+ Eps == Eps = True+ Sym s _ == Sym t _ = s==t+ Alt a b == Alt c d = a==c && b==d+ Seq a b == Seq c d = a==c && b==d+ Rep a == Rep b = a==b+ _ == _ = False
+ src/Text/RegExp/Matching.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts #-}++module Text.RegExp.Matching where++import Data.Semiring+import Text.RegExp.Data++-- |+-- Checks whether a regular expression matches the given word. For+-- example, @accept (fromString \"b|abc\") \"b\"@ yields @True@+-- because the first alternative of @b|abc@ matches the string+-- @\"b\"@.+-- +accept :: RegExp c -> [c] -> Bool+accept r = fullMatch r++-- |+-- Computes in how many ways a word can be matched against a regular+-- expression.+-- +matchingCount :: Num a => RegExp c -> [c] -> a+matchingCount r = getNumeric . fullMatch r++-- |+-- Matches a regular expression against a word computing a weight in+-- an arbitrary semiring.+-- +fullMatch :: Semiring w => RegExp c -> [c] -> w+fullMatch (RegExp r) = matchW r++-- |+-- Matches a regular expression against substrings of a word computing+-- a weight in an arbitrary semiring. The 'symWeight' function of+-- 'Weight's is used to report positional information about the+-- matching part of the word to the semiring.+-- +partialMatch :: Weight c (Int,c) w => RegExp c -> [c] -> w+partialMatch (RegExp r) =+ matchW (arb `seqW` weighted r `seqW` arb) . zip [(0::Int)..]+ where arb = repW (symW "." (const one))++matchW :: Semiring w => RegW w c -> [c] -> w+matchW r [] = empty r+matchW r (c:cs) = final (foldl (shiftW zero) (shiftW one r c) cs)++shiftW :: Semiring w => w -> RegW w c -> c -> RegW w c+shiftW w r c | active r || w /= zero = shift w (reg r) c+ | otherwise = r++shift :: Semiring w => w -> Reg w c -> c -> RegW w c+shift _ Eps _ = epsW+shift w (Sym s f) c = let w' = w .*. f c+ in (symW s f) { active = w' /= zero, final_ = w' }+shift w (Alt p q) c = altW (shiftW w p c) (shiftW w q c)+shift w (Seq p q) c = seqW (shiftW w p c)+ (shiftW (w .*. empty p .+. final p) q c)+shift w (Rep r) c = repW (shiftW (w .+. final r) r c)
+ src/Text/RegExp/Matching/LeftLong.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}++-- |+-- Module : Text.RegExp.Matching.LeftLong+-- Copyright : Thomas Wilke, Frank Huch, and Sebastian Fischer+-- License : BSD3+-- Maintainer : Sebastian Fischer <mailto:sebf@informatik.uni-kiel.de>+-- Stability : experimental+-- +-- This module implements leftmost longest matching based on weighted+-- regular expressions. It should be imported qualified as the+-- interface resembles that provided by other matching modules.+-- +module Text.RegExp.Matching.LeftLong (++ LeftLong(..), Matching(..),++ matching, getLeftLong++ ) where++import Text.RegExp++-- |+-- Subwords of words that match a regular expression are represented+-- as values of type 'Matching'.+-- +data Matching = Matching {+ + -- | Start index of the matching subword in the queried word.+ matchingIndex :: !Int,+ + -- | Length of the matching subword.+ matchingLength :: !Int+ + }+ deriving Eq++instance Show Matching+ where+ showsPrec _ m = showString "<index:" . shows (matchingIndex m)+ . showString " length:" . shows (matchingLength m)+ . showString ">"++-- |+-- Returns the leftmost longest of all non-empty matchings for a+-- regular expression in a given word. If the empty word is the only+-- matching its position is zero.+-- +matching :: RegExp c -> [c] -> Maybe Matching+matching r = getLeftLong . partialMatch r++-- | +-- Semiring used for leftmost longest matching.+-- +-- The `LeftLong` type satisfies the distributive laws only with a+-- precondition on all involved multiplications: multiplied matches+-- must be adjacent and the start position must be smaller than the+-- end position. This precondition is satisfied for all+-- multiplications during regular expression matching.+-- +data LeftLong = Zero | One | LeftLong !Int !Int+ deriving (Eq,Show)++getLeftLong :: LeftLong -> Maybe Matching+getLeftLong Zero = Nothing+getLeftLong One = Just $ Matching 0 0+getLeftLong (LeftLong x y) = Just $ Matching x (y-x+1)++instance Semiring LeftLong where+ zero = Zero; one = One++ Zero .+. y = y+ x .+. Zero = x+ One .+. y = y+ x .+. One = x+ LeftLong a b .+. LeftLong c d+ | a<c || a==c && b>=d = LeftLong a b+ | otherwise = LeftLong c d++ Zero .*. _ = Zero+ _ .*. Zero = Zero+ One .*. y = y+ x .*. One = x+ LeftLong a _ .*. LeftLong _ b = LeftLong a b++instance Weight c (Int,c) LeftLong where+ symWeight p (n,c) = p c .*. LeftLong n n+
+ src/Text/RegExp/Matching/Leftmost.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}++-- |+-- Module : Text.RegExp.Matching.Leftmost+-- Copyright : Thomas Wilke, Frank Huch, and Sebastian Fischer+-- License : BSD3+-- Maintainer : Sebastian Fischer <mailto:sebf@informatik.uni-kiel.de>+-- Stability : experimental+-- +-- This module implements leftmost matching based on weighted regular+-- expressions. It should be imported qualified as the interface+-- resembles that provided by other matching modules.+-- +module Text.RegExp.Matching.Leftmost (++ Leftmost(..), Matching(..),++ matching, getLeftmost++ ) where++import Text.RegExp++-- |+-- A 'Matching' records the leftmost start index of a matching subword.+-- +data Matching = Matching {+ + -- | Start index of the matching subword in the queried word.+ matchingIndex :: !Int+ + }+ deriving Eq++instance Show Matching+ where+ showsPrec _ m = showString "<index:" . shows (matchingIndex m)+ . showString ">"++-- |+-- Returns the leftmost of all non-empty matchings for a regular+-- expression in a given word. If the empty word is the only matching+-- its position is zero.+-- +matching :: RegExp c -> [c] -> Maybe Matching+matching r = getLeftmost . partialMatch r++-- | Semiring used for leftmost matching.+-- +data Leftmost = Zero | One | Leftmost !Int+ deriving (Eq,Show)++getLeftmost :: Leftmost -> Maybe Matching+getLeftmost Zero = Nothing+getLeftmost One = Just $ Matching 0 +getLeftmost (Leftmost x) = Just $ Matching x++instance Semiring Leftmost where+ zero = Zero; one = One++ Zero .+. y = y+ x .+. Zero = x+ One .+. y = y+ x .+. One = x+ Leftmost a .+. Leftmost b = Leftmost (min a b)++ Zero .*. _ = Zero+ _ .*. Zero = Zero+ One .*. y = y+ x .*. One = x+ Leftmost a .*. Leftmost b = Leftmost (min a b)++instance Weight c (Int,c) Leftmost where+ symWeight p (n,c) = p c .*. Leftmost n
+ src/Text/RegExp/Matching/Longest.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}++-- |+-- Module : Text.RegExp.Matching.Longest+-- Copyright : Thomas Wilke, Frank Huch, and Sebastian Fischer+-- License : BSD3+-- Maintainer : Sebastian Fischer <mailto:sebf@informatik.uni-kiel.de>+-- Stability : experimental+-- +-- This module implements longest matching based on weighted regular+-- expressions. It should be imported qualified as the interface+-- resembles that provided by other matching modules.+-- +module Text.RegExp.Matching.Longest (++ Longest(..), Matching(..),++ matching, getLongest++ ) where++import Text.RegExp++-- |+-- A 'Matching' records the leftmost start index of a matching subword.+-- +data Matching = Matching {+ + -- | Length of the matching subword in the queried word.+ matchingLength :: !Int+ + }+ deriving Eq++instance Show Matching+ where+ showsPrec _ m = showString "<length:" . shows (matchingLength m)+ . showString ">"++-- |+-- Returns the longest of all matchings for a regular expression in a+-- given word.+-- +matching :: RegExp c -> [c] -> Maybe Matching+matching r = getLongest . partialMatch r++-- | Semiring used for longest matching.+-- +data Longest = Zero | One | Longest !Int+ deriving (Eq,Show)++getLongest :: Longest -> Maybe Matching+getLongest Zero = Nothing+getLongest One = Just $ Matching 0 +getLongest (Longest x) = Just $ Matching x++instance Semiring Longest where+ zero = Zero; one = One++ Zero .+. y = y+ x .+. Zero = x+ One .+. y = y+ x .+. One = x+ Longest a .+. Longest b = Longest (max a b)++ Zero .*. _ = Zero+ _ .*. Zero = Zero+ One .*. y = y+ x .*. One = x+ Longest a .*. Longest b = Longest (a+b)++instance Weight c (Int,c) Longest where+ symWeight p (_,c) = p c .*. Longest 1
+ src/Text/RegExp/Parser.y view
@@ -0,0 +1,148 @@+{+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS -fno-warn-incomplete-patterns -fno-warn-missing-signatures #-}++module Text.RegExp.Parser ( parse ) where++import Text.RegExp.Data+ ( eps, char, psym, anySym, alt, seq_, rep, rep1, opt, brep )++import Data.Char ( isSpace, toLower, isAlphaNum, isDigit )++}++%name parseTokens+%tokentype { Token }+%error { parseError }++%token+ sym { Sym $$ }+ '*' { Ast }+ seq { Seq }+ '|' { Bar }+ '(' { L }+ ')' { R }+ '+' { Pls }+ '?' { Que }+ bnd { Bnd $$ }+ cls { Cls $$ }+ '.' { Dot }++%right '|'+%right seq+%right '*' '+' '?' bnd++%%++RegExp : {- empty -} { eps }+ | sym { char $1 }+ | RegExp '*' { rep $1 }+ | RegExp seq RegExp { seq_ $1 $3 }+ | RegExp '|' RegExp { alt $1 $3 }+ | '(' RegExp ')' { $2 }+ | RegExp '+' { rep1 $1 }+ | RegExp '?' { opt $1 }+ | RegExp bnd { brep $2 $1 }+ | cls { uncurry psym $1 }+ | '.' { anySym }++{++parse = parseTokens . scan++data Token = Seq | Sym Char | Ast | Bar | L | R+ | Pls | Que | Bnd (Int,Int)+ | Cls (String,Char -> Bool) | Dot+++token :: Char -> Token+token '*' = Ast+token '|' = Bar+token '(' = L+token ')' = R+token '?' = Que+token '+' = Pls+token '.' = Dot+token c = Sym c++scan :: String -> [Token]+scan = insertSeqs . process++insertSeqs :: [Token] -> [Token]+insertSeqs [] = []+insertSeqs [t] = [t]+insertSeqs (a:ts@(b:_))+ | lseq a && rseq b = a : Seq : insertSeqs ts+ | otherwise = a : insertSeqs ts++lseq :: Token -> Bool+lseq Bar = False+lseq L = False+lseq _ = True++rseq :: Token -> Bool+rseq (Sym _) = True+rseq L = True+rseq (Cls _) = True+rseq Dot = True+rseq _ = False++process :: String -> [Token]+process [] = []++process ('\\':c:cs) = Cls (['\\',c],symClassPred c) : process cs++process ('{':cs) = case reads cs of+ (n,'}':s1) : _ -> Bnd (n,n) : process s1+ (n,',':s1) : _ ->+ case reads s1 of+ (m,'}':s2) : _ -> Bnd (n,m) : process s2+ _ -> token '{' : process cs+ _ -> token '{' : process cs++process ('[':'^':cs) = Cls (('[':'^':s),not.p) : process xs+ where (s,p,xs) = processCls cs++process ('[' :cs) = Cls ('[':s,p) : process xs+ where (s,p,xs) = processCls cs++process (c:cs) = token c : process cs++processCls :: String -> (String, Char -> Bool, String)++processCls [] = parseError []++processCls (']':cs) = ("]", const False, cs)++processCls ('\\':c:cs)+ | isSymClassChar c = ('\\':c:s, \x -> symClassPred c x || p x, xs)+ where (s,p,xs) = processCls cs++processCls ('\\':c:cs) = ('\\':c:s, \x -> x==c || p x, xs)+ where (s,p,xs) = processCls cs++processCls (c:'-':e:cs) | e /= ']'+ = (c:'-':e:s, \d -> (c<=d && d<=e) || p d, xs)+ where (s,p,xs) = processCls cs++processCls (c:cs) = (c:s, \b -> b==c || p b, xs)+ where (s,p,xs) = processCls cs++isSymClassChar :: Char -> Bool+isSymClassChar = (`elem`"wWdDsS")++symClassPred :: Char -> Char -> Bool+symClassPred 'w' = isWordChar+symClassPred 'd' = isDigit+symClassPred 's' = isSpace+symClassPred 'W' = not . isWordChar+symClassPred 'D' = not . isDigit+symClassPred 'S' = not . isSpace+symClassPred c = (c==)++isWordChar :: Char -> Bool+isWordChar c = c == '_' || isAlphaNum c++parseError :: [Token] -> a+parseError _ = error "cannot parse regular expression"+}
+ src/criterion.lhs view
@@ -0,0 +1,78 @@++> {-# LANGUAGE OverloadedStrings #-}++We use Criterion to run a number of micro benchmarks that match+different regular expressions against strings.++> import Text.RegExp+> import Text.RegExp.Matching.Leftmost as Leftmost+> import Text.RegExp.Matching.Longest as Longest+> import Text.RegExp.Matching.LeftLong as LeftLong+>+> import Criterion.Main+>+> main :: IO ()+> main = defaultMain+> [ bgroup "full"+> [ bgroup mode+> [ bench name $ call re str+> | (name, re, str) <-+> [ ("phone", phone're, phone'str)+> , ("html" , html're , html'str)+> ]+> ]+> | (mode, call) <-+> [ ("accept", whnf . accept)+> , ("count" , whnf . (matchingCount :: RegExp Char -> String -> Int))+> ]+> ]+> , bgroup "partial"+> [ bgroup mode+> [ bench name $ call re str+> | (name, re, str) <-+> [ ("rna", rna're, rna'str)+> ]+> ]+> | (mode, call) <-+> [ ("accept" , whnf . accept)+> , ("leftmost", whnf . Leftmost.matching)+> , ("longest" , whnf . Longest.matching)+> , ("leftlong", whnf . LeftLong.matching)+> ]+> ]+> ]++The following regular expression for phone numbers matches uniquely+against phone numbers like the one given below.++> phone're :: RegExp Char+> phone're = "[0-9]+(-[0-9]+)*"+>+> phone'str :: String+> phone'str = "0431-880-7267"++As an example for an ambiguous match we match the following regular+expression wich reminds one of HTML documents.++> html're :: RegExp Char+> html're = "(<\\w*>.*</\\w*>)*"++This expressions matches the string below in two different ways.++> html'str :: String+> html'str = "<p>some</p><p>text</p>"++To benchmark partial matchings we search for a protein sequence in an+RNA sequence. Protein sequences start with `AUG`, followed by codons+(triplets) built from the bases adenin (`A`), cytosine (`C`), guanin+(`G`), and uracil (`U`), and end with `UAG`, `UGA`, or `UAA`.++> rna're :: RegExp Char+> rna're = "AUG([ACGU][ACGU][ACGU])*(UAG|UGA|UAA)"++For example, the following RNA sequence contains the protein sequence+`AUGACACUUGAAUGA`.++> rna'str :: String+> rna'str = "UUACGGAUGACACUUGAAUGACUGA"+
+ src/quickcheck.lhs view
@@ -0,0 +1,328 @@++> {-# LANGUAGE GeneralizedNewtypeDeriving #-}+> {-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-}+> {-# LANGUAGE ScopedTypeVariables #-}+> {-# LANGUAGE OverloadedStrings #-}+> {-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}++We specify a `Monoid` instance for a `newtype` of lists.++> import Data.Monoid ( Monoid(..) )++We use QuickCheck version 1 for testing because version 2 cannot be+used in batch mode.++> import Test.QuickCheck+> import Test.QuickCheck.Batch+> import Control.Monad ( ap, replicateM )+> import Data.Char ( chr, ord )++We import the semiring properties in order to check them for the+defined instances. We also define our own `sum` function for+semirings.++> import Data.Semiring.Properties+> import Prelude hiding ( sum )++Finally, we need the `RegExp` datatype, the `symWeight` function from+the `Weight` class, and the different semirings used for matching.++> import Text.RegExp+> import Text.RegExp.Data+> import Text.RegExp.Matching.Leftmost ( Leftmost(..), getLeftmost )+> import Text.RegExp.Matching.Longest ( Longest(..), getLongest )+> import Text.RegExp.Matching.LeftLong ( LeftLong(..), getLeftLong )+> import qualified Text.RegExp.Matching.Leftmost as Leftmost+> import qualified Text.RegExp.Matching.Longest as Longest+> import qualified Text.RegExp.Matching.LeftLong as LeftLong++The `main` function runs all tests defined in this program.++> main :: IO ()+> main = +> do runChecks "semiring laws (Bool)" (semiring'laws :: Checks Bool)+> runChecks "semiring laws (Int)" (semiring'laws :: Checks (Numeric Int))+> runChecks "semiring laws (Leftmost)" (semiring'laws :: Checks Leftmost)+> runChecks "semiring laws (Longest)" (semiring'laws :: Checks Longest)+> runChecks "semiring laws (LeftLong)" semiring'laws'LeftLong+> runTests (pad "full match") options $+> checks (full'match'spec :: Checks Bool) +++> checks (full'match'spec :: Checks (Numeric Int)) +++> checks (full'match'spec :: Checks Leftmost) +++> checks (full'match'spec :: Checks Longest) +++> checks (full'match'spec :: Checks LeftLong)+> runTests (pad "partial match") options $+> checks (partial'match'spec partialMatch id :: Checks Bool) +++> checks (partial'match'spec partialMatch id :: Checks (Numeric Int)) +++> checks (partial'match'spec Leftmost.matching getLeftmost) +++> checks (partial'match'spec Longest.matching getLongest) +++> checks (partial'match'spec LeftLong.matching getLeftLong)+> runTests (pad "parse printed regexp") options [run parse'printed]+> runChecks "lazy infinite regexps" infinite'regexp'checks+> where+> options = defOpt { no_of_tests = 1000, length_of_tests = 60 }+> runChecks s = runTests (pad s) options . checks+> pad s = replicate (25-length s) ' ' ++ s++The `Arbitrary` instance for numeric types wraps the underlying+instance. We also provide one for `Char` which is not predefined.++> instance (Num a, Arbitrary a) => Arbitrary (Numeric a) where+> arbitrary = Numeric `fmap` arbitrary+>+> instance Arbitrary Char where+> arbitrary = elements "abcde \\|*+?.[]{}"++We provide generic `Semiring` instances for the semirings used for+matching.++> instance Arbitrary Leftmost where+> arbitrary = frequency [ (1, return zero)+> , (1, return one)+> , (3, (Leftmost . abs) `fmap` arbitrary) ]+>+> instance Arbitrary Longest where+> arbitrary = frequency [ (1, return zero) +> , (1, return one)+> , (3, (Longest . succ . abs) `fmap` arbitrary) ]+>+> instance Arbitrary LeftLong where+> arbitrary = frequency [ (1, return zero)+> , (1, return one)+> , (3, do x <- abs `fmap` arbitrary+> y <- abs `fmap` arbitrary+> return $ LeftLong (min x y) (max x y)) ]++We define a list of `Checks` for the semiring laws.++> semiring'laws :: (Arbitrary s, Show s, Semiring s) => Checks s+> semiring'laws = mconcat [ prop2 plus'comm+> , prop1 left'zero+> , prop3 add'assoc+> , prop1 left'one+> , prop1 right'one+> , prop3 mul'assoc+> , prop3 left'distr+> , prop3 right'distr+> , prop1 left'ann+> , prop1 right'ann+> ]++`Checks` is a `newtype` for a list of batch tests with a phantom type+that can be used in definitions of the properties.++> newtype Checks a = Checks { checks :: [TestOptions -> IO TestResult] }+> deriving ( Monoid )++We define the auxiliary functions to create semiring properties with+different arities.++> prop1 :: (Arbitrary s, Show s, Testable a) => (s -> a) -> Checks s+> prop1 prop = Checks [run prop]+>+> prop2 :: (Arbitrary s, Show s, Testable a) => (s -> s -> a) -> Checks s+> prop2 prop = Checks [run prop]+>+> prop3 :: (Arbitrary s, Show s, Testable a) => (s-> s -> s -> a) -> Checks s+> prop3 prop = Checks [run prop]++The `LeftLong` type satisfies the distributive laws only with a+precondition on all involved multiplications: multiplied matches must+be adjacent and the start position must be smaller than the end+position. This precondition is satisfied for all multiplications+during regular expression matching.++We define a variant of `semiring'laws` with this precondition on the+distributive laws.++> semiring'laws'LeftLong :: Checks LeftLong+> semiring'laws'LeftLong = mconcat+> [ prop2 plus'comm+> , prop1 left'zero+> , prop3 add'assoc+> , prop1 left'one+> , prop1 right'one+> , prop3 mul'assoc+> , prop3 left'distr'LeftLong+> , prop3 right'distr'LeftLong+> , prop1 left'ann+> , prop1 right'ann+> ]++For testing the distributive laws, we adjust the randomly generated+`LeftLong` values such that the arguments of multiplications are+adjacent.++> left'distr'LeftLong :: LeftLong -> LeftLong -> LeftLong -> Bool+> left'distr'LeftLong a b c = left'distr a (shift a b) (shift a c)+> where+> shift (LeftLong _ x) (LeftLong y z) = LeftLong (x+1) (z+x+1-y)+> shift _ x = x+>+> right'distr'LeftLong :: LeftLong -> LeftLong -> LeftLong -> Bool+> right'distr'LeftLong a b c = right'distr (shift a c) (shift b c) c+> where+> shift (LeftLong x y) (LeftLong z _) = LeftLong (x+z-1-y) (z-1)+> shift x _ = x++Now we turn to the correctness of the `match` function. In order to+check it, we compare it with a executable specification which is+correct by definition:++> full'match'spec :: (Show s, Semiring s) => Checks s+> full'match'spec = match'spec fullMatchSpec fullMatch id+>+> partial'match'spec :: (Show a, Weight Char (Int,Char) s)+> => (RegExp Char -> String -> a)+> -> (s -> a)+> -> Checks s+> partial'match'spec = match'spec partialMatchSpec+>+> match'spec :: (Show a, Semiring s)+> => (RegExp Char -> String -> s)+> -> (RegExp Char -> String -> a)+> -> (s -> a)+> -> Checks s+> match'spec spec convmatch conv =+> Checks [run (check'match'spec spec convmatch conv)]+>+> check'match'spec :: (Show a, Semiring s)+> => (RegExp Char -> String -> s)+> -> (RegExp Char -> String -> a)+> -> (s -> a)+> -> RegExp Char -> String -> Property+> check'match'spec spec convmatch conv r s =+> length s < 7 ==> show (convmatch r s) == show (conv (spec r s))++To make this work, we need an `Arbitrary` instance for regular+expressions.++> instance Arbitrary (RegExp Char) where+> arbitrary = sized regexp+>+> regexp :: Int -> Gen (RegExp Char)+> regexp 0 = frequency [ (1, return eps)+> , (4, char `fmap` simpleChar) ]+> regexp n = frequency [ (1, regexp 0)+> , (3, alt `fmap` subexp `ap` subexp)+> , (6, seq_ `fmap` subexp `ap` subexp)+> , (3, rep `fmap` regexp (n-1))+> , (7, fromString `fmap` parsedRegExp n) ]+> where subexp = regexp (n `div` 2)+>+> simpleChar :: Gen Char+> simpleChar = elements "abcde"+>+> parsedRegExp :: Int -> Gen String+> parsedRegExp n = frequency [ (4, symClass)+> , (2, (++"?") `fmap` subexp)+> , (2, (++"+") `fmap` subexp)+> , (1, mkBrep1 =<< subexp)+> , (1, mkBrep2 =<< subexp) ]+> where+> subexp = (($"") . showParen True . shows)+> `fmap` (resize (n-1) arbitrary :: Gen (RegExp Char))+>+> mkBrep1 r = do x <- elements [0..3] :: Gen Int+> return $ r ++ "{" ++ show x ++ "}"+>+> mkBrep2 r = do x <- elements [0..2] :: Gen Int+> y <- elements [0..2] :: Gen Int+> return $ r ++ "{" ++ show x ++ "," ++ show (x+y) ++ "}"+>+> symClass :: Gen String+> symClass = frequency [ (1, specialChar)+> , (2, do n <- choose (0,3)+> cs <- replicateM n charClass+> s <- (["","^"]!!) `fmap` choose (0,1)+> return $ "[" ++ s ++ concat cs ++ "]") ]+> where+> specialChar = elements (map (:[]) "." +++> map (\c -> '\\':[c]) "abcdewWdDsS \\|*+?.[]{}^")+> charClass = oneof [ (:[]) `fmap` simpleChar+> , specialChar+> , do x <- simpleChar+> y <- simpleChar+> return $ x : '-' : [chr (ord x+ord y-ord 'a')] ]++The specification of the matching function is defined inductively on+the structure of a regular expression. It uses exhaustive search to+find all possibilities to match a regexp against a word.++> fullMatchSpec :: Semiring s => RegExp c -> [c] -> s+> fullMatchSpec (RegExp r) = matchSpec (reg r)+>+> matchSpec :: Semiring s => Reg s c -> [c] -> s+> matchSpec Eps u = if null u then one else zero+> matchSpec (Sym _ f) u = case u of [c] -> f c; _ -> zero+> matchSpec (Alt p q) u = matchSpec (reg p) u .+. matchSpec (reg q) u+> matchSpec (Seq p q) u =+> sum [ matchSpec (reg p) u1 .*. matchSpec (reg q) u2 | (u1,u2) <- split u ]+> matchSpec (Rep p) u =+> sum [ prod [ matchSpec (reg p) ui | ui <- ps] | ps <- parts u ]+>+> sum, prod :: Semiring s => [s] -> s+> sum = foldr (.+.) zero+> prod = foldr (.*.) one+>+> split :: [a] -> [([a],[a])]+> split [] = [([],[])]+> split (c:cs) = ([],c:cs) : [ (c:s1,s2) | (s1,s2) <- split cs ]+>+> parts :: [a] -> [[[a]]]+> parts [] = [[]]+> parts [c] = [[[c]]]+> parts (c:cs) = concat [ [(c:p):ps,[c]:p:ps] | p:ps <- parts cs ]++We can perform a similar test for partial instead of full matches.++> partialMatchSpec :: Weight c (Int,c) s => RegExp c -> [c] -> s+> partialMatchSpec (RegExp r) =+> matchSpec (reg (arb `seqW` weighted r `seqW` arb)) . zip [(0::Int)..]+> where arb = repW (symW "." (const one))++As a check for the parser, we check whether the representation+generated by the `Show` instance of regular expressions can be parsed+back and yields the original expression.++> parse'printed :: RegExp Char -> Bool+> parse'printed r = fromString (show r) == r++We can also match infinite regular expressions lazily to recognize+context-free or even context-sensitive languages.++> infinite'regexp'checks :: Checks Bool+> infinite'regexp'checks = Checks [run context'free, run context'sensitive]++As an example for a context-free language, we recognize the language+ ${a^nb^n | n >= 0}$.++> context'free :: String -> Bool+> context'free s = isInAnBn s == (anbn =~ s)+>+> isInAnBn :: String -> Bool+> isInAnBn s = all (=='a') xs && all (=='b') ys && length xs == length ys+> where (xs,ys) = break (=='b') s+>+> anbn :: RegExp Char+> anbn = eps `alt` seq_ "a" (anbn `seq_` "b")++As an example for a context-sensitive language we use the language+${a^nb^nc^n | n >= 0}$. To show that the alphabet cannot only contain+characters, we use numbers instead of characters.++> context'sensitive :: [Int] -> Bool+> context'sensitive s =+> fromBool (isInAnBnCn s) == (matchingCount anbncn s :: Numeric Int)+>+> isInAnBnCn :: [Int] -> Bool+> isInAnBnCn s = all (==1) xs && all (==2) ys && all (==3) zs+> && length xs == length ys && length ys == length zs+> where (xs,l) = break (==2) s+> (ys,zs) = break (==3) l+>+> anbncn :: RegExp Int+> anbncn = mkAnBnCn 0+> where+> mkAnBnCn n = brep (n,n) (sym 2) `seq_` brep (n,n) (sym 3)+> `alt` seq_ (sym 1) (mkAnBnCn (n+1))
+ weighted-regexp.cabal view
@@ -0,0 +1,99 @@+Name: weighted-regexp+Version: 0.1.0.0+Cabal-Version: >= 1.6+Synopsis: Weighted Regular Expression Matcher+Description:++ Haskell implementation of a weighted regular expression+ matcher with linear worst-case time and space bounds.++Category: Text, Parsing+License: BSD3+License-File: LICENSE+Author: Thomas Wilke, Frank Huch, Sebastian Fischer+Maintainer: Sebastian Fischer+Bug-Reports: http://github.com/sebfisch/haskell-regexp/issues+Homepage: http://sebfisch.github.com/haskell-regexp+Build-Type: Simple+Stability: experimental++Library+ Build-Tools: happy >= 1.17+ Build-Depends: base >= 3 && < 5,+ array >= 0.1 && < 0.4+ HS-Source-Dirs: src+ Exposed-Modules: Text.RegExp,+ Text.RegExp.Matching.Leftmost,+ Text.RegExp.Matching.Longest,+ Text.RegExp.Matching.LeftLong,+ Data.Semiring,+ Data.Semiring.Properties+ Other-Modules: Text.RegExp.Data,+ Text.RegExp.Parser,+ Text.RegExp.Matching+ Extensions: RankNTypes,+ FlexibleContexts,+ FlexibleInstances,+ MultiParamTypeClasses,+ NoMonomorphismRestriction,+ GeneralizedNewtypeDeriving++Flag QuickCheck+ Description: Build executable to run QuickCheck tests+ Default: False++Executable quickcheck-re+ Main-Is: quickcheck.lhs+ Build-Depends: base >= 3 && < 5, QuickCheck < 2+ HS-Source-Dirs: src+ Other-Modules: Text.RegExp,+ Text.RegExp.Matching.Leftmost,+ Text.RegExp.Matching.Longest,+ Text.RegExp.Matching.LeftLong,+ Data.Semiring,+ Data.Semiring.Properties+ Text.RegExp.Data,+ Text.RegExp.Parser,+ Text.RegExp.Matching+ Extensions: RankNTypes,+ FlexibleContexts,+ FlexibleInstances,+ MultiParamTypeClasses,+ NoMonomorphismRestriction,+ GeneralizedNewtypeDeriving,+ OverloadedStrings,+ ScopedTypeVariables+ GHC-Options: -fhpc -fno-warn-missing-methods -fno-warn-orphans+ If !flag(QuickCheck)+ Buildable: False++Flag Criterion+ Description: Build executable to run Criterion benchmarks+ Default: False++Executable criterion-re+ Main-Is: criterion.lhs+ Build-Depends: base >= 3 && < 5, criterion >= 0.5 && < 0.6+ HS-Source-Dirs: src+ Other-Modules: Text.RegExp,+ Text.RegExp.Matching.Leftmost,+ Text.RegExp.Matching.Longest,+ Text.RegExp.Matching.LeftLong,+ Data.Semiring,+ Text.RegExp.Data,+ Text.RegExp.Parser,+ Text.RegExp.Matching+ Extensions: RankNTypes,+ FlexibleContexts,+ FlexibleInstances,+ MultiParamTypeClasses,+ NoMonomorphismRestriction,+ GeneralizedNewtypeDeriving,+ OverloadedStrings+ GHC-Options: + If !flag(Criterion)+ Buildable: False++Source-Repository head+ type: git+ location: git://github.com/sebfisch/haskell-regexp.git