module Mezzolens
( set, modifyF, match
, get, gets, beget
, toListOf, firstOf, sumOf, productOf, allOf, anyOf, lengthOf, nullOf
, to, fro
, un
, alongside, eitherside
, (^.), (^..), (^?)
, (.~)
, module Mezzolens.Optics
, SuperStar, SubStar
, Constant, First, Sum, Product, All, Any
, AlongSide, EitherSide
) where
import Mezzolens.Combinators
import Mezzolens.Profunctor
import Mezzolens.Optics
import Mezzolens.Unchecked
import Data.Functor.Constant (Constant(..))
import Data.Monoid (All(..), Any(..), First(..), Product(..), Sum(..))
gets :: Optical (SubStar (Constant r)) ta tb a b -> (a -> r) -> ta -> r
gets l f = getConstant . h
where
Kleisli h = l (Kleisli (Constant . f))
get :: Optical (SubStar (Constant a)) ta tb a b -> ta -> a
get l = gets l id
beget :: Optical (SuperStar (Constant b)) ta tb a b -> b -> tb
beget l = h . Constant
where
SuperStar h = l (SuperStar getConstant)
set :: ((a -> b) -> c) -> b -> c
set l = l . const
modifyF :: Optical (SubStar f) ta tb a b -> (a -> f b) -> ta -> f tb
modifyF l f = tf
where
Kleisli tf = l (Kleisli f)
match :: Optical (SubStar (Either a)) ta tb a b -> ta -> Either tb a
match l = switch . h
where
Kleisli h = l (Kleisli Left)
toListOf :: Applicative f => Optical (SubStar (Constant (f a))) ta tb a b -> ta -> f a
toListOf l = gets l pure
firstOf :: Optical (SubStar (Constant (First a))) ta tb a b -> ta -> Maybe a
firstOf l = getFirst . gets l (First . pure)
sumOf :: Optical (SubStar (Constant (Sum a))) ta tb a b -> ta -> a
sumOf l = getSum . gets l Sum
productOf :: Optical (SubStar (Constant (Product a))) ta tb a b -> ta -> a
productOf l = getProduct . gets l Product
allOf :: Optical (SubStar (Constant All)) ta tb a b -> (a -> Bool) -> ta -> Bool
allOf l p = getAll . gets l (All . p)
anyOf :: Optical (SubStar (Constant Any)) ta tb a b -> (a -> Bool) -> ta -> Bool
anyOf l p = getAny . gets l (Any . p)
lengthOf :: Num r => Optical (SubStar (Constant (Sum r))) ta tb a b -> ta -> r
lengthOf l = getSum . gets l (const (Sum 1))
nullOf :: Optical (SubStar (Constant All)) ta tb a b -> ta -> Bool
nullOf l = allOf l (const False)
infixl 8 ^., ^.., ^?
infixr 4 .~
x^.l = get l x
x^..l = toListOf l x
x^?l = firstOf l x
l.~x = set l x
to :: (ta -> a) -> To ta tb a b
to f = ocoerce . imap f
fro :: (b -> tb) -> Fro ta tb a b
fro f = icoerce . omap f
un :: Optical (ProProduct (SubStar (Constant tb)) (SuperStar (Constant ta))) b a tb ta -> Iso ta tb a b
un l = iso (beget . Constant) (getConstant . get)
where
ProProduct (Kleisli get) (SuperStar beget) = l (ProProduct (Kleisli Constant) (SuperStar getConstant))
alongside :: Profunctor p => Optical (AlongSide p sc sd) ta tb a b -> Optical (AlongSide p a b) sc sd c d -> Optical p (ta,sc) (tb,sd) (a,c) (b,d)
alongside lab lcd = dimap swap swap . runAlongSide . lab . AlongSide . dimap swap swap . runAlongSide . lcd . AlongSide
eitherside :: Profunctor p => Optical (EitherSide p sc sd) ta tb a b -> Optical (EitherSide p a b) sc sd c d -> Optical p (Either ta sc) (Either tb sd) (Either a c) (Either b d)
eitherside lab lcd = dimap switch switch . runEitherSide . lab . EitherSide . dimap switch switch . runEitherSide . lcd . EitherSide
newtype AlongSide p c d a b = AlongSide { runAlongSide :: p (c,a) (d,b) }
instance Profunctor p => Profunctor (AlongSide p c d) where
dimap f g (AlongSide pab) = AlongSide $ dimap (fmap f) (fmap g) pab
instance Strong p => Strong (AlongSide p c d) where
_2 (AlongSide pab) = AlongSide . dimap shuffle shuffle . _2 $ pab
where
shuffle (x,(y,z)) = (y,(x,z))
instance OutPhantom p => OutPhantom (AlongSide p c d) where
ocoerce (AlongSide pab) = AlongSide $ ocoerce pab
newtype EitherSide p c d a b = EitherSide { runEitherSide :: p (Either c a) (Either d b) }
instance Profunctor p => Profunctor (EitherSide p c d) where
dimap f g (EitherSide pab) = EitherSide $ dimap (fmap f) (fmap g) pab
instance Choice p => Choice (EitherSide p c d) where
_Right (EitherSide pab) = EitherSide . dimap shuffle shuffle . _Right $ pab
where
shuffle = Right . Left ||| (Left ||| Right . Right)
instance InPhantom p => InPhantom (EitherSide p c d) where
icoerce (EitherSide pab) = EitherSide $ icoerce pab