-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Pointless.Lenses.Combinators
-- 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 lifts a standard set of point-free combinators into bidirectional lenses.
--
-----------------------------------------------------------------------------

module Generics.Pointless.Lenses.Combinators where

import Generics.Pointless.Lenses
import Generics.Pointless.Combinators
import Generics.Pointless.Functors

-- * Point-free lens combinators

-- | Function application is a lens.
ap_lns :: Eq a => (b -> a) -> Lens ((a -> b),a) b
ap_lns f = Lens get' put' create'
    where get' = app
          put' (y,(g,x)) = let h x' = if x == x' then y else g x in (h,x)
          create' = const /\ f              

-- | Predicate application is a lens.
infix 0 ?<
(?<) :: Eq a => Lens (a -> Bool,a) (Either a a)
(?<) = Lens get' put' create'
    where get' = (snd -|- snd) . distl . (out . app /\ snd)
          put' = ((orf \/ andf) . distl . (eqneq >< fst)) /\ ((id \/ id) . fst)
          create' = (curry eq /\ id) \/ (const (inn . inr . bang) /\ id)
          eqneq = curry eq -|- curry neq

-- | The right exponentiation combinator as a lens.
-- Applies a lens to the domain of a function.
rexp_lns :: Lens b c -> Lens (a -> b) (a -> c)
rexp_lns l = Lens get' put' create'
    where get' = rexp (get l)
          put' = rexp (put l) . split
          create' = rexp (create l)

curry_lns :: Lens ((a,b) -> c) (a -> b -> c)
curry_lns = Lens get' put' create'
    where get' = curry
          put' = uncurry . fst
          create' = uncurry

uncurry_lns :: Lens (a -> b -> c) ((a,b) -> c)
uncurry_lns = Lens get' put' create'
    where get' = uncurry
          put' = curry . fst
          create' = curry

-- | The lens composition operator.
infixr 9 .<
(.<) :: Lens b a -> Lens c b -> Lens c a
(.<) f g = Lens get' put' create'
    where get' = get f . get g
          put' = put g . (put f . (id >< get g) /\ snd)
          create' = create g . create f

-- | The @fst@ point-free combinator.
fst_lns :: (a -> b) -> Lens (a,b) a
fst_lns f = Lens get' put' create'
    where get' = fst
          put' = id >< snd
          create' = id /\ f

-- | The @snd@ point-free combinator.
snd_lns :: (b -> a) -> Lens (a,b) b
snd_lns f = Lens get' put' create'
    where get' = snd
          put' = swap . (id >< fst)
          create' = f /\ id

-- | The @><@ point-free combinator.
infix 7 ><<
(><<) :: Lens c a -> Lens d b -> Lens (c,d) (a,b)
(><<) f g = Lens get' put' create'
    where get' = get f >< get g
          put' = (put f >< put g) . distp
          create' = create f >< create g

infix 4 \/<
(\/<) :: (c -> Either One One) -> Lens a c -> Lens b c -> Lens (Either a b) c
(\/<) p f g = Lens get' put' create'
    where get' = get f \/ get g
          put' = (put f -|- put g) . distr
          create' = (create f -|- create g) . (p??)

-- | The left-biased @\/@ point-free combinator.
-- It chooses left values over right values in the @create@ direction.
infix 4 .\/<
(.\/<) :: Lens a c -> Lens b c -> Lens (Either a b) c
(.\/<) f g = Lens get' put' create'
    where get' = get f \/ get g
          put' = (put f -|- put g) . distr
          create' = inl . create f

-- | The right-biased @\/@ point-free combinator.
-- It chooses right values over left values in the @create@ direction.
infix 4 \/.<
(\/.<) :: Lens a c -> Lens b c -> Lens (Either a b) c
(\/.<) f g = Lens get' put' create'
    where get' = get f \/ get g
          put' = (put f -|- put g) . distr
          create' = inr . create g

-- | The @-|-@ point-free combinator.
infix 5 -|-<
(-|-<) :: Lens c a -> Lens d b -> Lens (Either c d) (Either a b)
(-|-<) f g = Lens get' put' create'
    where get' = get f -|- get g
          put' = ((put f \/ create f . fst) -|- (create g . fst \/ put g)) . dists
          create' = create f -|- create g

-- | The @-|-@ point-free combinator with user-defined backward behavior.
sum_lns :: ((a,d) -> c) -> ((b,c) -> d) -> Lens c a -> Lens d b -> Lens (Either c d) (Either a b)
sum_lns h i f g = Lens get' put' create'
    where get' = get f -|- get g
          put' = (put f -|- put g) . ((id \/ (fst /\ h)) -|- ((fst /\ i) \/ id)) . dists
          create' = create f -|- create g

-- | The @pnt@ point-free combinator.
infix 0 !<
(!<) :: (One -> c) -> Lens c One
(!<) f = Lens get' put' create'
    where get' = bang
          put' = snd
          create' = f

-- | The @(a!) \/ f@ point-free expression, where @a@ is a constant and @f@ a function.
-- The additional argument of type @c@ is the default value when the view matches the constant of type @a@.
infix 4 !\/<
(!\/<) :: Eq a => a -> Lens b a -> c -> Lens (Either c b) a
(!\/<) a f c = Lens get' put' create'
    where get' = (a!) \/ get f
          put' = (id \/ inr) . ((snd -|- create f . fst) -|- id) . ((((==a) . fst)?) -|- put f) . distr
          create' = ((c!) -|- create f) . ((==a)?)
          
