{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif
module Data.Vinyl.Lens
( RecElem(..)
, rget, rput, rput', rlens, rlens'
, RElem
, RecSubset(..)
, rsubset, rcast, rreplace
, rdowncast
, RSubset
, REquivalent
, type (∈)
, type (⊆)
, type (≅)
, type (<:)
, type (:~:)
) where
import Data.Kind (Constraint)
import Data.Vinyl.Core
import Data.Vinyl.Functor
import Data.Vinyl.TypeLevel
#if __GLASGOW_HASKELL__ < 806
import Data.Kind
#endif
class (i ~ RIndex r rs, NatToInt i)
=> RecElem (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k) (rs :: [k]) (rs' :: [k]) (i :: Nat) | r r' rs i -> rs' where
type RecElemFCtx record (f :: k -> *) :: Constraint
type RecElemFCtx record f = ()
rlensC
:: (Functor g, RecElemFCtx record f)
=> (f r -> g (f r'))
-> record f rs
-> g (record f rs')
rgetC
:: (RecElemFCtx record f, r ~ r')
=> record f rs
-> f r
rputC
:: RecElemFCtx record f
=> f r'
-> record f rs
-> record f rs'
type RElem x rs = RecElem Rec x x rs rs
lens
:: Functor f
=> (s -> a)
-> (s -> b -> t)
-> (a -> f b)
-> s
-> f t
lens :: (s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t
lens s -> a
sa s -> b -> t
sbt a -> f b
afb s
s = (b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s -> b -> t
sbt s
s) (f b -> f t) -> f b -> f t
forall a b. (a -> b) -> a -> b
$ a -> f b
afb (s -> a
sa s
s)
{-# INLINE lens #-}
instance RecElem Rec r r' (r ': rs) (r' ': rs) 'Z where
rlensC :: (f r -> g (f r')) -> Rec f (r : rs) -> g (Rec f (r' : rs))
rlensC f r -> g (f r')
f (f r
x :& Rec f rs
xs) = (f r' -> Rec f (r' : rs)) -> g (f r') -> g (Rec f (r' : rs))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f r' -> Rec f rs -> Rec f (r' : rs)
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f rs
xs) (f r -> g (f r')
f f r
f r
x)
{-# INLINE rlensC #-}
rgetC :: Rec f (r : rs) -> f r
rgetC = Const (f r) (Rec f (Any : rs)) -> f r
forall a k (b :: k). Const a b -> a
getConst (Const (f r) (Rec f (Any : rs)) -> f r)
-> (Rec f (r : rs) -> Const (f r) (Rec f (Any : rs)))
-> Rec f (r : rs)
-> f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f r -> Const (f r) (f Any))
-> Rec f (r : rs) -> Const (f r) (Rec f (Any : rs))
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (g :: * -> *) (f :: k -> *).
(RecElem record r r' rs rs' i, Functor g, RecElemFCtx record f) =>
(f r -> g (f r')) -> record f rs -> g (record f rs')
rlensC f r -> Const (f r) (f Any)
forall k a (b :: k). a -> Const a b
Const
{-# INLINE rgetC #-}
rputC :: f r' -> Rec f (r : rs) -> Rec f (r' : rs)
rputC f r'
y = Identity (Rec f (r' : rs)) -> Rec f (r' : rs)
forall a. Identity a -> a
getIdentity (Identity (Rec f (r' : rs)) -> Rec f (r' : rs))
-> (Rec f (r : rs) -> Identity (Rec f (r' : rs)))
-> Rec f (r : rs)
-> Rec f (r' : rs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f r -> Identity (f r'))
-> Rec f (r : rs) -> Identity (Rec f (r' : rs))
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (g :: * -> *) (f :: k -> *).
(RecElem record r r' rs rs' i, Functor g, RecElemFCtx record f) =>
(f r -> g (f r')) -> record f rs -> g (record f rs')
rlensC @_ @_ @r (\f r
_ -> f r' -> Identity (f r')
forall a. a -> Identity a
Identity f r'
y)
{-# INLINE rputC #-}
instance (RIndex r (s ': rs) ~ 'S i, RecElem Rec r r' rs rs' i)
=> RecElem Rec r r' (s ': rs) (s ': rs') ('S i) where
rlensC :: (f r -> g (f r')) -> Rec f (s : rs) -> g (Rec f (s : rs'))
rlensC f r -> g (f r')
f (f r
x :& Rec f rs
xs) = (Rec f rs' -> Rec f (r : rs'))
-> g (Rec f rs') -> g (Rec f (r : rs'))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (f r
x f r -> Rec f rs' -> Rec f (r : rs')
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:&) ((f r -> g (f r')) -> Rec f rs -> g (Rec f rs')
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (g :: * -> *) (f :: k -> *).
(RecElem record r r' rs rs' i, Functor g, RecElemFCtx record f) =>
(f r -> g (f r')) -> record f rs -> g (record f rs')
rlensC f r -> g (f r')
f Rec f rs
xs)
{-# INLINE rlensC #-}
rgetC :: Rec f (s : rs) -> f r
rgetC = Const (f r) (Rec f (s : rs')) -> f r
forall a k (b :: k). Const a b -> a
getConst (Const (f r) (Rec f (s : rs')) -> f r)
-> (Rec f (s : rs) -> Const (f r) (Rec f (s : rs')))
-> Rec f (s : rs)
-> f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f r -> Const (f r) (f r'))
-> Rec f (s : rs) -> Const (f r) (Rec f (s : rs'))
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (g :: * -> *) (f :: k -> *).
(RecElem record r r' rs rs' i, Functor g, RecElemFCtx record f) =>
(f r -> g (f r')) -> record f rs -> g (record f rs')
rlensC @_ @_ @r @r' f r -> Const (f r) (f r')
forall k a (b :: k). a -> Const a b
Const
{-# INLINE rgetC #-}
rputC :: f r' -> Rec f (s : rs) -> Rec f (s : rs')
rputC f r'
y = Identity (Rec f (s : rs')) -> Rec f (s : rs')
forall a. Identity a -> a
getIdentity (Identity (Rec f (s : rs')) -> Rec f (s : rs'))
-> (Rec f (s : rs) -> Identity (Rec f (s : rs')))
-> Rec f (s : rs)
-> Rec f (s : rs')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f r -> Identity (f r'))
-> Rec f (s : rs) -> Identity (Rec f (s : rs'))
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (g :: * -> *) (f :: k -> *).
(RecElem record r r' rs rs' i, Functor g, RecElemFCtx record f) =>
(f r -> g (f r')) -> record f rs -> g (record f rs')
rlensC @_ @_ @r (\f r
_ -> f r' -> Identity (f r')
forall a. a -> Identity a
Identity f r'
y)
{-# INLINE rputC #-}
rget :: forall r rs f record.
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f)
=> record f rs -> f r
rget :: record f rs -> f r
rget = record f rs -> f r
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (f :: k -> *).
(RecElem record r r' rs rs' i, RecElemFCtx record f, r ~ r') =>
record f rs -> f r
rgetC
rput' :: forall k (r :: k) (r' :: k) (rs :: [k]) (rs' :: [k]) record f
. (RecElem record r r' rs rs' (RIndex r rs), RecElemFCtx record f)
=> f r' -> record f rs -> record f rs'
rput' :: f r' -> record f rs -> record f rs'
rput' = forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (f :: k -> *).
(RecElem record r r' rs rs' i, RecElemFCtx record f) =>
f r' -> record f rs -> record f rs'
forall (i :: Nat) (f :: k -> *).
(RecElem record r r' rs rs' i, RecElemFCtx record f) =>
f r' -> record f rs -> record f rs'
rputC @k @record @r @r' @rs @rs'
rput :: forall k (r :: k) rs record f. (RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f)
=> f r -> record f rs -> record f rs
rput :: f r -> record f rs -> record f rs
rput = forall k (r :: k) (r' :: k) (rs :: [k]) (rs' :: [k])
(record :: (k -> *) -> [k] -> *) (f :: k -> *).
(RecElem record r r' rs rs' (RIndex r rs), RecElemFCtx record f) =>
f r' -> record f rs -> record f rs'
forall (f :: k -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
f r -> record f rs -> record f rs
rput' @_ @r @r @rs @rs @record
rlens' :: forall r r' record rs rs' f g.
(RecElem record r r' rs rs' (RIndex r rs), RecElemFCtx record f, Functor g)
=> (f r -> g (f r')) -> record f rs -> g (record f rs')
rlens' :: (f r -> g (f r')) -> record f rs -> g (record f rs')
rlens' = (f r -> g (f r')) -> record f rs -> g (record f rs')
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (g :: * -> *) (f :: k -> *).
(RecElem record r r' rs rs' i, Functor g, RecElemFCtx record f) =>
(f r -> g (f r')) -> record f rs -> g (record f rs')
rlensC
rlens :: forall r record rs f g.
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f, Functor g)
=> (f r -> g (f r)) -> record f rs -> g (record f rs)
rlens :: (f r -> g (f r)) -> record f rs -> g (record f rs)
rlens = (f r -> g (f r)) -> record f rs -> g (record f rs)
forall k (record :: (k -> *) -> [k] -> *) (r :: k) (r' :: k)
(rs :: [k]) (rs' :: [k]) (i :: Nat) (g :: * -> *) (f :: k -> *).
(RecElem record r r' rs rs' i, Functor g, RecElemFCtx record f) =>
(f r -> g (f r')) -> record f rs -> g (record f rs')
rlensC
class is ~ RImage rs ss => RecSubset record rs ss is where
type RecSubsetFCtx record (f :: k -> *) :: Constraint
type RecSubsetFCtx record f = ()
rsubsetC
:: (Functor g, RecSubsetFCtx record f)
=> (record f rs -> g (record f rs))
-> record f ss
-> g (record f ss)
rcastC
:: RecSubsetFCtx record f
=> record f ss
-> record f rs
rcastC = Const (record f rs) (record f ss) -> record f rs
forall a k (b :: k). Const a b -> a
getConst (Const (record f rs) (record f ss) -> record f rs)
-> (record f ss -> Const (record f rs) (record f ss))
-> record f ss
-> record f rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (record f rs -> Const (record f rs) (record f rs))
-> record f ss -> Const (record f rs) (record f ss)
forall k k (record :: (k -> *) -> [k] -> *) (rs :: [k]) (ss :: [k])
(is :: [Nat]) (g :: * -> *) (f :: k -> *).
(RecSubset record rs ss is, Functor g, RecSubsetFCtx record f) =>
(record f rs -> g (record f rs)) -> record f ss -> g (record f ss)
rsubsetC record f rs -> Const (record f rs) (record f rs)
forall k a (b :: k). a -> Const a b
Const
{-# INLINE rcastC #-}
rreplaceC
:: RecSubsetFCtx record f
=> record f rs
-> record f ss
-> record f ss
rreplaceC record f rs
rs = Identity (record f ss) -> record f ss
forall a. Identity a -> a
getIdentity (Identity (record f ss) -> record f ss)
-> (record f ss -> Identity (record f ss))
-> record f ss
-> record f ss
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (record f rs -> Identity (record f rs))
-> record f ss -> Identity (record f ss)
forall k k (record :: (k -> *) -> [k] -> *) (rs :: [k]) (ss :: [k])
(is :: [Nat]) (g :: * -> *) (f :: k -> *).
(RecSubset record rs ss is, Functor g, RecSubsetFCtx record f) =>
(record f rs -> g (record f rs)) -> record f ss -> g (record f ss)
rsubsetC (\record f rs
_ -> record f rs -> Identity (record f rs)
forall a. a -> Identity a
Identity record f rs
rs)
{-# INLINE rreplaceC #-}
rsubset :: forall k rs ss f g record is.
(RecSubset record (rs :: [k]) (ss :: [k]) is,
Functor g, RecSubsetFCtx record f)
=> (record f rs -> g (record f rs)) -> record f ss -> g (record f ss)
rsubset :: (record f rs -> g (record f rs)) -> record f ss -> g (record f ss)
rsubset = (record f rs -> g (record f rs)) -> record f ss -> g (record f ss)
forall k k (record :: (k -> *) -> [k] -> *) (rs :: [k]) (ss :: [k])
(is :: [Nat]) (g :: * -> *) (f :: k -> *).
(RecSubset record rs ss is, Functor g, RecSubsetFCtx record f) =>
(record f rs -> g (record f rs)) -> record f ss -> g (record f ss)
rsubsetC
rcast :: forall rs ss f record is.
(RecSubset record rs ss is, RecSubsetFCtx record f)
=> record f ss -> record f rs
rcast :: record f ss -> record f rs
rcast = record f ss -> record f rs
forall k k (record :: (k -> *) -> [k] -> *) (rs :: [k]) (ss :: [k])
(is :: [Nat]) (f :: k -> *).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f ss -> record f rs
rcastC
rreplace :: forall rs ss f record is.
(RecSubset record rs ss is, RecSubsetFCtx record f)
=> record f rs -> record f ss -> record f ss
rreplace :: record f rs -> record f ss -> record f ss
rreplace = record f rs -> record f ss -> record f ss
forall k k (record :: (k -> *) -> [k] -> *) (rs :: [k]) (ss :: [k])
(is :: [Nat]) (f :: k -> *).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f rs -> record f ss -> record f ss
rreplaceC
rdowncast :: (RecApplicative ss, RMap rs, rs ⊆ ss)
=> Rec f rs -> Rec (Maybe :. f) ss
rdowncast :: Rec f rs -> Rec (Maybe :. f) ss
rdowncast = (Rec (Maybe :. f) rs -> Rec (Maybe :. f) ss -> Rec (Maybe :. f) ss)
-> Rec (Maybe :. f) ss
-> Rec (Maybe :. f) rs
-> Rec (Maybe :. f) ss
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rec (Maybe :. f) rs -> Rec (Maybe :. f) ss -> Rec (Maybe :. f) ss
forall k k (rs :: [k]) (ss :: [k]) (f :: k -> *)
(record :: (k -> *) -> [k] -> *) (is :: [Nat]).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f rs -> record f ss -> record f ss
rreplace ((forall (x :: u). (:.) Maybe f x) -> Rec (Maybe :. f) ss
forall u (rs :: [u]) (f :: u -> *).
RecApplicative rs =>
(forall (x :: u). f x) -> Rec f rs
rpure (Maybe (f x) -> Compose Maybe f x
forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose Maybe (f x)
forall a. Maybe a
Nothing)) (Rec (Maybe :. f) rs -> Rec (Maybe :. f) ss)
-> (Rec f rs -> Rec (Maybe :. f) rs)
-> Rec f rs
-> Rec (Maybe :. f) ss
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (x :: u). f x -> (:.) Maybe f x)
-> Rec f rs -> Rec (Maybe :. f) rs
forall u (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
rmap (Maybe (f x) -> Compose Maybe f x
forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose (Maybe (f x) -> Compose Maybe f x)
-> (f x -> Maybe (f x)) -> f x -> Compose Maybe f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> Maybe (f x)
forall a. a -> Maybe a
Just)
type RSubset = RecSubset Rec
instance RecSubset Rec '[] ss '[] where
rsubsetC :: (Rec f '[] -> g (Rec f '[])) -> Rec f ss -> g (Rec f ss)
rsubsetC = (Rec f ss -> Rec f '[])
-> (Rec f ss -> Rec f '[] -> Rec f ss)
-> (Rec f '[] -> g (Rec f '[]))
-> Rec f ss
-> g (Rec f ss)
forall (f :: * -> *) s a b t.
Functor f =>
(s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t
lens (Rec f '[] -> Rec f ss -> Rec f '[]
forall a b. a -> b -> a
const Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil) Rec f ss -> Rec f '[] -> Rec f ss
forall a b. a -> b -> a
const
instance (RElem r ss i , RSubset rs ss is) => RecSubset Rec (r ': rs) ss (i ': is) where
rsubsetC :: (Rec f (r : rs) -> g (Rec f (r : rs))) -> Rec f ss -> g (Rec f ss)
rsubsetC = (Rec f ss -> Rec f (r : rs))
-> (Rec f ss -> Rec f (r : rs) -> Rec f ss)
-> (Rec f (r : rs) -> g (Rec f (r : rs)))
-> Rec f ss
-> g (Rec f ss)
forall (f :: * -> *) s a b t.
Functor f =>
(s -> a) -> (s -> b -> t) -> (a -> f b) -> s -> f t
lens (\Rec f ss
ss -> Rec f ss -> f r
forall k (r :: k) (rs :: [k]) (f :: k -> *)
(record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget Rec f ss
ss f r -> Rec f rs -> Rec f (r : rs)
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f ss -> Rec f rs
forall k k (record :: (k -> *) -> [k] -> *) (rs :: [k]) (ss :: [k])
(is :: [Nat]) (f :: k -> *).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f ss -> record f rs
rcastC Rec f ss
ss) Rec f ss -> Rec f (r : rs) -> Rec f ss
forall (f :: k -> *). Rec f ss -> Rec f (r : rs) -> Rec f ss
set
where
set :: Rec f ss -> Rec f (r ': rs) -> Rec f ss
set :: Rec f ss -> Rec f (r : rs) -> Rec f ss
set Rec f ss
ss (f r
r :& Rec f rs
rs) = f r -> Rec f ss -> Rec f ss
forall k (r :: k) (rs :: [k]) (record :: (k -> *) -> [k] -> *)
(f :: k -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
f r -> record f rs -> record f rs
rput f r
r (Rec f ss -> Rec f ss) -> Rec f ss -> Rec f ss
forall a b. (a -> b) -> a -> b
$ Rec f rs -> Rec f ss -> Rec f ss
forall k k (record :: (k -> *) -> [k] -> *) (rs :: [k]) (ss :: [k])
(is :: [Nat]) (f :: k -> *).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f rs -> record f ss -> record f ss
rreplaceC Rec f rs
rs Rec f ss
ss
type REquivalent rs ss is js = (RSubset rs ss is, RSubset ss rs js)
type r ∈ rs = RElem r rs (RIndex r rs)
type rs ⊆ ss = RSubset rs ss (RImage rs ss)
type rs ≅ ss = REquivalent rs ss (RImage rs ss) (RImage ss rs)
type rs <: ss = rs ⊆ ss
type rs :~: ss = rs ≅ ss