{-# LANGUAGE CPP #-}
module Composite.TH
  ( withProxies
  , withLensesAndProxies
  , withPrismsAndProxies
  , withOpticsAndProxies
  ) where

import Composite.CoRecord (Field, fieldValPrism)
import Composite.Record ((:->), Record, rlens)
import Control.Lens (Prism', _1, _head, each, over, toListOf)
import Data.Char (toLower)
import Data.List (foldl')
import Data.Maybe (catMaybes)
import Data.Proxy (Proxy(Proxy))
import Data.Vinyl (RecApplicative)
import Data.Vinyl.Lens (type (∈))
import Language.Haskell.TH
  ( Q, newName, mkName, nameBase
  , Body(NormalB), cxt, Dec(PragmaD, SigD, ValD), Exp(VarE), Inline(Inlinable), Name, Pat(VarP), Phases(AllPhases), Pragma(InlineP), RuleMatch(FunLike)
  , Type(AppT, ConT, ForallT, VarT), TyVarBndr(PlainTV, KindedTV), varT
#if MIN_VERSION_template_haskell(2,17,0)
  , Specificity(SpecifiedSpec)
#endif
  )
import Language.Haskell.TH.Lens (_TySynD)

-- |Make 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The proxies have the same names as the synonyms but with
-- the first letter lowercased.
--
-- For example:
--
-- @
--   withProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   fFoo :: Proxy FFoo
--   fFoo = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
withProxies :: Q [Dec] -> Q [Dec]
withProxies :: Q [Dec] -> Q [Dec]
withProxies Q [Dec]
qDecs = do
  [Dec]
decs <- Q [Dec]
qDecs
  [[Dec]]
proxyDecs <- (Name -> Q [Dec]) -> [Name] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> Q [Dec]
proxyDecForName (Getting (Endo [Name]) [Dec] Name -> [Dec] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf ((Dec -> Const (Endo [Name]) Dec)
-> [Dec] -> Const (Endo [Name]) [Dec]
forall s t a b. Each s t a b => Traversal s t a b
each ((Dec -> Const (Endo [Name]) Dec)
 -> [Dec] -> Const (Endo [Name]) [Dec])
-> ((Name -> Const (Endo [Name]) Name)
    -> Dec -> Const (Endo [Name]) Dec)
-> Getting (Endo [Name]) [Dec] Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [TyVarBndrUnit], Type)
 -> Const (Endo [Name]) (Name, [TyVarBndrUnit], Type))
-> Dec -> Const (Endo [Name]) Dec
Prism' Dec (Name, [TyVarBndrUnit], Type)
_TySynD (((Name, [TyVarBndrUnit], Type)
  -> Const (Endo [Name]) (Name, [TyVarBndrUnit], Type))
 -> Dec -> Const (Endo [Name]) Dec)
-> ((Name -> Const (Endo [Name]) Name)
    -> (Name, [TyVarBndrUnit], Type)
    -> Const (Endo [Name]) (Name, [TyVarBndrUnit], Type))
-> (Name -> Const (Endo [Name]) Name)
-> Dec
-> Const (Endo [Name]) Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Const (Endo [Name]) Name)
-> (Name, [TyVarBndrUnit], Type)
-> Const (Endo [Name]) (Name, [TyVarBndrUnit], Type)
forall s t a b. Field1 s t a b => Lens s t a b
_1) [Dec]
decs)
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
decs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
proxyDecs
  where
    proxyDecForName :: Name -> Q [Dec]
proxyDecForName Name
tySynName = do
      let tySynType :: Q Type
tySynType = Type -> Q Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Q Type) -> Type -> Q Type
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
tySynName
          proxyName :: Name
proxyName = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ Name
tySynName
      Type
proxyType <- [t|Proxy $tySynType|]
      Exp
proxyVal <- [|Proxy|]
      [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
proxyName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
        , Name -> Type -> Dec
SigD Name
proxyName Type
proxyType
        , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
proxyName) (Exp -> Body
NormalB Exp
proxyVal) []
        ]

