module Data.Lens.Edit.Product where
import Control.Arrow
import Data.Lens.Bidirectional
import Data.Lens.Edit.Stateful (C)
import Data.Module.Product
import qualified Data.Lens.Edit.Stateful as F
import qualified Data.Lens.Edit.Stateless as L
swizzleFF ((a, b), (c, d)) = ((a, c), (b, d))
data CompactProduct k l = CompactProduct k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l) => Bidirectional (CompactProduct k l) where
type L (CompactProduct k l) = (L k, L l)
type R (CompactProduct k l) = (R k, R l)
instance (F.Lens k, F.Lens l) => F.Lens (CompactProduct k l) where
type C (CompactProduct k l) = (F.C k, F.C l)
missing (CompactProduct k l) = (F.missing k, F.missing l)
dputr (CompactProduct k l) = swizzleFF . (F.dputr k *** F.dputr l) . swizzleFF
dputl (CompactProduct k l) = swizzleFF . (F.dputl k *** F.dputl l) . swizzleFF
instance (L.Lens k, L.Lens l) => L.Lens (CompactProduct k l) where
dputr (CompactProduct k l) = L.dputr k *** L.dputr l
dputl (CompactProduct k l) = L.dputl k *** L.dputl l
swizzleFL ((a, b), c) = ((a, c), b)
data CompactProductFL k l = CompactProductFL k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l) => Bidirectional (CompactProductFL k l) where
type L (CompactProductFL k l) = (L k, L l)
type R (CompactProductFL k l) = (R k, R l)
instance (F.Lens k, L.Lens l) => F.Lens (CompactProductFL k l) where
type C (CompactProductFL k l) = F.C k
missing (CompactProductFL k l) = F.missing k
dputr (CompactProductFL k l) = swizzleFL . (F.dputr k *** L.dputr l) . swizzleFL
dputl (CompactProductFL 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 CompactProductLF k l = CompactProductLF k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l) => Bidirectional (CompactProductLF k l) where
type L (CompactProductLF k l) = (L k, L l)
type R (CompactProductLF k l) = (R k, R l)
instance (L.Lens k, F.Lens l) => F.Lens (CompactProductLF k l) where
type C (CompactProductLF k l) = F.C l
missing (CompactProductLF k l) = F.missing l
dputr (CompactProductLF k l) = unswizzleLF . (L.dputr k *** F.dputr l) . swizzleLF
dputl (CompactProductLF k l) = unswizzleLF . (L.dputl k *** F.dputl l) . swizzleLF
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) = [ProductAtom (L k) (L l)]
type R (Product k l) = [ProductAtom (R k) (R l)]
instance (F.Lens k, F.Lens l) => F.Lens (Product k l) where
type C (Product k l) = (F.C k, F.C l)
missing (Product k l) = (F.missing k, F.missing l)
dputr (Product k l) = F.foldState (dputProductF (F.dputr k) (F.dputr l))
dputl (Product k l) = F.foldState (dputProductF (F.dputl k) (F.dputl l))
dputProductF dputk dputl (Left dx) (ck, cl) = let (dz, ck') = dputk (dx, ck) in ([Left dz], (ck', cl))
dputProductF dputk dputl (Right dy) (ck, cl) = let (dw, cl') = dputl (dy, cl) in ([Right dw], (ck, cl'))
instance (L.Lens k, L.Lens l) => L.Lens (Product k l) where
dputr (Product k l) = map (either (Left . L.dputr k) (Right . L.dputr l))
dputl (Product k l) = map (either (Left . L.dputl k) (Right . L.dputl l))
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) = [ProductAtom (L k) (L l)]
type R (ProductFL k l) = [ProductAtom (R k) (R l)]
instance (F.Lens k, L.Lens l) => F.Lens (ProductFL k l) where
type C (ProductFL k l) = F.C k
missing (ProductFL k l) = F.missing k
dputr (ProductFL k l) = F.foldState (dputProductFL (F.dputr k) (L.dputr l))
dputl (ProductFL k l) = F.foldState (dputProductFL (F.dputl k) (L.dputl l))
dputProductFL dputk dputl (Left dx) ck = let (dz, ck') = dputk (dx, ck) in ([Left dz], ck')
dputProductFL dputk dputl (Right dy) ck = ([Right (dputl dy)], ck)
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) = [ProductAtom (L k) (L l)]
type R (ProductLF k l) = [ProductAtom (R k) (R l)]
instance (L.Lens k, F.Lens l) => F.Lens (ProductLF k l) where
type C (ProductLF k l) = F.C l
missing (ProductLF k l) = F.missing l
dputr (ProductLF k l) = F.foldState (dputProductLF (L.dputr k) (F.dputr l))
dputl (ProductLF k l) = F.foldState (dputProductLF (L.dputl k) (F.dputl l))
dputProductLF dputk dputl (Left dx) cl = ([Left (dputk dx)], cl)
dputProductLF dputk dputl (Right dy) cl = let (dw, cl') = dputl (dy, cl) in ([Right dw], cl')