-- Copyright 2018-2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

-- | Provides lenses and related functionality for the "ten" package.

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Data.Ten.Lens
         ( rep10, field10, ixRep10, ap10, comp
         , _Field10, _Field10', (!=), (!=?), fragmented
         ) where

import Data.Functor.Contravariant (contramap)
import Data.Type.Equality ((:~:)(..))

import Control.Lens (Getting, Prism', Iso, iso, view)
import Control.Lens.Setter ((%~), Setter, ASetter, setting)
import Data.GADT.Compare (GEq(..))
import Data.Profunctor (dimap, right')

import Data.Ten.Ap (Ap10(..))
import Data.Ten.Sigma ((:**)(..), OpCostar, lmapFragment)
import Data.Ten.Representable (Representable10(..), rep10', field10')
import Data.Ten.Update (ixRep10)
import Data.Ten ((:.:)(..))

-- | Turn a record field lens into a 'Rep10'.
--
-- Since 'tabulate10' can give us a record of 'Rep10's, all we have to do to
-- convert a lens into a 'Rep10' is use 'view' to extract the desired 'Rep10'.
rep10
  :: Representable10 f
  => Getting (Rep10 f a) (f (Rep10 f)) (Rep10 f a) -> Rep10 f a
rep10 :: Getting (Rep10 f a) (f (Rep10 f)) (Rep10 f a) -> Rep10 f a
rep10 Getting (Rep10 f a) (f (Rep10 f)) (Rep10 f a)
l = (f (Rep10 f) -> Rep10 f a) -> Rep10 f a
forall k (f :: (k -> *) -> *) (a :: k).
Representable10 f =>
(f (Rep10 f) -> Rep10 f a) -> Rep10 f a
rep10' (Getting (Rep10 f a) (f (Rep10 f)) (Rep10 f a)
-> f (Rep10 f) -> Rep10 f a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Rep10 f a) (f (Rep10 f)) (Rep10 f a)
l)

-- | Convert a lens targeting Ap10 to a Rep10.
field10
  :: Representable10 rec
  => Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
  -> Rep10 rec a
field10 :: Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
-> Rep10 rec a
field10 Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
l = (rec (Rep10 rec) -> Ap10 a (Rep10 rec)) -> Rep10 rec a
forall k (rec :: (k -> *) -> *) (a :: k).
Representable10 rec =>
(rec (Rep10 rec) -> Ap10 a (Rep10 rec)) -> Rep10 rec a
field10' (Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
-> rec (Rep10 rec) -> Ap10 a (Rep10 rec)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
l)

-- | An 'Iso' between an @Ap10 a m@ wrapper and its contained @m a@.
ap10 :: Iso (Ap10 s fs) (Ap10 t ft) (fs s) (ft t)
ap10 :: p (fs s) (f (ft t)) -> p (Ap10 s fs) (f (Ap10 t ft))
ap10 = (Ap10 s fs -> fs s)
-> (ft t -> Ap10 t ft) -> Iso (Ap10 s fs) (Ap10 t ft) (fs s) (ft t)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso Ap10 s fs -> fs s
forall k (a :: k) (f :: k -> *). Ap10 a f -> f a
unAp10 ft t -> Ap10 t ft
forall k (a :: k) (f :: k -> *). f a -> Ap10 a f
Ap10

-- | An 'Iso' between a @(m :.: n) a@ wrapper and its contained @m (n a)@.
comp :: Iso ((m :.: n) a) ((k :.: l) b) (m (n a)) (k (l b))
comp :: p (m (n a)) (f (k (l b))) -> p ((:.:) m n a) (f ((:.:) k l b))
comp = ((:.:) m n a -> m (n a))
-> (k (l b) -> (:.:) k l b)
-> Iso ((:.:) m n a) ((:.:) k l b) (m (n a)) (k (l b))
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (:.:) m n a -> m (n a)
forall k2 (f :: k2 -> *) k1 (g :: k1 -> k2) (p :: k1).
(:.:) f g p -> f (g p)
unComp1 k (l b) -> (:.:) k l b
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1

