module Data.Lens.Edit.Primitive where
import Control.Arrow (first)
import Data.Lens.Bidirectional
import Data.Lens.Edit.Stateful (C)
import Data.Iso
import Data.Monoid
import qualified Data.Lens.Edit.Stateful as F
import qualified Data.Lens.Edit.Stateless as L
data Id dX = Id deriving (Eq, Ord, Show, Read)
instance Bidirectional (Id dX) where
type L (Id dX) = dX
type R (Id dX) = dX
instance F.Lens (Id dX) where
type C (Id dX) = ()
missing = const ()
dputr = const id
dputl = const id
instance L.Lens (Id dX) where
dputr = const id
dputl = const id
data Compose k l = Compose k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l, R k ~ L l) => Bidirectional (Compose k l) where
type L (Compose k l) = L k
type R (Compose k l) = R l
instance (F.Lens k, F.Lens l, R k ~ L l) => F.Lens (Compose k l) where
type C (Compose k l) = (F.C k, F.C l)
missing (Compose k l) = (F.missing k, F.missing l)
dputr (Compose k l) (dx, (ck, cl)) =
let (dy, ck') = F.dputr k (dx, ck)
(dz, cl') = F.dputr l (dy, cl)
in (dz, (ck', cl'))
dputl (Compose k l) (dz, (ck, cl)) =
let (dy, cl') = F.dputl l (dz, cl)
(dx, ck') = F.dputl k (dy, ck)
in (dx, (ck', cl'))
instance (L.Lens k, L.Lens l, R k ~ L l) => L.Lens (Compose k l) where
dputr (Compose k l) = L.dputr l . L.dputr k
dputl (Compose k l) = L.dputl k . L.dputl l
data ComposeFL k l = ComposeFL k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l, R k ~ L l) => Bidirectional (ComposeFL k l) where
type L (ComposeFL k l) = L k
type R (ComposeFL k l) = R l
instance (F.Lens k, L.Lens l, R k ~ L l) => F.Lens (ComposeFL k l) where
type C (ComposeFL k l) = F.C k
missing (ComposeFL k l) = F.missing k
dputr (ComposeFL k l) = first (L.dputr l) . F.dputr k
dputl (ComposeFL k l) = F.dputl k . first (L.dputl l)
data ComposeLF k l = ComposeLF k l deriving (Eq, Ord, Show, Read)
instance (Bidirectional k, Bidirectional l, R k ~ L l) => Bidirectional (ComposeLF k l) where
type L (ComposeLF k l) = L k
type R (ComposeLF k l) = R l
instance (L.Lens k, F.Lens l, R k ~ L l) => F.Lens (ComposeLF k l) where
type C (ComposeLF k l) = F.C l
missing (ComposeLF k l) = F.missing l
dputr (ComposeLF k l) = F.dputr l . first (L.dputr k)
dputl (ComposeLF k l) = first (L.dputl k) . F.dputl l
data Op l = Op l deriving (Eq, Ord, Show, Read)
unOp (Op l) = l
instance Bidirectional l => Bidirectional (Op l) where
type L (Op l) = R l
type R (Op l) = L l
instance F.Lens l => F.Lens (Op l) where
type C (Op l) = F.C l
missing = F.missing . unOp
dputr = F.dputl . unOp
dputl = F.dputr . unOp
instance L.Lens l => L.Lens (Op l) where
dputr = L.dputl . unOp
dputl = L.dputr . unOp
data Disconnect dX dY = Disconnect deriving (Eq, Ord, Show, Read)
instance Bidirectional (Disconnect dX dY) where
type L (Disconnect dX dY) = dX
type R (Disconnect dX dY) = dY
instance (Monoid dX, Monoid dY) => F.Lens (Disconnect dX dY) where
type C (Disconnect dX dY) = ()
missing = const ()
dputr _ (_, c) = (mempty, c)
dputl _ (_, c) = (mempty, c)
instance (Monoid dX, Monoid dY) => L.Lens (Disconnect dX dY) where
dputr = const (const mempty)
dputl = const (const mempty)
instance Bidirectional (Iso dX dY) where
type L (Iso dX dY) = dX
type R (Iso dX dY) = dY
instance F.Lens (Iso dX dY) where
type C (Iso dX dY) = ()
missing = const ()
dputr (Iso f g) (dx, c) = (f dx, c)
dputl (Iso f g) (dy, c) = (g dy, c)
instance L.Lens (Iso dX dY) where
dputr (Iso f g) = f
dputl (Iso f g) = g