regex-deriv-0.0.4: Text/Regex/Deriv/IntPattern.lhs
> {-# LANGUAGE BangPatterns #-}
> -- | This module defines the data type of internal regular expression pattern,
> -- | as well as the partial derivative operations for regular expression patterns.
> module Text.Regex.Deriv.IntPattern
> ( Pat(..)
> , strip
> , Binder
> , toBinder
> , listifyBinder
> , Key(..)
> )
> where
> import Data.List
> import qualified Data.IntMap as IM
> import Text.Regex.Deriv.Common (Range(..), range, minRange, maxRange, Letter, PosEpsilon(..), IsEpsilon(..), IsPhi(..), GFlag(..), IsGreedy(..), Simplifiable(..) )
> import Text.Regex.Deriv.RE
> import Text.Regex.Deriv.Dictionary (Key(..), primeL, primeR)
> import Text.Regex.Deriv.Pretty
> -- | regular expression patterns
> data Pat = PVar Int [Range] Pat -- ^ variable pattern
> | PE [RE] -- ^ pattern without binder
> | PPair Pat Pat -- ^ pair pattern
> | PChoice [Pat] GFlag -- ^ choice pattern
> | PStar Pat GFlag -- ^ star pattern
> | PPlus Pat Pat -- ^ plus pattern, it is used internally to indicate that it is unrolled from a PStar
> | PEmpty Pat -- ^ empty pattern, it is used intermally to indicate that mkEmpty function has been applied.
> deriving Show
> {-| The Eq instance for Pat data type
> NOTE: We ignore the 'consumed word' when comparing patterns
> (ie we only compare the pattern structure).
> Essential for later comparisons among patterns. -}
> instance Eq Pat where
> (==) (PVar x1 _ p1) (PVar x2 _ p2) = (x1 == x2) && (p1 == p2)
> (==) (PPair p1 p2) (PPair p1' p2') = (p1 == p1') && (p2 == p2')
> (==) (PChoice ps1 g1) (PChoice ps2 g2) = (g1 == g2) && (ps1 == ps2) -- more efficient, because choices are constructed in left-nested
> (==) (PPlus p1 p2) (PPlus p1' p2') = (p1 == p1') && (p2 == p2')
> (==) (PStar p1 g1) (PStar p2 g2) = (g1 == g2) && (p1 == p2)
> (==) (PE rs1) (PE rs2) = rs1 == rs2
> (==) _ _ = False
>
> instance Pretty a => Pretty [a] where
> pretty [] = "{}"
> pretty a@(x:xs) = "{" ++ prettyAll ++ "}"
> where prettyAll = foldl' (\a i -> a++","++(pretty i)) (pretty x) xs
> instance Pretty Pat where
> pretty (PVar x1 _ p1) = "(" ++ show x1 ++ ":" ++ pretty p1 ++ ")"
> pretty (PPair p1 p2) = "<" ++ pretty p1 ++ "," ++ pretty p2 ++ ">"
> pretty (PChoice ps g) = "(" ++ pretty ps ++ ")" ++ (show g)
> pretty (PE rs) = "|" ++ show rs ++ "|"
> pretty (PPlus p1 p2 ) = "(" ++ pretty p1 ++ "," ++ pretty p2 ++ ")"
> pretty (PStar p g) = (pretty p) ++ "*" ++ (show g)
> pretty (PEmpty p) = "[" ++ pretty p ++ "]"
> {-
> instance Show Pat where
> show pat = pretty pat
> -}
> instance Key Pat where
> hash (PVar x1 _ p1) = let y1 = head (hash x1)
> y2 = head (hash p1)
> in y1 `seq` y2 `seq` [ 1 + y1 * primeL + y2 * primeR ]
> hash (PPair p1 p2) = let x1 = head (hash p1)
> x2 = head (hash p2)
> in x1 `seq` x2 `seq` [ 2 + x1 * primeL + x2 * primeR ]
> hash (PChoice (p1:p2:_) Greedy) = let x1 = head (hash p1)
> x2 = head (hash p2)
> in x1 `seq` x2 `seq` [ 4 + x1 * primeL + x2 * primeR ]
> hash (PChoice (p1:p2:_) NotGreedy) = let x1 = head (hash p1)
> x2 = head (hash p2)
> in x1 `seq` x2 `seq` [ 5 + x1 * primeL + x2 * primeR ]
> hash (PChoice (p1:_) _) = let x1 = head (hash p1)
>
> in x1 `seq` [ 5 + x1 * primeL ]
> hash (PChoice [] _) = [5]
> hash (PPlus p1 p2) = let x1 = head (hash p1)
> x2 = head (hash p2)
> in x1 `seq` x2 `seq` [ 6 + x1 * primeL + x2 * primeR ]
> hash (PStar p Greedy) = let x = head (hash p)
> in x `seq` [ 7 + x * primeL ]
> hash (PStar p NotGreedy) = let x = head (hash p)
> in x `seq` [ 8 + x * primeL ]
> hash (PE r) = let x = head (hash r)
> in x `seq` [ 9 + x * primeL ]
> hash (PEmpty p) = let x = head (hash p)
> in x `seq` [ 3 + x * primeL ]
> hash p = error ("hash is applied to an unacceptable pattern " ++ (show p))
> -- | function 'strip' strips away the bindings from a pattern
> strip :: Pat -> RE
> strip (PVar _ w p) = strip p
> strip (PE rs) = resToRE rs
> strip (PStar p g) = Star (strip p) g
> strip (PPair p1 p2) = Seq (strip p1) (strip p2)
> strip (PPlus p1 p2) = Seq (strip p1) (strip p2)
> strip (PChoice ps g) = Choice (map strip ps) g
> strip (PEmpty p) = strip p
> -- | function 'mkEmpPat' makes an empty pattern
> mkEmpPat :: Pat -> Pat
> mkEmpPat (PVar x w p) = PVar x w (mkEmpPat p)
> mkEmpPat (PE rs)
> | any posEpsilon rs = PE [Empty]
> | otherwise = PE [Phi]
> mkEmpPat (PStar p g) = PE [Empty] -- problematic?! we are losing binding (x,()) from ( x : a*) ~> PE <>
> mkEmpPat (PPlus p1 p2) = mkEmpPat p1 -- since p2 must be pstar we drop it. If we mkEmpPat p2, we need to deal with pdPat (PPlus (x :<>) (PE <>)) l
> mkEmpPat (PPair p1 p2) = PPair (mkEmpPat p1) (mkEmpPat p2)
> mkEmpPat (PChoice ps g) = PChoice (map mkEmpPat ps) g
> -- | function 'getBindingsFrom' transfer bindings from p2 to p1
> getBindingsFrom :: Pat -- ^ the source of the
> -> Pat -> Pat
> getBindingsFrom p1 p2 = let b = toBinder p2
> in assign p1 b
> where assign :: Pat -> Binder -> Pat
> assign (PVar x w p) b =
> case IM.lookup x b of
> Nothing -> let p' = assign p b in PVar x w p'
> Just rs -> let
> p' = assign p b
> in PVar x (w ++ rs) p'
> assign (PE r) _ = PE r
> assign (PPlus p1 p2) b = PPlus (assign p1 b) p2 -- we don't need to care about p2 since it is a p*
> assign (PPair p1 p2) b = PPair (assign p1 b) (assign p2 b)
> assign (PChoice ps g) b = PChoice (map (\p -> assign p b) ps) g
> -- | Function 'isGreedy' checks whether a pattern is greedy
> instance IsGreedy Pat where
> isGreedy (PVar _ _ p) = isGreedy p
> isGreedy (PE rs) = any isGreedy rs
> isGreedy (PPair p1 p2) = isGreedy p1 || isGreedy p2
> isGreedy (PChoice ps Greedy) = True
> isGreedy (PChoice ps NotGreedy) = False -- isGreedy p1 || isGreedy p2
> isGreedy (PEmpty p) = False
> isGreedy (PStar p Greedy) = True
> isGreedy (PStar p NotGreedy) = False
> isGreedy (PPlus p p') = isGreedy p || isGreedy p'
> -- | The 'Binder' type denotes a set of (pattern var * range) pairs
> -- type Binder = [(Int, [Range])]
> type Binder = IM.IntMap [Range]
> -- | check whether a pattern has binder
> hasBinder :: Pat -> Bool
> hasBinder (PVar _ _ _) = True
> hasBinder (PPair p1 p2) = (hasBinder p1) || (hasBinder p2)
> hasBinder (PPlus p1 p2) = hasBinder p1
> hasBinder (PStar p1 g) = hasBinder p1
> hasBinder (PE rs) = False
> hasBinder (PChoice ps g) = any hasBinder ps
> hasBinder (PEmpty p) = hasBinder p
> -- | Function 'toBinder' turns a pattern into a binder
> toBinder :: Pat -> Binder
> toBinder p = IM.fromList (toBinderList p)
> toBinderList :: Pat -> [(Int, [Range])]
> toBinderList (PVar i rs p) = [(i, rs)] ++ (toBinderList p)
> toBinderList (PPair p1 p2) = (toBinderList p1) ++ (toBinderList p2)
> toBinderList (PPlus p1 p2) = (toBinderList p1)
> toBinderList (PStar p1 g) = (toBinderList p1)
> toBinderList (PE rs) = []
> toBinderList (PChoice ps g) = concatMap toBinderList ps
> toBinderList (PEmpty p) = toBinderList p
> listifyBinder :: Binder -> [(Int, [Range])]
> listifyBinder b = sortBy (\ x y -> compare (fst x) (fst y)) (IM.toList b)
>
> {-| Function 'updateBinderByIndex' updates a binder given an index to a pattern var
> ASSUMPTION: the var index in the pattern is linear. e.g. no ( 0 :: R1, (1 :: R2, 2 :a: R3))
> -}
> updateBinderByIndex :: Int
> -> Int
> -> Binder
> -> Binder
> updateBinderByIndex i !pos binder = -- binder {-
> IM.update (\ r -> case r of -- we always initialize to [], we don't need to handle the key miss case
> { (rs_@((Range b e):rs)) ->
> let !e' = e + 1
> in case e' of
> _ | pos == e' -> Just ((range b e'):rs)
> | pos > e' -> Just ((range pos pos):rs_)
> | otherwise -> error "impossible, the current letter position is smaller than the last recorded letter"
> ; [] -> Just [(range pos pos)]
> } ) i binder -- -}
> {-
> updateBinderByIndex i pos binder =
> case IM.lookup i binder of
> { Nothing -> IM.insert i [(pos, pos)] binder
> ; Just ranges ->
> case ranges of
> { [] -> IM.update (\_ -> Just [(pos,pos)]) i binder
> ; ((b,e):rs)
> | pos == e + 1 -> IM.update (\_ -> Just ((b,e+1):rs)) i binder
> | pos > e + 1 -> IM.update (\_ -> Just ((pos,pos):(b,e):rs)) i binder
> | otherwise -> error "impossible, the current letter position is smaller than the last recorded letter"
> }
> }
> -}
> {-
> {-# INLINE updateBinderByIndex #-}
> updateBinderByIndex :: Int -- ^ the indext of the pattern variable
> -> Int -- ^ the letter position
> -> Binder -> Binder
> updateBinderByIndex i lpos binder =
> updateBinderByIndexSub i lpos binder
>
> {-# INLINE updateBinderByIndexSub #-}
> updateBinderByIndexSub :: Int -> Int -> Binder -> Binder
> updateBinderByIndexSub idx pos [] = []
> updateBinderByIndexSub idx pos (x@(idx',(b,e):rs):xs)
> -- | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined
> | idx == idx' = if pos == (e + 1)
> then (idx', (b, e+ 1):rs):xs
> else if pos > (e + 1)
> then (idx', (pos,pos):(b, e):rs):xs
> else error "impossible, the current letter position is smaller than the last recorded letter"
> | otherwise = -- idx `seq` pos `seq` xs `seq`
> x:(updateBinderByIndexSub idx pos xs)
> updateBinderByIndexSub idx pos (x@(idx',[]):xs)
> -- | pos `seq` idx `seq` idx' `seq` xs `seq` False = undefined
> | idx == idx' = ((idx', [(pos, pos)]):xs)
> | otherwise = -- idx `seq` pos `seq` xs `seq`
> x:(updateBinderByIndexSub idx pos xs)
> -}
> {-
> {-| Function 'pdPat0' is the 'abstracted' form of the 'pdPat' function
> It computes a set of pairs. Each pair consists a 'shape' of the partial derivative, and
> an update function which defines the change of the pattern bindings from the 'source' pattern to
> the resulting partial derivative. This is used in the compilation of the regular expression pattern -}
> pdPat0 :: Pat -- ^ the source pattern
> -> Letter -- ^ the letter to be "consumed"
> -> [(Pat, Int -> Binder -> Binder)]
> pdPat0 (PVar x w p) (l,idx)
> | hasBinder p =
> let pfs = pdPat0 p (l,idx)
> in g `seq` pfs `seq` [ (PVar x [] pd, (\i -> (g i) . (f i) )) | (pd,f) <- pfs ]
> | otherwise = -- p is not nested
> let pds = partDeriv (strip p) l
> in g `seq` pds `seq` if null pds then []
> else -- not PCRE [ (PVar x [] (PE (resToRE pds)), g) ]
> [ (PVar x [] (PE pd), g) | pd <- pds ]
> where g = updateBinderByIndex x
> {-
> | IM.null (toBinder p) = -- p is not nested
> let pds = partDeriv (strip p) l
> in g `seq` pds `seq` if null pds then []
> else [ (PVar x [] (PE (resToRE pds)), g) ]
> | otherwise =
> let pfs = pdPat0 p (l,idx)
> in g `seq` pfs `seq` [ (PVar x [] pd, (\i -> (g i) . (f i) )) | (pd,f) <- pfs ]
> where g = updateBinderByIndex x
> -}
> pdPat0 (PE r) (l,idx) =
> let pds = partDeriv r l
> in pds `seq` if null pds then []
> else [ (PE (resToRE pds), ( \_ -> id ) ) ]
> pdPat0 (PStar p g) l = let pfs = pdPat0 p l
> in pfs `seq` [ (PPair p' (PStar p g), f) | (p', f) <- pfs ]
> pdPat0 (PPair p1 p2) l =
> if (posEpsilon (strip p1))
> then if isGreedy p1
> then nub2 ([ (PPair p1' p2, f) | (p1' , f) <- pdPat0 p1 l ] ++ (pdPat0 p2 l))
> else nub2 ((pdPat0 p2 l) ++ [ (PPair p1' p2, f) | (p1' , f) <- pdPat0 p1 l ])
> else [ (PPair p1' p2, f) | (p1',f) <- pdPat0 p1 l ]
> pdPat0 (PChoice ps g) l =
> nub2 (concatMap (\p -> pdPat0 p l) ps) -- nub doesn't seem to be essential
> nub2 :: Eq a => [(a,b)] -> [(a,b)]
> nub2 = nubBy (\(p1,f1) (p2, f2) -> p1 == p2)
> {-| Function 'pdPat0Sim' applies simplification to the results of 'pdPat0' -}
> pdPat0Sim :: Pat -- ^ the source pattern
> -> Letter -- ^ the letter to be "consumed"
> -> [(Pat, Int -> Binder -> Binder)]
> pdPat0Sim p l =
> let pfs = pdPat0 p l
> pfs' = pfs `seq` map (\(p,f) -> (simplify p, f)) pfs
> in nub2 pfs'
> -}
> -- | mainly interested in simplifying epsilon, p --> p
> -- could be made more optimal, e.g. (epsilon, epsilon) --> epsilon
> instance Simplifiable Pat where
> -- simplify :: Pat -> Pat
> simplify (PVar i rs p) = PVar i rs (simplify p)
> simplify (PPair p1 p2) =
> let p1' = simplify p1
> p2' = simplify p2
> in if isEpsilon p1'
> then p2'
> else if isEpsilon p2'
> then p1'
> else PPair p1' p2'
> simplify (PChoice ps g) =
> let ps' = filter (not . isPhi) (map simplify ps)
> in PChoice ps' g
> simplify (PStar p g) = PStar (simplify p) g
> simplify (PPlus p1 p2) = PPlus (simplify p1) (simplify p2)
> simplify (PE r) = PE (map simplify r)
> instance IsEpsilon Pat where
> isEpsilon (PVar _ _ p) = isEpsilon p
> isEpsilon (PE rs) = all isEpsilon rs
> isEpsilon (PPair p1 p2) = (isEpsilon p1) && (isEpsilon p2)
> isEpsilon (PChoice ps _) = all isEpsilon ps
> isEpsilon (PStar p _) = isEpsilon p
> isEpsilon (PPlus p1 p2) = isEpsilon p1 && isEpsilon p2
> isEpsilon (PEmpty _) = True
> instance IsPhi Pat where
> isPhi (PVar _ _ p) = isPhi p
> isPhi (PE rs) = all isPhi rs
> isPhi (PPair p1 p2) = (isPhi p1) || (isPhi p2)
> isPhi (PChoice ps _) = all isPhi ps
> isPhi (PStar p _) = False
> isPhi (PPlus p1 p2) = isPhi p1 || isPhi p2
> isPhi (PEmpty _) = False