{-# LANGUAGE Trustworthy #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.Internal.Rig
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Re-implementation of lens combinators
------------------------------------------------------------------------
module Data.Extensible.Internal.Rig (
  Optic
  , Optic'
  , view
  , views
  , over
  , withIso
  , Exchange(..)
  , review
  )
where
import Control.Applicative
import Data.Profunctor
import Data.Functor.Identity
import Data.Tagged
import Data.Coerce

type Optic p f s t a b = p a (f b) -> p s (f t)
type Optic' p f s a = p a (f a) -> p s (f s)

-- | @'view' :: Getter s a -> s -> a@
view :: Optic' (->) (Const a) s a -> s -> a
view :: Optic' (->) (Const a) s a -> s -> a
view Optic' (->) (Const a) s a
l = Optic' (->) (Const a) s a -> (a -> a) -> s -> a
forall r s a. Optic' (->) (Const r) s a -> (a -> r) -> s -> r
views Optic' (->) (Const a) s a
l a -> a
forall a. a -> a
id
{-# INLINE view #-}

-- | @'views' :: Getter s a -> (a -> r) -> (s -> r)@
views :: Optic' (->) (Const r) s a -> (a -> r) -> s -> r
views :: Optic' (->) (Const r) s a -> (a -> r) -> s -> r
views = Optic' (->) (Const r) s a -> (a -> r) -> s -> r
coerce
{-# INLINE views #-}

-- | @'over' :: Setter s t a b -> (a -> b) -> (s -> t)@
over :: Optic (->) Identity s t a b -> (a -> b) -> s -> t
over :: Optic (->) Identity s t a b -> (a -> b) -> s -> t
over = Optic (->) Identity s t a b -> (a -> b) -> s -> t
coerce
{-# INLINE over #-}

-- | Reifies the structure of 'Iso's
data Exchange a b s t = Exchange (s -> a) (b -> t)

instance Functor (Exchange a b s) where
  fmap :: (a -> b) -> Exchange a b s a -> Exchange a b s b
fmap a -> b
f (Exchange s -> a
sa b -> a
bt) = (s -> a) -> (b -> b) -> Exchange a b s b
forall a b s t. (s -> a) -> (b -> t) -> Exchange a b s t
Exchange s -> a
sa (a -> b
f (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
bt)
  {-# INLINE fmap #-}

instance Profunctor (Exchange a b) where
  dimap :: (a -> b) -> (c -> d) -> Exchange a b b c -> Exchange a b a d
dimap a -> b
f c -> d
g (Exchange b -> a
sa b -> c
bt) = (a -> a) -> (b -> d) -> Exchange a b a d
forall a b s t. (s -> a) -> (b -> t) -> Exchange a b s t
Exchange (b -> a
sa (b -> a) -> (a -> b) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) (c -> d
g (c -> d) -> (b -> c) -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> c
bt)
  {-# INLINE dimap #-}

-- | Recover tho functions from an Iso/
withIso :: Optic (Exchange a b) Identity s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso :: Optic (Exchange a b) Identity s t a b
-> ((s -> a) -> (b -> t) -> r) -> r
withIso Optic (Exchange a b) Identity s t a b
l (s -> a) -> (b -> t) -> r
r = case Optic (Exchange a b) Identity s t a b
l ((a -> a) -> (b -> Identity b) -> Exchange a b a (Identity b)
forall a b s t. (s -> a) -> (b -> t) -> Exchange a b s t
Exchange a -> a
forall a. a -> a
id b -> Identity b
forall a. a -> Identity a
Identity) of
  Exchange s -> a
f b -> Identity t
g -> (s -> a) -> (b -> t) -> r
r s -> a
f ((b -> Identity t) -> b -> t
coerce b -> Identity t
g)
{-# INLINE withIso #-}

-- | @'review' :: AReview s a -> a -> s@
review :: Optic' Tagged Identity s a -> a -> s
review :: Optic' Tagged Identity s a -> a -> s
review = Optic' Tagged Identity s a -> a -> s
coerce
{-# INLINE review #-}