Lenses.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Pointless.Lenses
-- Copyright   :  (c) 2009 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Pointless Lenses:
-- bidirectional lenses with point-free programming
-- 
-- This module defines the structure of lenses and provides Quickcheck procedures to test lens well-behavedness.
--
-----------------------------------------------------------------------------

module Generics.Pointless.Lenses where
    
import Generics.Pointless.Combinators
import Generics.Pointless.Functors

-- | The data type of lenses
data Lens c a = Lens { get :: c  -> a
                     , put :: (a,c) -> c
                     , create :: a -> c
                     }

-- | The type of natural lenses.
-- Lenses that encode bidirectional natural transformations.
type NatLens f g = forall a. Ann a -> Lens (Rep f a) (Rep g a)

rep_lns :: (ToRep s,ToRep v) => Lens (s a) (v b) -> Lens (Rep s a) (Rep v b)
rep_lns (l::Lens (s a) (v b)) = Lens get' put' create'
    where get' = rep . get l . unrep anns anna
          put' = rep . put l . (unrep annv annb >< unrep anns anna)
          create' = rep . create l . unrep annv annb
          anns = ann :: Ann (Fix s)
          annv = ann :: Ann (Fix v)
          anna = ann :: Ann a
          annb = ann :: Ann b

-- Lens where we use the whole view to help computing the function parameters to create
varlens :: (v -> Lens c a) -> v -> (a -> v) -> Lens c a
varlens l v f = Lens get' put' create'
    where get' c = get (l v) c
          put' (a,c) = put (l (f a)) (a,c)
          create' a = create (l (f a)) a

-- | Increment a number.
inc_lns :: Enum a => Lens a a
inc_lns = Lens succ (pred . fst) pred

-- | Decrement a number.
dec_lns :: Enum a => Lens a a
dec_lns = Lens pred (succ . fst) succ

-- | QuickCheck procedure to test if two lenses are equivalent.
lnsEq :: (Eq a,Eq c) => Lens c a -> Lens c a -> a -> c -> Bool
lnsEq l l' a c = getEq l l' c && putEq l l' a c && createEq l l' a

getEq :: Eq a => Lens c a -> Lens c a -> c -> Bool
getEq l l' c = get l c == get l' c

putEq :: (Eq a,Eq c) => Lens c a -> Lens c a -> a -> c -> Bool
putEq l l' a c = put l (a,c) == put l' (a,c)

createEq :: Eq c => Lens c a -> Lens c a -> a -> Bool
createEq l l' a = create l a == create l' a

-- | QuickCheck procedure to test if a lens is well-behaved.
wb :: (Eq a,Eq c) => Lens c a -> a -> c -> Bool
wb l a c = putget l a c && getput l c && createget l a

-- | QuickCheck procedure to test if a lens satisfies the PutGet law.
putget :: (Eq a,Eq c) => Lens c a -> a -> c -> Bool
putget l a c = get l (put l (a,c)) == a

-- | QuickCheck procedure to test if a lens satisfies the GetPut law.
getput :: Eq c => Lens c a -> c -> Bool
getput l c = put l (get l c,c) == c

-- | QuickCheck procedure to test if a lens satisfies the CreateGet law.
createget :: Eq a => Lens c a -> a -> Bool
createget l a = get l (create l a) == a