{-# LANGUAGE CPP #-}
{-# LANGUAGE InstanceSigs #-}
-- |
-- Module: Language.KURE.Lens
-- Copyright: (c) 2012--2021 The University of Kansas
-- License: BSD3
--
-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>
-- Stability: beta
-- Portability: ghc
--
-- This module defines the KURE 'Lens' type, along with some useful operations.
--
module Language.KURE.Lens
       (  -- * Lenses
          Lens
        , lens
        , lensT
        , focusR
        , focusT
        , pureL
        , failL
        , catchL
        , testLensT
        , bidirectionalL
        , injectL
        , projectL
) where

import Prelude hiding (id, (.))

import Control.Monad

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif

import Control.Category
import Control.Arrow

import Language.KURE.MonadCatch
import Language.KURE.Transform
import Language.KURE.BiTransform
import Language.KURE.Injection
import Language.KURE.Combinators.Transform

------------------------------------------------------------------------------------------

-- | A 'Lens' is a way to focus on a sub-structure of type @b@ from a structure of type @a@.
newtype Lens c m a b = Lens { -- | Convert a 'Lens' into a 'Transform' that produces a sub-structure (and its context) and an unfocussing function.
                              Lens c m a b -> Transform c m a ((c, b), b -> m a)
lensT :: Transform c m a ((c,b), b -> m a)}

-- | The primitive way of building a 'Lens'.
--   If the unfocussing function is applied to the value focussed on then it should succeed,
--   and produce the same value as the original argument (of type @a@).
lens :: Transform c m a ((c,b), b -> m a) -> Lens c m a b
lens :: Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens = Transform c m a ((c, b), b -> m a) -> Lens c m a b
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
Lens
{-# INLINE lens #-}

-- | Apply a rewrite at a point specified by a 'Lens'.
focusR :: Monad m => Lens c m a b -> Rewrite c m b -> Rewrite c m a
focusR :: Lens c m a b -> Rewrite c m b -> Rewrite c m a
focusR Lens c m a b
l Rewrite c m b
r = do ((c
c,b
b),b -> m a
k) <- Lens c m a b -> Transform c m a ((c, b), b -> m a)
forall c (m :: * -> *) a b.
Lens c m a b -> Transform c m a ((c, b), b -> m a)
lensT Lens c m a b
l
                m a -> Rewrite c m a
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT (Rewrite c m b -> c -> b -> m b
forall c (m :: * -> *) a. Rewrite c m a -> c -> a -> m a
applyR Rewrite c m b
r c
c b
b m b -> (b -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m a
k)
{-# INLINE focusR #-}

-- | Apply a transformation at a point specified by a 'Lens'.
focusT :: Monad m => Lens c m a b -> Transform c m b d -> Transform c m a d
focusT :: Lens c m a b -> Transform c m b d -> Transform c m a d
focusT Lens c m a b
l Transform c m b d
t = do ((c
c,b
b),b -> m a
_) <- Lens c m a b -> Transform c m a ((c, b), b -> m a)
forall c (m :: * -> *) a b.
Lens c m a b -> Transform c m a ((c, b), b -> m a)
lensT Lens c m a b
l
                m d -> Transform c m a d
forall k (m :: k -> *) (b :: k) c a. m b -> Transform c m a b
constT (Transform c m b d -> c -> b -> m d
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m b d
t c
c b
b)
{-# INLINE focusT #-}

-- | Check if the focusing succeeds, and additionally whether unfocussing from an unchanged value would succeed.
testLensT :: MonadCatch m => Lens c m a b -> Transform c m a Bool
testLensT :: Lens c m a b -> Transform c m a Bool
testLensT Lens c m a b
l = Transform c m a a -> Transform c m a Bool
forall (m :: * -> *) a. MonadCatch m => m a -> m Bool
testM (Lens c m a b -> Rewrite c m b -> Transform c m a a
forall (m :: * -> *) c a b.
Monad m =>
Lens c m a b -> Rewrite c m b -> Rewrite c m a
focusR Lens c m a b
l Rewrite c m b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
{-# INLINE testLensT #-}

instance Monad m => Category (Lens c m) where

   id :: Lens c m a a
   id :: Lens c m a a
id = Transform c m a ((c, a), a -> m a) -> Lens c m a a
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m a ((c, a), a -> m a) -> Lens c m a a)
-> Transform c m a ((c, a), a -> m a) -> Lens c m a a
forall a b. (a -> b) -> a -> b
$ (c -> a -> m ((c, a), a -> m a))
-> Transform c m a ((c, a), a -> m a)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> a -> m ((c, a), a -> m a))
 -> Transform c m a ((c, a), a -> m a))
-> (c -> a -> m ((c, a), a -> m a))
-> Transform c m a ((c, a), a -> m a)
forall a b. (a -> b) -> a -> b
$ \ c
c a
a -> ((c, a), a -> m a) -> m ((c, a), a -> m a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
c,a
a), a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return)
   {-# INLINE id #-}

   (.) :: Lens c m b d -> Lens c m a b -> Lens c m a d
   Lens c m b d
l2 . :: Lens c m b d -> Lens c m a b -> Lens c m a d
. Lens c m a b
l1 = Transform c m a ((c, d), d -> m a) -> Lens c m a d
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m a ((c, d), d -> m a) -> Lens c m a d)
-> Transform c m a ((c, d), d -> m a) -> Lens c m a d
forall a b. (a -> b) -> a -> b
$ (c -> a -> m ((c, d), d -> m a))
-> Transform c m a ((c, d), d -> m a)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> a -> m ((c, d), d -> m a))
 -> Transform c m a ((c, d), d -> m a))
-> (c -> a -> m ((c, d), d -> m a))
-> Transform c m a ((c, d), d -> m a)
forall a b. (a -> b) -> a -> b
$ \ c
ca a
a -> do ((c
cb,b
b),b -> m a
kb) <- Transform c m a ((c, b), b -> m a)
-> c -> a -> m ((c, b), b -> m a)
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT (Lens c m a b -> Transform c m a ((c, b), b -> m a)
forall c (m :: * -> *) a b.
Lens c m a b -> Transform c m a ((c, b), b -> m a)
lensT Lens c m a b
l1) c
ca a
a
                                             ((c
cd,d
d),d -> m b
kd) <- Transform c m b ((c, d), d -> m b)
-> c -> b -> m ((c, d), d -> m b)
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT (Lens c m b d -> Transform c m b ((c, d), d -> m b)
forall c (m :: * -> *) a b.
Lens c m a b -> Transform c m a ((c, b), b -> m a)
lensT Lens c m b d
l2) c
cb b
b
                                             ((c, d), d -> m a) -> m ((c, d), d -> m a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
cd,d
d),d -> m b
kd (d -> m b) -> (b -> m a) -> d -> m a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> b -> m a
kb)
   {-# INLINE (.) #-}

-- | The failing 'Lens'.
failL :: MonadFail m => String -> Lens c m a b
failL :: String -> Lens c m a b
failL = Transform c m a ((c, b), b -> m a) -> Lens c m a b
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m a ((c, b), b -> m a) -> Lens c m a b)
-> (String -> Transform c m a ((c, b), b -> m a))
-> String
-> Lens c m a b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Transform c m a ((c, b), b -> m a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
{-# INLINE failL #-}

-- | A 'Lens' is deemed to have failed (and thus can be caught) if either it fails on the way down, or,
--   crucially, if it would fail on the way up for an unmodified value.  However, actual failure on the way up is not caught
--   (as by then it is too late to use an alternative 'Lens').  This means that, in theory, a use of 'catchL' could cause a succeeding 'Lens' application to fail.
--   But provided 'lens' is used correctly, this should never happen.
catchL :: MonadCatch m => Lens c m a b -> (String -> Lens c m a b) -> Lens c m a b
Lens c m a b
l1 catchL :: Lens c m a b -> (String -> Lens c m a b) -> Lens c m a b
`catchL` String -> Lens c m a b
l2 = Transform c m a ((c, b), b -> m a) -> Lens c m a b
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m a a -> Transform c m a (Either String a)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Either String a)
attemptM (Lens c m a b -> Rewrite c m b -> Transform c m a a
forall (m :: * -> *) c a b.
Monad m =>
Lens c m a b -> Rewrite c m b -> Rewrite c m a
focusR Lens c m a b
l1 Rewrite c m b
forall (m :: * -> *) c a. Monad m => Rewrite c m a
idR) Transform c m a (Either String a)
-> (Either String a -> Transform c m a ((c, b), b -> m a))
-> Transform c m a ((c, b), b -> m a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Transform c m a ((c, b), b -> m a))
-> (a -> Transform c m a ((c, b), b -> m a))
-> Either String a
-> Transform c m a ((c, b), b -> m a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Lens c m a b -> Transform c m a ((c, b), b -> m a)
forall c (m :: * -> *) a b.
Lens c m a b -> Transform c m a ((c, b), b -> m a)
lensT (Lens c m a b -> Transform c m a ((c, b), b -> m a))
-> (String -> Lens c m a b)
-> String
-> Transform c m a ((c, b), b -> m a)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Lens c m a b
l2) (Transform c m a ((c, b), b -> m a)
-> a -> Transform c m a ((c, b), b -> m a)
forall a b. a -> b -> a
const (Lens c m a b -> Transform c m a ((c, b), b -> m a)
forall c (m :: * -> *) a b.
Lens c m a b -> Transform c m a ((c, b), b -> m a)
lensT Lens c m a b
l1)))
{-# INLINE catchL #-}

-- | Construct a 'Lens' from a 'BiTransform'.
bidirectionalL :: Monad m => BiTransform c m a b -> Lens c m a b
bidirectionalL :: BiTransform c m a b -> Lens c m a b
bidirectionalL BiTransform c m a b
bt = Transform c m a ((c, b), b -> m a) -> Lens c m a b
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m a ((c, b), b -> m a) -> Lens c m a b)
-> Transform c m a ((c, b), b -> m a) -> Lens c m a b
forall a b. (a -> b) -> a -> b
$ do c
c <- Transform c m a c
forall (m :: * -> *) c a. Monad m => Transform c m a c
contextT
                              b
b <- BiTransform c m a b -> Transform c m a b
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m a b
forwardT BiTransform c m a b
bt
                              ((c, b), b -> m a) -> Transform c m a ((c, b), b -> m a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
c,b
b), Transform c m b a -> c -> b -> m a
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT (BiTransform c m a b -> Transform c m b a
forall c (m :: * -> *) a b.
BiTransform c m a b -> Transform c m b a
backwardT BiTransform c m a b
bt) c
c)
{-# INLINE bidirectionalL #-}

-- | Construct a 'Lens' from two pure functions.
pureL :: Monad m => (a -> b) -> (b -> a) -> Lens c m a b
pureL :: (a -> b) -> (b -> a) -> Lens c m a b
pureL a -> b
f b -> a
g = BiTransform c m a b -> Lens c m a b
forall (m :: * -> *) c a b.
Monad m =>
BiTransform c m a b -> Lens c m a b
bidirectionalL (BiTransform c m a b -> Lens c m a b)
-> BiTransform c m a b -> Lens c m a b
forall a b. (a -> b) -> a -> b
$ Transform c m a b -> Transform c m b a -> BiTransform c m a b
forall c (m :: * -> *) a b.
Transform c m a b -> Transform c m b a -> BiTransform c m a b
bidirectional ((a -> b) -> Transform c m a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> b
f) ((b -> a) -> Transform c m b a
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> a
g)
{-# INLINE pureL #-}

------------------------------------------------------------------------------------------

-- | A 'Lens' to the injection of a value.
injectL  :: (MonadFail m, Injection a g) => Lens c m a g
injectL :: Lens c m a g
injectL = Transform c m a ((c, g), g -> m a) -> Lens c m a g
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m a ((c, g), g -> m a) -> Lens c m a g)
-> Transform c m a ((c, g), g -> m a) -> Lens c m a g
forall a b. (a -> b) -> a -> b
$ (c -> a -> m ((c, g), g -> m a))
-> Transform c m a ((c, g), g -> m a)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> a -> m ((c, g), g -> m a))
 -> Transform c m a ((c, g), g -> m a))
