PartialCombinators.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Pointless.Lenses.PartialCombinators
-- Copyright   :  (c) 2011 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 lifts a provides unsafe, non-total point-free combinators as lenses.
--
-----------------------------------------------------------------------------

module Generics.Pointless.Lenses.PartialCombinators where

import Generics.Pointless.Lenses
import Generics.Pointless.Lenses.Combinators
import Generics.Pointless.Lenses.RecursionPatterns
import Generics.Pointless.Combinators
    
-- | Split
infix 6 /\<
(/\<) :: Eq a => (Lens a b) -> (Lens a c) -> Lens a (b,c)
(/\<) f g = Lens get' put' create'
    where get' = get f /\ get g
          put' = aux . (put f . (fst >< id) /\ put g . (snd >< id))
          create' = aux . (create f >< create g)
          aux = (fst \/ error "/\\<: failed equality test") . (eq?)

-- | Left Injection
inl_lns :: Lens a (Either a b)
inl_lns = Lens inl put' create'
    where put' = create' . fst
          create' = id \/ error "inl_lns: branching changed"

-- | Right injection
inr_lns :: Lens b (Either a b)
inr_lns = Lens inr put' create'
    where put' = create' . fst
          create' = error "inr_lns: branching changed" \/ id

-- | The converse of a left injection
inlconv_lns :: Lens (Either a b) a
inlconv_lns = Lens (id \/ error "inlconv_lns") put' create'
	where put' = create' . fst
	      create' = inl

-- | The converse of a right injection
inrconv_lns :: Lens (Either a b) b
inrconv_lns = Lens (error "inrconv_lns" \/ id) put' create'
	where put' = create' . fst
	      create' = inr

-- | Conditional lens
infix 0 ?.<
(?.<) :: (a -> Bool) -> Lens a (Either a a)
(?.<) p = Lens get' put' create'
    where get' = (p?)
          put' = create' . fst
          create' (Left l) = if p l then l else error "?.<: branching changed"
          create' (Right r) = if p r then error "?.<: branching changed" else r