module Data.Vinyl.Lens
( module Control.Lens
, RLens
, rLens
, rGet
, rPut
, rMod
, RLens'
, rLens'
) where
import Data.Vinyl.Field
import Data.Vinyl.Rec
import Data.Vinyl.Witnesses
import Control.Lens
import Control.Monad.Identity
type RLens sy t = IElem (sy ::: t) rs => Lens' (PlainRec rs) t
type RLens' f sy t = IElem (sy ::: t) rs => Lens' (Rec rs f) (f t)
rLens :: (sy ::: t) -> RLens sy t
rLens f = rLens' f . lens runIdentity (const Identity)
rLens' :: (sy ::: t) -> RLens' f sy t
rLens' f = rLensAux f implicitly
rGet = view . rLens
rPut = set . rLens
rMod = over . rLens
rLensAux :: forall f r sy t rs. (r ~ (sy ::: t))
=> r -> Elem r rs -> Lens' (Rec rs f) (f t)
rLensAux _ = go
where goHere :: Elem r rs' -> Lens' (Rec rs' f) (f t)
goHere Here = lens (\(x :& _) -> x) (\(_ :& xs) x -> x :& xs)
goHere _ = error "Unintended base case invocation"
go :: Elem r rs' -> Lens' (Rec rs' f) (f t)
go Here = goHere Here
go (There Here) = rLensPrepend $ goHere Here
go (There (There Here)) = rLensPrepend $ rLensPrepend $ goHere Here
go (There (There (There Here))) =
rLensPrepend $ rLensPrepend $ rLensPrepend $ goHere Here
go (There (There (There (There Here)))) =
rLensPrepend $ rLensPrepend $ rLensPrepend $ rLensPrepend $ goHere Here
go (There (There (There (There p)))) =
rLensPrepend $ rLensPrepend $ rLensPrepend $ rLensPrepend $ go' p
go' :: Elem r rs' -> Lens' (Rec rs' f) (f t)
go' Here = goHere Here
go' (There p) = rLensPrepend $ go p
rLensPrepend :: Lens' (Rec rs f) (f t) -> Lens' (Rec (l ': rs) f) (f t)
rLensPrepend l = lens (\(_ :& xs) -> view l xs) (\(a :& xs) x -> a :& (set l x xs))