module Algebra.Lens(
Iso,Iso',(:<->:),
LensLike,
Fold,Fold',
Getter,Getter',
Lens,Lens',
Traversal,Traversal',
iso,from,lens,getter,prism,sat,simple,(.+),forl,forl_,
(^.),(^..),(^?),has,(^??),(%~),(%-),(%%~),(%%-),by,yb,warp,set,
(-.),(.-),
Lens1(..),Lens2(..),Lens3(..),Lens4(..),
Trav1(..),Trav2(..),
Compound(..),
i'list,i'pair,t'head,t'tail,
Isomorphic(..),
thunk,chunk,curried,
i'Id,i'OrdList,i'Const,i'Dual,i'Endo,i'Flip,i'maybe,i'Max,i'Compose,i'Backwards,i'Accum,
negated,commuted,adding,
warp2,mapping,mapping',promapping,
IsoFunctor(..),(<.>),IsoFunctor2(..)
) where
import Algebra.Core hiding (flip)
import Algebra.Functor
import Algebra.Applicative
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (evaluate)
import Data.ByteString.Lazy (toStrict,fromStrict)
type LensLike f s t a b = (s -> f t) -> (a -> f b)
type Simple f a b = 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 = Simple Lens a b
type Getter s t a b = LensLike (Const s) s t a b
type Getter' a b = Simple Getter a b
type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
type Traversal' a b = Simple Traversal a b
type Fold s t a b = forall f. (Semigroup (f b),Applicative f) => LensLike f s t a b
type Fold' a b = Simple Fold a b
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 = Simple Iso a b
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)
simple :: LensLike f a b a b -> LensLike f a b a b
simple l = l
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
(%~) :: LensLike Id s t a b -> (s -> t) -> (a -> b)
(%~) = warp
(%%~) :: Iso s t a b -> (b -> a) -> (t -> s)
(%%~) i = warp (from i)
(%-) :: LensLike Id 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
(-.) :: 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 :: LensLike Id s t a b -> (s -> t) -> (a -> b)
warp l = map getId . l . map Id
set :: LensLike Id s t a b -> t -> (a -> b)
set l = warp l . const
forl :: LensLike f a b c d -> c -> (a -> f b) -> f d
forl l c f = l f c
forl_ :: Functor f => LensLike f a a c c -> c -> (a -> f ()) -> f ()
forl_ l c f = void $ l (\a -> a<$f a) c
class Lens1 s t a b | a -> s, a t -> b where
l'1 :: Lens s t a b
class Lens2 s t a b | a -> s, a t -> b where
l'2 :: Lens s t a b
class Lens3 s t a b | a -> s, a t -> b where
l'3 :: Lens s t a b
class Lens4 s t a b | a -> s, a t -> b where
l'4 :: Lens s t a b
class Trav1 s t a b | a -> s, a t -> b where
t'l :: Traversal s t a b
class Trav2 s t a b | a -> s, a t -> b where
t'r :: Traversal s t a b
instance Lens1 a a [a] [a] where
l'1 = lens (\ ~(a:_) -> a ) (\ ~(_:t) a -> a:t )
instance Lens1 a b (a:*:c) (b:*:c) where
l'1 = lens fst (flip (first . const))
instance Lens1 a b (a,c,d) (b,c,d) where
l'1 = lens (\ ~(a,_,_) -> a) (\ (_,c,d) b -> (b,c,d))
instance Lens1 a b (a,c,d,e) (b,c,d,e) where
l'1 = lens (\ ~(a,_,_,_) -> a) (\ (_,c,d,e) b -> (b,c,d,e))
instance Lens2 a b (c:*:a) (c:*:b) where
l'2 = lens snd (flip (second . const))
instance Lens2 a b (c,a,d) (c,b,d) where
l'2 = lens (\ ~(_,a,_) -> a ) (\ ~(c,_,d) b -> (c,b,d))
instance Lens2 a b (c,a,d,e) (c,b,d,e) where
l'2 = lens (\ ~(_,a,_,_) -> a ) (\ ~(c,_,d,e) b -> (c,b,d,e))
instance Lens3 a b (c,d,a) (c,d,b) where
l'3 = lens (\ ~(_,_,a) -> a ) (\ ~(c,d,_) b -> (c,d,b))
instance Lens3 a b (c,d,a,e) (c,d,b,e) where
l'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
l'4 = lens (\ ~(_,_,_,a) -> a ) (\ ~(c,d,e,_) b -> (c,d,e,b))
instance Trav1 a b (a:+:c) (b:+:c) where
t'l = prism ((id ||| Right) >>> swapE) (flip (left . const))
where swapE :: (b:+:a) -> (a:+:b)
swapE = Right<|>Left
instance Trav1 a b [a] [b] where
t'l = prism f g
where f [] = Left []
f (a:_) = Right a
g [] _ = []
g _ b = [b]
instance Trav2 a b (c:+:a) (c:+:b) where
t'r = prism (Left ||| id) (flip (right . const))
instance Trav2 a b (Maybe a) (Maybe b) where
t'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
i'list :: [a] :<->: (():+:(a:*:[a]))
i'list = iso (\l -> case l of
[] -> Left ()
(x:t) -> Right (x,t)) (const [] <|> uncurry (:))
t'head :: Traversal' [a] a
t'head = t'l
t'tail :: Traversal' [a] [a]
t'tail = i'list.t'r.l'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
i'_ :: Iso s t a b
instance Isomorphic a b (Id a) (Id b) where
i'_ = iso Id getId
instance Isomorphic [a] [b] (OrdList a) (OrdList b) where
i'_ = iso OrdList getOrdList
instance Isomorphic a b (Const a c) (Const b c) where
i'_ = iso Const getConst
instance Isomorphic a b (Dual a) (Dual b) where
i'_ = iso Dual getDual
instance Isomorphic a b (Product a) (Product b) where
i'_ = iso Product getProduct
instance Isomorphic a b (Max a) (Max b) where
i'_ = iso Max getMax
instance Isomorphic (k a a) (k b b) (Endo k a) (Endo k b) where
i'_ = iso Endo runEndo
instance Isomorphic (f a b) (f c d) (Flip f b a) (Flip f d c) where
i'_ = iso Flip unFlip
instance Isomorphic Bool Bool (Maybe a) (Maybe Void) where
i'_ = iso (bool (Just zero) Nothing) (maybe False (const True))
instance Isomorphic (f (g a)) (f' (g' b)) ((f:.:g) a) ((f':.:g') b) where
i'_ = iso Compose getCompose
instance Isomorphic a b (Void,a) (Void,b) where
i'_ = iso (zero,) snd
i'Id :: Iso (Id a) (Id b) a b
i'Id = i'_
i'OrdList :: Iso (OrdList a) (OrdList b) [a] [b]
i'OrdList = i'_
i'Dual :: Iso (Dual a) (Dual b) a b
i'Dual = i'_
i'Const :: Iso (Const a c) (Const b c) a b
i'Const = i'_
i'Max :: Iso (Max a) (Max b) a b
i'Max = i'_
i'Endo :: Iso (Endo k a) (Endo k b) (k a a) (k b b)
i'Endo = i'_
i'maybe :: Iso (Maybe Void) (Maybe a) Bool Bool
i'maybe = i'_
i'Flip :: Iso (Flip f b a) (Flip f d c) (f a b) (f c d)
i'Flip = i'_
i'Compose :: Iso ((f:.:g) a) ((f':.:g') b) (f (g a)) (f' (g' b))
i'Compose = i'_
i'Backwards :: Iso (Backwards f a) (Backwards g b) (f a) (g b)
i'Backwards = iso Backwards forwards
i'Accum :: Iso (Accum a) (Accum b) (Maybe a) (Maybe b)
i'Accum = iso Accum getAccum
curried :: Iso (a -> b -> c) (a' -> b' -> c') ((a,b) -> c) ((a',b') -> c')
curried = iso curry uncurry
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 <.>
i'pair :: Iso s t a b -> Iso s' t' a' b' -> Iso (s,s') (t,t') (a,a') (b,b')
i'pair i i' = let IsoT u v = isoT i ; IsoT u' v' = isoT i' in iso (u<#>u') (v<#>v')
instance IsoFunctor ((->) a) where mapIso = mapping
instance IsoFunctor2 (->) where mapIso2 i j = promapping i.mapping j
instance IsoFunctor2 (,) where
mapIso2 = i'pair
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
chunk :: Bytes:<->:Chunk
chunk = iso toStrict fromStrict
negated :: (Negative a,Negative b) => Iso a b a b
negated = iso negate negate
commuted :: Commutative f => Iso (f a b) (f c d) (f b a) (f d c)
commuted = iso commute commute
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