-> (c -> a -> m ((c, g), g -> m a))
-> Transform c m a ((c, g), g -> m a)
forall a b. (a -> b) -> a -> b
$ \ c
c a
a -> ((c, g), g -> m a) -> m ((c, g), g -> m a)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
c, a -> g
forall a u. Injection a u => a -> u
inject a
a), g -> m a
forall (m :: * -> *) a u. (MonadFail m, Injection a u) => u -> m a
projectM)
{-# INLINE injectL #-}

-- | A 'Lens' to the projection of a value.
projectL :: (MonadFail m, Injection a g) => Lens c m g a
projectL :: Lens c m g a
projectL = Transform c m g ((c, a), a -> m g) -> Lens c m g a
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m g ((c, a), a -> m g) -> Lens c m g a)
-> Transform c m g ((c, a), a -> m g) -> Lens c m g a
forall a b. (a -> b) -> a -> b
$ (c -> g -> m ((c, a), a -> m g))
-> Transform c m g ((c, a), a -> m g)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> g -> m ((c, a), a -> m g))
 -> Transform c m g ((c, a), a -> m g))
-> (c -> g -> m ((c, a), a -> m g))
-> Transform c m g ((c, a), a -> m g)
forall a b. (a -> b) -> a -> b
$ \ c
c -> g -> m a
forall (m :: * -> *) a u. (MonadFail m, Injection a u) => u -> m a
projectM (g -> m a)
-> (a -> m ((c, a), a -> m g)) -> g -> m ((c, a), a -> m g)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (\ a
a -> ((c, a), a -> m g) -> m ((c, a), a -> m g)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c
c,a
a), a -> m g
forall (m :: * -> *) a u. (Monad m, Injection a u) => a -> m u
injectM))
{-# INLINE projectL #-}

-------------------------------------------------------------------------------