-- |Make 'rlens' and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The lenses have the same names as the synonyms
-- but with the first letter lowercased. The proxies have that name but with @_@ suffix.
--
-- For example:
--
-- @
--   withLensesAndProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   fFoo :: FFoo ∈ rs => Lens' (Record rs) Int
--   fFoo = rlens fFoo_
--   fFoo_ :: Proxy FFoo
--   fFoo_ = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
--
-- This is equivalent to 'withOpticsAndProxies' but without the prisms.
withLensesAndProxies :: Q [Dec] -> Q [Dec]
withLensesAndProxies :: Q [Dec] -> Q [Dec]
withLensesAndProxies = Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
True Bool
False

-- |Make 'fieldValPrism' and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations. The prisms have the same names as the
-- synonyms but prefixed with @_@. The proxies will have the same name as the synonym but with the first character lowercased and @_@ appended.
--
-- For example:
--
-- @
--   withPrismsAndProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int
--   _FFoo = fieldValPrism fFoo_
--   fFoo_ :: Proxy FFoo
--   fFoo_ = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
--
-- This is equivalent to 'withOpticsAndProxies' but without the prisms.
withPrismsAndProxies :: Q [Dec] -> Q [Dec]
withPrismsAndProxies :: Q [Dec] -> Q [Dec]
withPrismsAndProxies = Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
False Bool
True

-- |Make 'rlens', 'fieldValPrism', and 'Proxy' definitions for each of the @type@ synonyms in the given block of declarations.
-- The lenses have the same names as the synonyms but with the first letter lowercased, e.g. @FFoo@ becomes @fFoo@.
-- The prisms have the same names as the synonyms but with @_@ prepended, e.g. @FFoo@ becomes @_FFoo@.
-- The proxies have the same names as the synonyms but with the first letter lowercase and trailing @_@, e.g. @FFoo@ becomes @fFoo_@.
--
-- For example:
--
-- @
--   withOpticsAndProxies [d|
--     type FFoo = "foo" :-> Int
--     |]
-- @
--
-- Is equivalent to:
--
-- @
--   type FFoo = "foo" :-> Int
--   fFoo :: FFoo ∈ rs => Lens' (Record rs) Int
--   fFoo = rlens fFoo_
--   _FFoo :: FFoo ∈ rs => Prism' (Field rs) Int
--   _FFoo = fieldValPrism fFoo_
--   fFoo_ :: Proxy FFoo
--   fFoo_ = Proxy
-- @
--
-- __Note:__ the trailing @|]@ of the quasi quote bracket has to be indented or a parse error will occur.
withOpticsAndProxies :: Q [Dec] -> Q [Dec]
withOpticsAndProxies :: Q [Dec] -> Q [Dec]
withOpticsAndProxies = Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
True Bool
True

#if MIN_VERSION_template_haskell(2,17,0)
tyUnitToSpec :: Specificity -> TyVarBndr () -> TyVarBndr Specificity
tyUnitToSpec x (PlainTV n ()) = PlainTV n x
tyUnitToSpec x (KindedTV n () k) = KindedTV n x k

fieldDecUnitToSpec :: Specificity -> FieldDec () -> FieldDec Specificity
fieldDecUnitToSpec x (FieldDec n b t v) = FieldDec n (map (tyUnitToSpec x) b) t v

data FieldDec a = FieldDec
#else
data FieldDec = FieldDec
#endif
  { FieldDec -> Name
fieldName        :: Name
#if MIN_VERSION_template_haskell(2,17,0)
  , fieldBinders     :: [TyVarBndr a]
#else
  , FieldDec -> [TyVarBndrUnit]
fieldBinders     :: [TyVarBndr]
#endif
  , FieldDec -> Type
fieldTypeApplied :: Type
  , FieldDec -> Type
fieldValueType   :: Type
  }

-- |TH splice which implements 'withLensesAndProxies', 'withPrismsAndProxies', and 'withOpticsAndProxies'
withBoilerplate :: Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate :: Bool -> Bool -> Q [Dec] -> Q [Dec]
withBoilerplate Bool
generateLenses Bool
generatePrisms Q [Dec]
qDecs = do
  [Dec]