-- | A 'Control.Lens.Prism' from a ':**" to a particular field.
--
--     _Field10 k f (k := m) === (k :=) <$> f m
--     _Field10 k' f (k := m) === k := m | k' /= k
--     _Field10 k # m === k := m
_Field10
  :: GEq k
  => k a -> Prism' (k :** m) (m a)
_Field10 :: k a -> Prism' (k :** m) (m a)
_Field10 k a
k = ((k :** m) -> Either (k :** m) (m a))
-> (Either (k :** m) (f (m a)) -> f (k :** m))
-> p (Either (k :** m) (m a)) (Either (k :** m) (f (m a)))
-> p (k :** m) (f (k :** m))
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (k :** m) -> Either (k :** m) (m a)
toE Either (k :** m) (f (m a)) -> f (k :** m)
fromE (p (Either (k :** m) (m a)) (Either (k :** m) (f (m a)))
 -> p (k :** m) (f (k :** m)))
-> (p (m a) (f (m a))
    -> p (Either (k :** m) (m a)) (Either (k :** m) (f (m a))))
-> p (m a) (f (m a))
-> p (k :** m) (f (k :** m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p (m a) (f (m a))
-> p (Either (k :** m) (m a)) (Either (k :** m) (f (m a)))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
 where
  toE :: (k :** m) -> Either (k :** m) (m a)
toE frag :: k :** m
frag@(k a
k' :** m a
m) = case k a -> k a -> Maybe (a :~: a)
forall k (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
geq k a
k k a
k' of
    Just a :~: a
Refl -> m a -> Either (k :** m) (m a)
forall a b. b -> Either a b
Right m a
m
    Maybe (a :~: a)
Nothing -> (k :** m) -> Either (k :** m) (m a)
forall a b. a -> Either a b
Left k :** m
frag

  fromE :: Either (k :** m) (f (m a)) -> f (k :** m)
fromE = ((k :** m) -> f (k :** m))
-> (f (m a) -> f (k :** m))
-> Either (k :** m) (f (m a))
-> f (k :** m)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (k :** m) -> f (k :** m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((m a -> k :** m) -> f (m a) -> f (k :** m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k a
k k a -> m a -> k :** m
forall (k :: * -> *) (m :: * -> *) a. k a -> m a -> k :** m
:**))

-- | '_Field10' taking the field lens rather than the 'Rep10'.
_Field10'
  :: forall rec a m
   . (GEq (Rep10 rec), Representable10 rec)
  => (forall n. Getting (Ap10 a n) (rec n) (Ap10 a n))
  -> Prism' (Rep10 rec :** m) (m a)
_Field10' :: (forall (n :: * -> *). Getting (Ap10 a n) (rec n) (Ap10 a n))
-> Prism' (Rep10 rec :** m) (m a)
_Field10' forall (n :: * -> *). Getting (Ap10 a n) (rec n) (Ap10 a n)
l = Rep10 rec a -> Prism' (Rep10 rec :** m) (m a)
forall (k :: * -> *) a (m :: * -> *).
GEq k =>
k a -> Prism' (k :** m) (m a)
_Field10 @(Rep10 rec) (Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
-> Rep10 rec a
forall (rec :: (* -> *) -> *) a.
Representable10 rec =>
Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
-> Rep10 rec a
field10 Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
forall (n :: * -> *). Getting (Ap10 a n) (rec n) (Ap10 a n)
l)

infixr 5 !=
-- | Shortcut to construct a (':**') from a 'Control.Lens.Getter'.
--
-- Note that this assumes the fields are ultimately wrapped in 'Ap10'.  If a
-- particular field doesn't have 'Ap10' (which can only arise from a
-- manually-written 'Representable10' instance), just pretend it does by adding
-- @from ap10@ to the lens.
(!=)
  :: Representable10 rec
  => (forall m. Getting (Ap10 a m) (rec m) (Ap10 a m))
  -> f a -> Rep10 rec :** f
forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m)
l != :: (forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m))
-> f a -> Rep10 rec :** f
!= f a
x = Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
-> Rep10 rec a
forall (rec :: (* -> *) -> *) a.
Representable10 rec =>
Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
-> Rep10 rec a
field10 Getting (Ap10 a (Rep10 rec)) (rec (Rep10 rec)) (Ap10 a (Rep10 rec))
forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m)
l Rep10 rec a -> f a -> Rep10 rec :** f
forall (k :: * -> *) (m :: * -> *) a. k a -> m a -> k :** m
:** f a
x

