module Control.Lens(
Iso,Iso',(:<->:),
LensLike,LensLike',
Fold,Fold',
Getter,Getter',
Lens,Lens',
Traversal,Traversal',
iso,from,lens,getter,prism,sat,simple,(.+),
(^.),(^..),(^?),has,(^??),(%~),(%-),(%%~),(%%-),by,yb,warp,set,
(-.),(.-),
Lens1(..),Lens2(..),Lens3(..),Lens4(..),
Trav1(..),Trav2(..),
Compound(..),
_list,_head,_tail,
Isomorphic(..),
adding,_swapped,
_Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,
warp2,_mapping,_mapping',_promapping,
IsoFunctor(..),(<.>),IsoFunctor2(..),
_thunk
) where
import Algebra.Core
import Algebra.Functor
import Algebra.Applicative
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (evaluate)
type LensLike f s t a b = (s -> f t) -> (a -> f b)
type LensLike' f a b = LensLike f b b a a
type Lens s t a b = forall f.Functor f => LensLike f s t a b
type Lens' a b = Lens b b a a
type Getter s t a b = LensLike (Const s) s t a b
type Getter' a b = Getter b b a a
type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
type Traversal' a b = Traversal b b a a
type Fold s t a b = forall f. (Semigroup (f b),Applicative f) => LensLike f s t a b
type Fold' a b = Fold b b a a
type Iso s t a b = forall p f. (Functor f,Bifunctor p) => p s (f t) -> p a (f b)
type Iso' a b = Iso b b a a
type a :<->: b = Iso' a b
data IsoT a b s t = IsoT (s -> a) (b -> t)
instance Functor (IsoT a b s) where map f (IsoT u v) = IsoT u (map f v)
instance Cofunctor (Flip (IsoT a b) t) where
comap f (Flip (IsoT u v)) = Flip (IsoT (promap f u) v)
instance Bifunctor (IsoT a b)
iso :: (a -> s) -> (t -> b) -> Iso s t a b
iso f g = dimap f (map g)
isoT :: Iso s t a b -> IsoT s t a b
isoT i = getId<$>i (IsoT id Id)
unIsoT :: IsoT s t a b -> Iso s t a b
unIsoT (IsoT u v) = iso u v
from :: Iso s t a b -> Iso b a t s
from = isoT >>> (\ ~(IsoT u v) -> IsoT v u) >>> unIsoT
lens :: (a -> s) -> (a -> t -> b) -> Lens s t a b
lens f g = \k a -> g a <$> k (f a)
getter :: (a -> b) -> Traversal' a b
getter f = \k a -> a<$k (f a)
prism :: (a -> (b:+:s)) -> (a -> t -> b) -> Traversal s t a b
prism f g = \k a -> (pure <|> map (g a) . k) (f a)
sat :: (a -> Bool) -> Traversal' a a
sat p = \k a -> (if p a then k else pure) a
(.+) :: Fold s t a b -> Fold s t a b -> Fold s t a b
f .+ f' = \k a -> f k a + f' k a
infixr 8 .+
infixl 8 ^.,^..,^?,^??,%~,%-,%%~,%%-
(^.) :: a -> Getter b b a a -> b
(^.) = flip by
(^..) :: a -> Iso a a b b -> b
(^..) = flip yb
(%~) :: Traversal s t a b -> (s -> t) -> (a -> b)
(%~) = warp
(%%~) :: Iso s t a b -> (b -> a) -> (t -> s)
(%%~) i = warp (from i)
(%-) :: Traversal s t a b -> t -> (a -> b)
(%-) = set
(%%-) :: Iso s t a b -> a -> (t -> s)
(%%-) i = set (from i)
(^?) :: (Unit f,Monoid (f b)) => a -> Fold' a b -> f b
x^?l = getConst $ l (Const . pure) x
(^??) :: a -> ((b -> Const [b] b) -> a -> Const [b] a) -> [b]
x^??l = getConst $ l (Const . pure) x
simple :: Iso' a b -> Iso' a b
simple i = i
(-.) :: Getter c u b v -> (a -> b) -> a -> c
l-.f = by l.f
(.-) :: (b -> c) -> Iso a a b b -> a -> c
f.-i = f.yb i
infixr 9 -.,.-
by :: Getter b u a v -> a -> b
by l = getConst . l Const
yb :: Iso s t a b -> t -> b
yb i = by (from i)
warp :: Traversal s t a b -> (s -> t) -> (a -> b)
warp l = map getId . l . map Id
set :: Traversal s t a b -> t -> (a -> b)
set l = warp l . const
class Lens1 s t a b | a -> s, a t -> b where
_1 :: Lens s t a b
class Lens2 s t a b | a -> s, a t -> b where
_2 :: Lens s t a b
class Lens3 s t a b | a -> s, a t -> b where
_3 :: Lens s t a b
class Lens4 s t a b | a -> s, a t -> b where
_4 :: Lens s t a b
class Trav1 s t a b | a -> s, a t -> b where
_l :: Traversal s t a b
class Trav2 s t a b | a -> s, a t -> b where
_r :: Traversal s t a b
instance Lens1 a b (a:*:c) (b:*:c) where
_1 = lens fst (flip (first . const))
instance Lens1 a b (a,c,d) (b,c,d) where
_1 = lens (\ ~(a,_,_) -> a) (\ (_,c,d) b -> (b,c,d))
instance Lens1 a b (a,c,d,e) (b,c,d,e) where
_1 = lens (\ ~(a,_,_,_) -> a) (\ (_,c,d,e) b -> (b,c,d,e))
instance Lens2 a b (c:*:a) (c:*:b) where
_2 = lens snd (flip (second . const))
instance Lens2 a b (c,a,d) (c,b,d) where
_2 = lens (\ ~(_,a,_) -> a ) (\ ~(c,_,d) b -> (c,b,d))
instance Lens2 a b (c,a,d,e) (c,b,d,e) where
_2 = lens (\ ~(_,a,_,_) -> a ) (\ ~(c,_,d,e) b -> (c,b,d,e))
instance Lens3 a b (c,d,a) (c,d,b) where
_3 = lens (\ ~(_,_,a) -> a ) (\ ~(c,d,_) b -> (c,d,b))
instance Lens3 a b (c,d,a,e) (c,d,b,e) where
_3 = lens (\ ~(_,_,a,_) -> a ) (\ ~(c,d,_,e) b -> (c,d,b,e))
instance Lens4 a b (c,d,e,a) (c,d,e,b) where
_4 = lens (\ ~(_,_,_,a) -> a ) (\ ~(c,d,e,_) b -> (c,d,e,b))
instance Trav1 a b (a:+:c) (b:+:c) where
_l = prism ((id ||| Right) >>> swapE) (flip (left . const))
where swapE :: (b:+:a) -> (a:+:b)
swapE = Right<|>Left
instance Trav2 a b (c:+:a) (c:+:b) where
_r = prism (Left ||| id) (flip (right . const))
instance Trav2 a b (Maybe a) (Maybe b) where
_r = prism (\a -> maybe (Left Nothing) Right a) (flip (<$))
class Compound a b s t | s -> a, b s -> t where
_each :: Traversal a b s t
instance Compound a b (a,a) (b,b) where
_each k (a,a') = (,)<$>k a<*>k a'
instance Compound a b (a,a,a) (b,b,b) where
_each k (a,a',a'') = (,,)<$>k a<*>k a'<*>k a''
instance Compound a b (a:+:a) (b:+:b) where
_each k = map Left . k <|> map Right . k
_list :: [a] :<->: (():+:(a:*:[a]))
_list = iso (\l -> case l of
[] -> Left ()
(x:t) -> Right (x,t)) (const [] <|> uncurry (:))
_head :: Traversal' [a] a
_head = _list._r._1
_tail :: Traversal' [a] [a]
_tail = _list._r._2
_mapping :: (Functor f,Functor f') => Iso s t a b -> Iso (f s) (f' t) (f a) (f' b)
_mapping (isoT -> IsoT u v) = map u `dimap` map (map v)
_mapping' :: Functor f => Iso s t a b -> Iso (f s) (f t) (f a) (f b)
_mapping' = _mapping
_promapping :: Bifunctor f => Iso s t a b -> Iso (f t x) (f s y) (f b x) (f a y)
_promapping (isoT -> IsoT u v) = dimap v id`dimap` map (dimap u id)
class Isomorphic b a t s | t -> b, t a -> s where
_iso :: Iso s t a b
instance Isomorphic a b (Id a) (Id b) where
_iso = iso Id getId
instance Isomorphic [a] [b] (OrdList a) (OrdList b) where
_iso = iso OrdList getOrdList
instance Isomorphic a b (Const a c) (Const b c) where
_iso = iso Const getConst
instance Isomorphic a b (Dual a) (Dual b) where
_iso = iso Dual getDual
instance Isomorphic a b (Max a) (Max b) where
_iso = iso Max getMax
instance Isomorphic (k a a) (k b b) (Endo k a) (Endo k b) where
_iso = iso Endo runEndo
instance Isomorphic (f a b) (f c d) (Flip f b a) (Flip f d c) where
_iso = iso Flip unFlip
instance Isomorphic Bool Bool (Maybe a) (Maybe Void) where
_iso = iso (bool (Just zero) Nothing) (maybe False (const True))
instance Isomorphic (f (g a)) (f' (g' b)) ((f:.:g) a) ((f':.:g') b) where
_iso = iso Compose getCompose
instance Isomorphic a b (Void,a) (Void,b) where
_iso = iso (zero,) snd
_Id :: Iso (Id a) (Id b) a b
_Id = _iso
_OrdList :: Iso (OrdList a) (OrdList b) [a] [b]
_OrdList = _iso
_Dual :: Iso (Dual a) (Dual b) a b
_Dual = _iso
_Const :: Iso (Const a c) (Const b c) a b
_Const = _iso
_Max :: Iso (Max a) (Max b) a b
_Max = _iso
_Endo :: Iso (Endo k a) (Endo k b) (k a a) (k b b)
_Endo = _iso
_maybe :: Iso (Maybe Void) (Maybe a) Bool Bool
_maybe = _iso
_Flip :: Iso (Flip f b a) (Flip f d c) (f a b) (f c d)
_Flip = _iso
_Compose :: Iso ((f:.:g) a) ((f':.:g') b) (f (g a)) (f' (g' b))
_Compose = _iso
_Backwards :: Iso (Backwards f a) (Backwards g b) (f a) (g b)
_Backwards = iso Backwards forwards
_Accum :: Iso (Accum a) (Accum b) (Maybe a) (Maybe b)
_Accum = iso Accum getAccum
warp2 :: Iso s t a b -> (s -> s -> t) -> (a -> a -> b)
warp2 i f = \a a' -> yb i (by i a`f`by i a')
class IsoFunctor f where
mapIso :: Iso s t a b -> Iso (f s) (f t) (f a) (f b)
class IsoFunctor2 f where
mapIso2 :: (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d)
(<.>) :: IsoFunctor2 f => (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d)
(<.>) = mapIso2
infixr 9 <.>
instance IsoFunctor ((->) a) where mapIso = _mapping
instance IsoFunctor2 (->) where mapIso2 i j = _promapping i._mapping j
instance IsoFunctor2 (,) where
mapIso2 i j = iso (by i <#> by j) (yb i <#> yb j)
instance IsoFunctor2 Either where
mapIso2 i j = iso (by i ||| by j) (yb i ||| yb j)
adding :: (Num n,Semigroup n) => n -> Iso' n n
adding n = iso (+n) (subtract n)
_thunk :: Iso a b (IO a) (IO b)
_thunk = iso unsafePerformIO evaluate
_swapped :: Iso (a,b) (c,d) (b,a) (d,c)
_swapped = iso (\(b,a) -> (a,b)) (\(c,d) -> (d,c))
newtype Test a = Test (Const (Product Bool) a)
deriving (Semigroup,Monoid,Functor,Unit
,Applicative)
has :: Fold' a b -> a -> Bool
has l x = x^?l & \(Test (Const (Product b))) -> b