decs <- Q [Dec]
qDecs

  let fieldDecs :: [FieldDec]
fieldDecs = [Maybe FieldDec] -> [FieldDec]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FieldDec] -> [FieldDec])
-> ([Dec] -> [Maybe FieldDec]) -> [Dec] -> [FieldDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [TyVarBndrUnit], Type) -> Maybe FieldDec)
-> [(Name, [TyVarBndrUnit], Type)] -> [Maybe FieldDec]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [TyVarBndrUnit], Type) -> Maybe FieldDec
fieldDecMay ([(Name, [TyVarBndrUnit], Type)] -> [Maybe FieldDec])
-> ([Dec] -> [(Name, [TyVarBndrUnit], Type)])
-> [Dec]
-> [Maybe FieldDec]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Endo [(Name, [TyVarBndrUnit], Type)])
  [Dec]
  (Name, [TyVarBndrUnit], Type)
-> [Dec] -> [(Name, [TyVarBndrUnit], Type)]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf ((Dec -> Const (Endo [(Name, [TyVarBndrUnit], Type)]) Dec)
-> [Dec] -> Const (Endo [(Name, [TyVarBndrUnit], Type)]) [Dec]
forall s t a b. Each s t a b => Traversal s t a b
each ((Dec -> Const (Endo [(Name, [TyVarBndrUnit], Type)]) Dec)
 -> [Dec] -> Const (Endo [(Name, [TyVarBndrUnit], Type)]) [Dec])
-> (((Name, [TyVarBndrUnit], Type)
     -> Const
          (Endo [(Name, [TyVarBndrUnit], Type)])
          (Name, [TyVarBndrUnit], Type))
    -> Dec -> Const (Endo [(Name, [TyVarBndrUnit], Type)]) Dec)
-> Getting
     (Endo [(Name, [TyVarBndrUnit], Type)])
     [Dec]
     (Name, [TyVarBndrUnit], Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, [TyVarBndrUnit], Type)
 -> Const
      (Endo [(Name, [TyVarBndrUnit], Type)])
      (Name, [TyVarBndrUnit], Type))
-> Dec -> Const (Endo [(Name, [TyVarBndrUnit], Type)]) Dec
Prism' Dec (Name, [TyVarBndrUnit], Type)
_TySynD) ([Dec] -> [FieldDec]) -> [Dec] -> [FieldDec]
forall a b. (a -> b) -> a -> b
$ [Dec]
decs
#if MIN_VERSION_template_haskell(2,17,0)
  let sFieldDecs = map (fieldDecUnitToSpec SpecifiedSpec) fieldDecs
#endif
  [[Dec]]
proxyDecs <- (FieldDec -> Q [Dec]) -> [FieldDec] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDec -> Q [Dec]
proxyDecFor [FieldDec]
fieldDecs
#if MIN_VERSION_template_haskell(2,17,0)
  lensDecs  <- if generateLenses then traverse lensDecFor sFieldDecs else pure []
  prismDecs <- if generatePrisms then traverse prismDecFor sFieldDecs else pure []
#else 
  [[Dec]]
