{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Composite.Lens.Extra
( pattern (:!:),
rlens'',
rlensS,
rlensS',
rlensS'',
)
where
import Composite.Record
import qualified Control.Lens as L
import Data.Functor.Contravariant
import qualified Data.Vinyl as Vinyl
import Data.Vinyl.TypeLevel
-- | Bidirectional pattern matching the first field of a record using ':->' values and any contavariant functor.
--
-- This pattern is bidirectional meaning you can use it either as a pattern or a constructor, e.g.
--
-- @
-- let rec = Predicate even :!: Predicate (even . length) :!: RNil
-- Predicate foo :!: Predicate bar :!: RNil = rec
-- @
--
-- @since 0.0.1.0
pattern (:!:) :: forall s f rs a. Contravariant f => () => f a -> Rec f rs -> Rec f (s :-> a ': rs)
pattern (:!:) fa rs <-
(contramap Val -> fa) :& rs
where
(:!:) fa rs = contramap getVal fa :& rs
infixr 5 :!:
-- | Lens to a particular field of a record using a contravariant functor.
--
-- For example, given:
--
-- @
-- type FFoo = "foo" :-> Int
-- type FBar = "bar" :-> String
-- fBar_ :: Proxy FBar
-- fBar_ = Proxy
--
-- rec :: 'Rec' 'Predicate' '[FFoo, FBar]
-- rec = Predicate even :!: Predicate (even . length) :!: Nil
-- @
--
-- Then:
--
-- @
-- view (rlens'' fBar_) rec == Predicate even
-- set (rlens'' fBar_) Predicate (odd . length) rec == Predicate even :!: Predicate (odd . length) :!: Nil
-- over (rlens'' fBar_) (contramap show) rec == Predicate even :!: Predicate (odd . length . show) :!: Nil
-- @
--
-- @since 0.0.1.0
rlens'' :: (Contravariant f, Functor g, RElem (s :-> a) rs) => proxy (s :-> a) -> (f a -> g (f a)) -> Rec f rs -> g (Rec f rs)
rlens'' proxy f =
Vinyl.rlens $ \(contramap (reifyVal proxy . Val) -> fa) ->
contramap getVal <$> f fa
{-# INLINE rlens'' #-}
-- | Type changing lens over a `Record` field.
--
-- @since 0.0.1.0
rlensS ::
forall p p' s s' a b g rs rs'.
( (p ~ (s :-> a)),
(p' ~ (s' :-> b)),
Vinyl.RecElem
Rec
(s :-> a)
(s' :-> b)
rs
rs'
(RIndex (s :-> a) rs),
Functor g
) =>
(a -> g b) ->
Record rs ->
g (Record rs')
rlensS f = Vinyl.rlens' @p @p' $ \(L.Identity (getVal -> a)) -> L.Identity . Val <$> f a
-- | Type changing lens over a `Rec f` (Covariant).
--
-- @since 0.0.1.0
rlensS' ::
forall p p' s s' a b f g rs rs'.
( (p ~ (s :-> a)),
(p' ~ (s' :-> b)),
Vinyl.RecElem
Rec
(s :-> a)
(s' :-> b)
rs
rs'
(Data.Vinyl.TypeLevel.RIndex (s :-> a) rs),
Functor f,
Functor g
) =>
(f a -> g (f b)) ->
Rec f rs ->
g (Rec f rs')
rlensS' f = Vinyl.rlens' @p @p' $ \(fmap getVal -> a) -> fmap Val <$> f a
-- | Type changing lens over a `Rec f` (Contravariant).
--
-- @since 0.0.1.0
rlensS'' ::
forall p p' s s' a b f g rs rs'.
( (p ~ (s :-> a)),
(p' ~ (s' :-> b)),
Vinyl.RecElem
Rec
(s :-> a)
(s' :-> b)
rs
rs'
(Data.Vinyl.TypeLevel.RIndex (s :-> a) rs),
Contravariant f,
Functor g
) =>
(f a -> g (f b)) ->
Rec f rs ->
g (Rec f rs')
rlensS'' f = Vinyl.rlens' @p @p' $ \(contramap Val -> a) -> contramap getVal <$> f a