app-lens-0.1.0.3: Control/LensFunction.hs

{-# LANGUAGE RankNTypes #-}

-- Required for sequenceL, if we use var Laarhoven repl.
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE Trustworthy #-}


{-|
This module provides an "applicative" (functional) way of composing
lenses through the data type 'L'. For example, this module enables us
to define a "lens" version of 'unlines' as follows.

@
unlinesF :: [L s String] -> L s String
unlinesF []     = new ""
unlinesF (x:xs) = catLineF x (unlinesF xs)
  where catLineF = lift2 catLineL

catLineL :: Lens' (String, String) String
catLineL = ...
@

To make a lens from such "lens functions", one can use unlifting
functions ('unlift', 'unlift2', 'unliftT') as follows.

@
unlinesL :: Lens' [String] String
unlinesL = unliftT unlinesF
@

The obtained lens works as expected (here 'Control.Lens.^.', 'Control.Lens.&'
and 'Control.Lens..~' are taken from "Control.Lens").

>>> ["banana", "orange", "apple"] ^. unlinesL
"banana\norange\napple\n"
>>> ["banana", "orange", "apple"] & unlinesL .~ "Banana\nOrange\nApple\n"
["Banana","Orange","Apple"]

One can understand that @L s a@ is an updatable @a@. 
The type @[L s String] -> L s String@ of @unlinesF@ tells us that
we can update only the list elements.
Actually, insertion or deletion of lines to the view will fail, as below.

>>> ["banana", "orange", "apple"] & unlinesL .~ "Banana\nOrange\nApple"
*** Exception: ...
>>> ["banana", "orange", "apple"] & unlinesL .~ "Banana\nOrange\nApple\n\n"
*** Exception: ...

If you want to reflect insertions and deletions, one have to write a
function of type @L s [String] -> L s String@, which says that the
list structure itself would be updatable. To write a function of this
type, 'liftC' and 'liftC2' functions would be sometimes useful.

@
unlinesF' :: L s [String] -> L s String
unlinesF' = liftC (foldWithDefault "" "\n") (lift catLineL')

catLineL' :: Lens' (Either () (String,String)) String
catLineL' = ...

foldWithDefault :: a -> (Lens' (Either () (a,b)) b) -> Lens' [a] b
foldWithDefault d f = ...
@




-}

module Control.LensFunction
       (

       -- * Core Datatype
         L() -- abstract

       -- * Other constructors for @Lens'@
       , lens'
       -- * Functions handling pairs and containers
       , unit, pair, list, sequenceL

       -- * Lifting Functions 
       , new, lift, lift2, liftT
       , liftLens, liftLens'
       -- * Unlifting Functions
       , unlift, unlift2, unliftT

       -- * Functions for Handling Observations
       -- ** Core Monad
       , R() -- abstract
       -- ** Lifting Observations
       , observe
       , liftO, liftO2
       -- ** Unlifting Functions 
       , unliftM, unliftM2, unliftMT
       -- * Lifting Functions for Combinators 
       , liftC, liftC2 
       , module Control.LensFunction.Exception
       ) where

import Control.LensFunction.Core
import Control.LensFunction.Util
import Control.LensFunction.Exception

import Data.Traversable (Traversable)

import Control.Exception

import qualified Control.Lens as L 
---------------------------------------------------------

mName :: String
mName = "Control.LensFunction"

{- | 
The nullary version of a lifting function. Since there is no source,
every view generated by 'new' is not updatable.

The function will throw 'ConstantUpdateException', if its view is
updated. 
-}
new :: Eq a => a -> L s a
new a = lift (lens' $ const (a, check a)) unit
  where
    check x x' = if x == x' then
                   ()
                 else
                   throw (ConstantUpdateException $ mName ++ ".new")

{- |
The lifting function for binary lenses. 'unlift2' is a left inverse of this function. 

prop> unlift2 (lift2 l) = l

This function can be defined from 'lift' and 'pair' as below.

prop> lift2 l x y = lift l (pair x y)

NB: This is not a right inverse of 'unlift2'.

prop> (\x y -> x) /= lift2 (unlift2 (\x y -> x))

>>> set (unlift (\z -> (\x y -> x) z z)) "A" "B"
"B"
>>> set (unlift (\z -> lift2 (unlift2 (\x y -> x)) (z,z))) "A" "B"
Error: ...
-}
lift2 :: L.Lens' (a,b) c -> (L s a -> L s b -> L s c)
lift2 l x y = lift l (pair x y) 

{- Derived Functions -}

{- | Similar to @pair@, but this function is for lists. This is a
derived function, because this can be defined by using 'lift' and
'pair'.
-}
list :: [L s a] -> L s [a]
list []     = lift (L.lens (\() -> [])
                           (\() v -> case v of
                                      [] -> ()
                                      _  -> throw (ShapeMismatchException $ mName ++ ".list") ))
              unit
list (z:zs) = lift consL (pair z (list zs))
  where
    consL = L.lens (uncurry (:))
                   (\_ z -> case z of
                             (x:xs) -> (x,xs)
                             _ -> throw (ShapeMismatchException $ mName ++ ".list"))

{- | A data-type generic version of 'list'. The contraint @Eq (t ())@
says that we can check the equivalence of shapes of containers @t@. -}
sequenceL :: (Eq (t ()), Traversable t) => t (L s a) -> L s (t a)
sequenceL x = lift (fillL x) $ list (contents x)
  where
    fillL t = L.lens (fill t)
                     (\_ v -> if shape t == shape v then
                                contents v
                              else
                                throw (ShapeMismatchException $ mName ++ ".sequenceL"))

{-# SPECIALIZE sequenceL :: [L s a] -> L s [a] #-}              

{- | A lifting function for lens combinators. One can understand that the
     universal quantification for the second argument as closedness restriction. -}
liftC :: Eq a => (L.Lens' a b -> L.Lens' c d) ->
             (forall s. L s a -> L s b) ->
             (forall s. L s c -> L s d)
liftC c f = lift (c (unlift f))

{- | Similar to 'liftC', but this function is for binary lens combinators.
-}
liftC2 :: (Eq a, Eq c) => (L.Lens' a b -> L.Lens' c d -> L.Lens' e f) 
          -> (forall s. L s a -> L s b) 
          -> (forall s. L s c -> L s d)
          -> (forall s. L s e -> L s f)
liftC2 c f g = lift (c (unlift f) (unlift g))

----------------------------------------------------------
{- | A datatype-generic version of 'lift2'-}
liftT :: (Eq (t ()), Traversable t)
         => L.Lens' (t a) b -> (forall s. t (L s a) -> L s b)
liftT l xs = lift l (sequenceL xs)

{- | Lifting of observations.
A typical use of this function would be as follows. 

@
f x :: L s Int -> R s (L s B)
f x = do b <- liftO (> 0) x 
         if b then ... else ...           
@

-}
liftO :: Eq w => (a -> w) -> L s a -> R s w
liftO p x = observe (lift (L.lens p unused) x)
  where
    unused s v | v == p s  = s
               | otherwise = error "This error cannot happen"

{- | Lifting of binary observations -}
liftO2 :: Eq w => (a -> b -> w) -> L s a -> L s b -> R s w
liftO2 p x y = liftO (uncurry p) (x `pair` y)