module Data.Label.Abstract where
import Control.Arrow
import Prelude hiding ((.), id)
import Control.Applicative
import Control.Category
data Point (~>) f i o = Point
{ _get :: f ~> o
, _set :: (i, f) ~> f
}
_modify :: ArrowApply (~>) => Point (~>) f i o -> (o ~> i, f) ~> f
_modify l = proc (m, f) -> do i <- m . _get l -<< f; _set l -< (i, f)
newtype Lens (~>) f a = Lens { unLens :: Point (~>) f a a }
lens :: (f ~> a) -> ((a, f) ~> f) -> Lens (~>) f a
lens g s = Lens (Point g s)
get :: Arrow (~>) => Lens (~>) f a -> f ~> a
get = _get . unLens
set :: Arrow (~>) => Lens (~>) f a -> (a, f) ~> f
set = _set . unLens
modify :: ArrowApply (~>) => Lens (~>) f o -> (o ~> o, f) ~> f
modify = _modify . unLens
instance ArrowApply (~>) => Category (Lens (~>)) where
id = lens id (arr fst)
Lens a . Lens b = lens (_get a . _get b) (_modify b . first (curryA (_set a)))
where curryA f = arr (\i -> f . arr (i,))
instance Arrow (~>) => Functor (Point (~>) f i) where
fmap f x = Point (arr f . _get x) (_set x)
instance Arrow (~>) => Applicative (Point (~>) f i) where
pure a = Point (arr (const a)) (arr snd)
a <*> b = Point (arr app . (_get a &&& _get b)) (_set b . (arr fst &&& _set a))
bimap :: Arrow (~>) => (o' ~> o) -> (i ~> i') -> Point (~>) f i' o' -> Point (~>) f i o
bimap f g l = Point (f . _get l) (_set l . first g)
infix 8 `for`
for :: Arrow (~>) => (i ~> o) -> Lens (~>) f o -> Point (~>) f i o
for p = bimap id p . unLens
data Bijection (~>) a b = Bij { fw :: a ~> b, bw :: b ~> a }
instance Category (~>) => Category (Bijection (~>)) where
id = Bij id id
Bij a b . Bij c d = Bij (a . c) (d . b)
liftBij :: Functor f => Bijection (->) a b -> Bijection (->) (f a) (f b)
liftBij a = Bij (fmap (fw a)) (fmap (bw a))
infixr 8 `iso`
class Iso (~>) f where
iso :: Bijection (~>) a b -> f a ~> f b
instance Arrow (~>) => Iso (~>) (Lens (~>) f) where
iso bi = arr ((\a -> lens (fw bi . _get a) (_set a . first (bw bi))) . unLens)
instance Arrow (~>) => Iso (~>) (Bijection (~>) a) where
iso = arr . (.)