lensDecs  <- if Bool
generateLenses then (FieldDec -> Q [Dec]) -> [FieldDec] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDec -> Q [Dec]
lensDecFor [FieldDec]
fieldDecs else [[Dec]] -> Q [[Dec]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  [[Dec]]
prismDecs <- if Bool
generatePrisms then (FieldDec -> Q [Dec]) -> [FieldDec] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FieldDec -> Q [Dec]
prismDecFor [FieldDec]
fieldDecs else [[Dec]] -> Q [[Dec]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
#endif
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
decs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
proxyDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
lensDecs [Dec] -> [Dec] -> [Dec]
forall a. Semigroup a => a -> a -> a
<> [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
prismDecs

#if MIN_VERSION_template_haskell(2,17,0)
fieldDecMay :: (Name, [TyVarBndr ()], Type) -> Maybe (FieldDec ())
#else
fieldDecMay :: (Name, [TyVarBndr], Type) -> Maybe FieldDec
#endif
fieldDecMay :: (Name, [TyVarBndrUnit], Type) -> Maybe FieldDec
fieldDecMay (Name
fieldName, [TyVarBndrUnit]
fieldBinders, Type
ty) = case Type
ty of
  AppT (AppT (ConT Name
n) Type
_) Type
fieldValueType | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== ''(:->) ->
    let fieldTypeApplied :: Type
fieldTypeApplied         = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Type -> Type -> Type
AppT (Name -> Type
ConT Name
fieldName) ((TyVarBndrUnit -> Type) -> [TyVarBndrUnit] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndrUnit -> Type
binderTy [TyVarBndrUnit]
fieldBinders)
#if MIN_VERSION_template_haskell(2,17,0)
        binderTy (PlainTV n' _ )    = VarT n'
        binderTy (KindedTV n' _ _) = VarT n'
#else
        binderTy :: TyVarBndrUnit -> Type
binderTy (PlainTV Name
n' )    = Name -> Type
VarT Name
n'
        binderTy (KindedTV Name
n' Type
_) = Name -> Type
VarT Name
n'
#endif
    in FieldDec -> Maybe FieldDec
forall a. a -> Maybe a
Just (FieldDec -> Maybe FieldDec) -> FieldDec -> Maybe FieldDec
forall a b. (a -> b) -> a -> b
$ FieldDec :: Name -> [TyVarBndrUnit] -> Type -> Type -> FieldDec
FieldDec {[TyVarBndrUnit]
Type
Name
fieldTypeApplied :: Type
fieldValueType :: Type
fieldBinders :: [TyVarBndrUnit]
fieldName :: Name
fieldValueType :: Type
fieldTypeApplied :: Type
fieldBinders :: [TyVarBndrUnit]
fieldName :: Name
..}
  Type
_ ->
    Maybe FieldDec
forall a. Maybe a
Nothing

lensNameFor, prismNameFor, proxyNameFor :: Name -> Name
lensNameFor :: Name -> Name
lensNameFor  = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
prismNameFor :: Name -> Name
prismNameFor = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase
proxyNameFor :: Name -> Name
proxyNameFor = String -> Name
mkName (String -> Name) -> (Name -> String) -> Name -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_") (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower (String -> String) -> (Name -> String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase

#if MIN_VERSION_template_haskell(2,17,0)
proxyDecFor :: FieldDec () -> Q [Dec]
#else
proxyDecFor :: FieldDec -> Q [Dec]
#endif
proxyDecFor :: FieldDec -> Q [Dec]
proxyDecFor (FieldDec { Name
fieldName :: Name
fieldName :: FieldDec -> Name
fieldName, Type
fieldTypeApplied :: Type
fieldTypeApplied :: FieldDec -> Type
fieldTypeApplied }) = do
  let proxyName :: Name
proxyName = Name -> Name
proxyNameFor Name
fieldName

  Type
proxyType <- [t|Proxy $(pure fieldTypeApplied)|]
  Exp
proxyVal <- [|Proxy|]
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
proxyName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
    , Name -> Type -> Dec
SigD Name
proxyName Type
proxyType
    , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
proxyName) (Exp -> Body
NormalB Exp
proxyVal) []
    ]

#if MIN_VERSION_template_haskell(2,17,0)
lensDecFor :: FieldDec Specificity -> Q [Dec]
#else
lensDecFor :: FieldDec -> Q [Dec]
#endif
lensDecFor :: FieldDec -> Q [Dec]
lensDecFor (FieldDec {[TyVarBndrUnit]
Type
Name
fieldValueType :: Type
fieldTypeApplied :: Type
fieldBinders :: [TyVarBndrUnit]
fieldName :: Name
fieldValueType :: FieldDec -> Type
fieldTypeApplied :: FieldDec -> Type
fieldBinders :: FieldDec -> [TyVarBndrUnit]
fieldName :: FieldDec -> Name
..}) = do
  Name
f  <- String -> Q Name
newName String
"f"
  Name
rs <- String -> Q Name
newName String
"rs"

  let fTy :: Q Type
fTy                     = Name -> Q Type
varT Name
f
      rsTy :: Q Type
rsTy                    = Name -> Q Type
varT Name
rs
      proxyName :: Name
proxyName               = Name -> Name
proxyNameFor Name
fieldName
      lensName :: Name
lensName                = Name -> Name
lensNameFor Name
fieldName
      proxyVal :: Exp
proxyVal                = Name -> Exp
VarE Name
proxyName
#if MIN_VERSION_template_haskell(2,17,0)
      lensBinders             = fieldBinders ++ [PlainTV f SpecifiedSpec, PlainTV rs SpecifiedSpec]
#else
      lensBinders :: [TyVarBndrUnit]
lensBinders             = [TyVarBndrUnit]
fieldBinders [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndrUnit
PlainTV Name
f, Name -> TyVarBndrUnit
PlainTV Name
rs]
#endif

  [Type]
lensContext <- [Q Type] -> CxtQ
cxt [ [t| Functor $fTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ]
  Type
lensType    <- [t| ($(pure fieldValueType) -> $fTy $(pure fieldValueType)) -> (Record $rsTy -> $fTy (Record $rsTy)) |]
  Exp
rlensVal    <- [| rlens $(pure proxyVal) |]

  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
lensName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
    , Name -> Type -> Dec
SigD Name
lensName ([TyVarBndrUnit] -> [Type] -> Type -> Type
ForallT [TyVarBndrUnit]
lensBinders [Type]
lensContext Type
lensType)
    , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
lensName) (Exp -> Body
NormalB Exp
rlensVal) []
    ]

#if MIN_VERSION_template_haskell(2,17,0)
prismDecFor :: FieldDec Specificity -> Q [Dec]
#else
prismDecFor :: FieldDec -> Q [Dec]
#endif
prismDecFor :: FieldDec -> Q [Dec]
prismDecFor (FieldDec {[TyVarBndrUnit]
Type
Name
fieldValueType :: Type
fieldTypeApplied :: Type
fieldBinders :: [TyVarBndrUnit]
fieldName :: Name
fieldValueType :: FieldDec -> Type
fieldTypeApplied :: FieldDec -> Type
fieldBinders :: FieldDec -> [TyVarBndrUnit]
fieldName :: FieldDec -> Name
..}) = do
  Name
rs <- String -> Q Name
newName String
"rs"

  let rsTy :: Q Type
rsTy                    = Name -> Q Type
varT Name
rs
      proxyName :: Name
proxyName               = Name -> Name
proxyNameFor Name
fieldName
      prismName :: Name
prismName               = Name -> Name
prismNameFor Name
fieldName
      proxyVal :: Exp
proxyVal                = Name -> Exp
VarE Name
proxyName
#if MIN_VERSION_template_haskell(2,17,0)
      prismBinders            = fieldBinders ++ [PlainTV rs SpecifiedSpec]
#else
      prismBinders :: [TyVarBndrUnit]
prismBinders            = [TyVarBndrUnit]
fieldBinders [TyVarBndrUnit] -> [TyVarBndrUnit] -> [TyVarBndrUnit]
forall a. [a] -> [a] -> [a]
++ [Name -> TyVarBndrUnit
PlainTV Name
rs]
#endif

  [Type]
prismContext  <- [Q Type] -> CxtQ
cxt [ [t| RecApplicative $rsTy |], [t| $(pure fieldTypeApplied) ∈ $rsTy |] ]
  Type
prismType     <- [t| Prism' (Field $rsTy) $(pure fieldValueType) |]
  Exp
fieldPrismVal <- [| fieldValPrism $(pure proxyVal) |]

  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP Name
prismName Inline
Inlinable RuleMatch
FunLike Phases
AllPhases)
    , Name -> Type -> Dec
SigD Name
prismName ([TyVarBndrUnit] -> [Type] -> Type -> Type
ForallT [TyVarBndrUnit]
prismBinders [Type]
prismContext Type
prismType)
    , Pat -> Body -> [Dec] -> Dec
ValD (Name -> Pat
VarP Name
prismName) (Exp -> Body
NormalB Exp
fieldPrismVal) []
    ]