module Data.Vinyl.Lens where
import Control.Applicative
import Data.Functor.Identity
import Data.Vinyl.Field
import Data.Vinyl.Rec
import Data.Vinyl.Witnesses
rGet' :: IElem (sy ::: t) rs => (sy ::: t) -> Rec rs f -> f t
rGet' r = getConst . rLens' r Const
rGet :: IElem (sy ::: t) rs => (sy ::: t) -> PlainRec rs -> t
rGet = (runIdentity .) . rGet'
rPut' :: IElem (sy ::: t) rs => (sy ::: t) -> f t -> Rec rs f -> Rec rs f
rPut' r x = runIdentity . rLens' r (Identity . const x)
rPut :: IElem (sy:::t) rs => (sy:::t) -> t -> PlainRec rs -> PlainRec rs
rPut r x = rPut' r (Identity x)
rMod :: (IElem (sy:::t) rs, Functor f)
=> (sy:::t) -> (t -> t) -> Rec rs f -> Rec rs f
rMod r f = runIdentity . rLens' r (Identity . fmap f)
rLens' :: forall r rs sy t f g. (r ~ (sy:::t), IElem r rs, Functor g)
=> r -> (f t -> g (f t)) -> Rec rs f -> g (Rec rs f)
rLens' _ f = go implicitly
where go :: Elem r rr -> Rec rr f -> g (Rec rr f)
go Here (x :& xs) = fmap (:& xs) (f x)
go (There Here) (a :& x :& xs) = fmap ((a :&) . (:& xs)) (f x)
go (There (There Here)) (a :& b :& x :& xs) =
fmap (\x' -> a :& b :& x' :& xs) (f x)
go (There (There (There Here))) (a :& b :& c :& x :& xs) =
fmap (\x' -> a :& b :& c :& x' :& xs) (f x)
go (There (There (There (There Here)))) (a :& b :& c :& d :& x :& xs) =
fmap (\x' -> a :& b :& c :& d :& x' :& xs) (f x)
go (There (There (There (There p)))) (a :& b :& c :& d :& xs) =
fmap (\xs' -> a :& b :& c :& d :& xs') (go' p xs)
go' :: Elem r rr -> Rec rr f -> g (Rec rr f)
go' Here (x :& xs) = fmap (:& xs) (f x)
go' (There p) (x :& xs) = fmap (x :&) (go p xs)
rLens :: forall r rs sy t g. (r ~ (sy:::t), IElem r rs, Functor g)
=> r -> (t -> g t) -> PlainRec rs -> g (PlainRec rs)
rLens r = rLens' r . lenser runIdentity (const Identity)
where lenser sa sbt afb s = sbt s <$> afb (sa s)