Product.hs

{-# LANGUAGE TypeFamilies #-}
module Data.Lens.Edit.Product where

import Control.Arrow
import Data.Lens.Bidirectional
import qualified Data.Lens.Edit.Stateful  as F -- state_f_ul
import qualified Data.Lens.Edit.Stateless as L -- state_l_ess

swizzleFF ((a, b), (c, d)) = ((a, c), (b, d))
data Product k l = Product k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l) => Bidirectional (Product k l) where
	type L (Product k l) = (L k, L l)
	type R (Product k l) = (R k, R l)

instance (F.Lens k, F.Lens l) => F.Lens (Product k l) where
	type F.C (Product k l) = (F.C k, F.C l)
	missing  (Product k l) = (F.missing k, F.missing l)
	dputr (Product k l) = swizzleFF . (F.dputr k *** F.dputr l) . swizzleFF
	dputl (Product k l) = swizzleFF . (F.dputl k *** F.dputl l) . swizzleFF

instance (L.Lens k, L.Lens l) => L.Lens (Product k l) where
	dputr (Product k l) = L.dputr k *** L.dputr l
	dputl (Product k l) = L.dputl k *** L.dputl l

swizzleFL ((a, b), c) = ((a, c), b)
data ProductFL k l = ProductFL k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l) => Bidirectional (ProductFL k l) where
	type L (ProductFL k l) = (L k, L l)
	type R (ProductFL k l) = (R k, R l)

instance (F.Lens k, L.Lens l) => F.Lens (ProductFL k l) where
	type F.C (ProductFL k l) = F.C k
	missing  (ProductFL k l) = F.missing k
	dputr (ProductFL k l) = swizzleFL . (F.dputr k *** L.dputr l) . swizzleFL
	dputl (ProductFL k l) = swizzleFL . (F.dputl k *** L.dputl l) . swizzleFL

swizzleLF   ((a, b), c) = (a, (b, c))
unswizzleLF (a, (b, c)) = ((a, b), c)
data ProductLF k l = ProductLF k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l) => Bidirectional (ProductLF k l) where
	type L (ProductLF k l) = (L k, L l)
	type R (ProductLF k l) = (R k, R l)

instance (L.Lens k, F.Lens l) => F.Lens (ProductLF k l) where
	type F.C (ProductLF k l) = F.C l
	missing  (ProductLF k l) = F.missing l
	dputr (ProductLF k l) = unswizzleLF . (L.dputr k *** F.dputr l) . swizzleLF
	dputl (ProductLF k l) = unswizzleLF . (L.dputl k *** F.dputl l) . swizzleLF