-- | The @f \/ (a!)@ point-free expression, where @a@ is a constant and @f@ a function.
-- The additional argument of type @b@ is the default value when the view matches the constant of type @a@.
infix 4 \/!<
(\/!<) :: Eq a => a -> Lens c a -> b -> Lens (Either c b) a
(\/!<) a f b = Lens get' put' create'
    where get' = get f \/ (a!)
          put' = (inl \/ coswap) . (id -|- (snd -|- create f . fst)) . (put f -|- (((==a) . fst)?)) . distr
          create' =  (create f -|- (b!)). ((==a)?)

-- | The @inl \/ f@ point-free expression, where @f@ is a function.
infix 4 #\/<
(#\/<) :: Lens a c -> Lens b (Either c d) -> Lens (Either a b) (Either c d)
(#\/<) f g = ((id_lns .\/< id_lns) -|-< id_lns) .< coassocl_lns .< (f -|-< g)
{-(#\/<) f g = Lens get' put' create'
    where get' = inl . get f \/ get g
          put' = ((put f -|- create g . inr . fst) . distl \/ inr . put g) . distr
          create' = create f -|- create g . inr-}
          

-- | The @f \/ inr@ point-free expression, where @f@ is a function.
infix 4 \/$<
(\/$<) :: Lens a (Either c d) -> Lens b d -> Lens (Either a b) (Either c d)
(\/$<) f g = (id_lns -|-< (id_lns \/.< id_lns)) .< coassocr_lns .< (f -|-< g)
{-(\/$<) f g = Lens get' put' create'
    where get' = get f \/ inr . get g
          put' = (inl . put f \/ (create f . inl . fst -|- put g) . distl) . distr
          create' = create f . inl -|- create g-}

-- | The @bang /\ f@ point-free expression, where @f@ is a function.
infix 4 !/\<
(!/\<) :: Lens c a -> Lens c (One,a)
(!/\<) f = Lens get' put' create'
    where get' = bang /\ get f
          put' = put f . (snd >< id)
          create' = create f . snd

-- | The @f /\ bang@ point-free expression, where @f@ is a function.
infix 4 /\!<
(/\!<) :: Lens c a -> Lens c (a,One)
(/\!<) f = Lens get' put' create'
    where get' = get f /\ bang
          put' = put f . (fst >< id)
          create' = create f . fst

-- * Point-free isomorphism combinators

-- | The lens identity combinator.
id_lns :: Lens c c
id_lns = Lens id fst id

-- | The @subr@ point-free combinator.
subr_lns :: Lens (a,(b,c)) (b,(a,c))
subr_lns = Lens subr (subr . fst) subr

-- | The @subl@ point-free combinator.
subl_lns :: Lens ((a,b),c) ((a,c),b)
subl_lns = Lens subl (subl . fst) subl

-- | The @cosubr@ point-free combinator.
cosubr_lns :: Lens (Either a (Either b c)) (Either b (Either a c))
cosubr_lns = Lens cosubr (cosubr . fst) cosubr

-- | The @cosubl@ point-free combinator.
cosubl_lns :: Lens (Either (Either a b) c) (Either (Either a c) b)
cosubl_lns = Lens cosubl (cosubl . fst) cosubl

-- | The @distp@ point-free combinator.
distp_lns :: Lens ((c,d),(a,b)) ((c,a),(d,b))
distp_lns = Lens distp (distp . fst) distp

-- | The @dists@ point-free combinator.
dists_lns :: Lens (Either a b,Either c d) (Either (Either (a,c) (a,d)) (Either (b,c) (b,d)))
dists_lns = (distr_lns -|-< distr_lns) .< distl_lns

-- | The @swap@ point-free combinator.
swap_lns :: Lens (a,b) (b,a)
swap_lns = Lens swap (swap . fst) swap

-- | The @coswap@ point-free combinator
coswap_lns :: Lens (Either a b) (Either b a)
coswap_lns = Lens coswap (coswap . fst) coswap

-- | The @distl@ point-free combinator.
distl_lns :: Lens (Either a b, c) (Either (a,c) (b,c))
distl_lns = Lens distl (undistl . fst) undistl

-- | The @undistl@ point-free combinator.
undistl_lns :: Lens (Either (a,c) (b,c)) (Either a b, c)
undistl_lns = Lens undistl (distl . fst) distl

-- | The @distr@ point-free combinator.
distr_lns :: Lens (c, Either a b) (Either (c,a) (c,b))
distr_lns = Lens distr (undistr . fst) undistr

-- | The @undistr@ point-free combinator.
undistr_lns :: Lens (Either (c,a) (c,b)) (c, Either a b)
undistr_lns = Lens undistr (distr . fst) distr

-- | The @assocl@ point-free combinator.
assocl_lns :: Lens (a,(b,c)) ((a,b),c)
assocl_lns = Lens assocl (assocr . fst) assocr

-- | The @assocr@ point-free combinator.
assocr_lns :: Lens ((a,b),c) (a,(b,c))
assocr_lns = Lens assocr (assocl . fst) assocl

-- | The @coassocl@ point-free combinator.
coassocl_lns :: Lens (Either a (Either b c)) (Either (Either a b) c)
coassocl_lns = Lens coassocl (coassocr . fst) coassocr

-- | The @coassocr@ point-free combinator.
coassocr_lns :: Lens (Either (Either a b) c) (Either a (Either b c))
coassocr_lns = Lens coassocr (coassocl . fst) coassocl