module Generics.Regular.Rewriting.Base (
Functor (..),
GMap (..),
Crush (..),
flatten,
Zip (..),
fzip,
fzip',
geq,
GShow (..),
LRBase (..),
LR (..),
left,
right
) where
import Control.Monad
import Generics.Regular.Rewriting.Representations
instance Functor Id where
fmap f (Id r) = Id (f r)
instance Functor (K a) where
fmap _ (K a) = K a
instance Functor Unit where
fmap _ Unit = Unit
instance (Functor f, Functor g) => Functor (f :+: g) where
fmap f (L x) = L (fmap f x)
fmap f (R y) = R (fmap f y)
instance (Functor f, Functor g) => Functor (f :*: g) where
fmap f (x :*: y) = fmap f x :*: fmap f y
instance Functor f => Functor (Con f) where
fmap f (Con con r) = Con con (fmap f r)
class GMap f where
fmapM :: Monad m => (a -> m b) -> f a -> m (f b)
instance GMap Id where
fmapM f (Id r) = liftM Id (f r)
instance GMap (K a) where
fmapM _ (K x) = return (K x)
instance GMap Unit where
fmapM _ Unit = return Unit
instance (GMap f, GMap g) => GMap (f :+: g) where
fmapM f (L x) = liftM L (fmapM f x)
fmapM f (R x) = liftM R (fmapM f x)
instance (GMap f, GMap g) => GMap (f :*: g) where
fmapM f (x :*: y) = liftM2 (:*:) (fmapM f x) (fmapM f y)
instance GMap f => GMap (Con f) where
fmapM f (Con c x) = liftM (Con c) (fmapM f x)
class Crush f where
crush :: (a -> b -> b) -> b -> f a -> b
instance Crush Id where
crush op e (Id x) = x `op` e
instance Crush (K a) where
crush _ e _ = e
instance Crush Unit where
crush _ e _ = e
instance (Crush f, Crush g) => Crush (f :+: g) where
crush op e (L x) = crush op e x
crush op e (R y) = crush op e y
instance (Crush f, Crush g) => Crush (f :*: g) where
crush op e (x :*: y) = crush op (crush op e y) x
instance Crush f => Crush (Con f) where
crush op e (Con _c x) = crush op e x
flatten :: Crush f => f a -> [a]
flatten = crush (:) []
class Zip f where
fzipM :: Monad m => (a -> b -> m c) -> f a -> f b -> m (f c)
instance Zip Id where
fzipM f (Id x) (Id y) = liftM Id (f x y)
instance Eq a => Zip (K a) where
fzipM _ (K x) (K y)
| x == y = return (K x)
| otherwise = fail "fzipM: structure mismatch"
instance Zip Unit where
fzipM _ Unit Unit = return Unit
instance (Zip f, Zip g) => Zip (f :+: g) where
fzipM f (L x) (L y) = liftM L (fzipM f x y)
fzipM f (R x) (R y) = liftM R (fzipM f x y)
fzipM _ _ _ = fail "fzipM: structure mismatch"
instance (Zip f, Zip g) => Zip (f :*: g) where
fzipM f (x1 :*: y1) (x2 :*: y2) =
liftM2 (:*:) (fzipM f x1 x2)
(fzipM f y1 y2)
instance Zip f => Zip (Con f) where
fzipM f (Con c1 x) (Con _c2 y) = liftM (Con c1) (fzipM f x y)
fzip :: (Zip f, Monad m) => (a -> b -> c) -> f a -> f b -> m (f c)
fzip f = fzipM (\x y -> return (f x y))
fzip' :: Zip f => (a -> b -> c) -> f a -> f b -> f c
fzip' f x y = maybe (error "fzip': structure mismatch") id (fzip f x y)
geq :: (b ~ PF a, Regular a, Crush b, Zip b) => a -> a -> Bool
geq x y = maybe False (crush (&&) True) (fzip geq (from x) (from y))
class GShow f where
gshow :: (a -> ShowS) -> f a -> ShowS
instance GShow Id where
gshow f (Id r) = f r
instance Show a => GShow (K a) where
gshow _ (K x) = shows x
instance GShow Unit where
gshow _ Unit = id
instance (GShow f, GShow g) => GShow (f :+: g) where
gshow f (L x) = gshow f x
gshow f (R x) = gshow f x
instance (GShow f, GShow g) => GShow (f :*: g) where
gshow f (x :*: y) = gshow f x . showChar ' ' . gshow f y
instance GShow f => GShow (Con f) where
gshow f (Con c x) = showParen True (showString c . showChar ' ' . gshow f x)
class LRBase a where
leftb :: a
rightb :: a
instance LRBase Int where
leftb = 0
rightb = 1
instance LRBase Char where
leftb = 'L'
rightb = 'R'
instance LRBase a => LRBase [a] where
leftb = []
rightb = [error "Should never be inspected"]
class LR f where
leftf :: a -> f a
rightf :: a -> f a
instance LR Id where
leftf x = Id x
rightf x = Id x
instance LRBase a => LR (K a) where
leftf _ = K leftb
rightf _ = K rightb
instance LR Unit where
leftf _ = Unit
rightf _ = Unit
instance (LR f, LR g) => LR (f :+: g) where
leftf x = L (leftf x)
rightf x = R (rightf x)
instance (LR f, LR g) => LR (f :*: g) where
leftf x = leftf x :*: leftf x
rightf x = rightf x :*: rightf x
instance LR f => LR (Con f) where
leftf x = Con (error "Should never be inspected") (leftf x)
rightf x = Con (error "Should never be inspected") (rightf x)
left :: (Regular a, LR (PF a)) => a
left = to (leftf left)
right :: (Regular a, LR (PF a)) => a
right = to (rightf right)