{-# 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)