module Generics.Regular.Functions (
Functor (..),
GMap (..),
CrushR (..),
flatten,
Zip (..),
fzip,
fzip',
geq,
GShow (..),
gshow,
LRBase (..),
LR (..),
left,
right,
Alg, Algebra,
Fold, alg,
fold,
(&)
) where
import Control.Monad
import Generics.Regular.Base
class GMap f where
fmapM :: Monad m => (a -> m b) -> f a -> m (f b)
instance GMap I where
fmapM f (I r) = liftM I (f r)
instance GMap (K a) where
fmapM _ (K x) = return (K x)
instance GMap U where
fmapM _ U = return U
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 (C c f) where
fmapM f (C x) = liftM C (fmapM f x)
class CrushR f where
crushr :: (a -> b -> b) -> b -> f a -> b
instance CrushR I where
crushr op e (I x) = x `op` e
instance CrushR (K a) where
crushr _ e _ = e
instance CrushR U where
crushr _ e _ = e
instance (CrushR f, CrushR g) => CrushR (f :+: g) where
crushr op e (L x) = crushr op e x
crushr op e (R y) = crushr op e y
instance (CrushR f, CrushR g) => CrushR (f :*: g) where
crushr op e (x :*: y) = crushr op (crushr op e y) x
instance CrushR f => CrushR (C c f) where
crushr op e (C x) = crushr op e x
flatten :: CrushR f => f a -> [a]
flatten = crushr (:) []
class Zip f where
fzipM :: Monad m => (a -> b -> m c) -> f a -> f b -> m (f c)
instance Zip I where
fzipM f (I x) (I y) = liftM I (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 U where
fzipM _ U U = return U
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 (C c f) where
fzipM f (C x) (C y) = liftM C (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, CrushR b, Zip b) => a -> a -> Bool
geq x y = maybe False (crushr (&&) True) (fzip geq (from x) (from y))
class GShow f where
gshowf :: (a -> ShowS) -> f a -> ShowS
instance GShow I where
gshowf f (I r) = f r
instance Show a => GShow (K a) where
gshowf _ (K x) = shows x
instance GShow U where
gshowf _ U = id
instance (GShow f, GShow g) => GShow (f :+: g) where
gshowf f (L x) = gshowf f x
gshowf f (R x) = gshowf f x
instance (GShow f, GShow g) => GShow (f :*: g) where
gshowf f (x :*: y) = gshowf f x . showChar ' ' . gshowf f y
instance (Constructor c, GShow f) => GShow (C c f) where
gshowf f cx@(C x) =
showParen True (showString (conName cx) . showChar ' ' . gshowf f x)
gshow :: (Regular a, GShow (PF a)) => a -> ShowS
gshow x = gshowf gshow (from x)
class LRBase a where
leftb :: a
rightb :: a
instance LRBase Int where
leftb = 0
rightb = 1
instance LRBase Integer 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 I where
leftf x = I x
rightf x = I x
instance LRBase a => LR (K a) where
leftf _ = K leftb
rightf _ = K rightb
instance LR U where
leftf _ = U
rightf _ = U
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 (C c f) where
leftf x = C (leftf x)
rightf x = C (rightf x)
left :: (Regular a, LR (PF a)) => a
left = to (leftf left)
right :: (Regular a, LR (PF a)) => a
right = to (rightf right)
type family Alg (f :: (* -> *))
(r :: *)
:: *
type instance Alg (K a) r = a -> r
type instance Alg U r = r
type instance Alg I r = r -> r
type instance Alg (f :+: g) r = (Alg f r, Alg g r)
type instance Alg (K a :*: g) r = a -> Alg g r
type instance Alg (I :*: g) r = r -> Alg g r
type instance Alg (C c f) r = Alg f r
type Algebra a r = Alg (PF a) r
class Fold (f :: * -> *) where
alg :: Alg f r -> f r -> r
instance Fold (K a) where
alg f (K x) = f x
instance Fold U where
alg f U = f
instance Fold I where
alg f (I x) = f x
instance (Fold f, Fold g) => Fold (f :+: g) where
alg (f, _) (L x) = alg f x
alg (_, g) (R x) = alg g x
instance (Fold g) => Fold (K a :*: g) where
alg f (K x :*: y) = alg (f x) y
instance (Fold g) => Fold (I :*: g) where
alg f (I x :*: y) = alg (f x) y
instance (Fold f) => Fold (C c f) where
alg f (C x) = alg f x
fold :: (Regular a, Fold (PF a), Functor (PF a))
=> Algebra a r -> a -> r
fold f = alg f . fmap (\x -> fold f x) . from
infixr 5 &
(&) :: a -> b -> (a, b)
(&) = (,)