{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.Profunctor.Optic.Iso (
Equality
, Equality'
, As
, Iso
, Iso'
, iso
, isoVl
, ixmapping
, cxmapping
, fmapping
, contramapping
, dimapping
, toYoneda
, toCoyoneda
, cloneIso
, equaled
, coerced
, wrapped
, rewrapped
, rewrapping
, generic
, generic1
, flipped
, curried
, swapped
, eswapped
, associated
, eassociated
, involuted
, added
, subtracted
, viewedl
, viewedr
, non
, anon
, u1
, par1
, rec1
, k1
, m1
, withIso
, invert
, reover
, reixed
, recxed
, op
, au
, aup
, ala
, Re(..)
, AIso
, AIso'
, IsoRep(..)
) where
import Control.Newtype.Generics (Newtype(..), op)
import Data.Coerce
import Data.Group
import Data.Maybe (fromMaybe)
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Index
import Data.Profunctor.Optic.Type hiding (Rep)
import Data.Profunctor.Yoneda (Coyoneda(..), Yoneda(..))
import Data.Sequence as Seq
import GHC.Generics hiding (from, to)
import qualified Control.Monad as M (join)
import qualified GHC.Generics as GHC (to, from, to1, from1)
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso = dimap
{-# INLINE iso #-}
isoVl :: (forall f g. Functor f => Functor g => (g a -> f b) -> g s -> f t) -> Iso s t a b
isoVl abst = iso f g
where f = getConst . (abst (Const . runIdentity)) . Identity
g = runIdentity . (abst (Identity . getConst)) . Const
{-# INLINE isoVl #-}
ixmapping :: Profunctor p => AIso s t a b -> IndexedOptic p i s t a b
ixmapping o = withIso o ixmap
{-# INLINE ixmapping #-}
cxmapping :: Profunctor p => AIso s t a b -> CoindexedOptic p k s t a b
cxmapping o = withIso o cxmap
{-# INLINE cxmapping #-}
fmapping
:: Functor f
=> Functor g
=> AIso s t a b
-> Iso (f s) (g t) (f a) (g b)
fmapping l = withIso l $ \sa bt -> iso (fmap sa) (fmap bt)
{-# INLINE fmapping #-}
contramapping :: Contravariant f => Contravariant g => AIso s t a b -> Iso (f a) (g b) (f s) (g t)
contramapping f = withIso f $ \sa bt -> iso (contramap sa) (contramap bt)
{-# INLINE contramapping #-}
dimapping
:: Profunctor p
=> Profunctor q
=> AIso s1 t1 a1 b1
-> AIso s2 t2 a2 b2
-> Iso (p a1 s2) (q b1 t2) (p s1 a2) (q t1 b2)
dimapping f g = withIso f $ \sa1 bt1 ->
withIso g $ \sa2 bt2 -> iso (dimap sa1 sa2) (dimap bt1 bt2)
{-# INLINE dimapping #-}
toYoneda :: Profunctor p => Iso s t a b -> p a b -> Yoneda p s t
toYoneda o p = withIso o $ \sa bt -> Yoneda $ \f g -> dimap (sa . f) (g . bt) p
{-# INLINE toYoneda #-}
toCoyoneda :: Iso s t a b -> p a b -> Coyoneda p s t
toCoyoneda o p = withIso o $ \sa bt -> Coyoneda sa bt p
{-# INLINE toCoyoneda #-}
cloneIso :: AIso s t a b -> Iso s t a b
cloneIso k = withIso k iso
{-# INLINE cloneIso #-}
equaled :: s ~ a => t ~ b => Iso s t a b
equaled = id
{-# INLINE equaled #-}
coerced :: Coercible s a => Coercible t b => Iso s t a b
coerced = dimap coerce coerce
{-# INLINE coerced #-}
wrapped :: Newtype s => Iso' s (O s)
wrapped = dimap unpack pack
{-# INLINE wrapped #-}
rewrapped :: Newtype s => Newtype t => Iso s t (O s) (O t)
rewrapped = withIso wrapped $ \ sa _ -> withIso wrapped $ \ _ bt -> iso sa bt
{-# INLINE rewrapped #-}
rewrapping :: Newtype s => Newtype t => (O s -> s) -> Iso s t (O s) (O t)
rewrapping _ = rewrapped
{-# INLINE rewrapping #-}
generic :: Generic a => Generic b => Iso a b (Rep a c) (Rep b c)
generic = iso GHC.from GHC.to
{-# INLINE generic #-}
generic1 :: Generic1 f => Generic1 g => Iso (f a) (g b) (Rep1 f a) (Rep1 g b)
generic1 = iso GHC.from1 GHC.to1
{-# INLINE generic1 #-}
flipped :: Iso (a -> b -> c) (d -> e -> f) (b -> a -> c) (e -> d -> f)
flipped = iso flip flip
{-# INLINE flipped #-}
curried :: Iso ((a , b) -> c) ((d , e) -> f) (a -> b -> c) (d -> e -> f)
curried = iso curry uncurry
{-# INLINE curried #-}
swapped :: Iso (a , b) (c , d) (b , a) (d , c)
swapped = iso swap swap
{-# INLINE swapped #-}
eswapped :: Iso (a + b) (c + d) (b + a) (d + c)
eswapped = iso eswap eswap
{-# INLINE eswapped #-}
associated :: Iso (a , (b , c)) (d , (e , f)) ((a , b) , c) ((d , e) , f)
associated = iso assocl assocr
{-# INLINE associated #-}
eassociated :: Iso (a + (b + c)) (d + (e + f)) ((a + b) + c) ((d + e) + f)
eassociated = iso eassocl eassocr
{-# INLINE eassociated #-}
involuted :: (s -> a) -> Iso s a a s
involuted = M.join iso
{-# INLINE involuted #-}
added :: Group a => a -> Iso' a a
added n = iso (<> n) (<< n)
{-# INLINE added #-}
subtracted :: Group a => a -> Iso' a a
subtracted n = iso (<< n) (<> n)
{-# INLINE subtracted #-}
viewedl :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b)
viewedl = iso viewl $ \xs -> case xs of
EmptyL -> mempty
a Seq.:< as -> a Seq.<| as
{-# INLINE viewedl #-}
viewedr :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b)
viewedr = iso viewr $ \xs -> case xs of
EmptyR -> mempty
as Seq.:> a -> as Seq.|> a
{-# INLINE viewedr #-}
non :: Eq a => a -> Iso' (Maybe a) a
non def = iso (fromMaybe def) g
where g a | a == def = Nothing
| otherwise = Just a
{-# INLINE non #-}
anon :: a -> (a -> Bool) -> Iso' (Maybe a) a
anon a p = iso (fromMaybe a) go where
go b | p b = Nothing
| otherwise = Just b
{-# INLINE anon #-}
u1 :: Iso (U1 p) (U1 q) () ()
u1 = iso (const ()) (const U1)
{-# INLINE u1 #-}
k1 :: Iso (K1 i c p) (K1 j d q) c d
k1 = iso unK1 K1
{-# INLINE k1 #-}
m1 :: Iso (M1 i c f p) (M1 j d g q) (f p) (g q)
m1 = iso unM1 M1
{-# INLINE m1 #-}
par1 :: Iso (Par1 p) (Par1 q) p q
par1 = iso unPar1 Par1
{-# INLINE par1 #-}
rec1 :: Iso (Rec1 f p) (Rec1 g q) (f p) (g q)
rec1 = iso unRec1 Rec1
{-# INLINE rec1 #-}
withIso :: AIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso x k = case x (IsoRep id id) of IsoRep sa bt -> k sa bt
{-# INLINE withIso #-}
invert :: AIso s t a b -> Iso b a t s
invert o = withIso o $ \sa bt -> iso bt sa
{-# INLINE invert #-}
reover :: AIso s t a b -> (t -> s) -> b -> a
reover o = withIso o $ \sa bt ts -> sa . ts . bt
{-# INLINE reover #-}
reixed :: Profunctor p => AIso' i j -> IndexedOptic p i s t a b -> IndexedOptic p j s t a b
reixed o = withIso o reix
{-# INLINE reixed #-}
recxed :: Profunctor p => AIso' k l -> CoindexedOptic p k s t a b -> CoindexedOptic p l s t a b
recxed o = withIso o recx
{-# INLINE recxed #-}
au :: Functor f => AIso s t a b -> ((b -> t) -> f s) -> f a
au k = withIso k $ \ sa bt f -> fmap sa (f bt)
{-# INLINE au #-}
aup :: Profunctor p => Functor f => AIso s t a b -> (p c a -> f b) -> p c s -> f t
aup o = withIso o $ \sa bt f g -> fmap bt (f (rmap sa g))
{-# INLINE aup #-}
ala :: Newtype s => Newtype t => Functor f => (O s -> s) -> ((O t -> t) -> f s) -> f (O s)
ala = au . rewrapping
{-# INLINE ala #-}
data IsoRep a b s t = IsoRep (s -> a) (b -> t)
type AIso s t a b = Optic (IsoRep a b) s t a b
type AIso' s a = AIso s s a a
instance Functor (IsoRep a b s) where
fmap f (IsoRep sa bt) = IsoRep sa (f . bt)
{-# INLINE fmap #-}
instance Profunctor (IsoRep a b) where
dimap f g (IsoRep sa bt) = IsoRep (sa . f) (g . bt)
{-# INLINE dimap #-}
lmap f (IsoRep sa bt) = IsoRep (sa . f) bt
{-# INLINE lmap #-}
rmap f (IsoRep sa bt) = IsoRep sa (f . bt)
{-# INLINE rmap #-}
instance Sieve (IsoRep a b) (Index a b) where
sieve (IsoRep sa bt) s = Index (sa s) bt
instance Cosieve (IsoRep a b) (Coindex a b) where
cosieve (IsoRep sa bt) (Coindex sab) = bt (sab sa)