infixr 5 !=?
-- | Shortcut to construct a (':**') using 'pure' for the value.
(!=?)
  :: (Representable10 rec, Applicative f)
  => (forall m. Getting (Ap10 a m) (rec m) (Ap10 a m))
  -> a -> Rep10 rec :** f
forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m)
l !=? :: (forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m))
-> a -> Rep10 rec :** f
!=? a
x = forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m)
l (forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m))
-> f a -> Rep10 rec :** f
forall (rec :: (* -> *) -> *) a (f :: * -> *).
Representable10 rec =>
(forall (m :: * -> *). Getting (Ap10 a m) (rec m) (Ap10 a m))
-> f a -> Rep10 rec :** f
!= a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Lifts a 'Setter' to work underneath (':**').
--
-- This means if you know how to change the type of a whole record, you can use
-- this to change the type of a (':**').
--
-- Example usage:
--
--     data MyRecord a m = MyRecord { _mrA :: Ap10 a m, _mrInt :: Ap10 Int m }
--     mrA :: Lens' (MyRecord a m) (MyRecord b m) (Ap10 m a) (Ap10 m b)
--
--     example
--       :: Rep10 (MyRecord Int) :** Identity
--       -> Rep10 (MyRecord String) :** Identity
--     example = fragmented (mrA.ap10) %~ show
fragmented
  :: ( Functor m, Representable10 recA, Representable10 recB
     , f ~ OpCostar m (Rep10 recB :** m)
     )
  => ASetter (recB f) (recA f) (f b) (f a)
  -> Setter (Rep10 recA :** m) (Rep10 recB :** m) a b
fragmented :: ASetter (recB f) (recA f) (f b) (f a)
-> Setter (Rep10 recA :** m) (Rep10 recB :** m) a b
fragmented ASetter (recB f) (recA f) (f b) (f a)
l = ((a -> b) -> (Rep10 recA :** m) -> Rep10 recB :** m)
-> IndexPreservingSetter (Rep10 recA :** m) (Rep10 recB :** m) a b
forall a b s t.
((a -> b) -> s -> t) -> IndexPreservingSetter s t a b
setting (((a -> b) -> (Rep10 recA :** m) -> Rep10 recB :** m)
 -> IndexPreservingSetter (Rep10 recA :** m) (Rep10 recB :** m) a b)
-> ((a -> b) -> (Rep10 recA :** m) -> Rep10 recB :** m)
-> IndexPreservingSetter (Rep10 recA :** m) (Rep10 recB :** m) a b
forall a b. (a -> b) -> a -> b
$ \a -> b
f -> (recB f -> recA f) -> (Rep10 recA :** m) -> Rep10 recB :** m
forall (recA :: (* -> *) -> *) (recB :: (* -> *) -> *)
       (m :: * -> *) (f :: * -> *).
(Representable10 recA, Representable10 recB,
 f ~ OpCostar m (Rep10 recB :** m)) =>
(recB f -> recA f) -> (Rep10 recA :** m) -> Rep10 recB :** m
lmapFragment (ASetter (recB f) (recA f) (f b) (f a)
l ASetter (recB f) (recA f) (f b) (f a)
-> (f b -> f a) -> recB f -> recA f
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (a -> b) -> f b -> f a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap a -> b
f)