module Data.Regex.Generics (
Regex(Regex),
Regex'(Inject),
Fix(..),
empty_, none,
any_,
inj, __,
square, var, (#),
choice, (<||>),
concat_, (<.>),
iter, (^*),
capture, (<<-),
Matchable,
matches, match,
with,
arbitraryFromRegex,
arbitraryFromRegexAndGen
) where
import Control.Applicative
import Control.Exception
import Control.Monad (guard)
import Data.Foldable as F
import Data.Functor.Foldable (Fix(..))
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (isJust)
import Data.Typeable
import GHC.Generics
import System.IO.Unsafe (unsafePerformIO)
import Test.QuickCheck
import Test.QuickCheck.Arbitrary1
data Regex' k c (f :: * -> *)
= Empty
| Any
| Inject (f (Regex' k c f))
| Square k
| Choice (Regex' k c f) (Regex' k c f)
| Concat (k -> Regex' k c f) (Regex' k c f)
| Capture c (Regex' k c f)
newtype Regex c (f :: * -> *) = Regex { unRegex :: forall k. Regex' k c f }
empty_, none :: Regex' k c f
empty_ = Empty
none = empty_
any_ :: Regex' k c f
any_ = Any
inj :: f (Regex' k c f) -> Regex' k c f
inj = Inject
__ :: a
__ = throw DoNotCheckThisException
data DoNotCheckThisException = DoNotCheckThisException deriving (Show, Typeable)
instance Exception DoNotCheckThisException
square, var :: k -> Regex' k c f
square = Square
var = square
(#) :: k -> Regex' k c f
(#) = square
infixl 3 <||>
choice, (<||>) :: Regex' k c f -> Regex' k c f -> Regex' k c f
choice = Choice
(<||>) = choice
concat_, (<.>) :: (k -> Regex' k c f) -> Regex' k c f -> Regex' k c f
concat_ = Concat
(<.>) = concat_
iter :: (k -> Regex' k c f) -> Regex' k c f
iter r = Concat r (iter r)
(^*) :: (k -> Regex' k c f) -> Regex' k c f
(^*) = iter
infixl 4 <<-
capture, (<<-) :: c -> Regex' k c f -> Regex' k c f
capture = Capture
(<<-) = capture
type Matchable f = (Generic1 f, MatchG (Rep1 f))
matches :: forall c f. (Ord c, Matchable f)
=> Regex c f -> Fix f -> Bool
r `matches` t = isJust $ (match r t :: Maybe (Map c [Fix f]))
match :: (Ord c, Matchable f, Alternative m)
=> Regex c f -> Fix f -> Maybe (Map c (m (Fix f)))
match r t = match' (unRegex r) t 0 []
match' :: (Ord c, Matchable f, Alternative m)
=> Regex' Integer c f
-> Fix f
-> Integer
-> [(Integer, Regex' Integer c f)]
-> Maybe (Map c (m (Fix f)))
match' Empty _ _ _ = Nothing
match' Any _ _ _ = Just M.empty
match' (Inject r) (Fix t) i s = injG (from1 r) (from1 t) i s
match' (Square n) t i s = let Just r = lookup n s in match' r t i s
match' (Choice r1 r2) t i s = match' r1 t i s <|> match' r2 t i s
match' (Concat r1 r2) t i s = match' (r1 i) t (i+1) ((i,r2):s)
match' (Capture c r) t i s = M.insertWith (<|>) c (pure t) <$> match' r t i s
class MatchG f where
injG :: (Ord c, Matchable g, Alternative m)
=> f (Regex' Integer c g) -> f (Fix g)
-> Integer -> [(Integer, Regex' Integer c g)]
-> Maybe (Map c (m (Fix g)))
instance MatchG U1 where
injG _ _ _ _ = Just M.empty
instance MatchG Par1 where
injG (Par1 r) (Par1 t) = match' r t
instance Eq c => MatchG (K1 i c) where
injG (K1 r) (K1 t) _ _ = unsafePerformIO $
catch (evaluate $ do guard (r == t)
return M.empty)
(\(_ :: DoNotCheckThisException) -> return $ Just M.empty)
instance (Functor f, Foldable f) => MatchG (Rec1 f) where
injG (Rec1 rs) (Rec1 ts) i s =
F.foldr (<|>) Nothing
$ fmap (\r -> F.foldr (\x1 x2 -> case (x1, x2) of
(Just m1, Just m2) -> Just (M.unionWith (<|>) m1 m2)
_ -> Nothing)
(Just M.empty)
$ fmap (\t -> match' r t i s) ts) rs
instance MatchG a => MatchG (M1 i c a) where
injG (M1 r) (M1 t) = injG r t
instance (MatchG a, MatchG b) => MatchG (a :+: b) where
injG (L1 r) (L1 t) i s = injG r t i s
injG (R1 r) (R1 t) i s = injG r t i s
injG _ _ _ _ = Nothing
instance (MatchG a, MatchG b) => MatchG (a :*: b) where
injG (r1 :*: r2) (t1 :*: t2) i s = M.unionWith (<|>) <$> injG r1 t1 i s <*> injG r2 t2 i s
instance (Functor f, Foldable f, MatchG g) => MatchG (f :.: g) where
injG (Comp1 rs) (Comp1 ts) i s =
F.foldr (<|>) Nothing
$ fmap (\r -> F.foldr (\x1 x2 -> case (x1, x2) of
(Just m1, Just m2) -> Just (M.unionWith (<|>) m1 m2)
_ -> Nothing)
(Just M.empty)
$ fmap (\t -> injG r t i s) ts) rs
class With f fn r | fn -> r where
with :: fn -> Fix f -> Maybe r
instance (Generic1 f, MatchG (Rep1 f), Ord c)
=> With f (Regex c f) () where
with r t = (const ()) <$> (match r t :: Maybe (Map c [Fix f]))
instance (Generic1 f, MatchG (Rep1 f))
=> With f (Integer -> Regex Integer f) [Fix f] where
with r t = M.findWithDefault [] 1 <$> match (r 1) t
instance (Generic1 f, MatchG (Rep1 f))
=> With f (Integer -> Integer -> Regex Integer f)
([Fix f], [Fix f]) where
with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m))
<$> match (r 1 2) t
instance (Generic1 f, MatchG (Rep1 f))
=> With f (Integer -> Integer -> Integer -> Regex Integer f)
([Fix f],[Fix f],[Fix f]) where
with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m, M.findWithDefault [] 3 m))
<$> match (r 1 2 3) t
instance (Generic1 f, MatchG (Rep1 f))
=> With f (Integer -> Integer -> Integer -> Integer -> Regex Integer f)
([Fix f],[Fix f],[Fix f],[Fix f]) where
with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m,
M.findWithDefault [] 3 m, M.findWithDefault [] 4 m))
<$> match (r 1 2 3 4) t
instance (Generic1 f, MatchG (Rep1 f))
=> With f (Integer -> Integer -> Integer -> Integer -> Integer -> Regex Integer f)
([Fix f],[Fix f],[Fix f],[Fix f],[Fix f]) where
with r t = (\m -> (M.findWithDefault [] 1 m, M.findWithDefault [] 2 m, M.findWithDefault [] 3 m,
M.findWithDefault [] 4 m, M.findWithDefault [] 5 m))
<$> match (r 1 2 3 4 5) t
arbitraryFromRegex :: (Generic1 f, ArbitraryRegexG (Rep1 f), Arbitrary (Fix f))
=> Regex c f -> Gen (Fix f)
arbitraryFromRegex = arbitraryFromRegexAndGen arbitrary
arbitraryFromRegexAndGen :: (Generic1 f, ArbitraryRegexG (Rep1 f))
=> Gen (Fix f) -> Regex c f -> Gen (Fix f)
arbitraryFromRegexAndGen g r = arbitraryFromRegex_ g (unRegex r) 0 []
arbitraryFromRegex_ :: (Generic1 f, ArbitraryRegexG (Rep1 f))
=> Gen (Fix f)
-> Regex' Integer c f
-> Integer -> [(Integer, Regex' Integer c f)]
-> Gen (Fix f)
arbitraryFromRegex_ _ Empty _ _ = error "Cannot generate empty tree"
arbitraryFromRegex_ g Any _ _ = g
arbitraryFromRegex_ g (Capture _ r) i s = arbitraryFromRegex_ g r i s
arbitraryFromRegex_ g (Inject r) i s = Fix . to1 <$> arbG g (from1 r) i s
arbitraryFromRegex_ g (Square n) i s = let Just r = lookup n s in arbitraryFromRegex_ g r i s
arbitraryFromRegex_ g (Concat r1 r2) i s = arbitraryFromRegex_ g (r1 i) (i+1) ((i,r2):s)
arbitraryFromRegex_ g r@(Choice _ _) i s = oneof [arbitraryFromRegex_ g rx i s | rx <- toListOfChoices r]
toListOfChoices :: Regex' k c f -> [Regex' k c f]
toListOfChoices Empty = []
toListOfChoices Any = [Any]
toListOfChoices (Capture _ r) = toListOfChoices r
toListOfChoices (Choice r1 r2) = toListOfChoices r1 ++ toListOfChoices r2
toListOfChoices r = [r]
class ArbitraryRegexG f where
arbG :: (Generic1 g, ArbitraryRegexG (Rep1 g))
=> Gen (Fix g)
-> f (Regex' Integer c g)
-> Integer -> [(Integer, Regex' Integer c g)]
-> Gen (f (Fix g))
instance ArbitraryRegexG U1 where
arbG _ U1 _ _ = return U1
instance ArbitraryRegexG Par1 where
arbG g (Par1 r) i s = Par1 <$> arbitraryFromRegex_ g r i s
instance Arbitrary c => ArbitraryRegexG (K1 i c) where
arbG _ (K1 r) _ _ = unsafePerformIO $
catch (r `seq` return (return (K1 r)))
(\(_ :: DoNotCheckThisException) -> return (K1 <$> arbitrary))
instance (Foldable f, Arbitrary1 f) => ArbitraryRegexG (Rec1 f) where
arbG g (Rec1 rs) i s = let r:_ = toList rs in Rec1 <$> arbitrary1 (arbitraryFromRegex_ g r i s)
instance ArbitraryRegexG a => ArbitraryRegexG (M1 i c a) where
arbG g (M1 r) i s = M1 <$> arbG g r i s
instance (ArbitraryRegexG a, ArbitraryRegexG b) => ArbitraryRegexG (a :+: b) where
arbG g (L1 r) i s = L1 <$> arbG g r i s
arbG g (R1 r) i s = R1 <$> arbG g r i s
instance (ArbitraryRegexG a, ArbitraryRegexG b) => ArbitraryRegexG (a :*: b) where
arbG g (r1 :*: r2) i s = (:*:) <$> arbG g r1 i s <*> arbG g r2 i s