>
>
>
> 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
>
> data Pat = PVar Int [Range] Pat
> | PE [RE]
> | PPair Pat Pat
> | PChoice [Pat] GFlag
> | PStar Pat GFlag
> | PPlus Pat Pat
> | PEmpty Pat
> deriving Show
>
> 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)
> (==) (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 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))
>
> 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
>
> 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]
> mkEmpPat (PPlus p1 p2) = mkEmpPat p1
> mkEmpPat (PPair p1 p2) = PPair (mkEmpPat p1) (mkEmpPat p2)
> mkEmpPat (PChoice ps g) = PChoice (map mkEmpPat ps) g
>
> getBindingsFrom :: Pat
> -> 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
> 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
>
> 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 (PEmpty p) = False
> isGreedy (PStar p Greedy) = True
> isGreedy (PStar p NotGreedy) = False
> isGreedy (PPlus p p') = isGreedy p || isGreedy p'
>
>
> type Binder = IM.IntMap [Range]
>
> 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
>
> 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)
>
>
> updateBinderByIndex :: Int
> -> Int
> -> Binder
> -> Binder
> updateBinderByIndex i !pos binder =
> IM.update (\ r -> case r of
> { (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
>
>
>
> nub2 :: Eq a => [(a,b)] -> [(a,b)]
> nub2 = nubBy (\(p1,f1) (p2, f2) -> p1 == p2)
>
> pdPat0Sim :: Pat
> -> Letter
> -> [(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'
> }
>
>
> instance Simplifiable Pat where
>
> 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