module Term.Rewriting.Definitions (
Equal (..)
, evalEqual
, Match(..)
, flattenMatch
, matchWith
, matchOnlyIf
, RRule(..)
) where
import Control.Arrow ( (***) )
import Control.Applicative
import Extension.Data.Monoid
import Data.Foldable
import Data.Traversable
data Equal a = Equal { eqLHS :: a, eqRHS :: a }
deriving (Eq, Show)
evalEqual :: Eq a => Equal a -> Bool
evalEqual (Equal l r) = l == r
instance Functor Equal where
fmap f (Equal lhs rhs) = Equal (f lhs) (f rhs)
instance Monoid a => Monoid (Equal a) where
mempty = Equal mempty mempty
(Equal l1 r1) `mappend` (Equal l2 r2) =
Equal (l1 `mappend` l2) (r1 `mappend` r2)
instance Foldable Equal where
foldMap f (Equal l r) = f l `mappend` f r
instance Traversable Equal where
traverse f (Equal l r) = Equal <$> f l <*> f r
instance Applicative Equal where
pure x = Equal x x
(Equal fl fr) <*> (Equal l r) = Equal (fl l) (fr r)
data Match a =
NoMatch
| DelayedMatches [(a,a)]
instance Eq a => Eq (Match a) where
x == y = flattenMatch x == flattenMatch y
instance Show a => Show (Match a) where
show = show . flattenMatch
matchOnlyIf :: Bool -> Match a
matchOnlyIf False = NoMatch
matchOnlyIf True = mempty
matchWith :: a
-> a
-> Match a
matchWith t p = DelayedMatches [(t, p)]
flattenMatch :: Match a -> Maybe [(a, a)]
flattenMatch NoMatch = Nothing
flattenMatch (DelayedMatches ms) = Just ms
instance Functor Match where
fmap _ NoMatch = NoMatch
fmap f (DelayedMatches ms) = DelayedMatches (fmap (f *** f) ms)
instance Monoid (Match a) where
mempty = DelayedMatches []
NoMatch `mappend` _ = NoMatch
_ `mappend` NoMatch = NoMatch
DelayedMatches ms1 `mappend` DelayedMatches ms2 =
DelayedMatches (ms1 `mappend` ms2)
instance Foldable Match where
foldMap _ NoMatch = mempty
foldMap f (DelayedMatches ms) = foldMap (\(t, p) -> f t <> f p) ms
instance Traversable Match where
traverse _ NoMatch = pure NoMatch
traverse f (DelayedMatches ms) =
DelayedMatches <$> traverse (\(t, p) -> (,) <$> f t <*> f p) ms
data RRule a = RRule a a
deriving (Show, Ord, Eq)
instance Functor RRule where
fmap f (RRule lhs rhs) = RRule (f lhs) (f rhs)
instance Monoid a => Monoid (RRule a) where
mempty = RRule mempty mempty
(RRule l1 r1) `mappend` (RRule l2 r2) =
RRule (l1 `mappend` l2) (r1 `mappend` r2)
instance Foldable RRule where
foldMap f (RRule l r) = f l `mappend` f r
instance Traversable RRule where
traverse f (RRule l r) = RRule <$> f l <*> f r
instance Applicative RRule where
pure x = RRule x x
(RRule fl fr) <*> (RRule l r) = RRule (fl l) (fr r)