{-# LANGUAGE CPP #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif

#include "lens-common.h"

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Internal.PrismTH
-- Copyright   :  (C) 2014-2016 Edward Kmett and Eric Mertens
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
-----------------------------------------------------------------------------

module Control.Lens.Internal.PrismTH
  ( makePrisms
  , makeClassyPrisms
  , makeDecPrisms
  ) where

import Control.Applicative
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Internal.TH
import Control.Lens.Lens
import Control.Lens.Setter
import Control.Monad
import Data.Char (isUpper)
import Data.List
import Data.Set.Lens
import Data.Traversable
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import Language.Haskell.TH.Lens
import qualified Data.Map as Map
import qualified Data.Set as Set
import Prelude

-- | Generate a 'Prism' for each constructor of a data type.
-- Isos generated when possible.
-- Reviews are created for constructors with existentially
-- quantified constructors and GADTs.
--
-- /e.g./
--
-- @
-- data FooBarBaz a
--   = Foo Int
--   | Bar a
--   | Baz Int Char
-- makePrisms ''FooBarBaz
-- @
--
-- will create
--
-- @
-- _Foo :: Prism' (FooBarBaz a) Int
-- _Bar :: Prism (FooBarBaz a) (FooBarBaz b) a b
-- _Baz :: Prism' (FooBarBaz a) (Int, Char)
-- @
makePrisms :: Name {- ^ Type constructor name -} -> DecsQ
makePrisms :: Name -> DecsQ
makePrisms = Bool -> Name -> DecsQ
makePrisms' Bool
True


-- | Generate a 'Prism' for each constructor of a data type
-- and combine them into a single class. No Isos are created.
-- Reviews are created for constructors with existentially
-- quantified constructors and GADTs.
--
-- /e.g./
--
-- @
-- data FooBarBaz a
--   = Foo Int
--   | Bar a
--   | Baz Int Char
-- makeClassyPrisms ''FooBarBaz
-- @
--
-- will create
--
-- @
-- class AsFooBarBaz s a | s -> a where
--   _FooBarBaz :: Prism' s (FooBarBaz a)
--   _Foo :: Prism' s Int
--   _Bar :: Prism' s a
--   _Baz :: Prism' s (Int,Char)
--
--   _Foo = _FooBarBaz . _Foo
--   _Bar = _FooBarBaz . _Bar
--   _Baz = _FooBarBaz . _Baz
--
-- instance AsFooBarBaz (FooBarBaz a) a
-- @
--
-- Generate an "As" class of prisms. Names are selected by prefixing the constructor
-- name with an underscore.  Constructors with multiple fields will
-- construct Prisms to tuples of those fields.
--
-- In the event that the name of a data type is also the name of one of its
-- constructors, the name of the 'Prism' generated for the data type will be
-- prefixed with an extra @_@ (if the data type name is prefix) or @.@ (if the
-- name is infix) to disambiguate it from the 'Prism' for the corresponding
-- constructor. For example, this code:
--
-- @
-- data Quux = Quux Int | Fred Bool
-- makeClassyPrisms ''Quux
-- @
--
-- will create:
--
-- @
-- class AsQuux s where
--   __Quux :: Prism' s Quux -- Data type prism
--   _Quux :: Prism' s Int   -- Constructor prism
--   _Fred :: Prism' s Bool
--
--   _Quux = __Quux . _Quux
--   _Fred = __Quux . _Fred
--
-- instance AsQuux Quux
-- @
makeClassyPrisms :: Name {- ^ Type constructor name -} -> DecsQ
makeClassyPrisms :: Name -> DecsQ
makeClassyPrisms = Bool -> Name -> DecsQ
makePrisms' Bool
False


-- | Main entry point into Prism generation for a given type constructor name.
makePrisms' :: Bool -> Name -> DecsQ
makePrisms' :: Bool -> Name -> DecsQ
makePrisms' Bool
normal Name
typeName =
  do DatatypeInfo
info <- Name -> Q DatatypeInfo
D.reifyDatatype Name
typeName
     let cls :: Maybe Name
cls | Bool
normal    = Maybe Name
forall a. Maybe a
Nothing
             | Bool
otherwise = Name -> Maybe Name
forall a. a -> Maybe a
Just (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)
         cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
     Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms (DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info) ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> NCon
normalizeCon [ConstructorInfo]
cons) Maybe Name
cls


-- | Generate prisms for the given 'Dec'
makeDecPrisms :: Bool {- ^ generate top-level definitions -} -> Dec -> DecsQ
makeDecPrisms :: Bool -> Dec -> DecsQ
makeDecPrisms Bool
normal Dec
dec =
  do DatatypeInfo
info <- Dec -> Q DatatypeInfo
D.normalizeDec Dec
dec
     let cls :: Maybe Name
cls | Bool
normal    = Maybe Name
forall a. Maybe a
Nothing
             | Bool
otherwise = Name -> Maybe Name
forall a. a -> Maybe a
Just (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
info)
         cons :: [ConstructorInfo]
cons = DatatypeInfo -> [ConstructorInfo]
D.datatypeCons DatatypeInfo
info
     Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms (DatatypeInfo -> Type
D.datatypeType DatatypeInfo
info) ((ConstructorInfo -> NCon) -> [ConstructorInfo] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map ConstructorInfo -> NCon
normalizeCon [ConstructorInfo]
cons) Maybe Name
cls


-- | Generate prisms for the given type, normalized constructors, and
-- an optional name to be used for generating a prism class.
-- This function dispatches between Iso generation, normal top-level
-- prisms, and classy prisms.
makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ

-- special case: single constructor, not classy -> make iso
makeConsPrisms :: Type -> [NCon] -> Maybe Name -> DecsQ
makeConsPrisms Type
t [con :: NCon
con@(NCon Name
_ [] [] [Type]
_)] Maybe Name
Nothing = Type -> NCon -> DecsQ
makeConIso Type
t NCon
con

-- top-level definitions
makeConsPrisms Type
t [NCon]
cons Maybe Name
Nothing =
  ([[Dec]] -> [Dec]) -> Q [[Dec]] -> DecsQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> DecsQ) -> Q [[Dec]] -> DecsQ
forall a b. (a -> b) -> a -> b
$ [NCon] -> (NCon -> DecsQ) -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [NCon]
cons ((NCon -> DecsQ) -> Q [[Dec]]) -> (NCon -> DecsQ) -> Q [[Dec]]
forall a b. (a -> b) -> a -> b
$ \NCon
con ->
    do let conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
       Stab
stab <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con
       let n :: Name
n = Name -> Name
prismName Name
conName
       [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
         ( [ Name -> TypeQ -> Q Dec
sigD Name
n (Type -> TypeQ
close (Stab -> Type
stabToType Stab
stab))
           , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
n) (ExpQ -> BodyQ
normalB (Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab [NCon]
cons NCon
con)) []
           ]
           [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ Name -> [Q Dec]
inlinePragma Name
n
         )


-- classy prism class and instance
makeConsPrisms Type
t [NCon]
cons (Just Name
typeName) =
  [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
    [ Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismClass Type
t Name
className Name
methodName [NCon]
cons
    , Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismInstance Type
t Name
className Name
methodName [NCon]
cons
    ]
  where
  typeNameBase :: String
typeNameBase = Name -> String
nameBase Name
typeName
  className :: Name
className = String -> Name
mkName (String
"As" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeNameBase)
  sameNameAsCon :: Bool
sameNameAsCon = (NCon -> Bool) -> [NCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\NCon
con -> Name -> String
nameBase (Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
typeNameBase) [NCon]
cons
  methodName :: Name
methodName = Bool -> Name -> Name
prismName' Bool
sameNameAsCon Name
typeName


data OpticType = PrismType | ReviewType
data Stab  = Stab Cxt OpticType Type Type Type Type

simplifyStab :: Stab -> Stab
simplifyStab :: Stab -> Stab
simplifyStab (Stab [Type]
cx OpticType
ty Type
_ Type
t Type
_ Type
b) = [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
ty Type
t Type
t Type
b Type
b
  -- simplification uses t and b because those types
  -- are interesting in the Review case

stabSimple :: Stab -> Bool
stabSimple :: Stab -> Bool
stabSimple (Stab [Type]
_ OpticType
_ Type
s Type
t Type
a Type
b) = Type
s Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t Bool -> Bool -> Bool
&& Type
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b

stabToType :: Stab -> Type
stabToType :: Stab -> Type
stabToType stab :: Stab
stab@(Stab [Type]
cx OpticType
ty Type
s Type
t Type
a Type
b) = [TyVarBndr] -> [Type] -> Type -> Type
ForallT [TyVarBndr]
vs [Type]
cx (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
  case OpticType
ty of
    OpticType
PrismType  | Stab -> Bool
stabSimple Stab
stab -> Name
prism'TypeName  Name -> [Type] -> Type
`conAppsT` [Type
t,Type
b]
               | Bool
otherwise       -> Name
prismTypeName   Name -> [Type] -> Type
`conAppsT` [Type
s,Type
t,Type
a,Type
b]
    OpticType
ReviewType                   -> Name
reviewTypeName  Name -> [Type] -> Type
`conAppsT` [Type
t,Type
b]

  where
  vs :: [TyVarBndr]
vs = (Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV
     ([Name] -> [TyVarBndr]) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub -- stable order
     ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Getting (Endo [Name]) [Type] Name -> [Type] -> [Name]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [Name]) [Type] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [Type]
cx

stabType :: Stab -> OpticType
stabType :: Stab -> OpticType
stabType (Stab [Type]
_ OpticType
o Type
_ Type
_ Type
_ Type
_) = OpticType
o

computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
computeOpticType :: Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con =
  do let cons' :: [NCon]
cons' = NCon -> [NCon] -> [NCon]
forall a. Eq a => a -> [a] -> [a]
delete NCon
con [NCon]
cons
     if [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (NCon -> [Name]
_nconVars NCon
con)
         then Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType Type
t (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconCxt NCon
con) [NCon]
cons' NCon
con
         else Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
t (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconCxt NCon
con) (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)


computeReviewType :: Type -> Cxt -> [Type] -> Q Stab
computeReviewType :: Type -> [Type] -> [Type] -> Q Stab
computeReviewType Type
s' [Type]
cx [Type]
tys =
  do let t :: Type
t = Type
s'
     Type
s <- (Name -> Type) -> Q Name -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT (String -> Q Name
newName String
"s")
     Type
a <- (Name -> Type) -> Q Name -> TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Type
VarT (String -> Q Name
newName String
"a")
     Type
b <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
tys)
     Stab -> Q Stab
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
ReviewType Type
s Type
t Type
a Type
b)


-- | Compute the full type-changing Prism type given an outer type,
-- list of constructors, and target constructor name. Additionally
-- return 'True' if the resulting type is a "simple" prism.
computePrismType :: Type -> Cxt -> [NCon] -> NCon -> Q Stab
computePrismType :: Type -> [Type] -> [NCon] -> NCon -> Q Stab
computePrismType Type
t [Type]
cx [NCon]
cons NCon
con =
  do let ts :: [Type]
ts      = Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con
         unbound :: Set Name
unbound = Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Getting (Set Name) [NCon] Name -> [NCon] -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) [NCon] Name
forall t. HasTypeVars t => Traversal' t Name
typeVars [NCon]
cons
     Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k v. (k -> v) -> Set k -> Map k v
fromSet (String -> Q Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) Set Name
unbound)
     Type
b   <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Type]
ts)
     Type
a   <- [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
ts))
     let s :: Type
s = Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Type
t
     Stab -> Q Stab
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
PrismType Type
s Type
t Type
a Type
b)


computeIsoType :: Type -> [Type] -> TypeQ
computeIsoType :: Type -> [Type] -> TypeQ
computeIsoType Type
t' [Type]
fields =
  do Map Name Name
sub <- Map Name (Q Name) -> Q (Map Name Name)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((Name -> Q Name) -> Set Name -> Map Name (Q Name)
forall k v. (k -> v) -> Set k -> Map k v
fromSet (String -> Q Name
newName (String -> Q Name) -> (Name -> String) -> Name -> Q Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase) (Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t'))
     let t :: TypeQ
t = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return                    Type
t'
         s :: TypeQ
s = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> Type -> Type
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub Type
t')
         b :: TypeQ
b = [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return                    [Type]
fields)
         a :: TypeQ
a = [TypeQ] -> TypeQ
toTupleT ((Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Name Name -> [Type] -> [Type]
forall t. HasTypeVars t => Map Name Name -> t -> t
substTypeVars Map Name Name
sub [Type]
fields))

#ifndef HLINT
         ty :: TypeQ
ty | Map Name Name -> Bool
forall k a. Map k a -> Bool
Map.null Map Name Name
sub = TypeQ -> [TypeQ] -> TypeQ
appsT (Name -> TypeQ
conT Name
iso'TypeName) [TypeQ
t,TypeQ
b]
            | Bool
otherwise    = TypeQ -> [TypeQ] -> TypeQ
appsT (Name -> TypeQ
conT Name
isoTypeName) [TypeQ
s,TypeQ
t,TypeQ
a,TypeQ
b]
#endif

     Type -> TypeQ
close (Type -> TypeQ) -> TypeQ -> TypeQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TypeQ
ty



-- | Construct either a Review or Prism as appropriate
makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp :: Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab [NCon]
cons NCon
con =
  case Stab -> OpticType
stabType Stab
stab of
    OpticType
PrismType  -> Stab -> [NCon] -> NCon -> ExpQ
makeConPrismExp Stab
stab [NCon]
cons NCon
con
    OpticType
ReviewType -> NCon -> ExpQ
makeConReviewExp NCon
con


-- | Construct an iso declaration
makeConIso :: Type -> NCon -> DecsQ
makeConIso :: Type -> NCon -> DecsQ
makeConIso Type
s NCon
con =
  do let ty :: TypeQ
ty      = Type -> [Type] -> TypeQ
computeIsoType Type
s (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)
         defName :: Name
defName = Name -> Name
prismName (Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con)
     [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
       ( [ Name -> TypeQ -> Q Dec
sigD       Name
defName  TypeQ
ty
         , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB (NCon -> ExpQ
makeConIsoExp NCon
con)) []
         ] [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++
         Name -> [Q Dec]
inlinePragma Name
defName
       )


-- | Construct prism expression
--
-- prism <<reviewer>> <<remitter>>
makeConPrismExp ::
  Stab ->
  [NCon] {- ^ constructors       -} ->
  NCon   {- ^ target constructor -} ->
  ExpQ
makeConPrismExp :: Stab -> [NCon] -> NCon -> ExpQ
makeConPrismExp Stab
stab [NCon]
cons NCon
con = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
prismValName, ExpQ
reviewer, ExpQ
remitter]
  where
  ts :: [Type]
ts = Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con
  fields :: Int
fields  = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
ts
  conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con

  reviewer :: ExpQ
reviewer                   = Name -> Int -> ExpQ
makeReviewer       Name
conName Int
fields
  remitter :: ExpQ
remitter | Stab -> Bool
stabSimple Stab
stab = Name -> Int -> Int -> ExpQ
makeSimpleRemitter Name
conName ([NCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NCon]
cons) Int
fields
           | Bool
otherwise       = [NCon] -> Name -> ExpQ
makeFullRemitter [NCon]
cons Name
conName


-- | Construct an Iso expression
--
-- iso <<reviewer>> <<remitter>>
makeConIsoExp :: NCon -> ExpQ
makeConIsoExp :: NCon -> ExpQ
makeConIsoExp NCon
con = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
isoValName, ExpQ
remitter, ExpQ
reviewer]
  where
  conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
  fields :: Int
fields  = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)

  reviewer :: ExpQ
reviewer = Name -> Int -> ExpQ
makeReviewer    Name
conName Int
fields
  remitter :: ExpQ
remitter = Name -> Int -> ExpQ
makeIsoRemitter Name
conName Int
fields


-- | Construct a Review expression
--
-- unto (\(x,y,z) -> Con x y z)
makeConReviewExp :: NCon -> ExpQ
makeConReviewExp :: NCon -> ExpQ
makeConReviewExp NCon
con = ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
varE Name
untoValName) ExpQ
reviewer
  where
  conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
  fields :: Int
fields  = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Getting [Type] NCon [Type] -> NCon -> [Type]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [Type] NCon [Type]
Lens' NCon [Type]
nconTypes NCon
con)

  reviewer :: ExpQ
reviewer = Name -> Int -> ExpQ
makeReviewer Name
conName Int
fields


------------------------------------------------------------------------
-- Prism and Iso component builders
------------------------------------------------------------------------


-- | Construct the review portion of a prism.
--
-- (\(x,y,z) -> Con x y z) :: b -> t
makeReviewer :: Name -> Int -> ExpQ
makeReviewer :: Name -> Int -> ExpQ
makeReviewer Name
conName Int
fields =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
     PatQ -> ExpQ -> ExpQ
lam1E ([PatQ] -> PatQ
toTupleP ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
           (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> ExpQ
`appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs)


-- | Construct the remit portion of a prism.
-- Pattern match only target constructor, no type changing
--
-- (\x -> case s of
--          Con x y z -> Right (x,y,z)
--          _         -> Left x
-- ) :: s -> Either s a
makeSimpleRemitter ::
  Name {- The name of the constructor on which this prism focuses -} ->
  Int  {- The number of constructors the parent data type has     -} ->
  Int  {- The number of fields the constructor has                -} ->
  ExpQ
makeSimpleRemitter :: Name -> Int -> Int -> ExpQ
makeSimpleRemitter Name
conName Int
numCons Int
fields =
  do Name
x  <- String -> Q Name
newName String
"x"
     [Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" Int
fields
     let matches :: [MatchQ]
matches =
           [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
                   (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
rightDataName) ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))))
                   []
           ] [MatchQ] -> [MatchQ] -> [MatchQ]
forall a. [a] -> [a] -> [a]
++
           [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
match PatQ
wildP (ExpQ -> BodyQ
normalB (ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
leftDataName) (Name -> ExpQ
varE Name
x))) []
           | Int
numCons Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 -- Only generate a catch-all case if there is at least
                         -- one constructor besides the one being focused on.
           ]
     PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
x) (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [MatchQ]
matches)


-- | Pattern match all constructors to enable type-changing
--
-- (\x -> case s of
--          Con x y z -> Right (x,y,z)
--          Other_n w   -> Left (Other_n w)
-- ) :: s -> Either t a
makeFullRemitter :: [NCon] -> Name -> ExpQ
makeFullRemitter :: [NCon] -> Name -> ExpQ
makeFullRemitter [NCon]
cons Name
target =
  do Name
x <- String -> Q Name
newName String
"x"
     PatQ -> ExpQ -> ExpQ
lam1E (Name -> PatQ
varP Name
x) (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) ((NCon -> MatchQ) -> [NCon] -> [MatchQ]
forall a b. (a -> b) -> [a] -> [b]
map NCon -> MatchQ
mkMatch [NCon]
cons))
  where
  mkMatch :: NCon -> MatchQ
mkMatch (NCon Name
conName [Name]
_ [Type]
_ [Type]
n) =
    do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"y" ([Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
n)
       PatQ -> BodyQ -> [Q Dec] -> MatchQ
match (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
             (ExpQ -> BodyQ
normalB
               (if Name
conName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
target
                  then ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
rightDataName) ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))
                  else ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
leftDataName) (Name -> ExpQ
conE Name
conName ExpQ -> [ExpQ] -> ExpQ
`appsE1` (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs)))
             []


-- | Construct the remitter suitable for use in an 'Iso'
--
-- (\(Con x y z) -> (x,y,z)) :: s -> a
makeIsoRemitter :: Name -> Int -> ExpQ
makeIsoRemitter :: Name -> Int -> ExpQ
makeIsoRemitter Name
conName Int
fields =
  do [Name]
xs <- String -> Int -> Q [Name]
newNames String
"x" Int
fields
     PatQ -> ExpQ -> ExpQ
lam1E (Name -> [PatQ] -> PatQ
conP Name
conName ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
xs))
           ([ExpQ] -> ExpQ
toTupleE ((Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
xs))


------------------------------------------------------------------------
-- Classy prisms
------------------------------------------------------------------------


-- | Construct the classy prisms class for a given type and constructors.
--
-- class ClassName r <<vars in type>> | r -> <<vars in Type>> where
--   topMethodName   :: Prism' r Type
--   conMethodName_n :: Prism' r conTypes_n
--   conMethodName_n = topMethodName . conMethodName_n
makeClassyPrismClass ::
  Type   {- Outer type      -} ->
  Name   {- Class name      -} ->
  Name   {- Top method name -} ->
  [NCon] {- Constructors    -} ->
  DecQ
makeClassyPrismClass :: Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismClass Type
t Name
className Name
methodName [NCon]
cons =
  do Name
r <- String -> Q Name
newName String
"r"
#ifndef HLINT
     let methodType :: TypeQ
methodType = TypeQ -> [TypeQ] -> TypeQ
appsT (Name -> TypeQ
conT Name
prism'TypeName) [Name -> TypeQ
varT Name
r,Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t]
#endif
     [[Dec]]
methodss <- (NCon -> DecsQ) -> [NCon] -> Q [[Dec]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Type -> NCon -> DecsQ
mkMethod (Name -> Type
VarT Name
r)) [NCon]
cons'
     CxtQ -> Name -> [TyVarBndr] -> [FunDep] -> [Q Dec] -> Q Dec
classD ([TypeQ] -> CxtQ
cxt[]) Name
className ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV (Name
r Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
vs)) (Name -> [FunDep]
fds Name
r)
       ( Name -> TypeQ -> Q Dec
sigD Name
methodName TypeQ
methodType
       Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: (Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
methodss)
       )

  where
  mkMethod :: Type -> NCon -> DecsQ
mkMethod Type
r NCon
con =
    do Stab [Type]
cx OpticType
o Type
_ Type
_ Type
_ Type
b <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
t [NCon]
cons NCon
con
       let stab' :: Stab
stab' = [Type] -> OpticType -> Type -> Type -> Type -> Type -> Stab
Stab [Type]
cx OpticType
o Type
r Type
r Type
b Type
b
           defName :: Name
defName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
           body :: ExpQ
body    = [ExpQ] -> ExpQ
appsE [Name -> ExpQ
varE Name
composeValName, Name -> ExpQ
varE Name
methodName, Name -> ExpQ
varE Name
defName]
       [Q Dec] -> DecsQ
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
         [ Name -> TypeQ -> Q Dec
sigD Name
defName        (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Stab -> Type
stabToType Stab
stab'))
         , PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
defName) (ExpQ -> BodyQ
normalB ExpQ
body) []
         ]

  cons' :: [NCon]
cons'         = (NCon -> NCon) -> [NCon] -> [NCon]
forall a b. (a -> b) -> [a] -> [b]
map (ASetter NCon NCon Name Name -> (Name -> Name) -> NCon -> NCon
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter NCon NCon Name Name
Lens' NCon Name
nconName Name -> Name
prismName) [NCon]
cons
  vs :: [Name]
vs            = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t)
  fds :: Name -> [FunDep]
fds Name
r
    | [Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
vs   = []
    | Bool
otherwise = [[Name] -> [Name] -> FunDep
FunDep [Name
r] [Name]
vs]



-- | Construct the classy prisms instance for a given type and constructors.
--
-- instance Classname OuterType where
--   topMethodName = id
--   conMethodName_n = <<prism>>
makeClassyPrismInstance ::
  Type ->
  Name     {- Class name      -} ->
  Name     {- Top method name -} ->
  [NCon] {- Constructors    -} ->
  DecQ
makeClassyPrismInstance :: Type -> Name -> Name -> [NCon] -> Q Dec
makeClassyPrismInstance Type
s Name
className Name
methodName [NCon]
cons =
  do let vs :: [Name]
vs = Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
s)
         cls :: Type
cls = Name
className Name -> [Type] -> Type
`conAppsT` (Type
s Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: (Name -> Type) -> [Name] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Type
VarT [Name]
vs)

     CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt[]) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
cls)
       (   PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP Name
methodName)
                (ExpQ -> BodyQ
normalB (Name -> ExpQ
varE Name
idValName)) []
       Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
: [ do Stab
stab <- Type -> [NCon] -> NCon -> Q Stab
computeOpticType Type
s [NCon]
cons NCon
con
              let stab' :: Stab
stab' = Stab -> Stab
simplifyStab Stab
stab
              PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (Name -> PatQ
varP (Name -> Name
prismName Name
conName))
                (ExpQ -> BodyQ
normalB (Stab -> [NCon] -> NCon -> ExpQ
makeConOpticExp Stab
stab' [NCon]
cons NCon
con)) []
           | NCon
con <- [NCon]
cons
           , let conName :: Name
conName = Getting Name NCon Name -> NCon -> Name
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Name NCon Name
Lens' NCon Name
nconName NCon
con
           ]
       )


------------------------------------------------------------------------
-- Utilities
------------------------------------------------------------------------


-- | Normalized constructor
data NCon = NCon
  { NCon -> Name
_nconName :: Name
  , NCon -> [Name]
_nconVars :: [Name]
  , NCon -> [Type]
_nconCxt  :: Cxt
  , NCon -> [Type]
_nconTypes :: [Type]
  }
  deriving (NCon -> NCon -> Bool
(NCon -> NCon -> Bool) -> (NCon -> NCon -> Bool) -> Eq NCon
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NCon -> NCon -> Bool
$c/= :: NCon -> NCon -> Bool
== :: NCon -> NCon -> Bool
$c== :: NCon -> NCon -> Bool
Eq)

instance HasTypeVars NCon where
  typeVarsEx :: Set Name -> Traversal' NCon Name
typeVarsEx Set Name
s Name -> f Name
f (NCon Name
x [Name]
vars [Type]
y [Type]
z) = Name -> [Name] -> [Type] -> [Type] -> NCon
NCon Name
x [Name]
vars ([Type] -> [Type] -> NCon) -> f [Type] -> f ([Type] -> NCon)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Name -> (Name -> f Name) -> [Type] -> f [Type]
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f [Type]
y f ([Type] -> NCon) -> f [Type] -> f NCon
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Name -> (Name -> f Name) -> [Type] -> f [Type]
forall t. HasTypeVars t => Set Name -> Traversal' t Name
typeVarsEx Set Name
s' Name -> f Name
f [Type]
z
    where s' :: Set Name
s' = (Set Name -> Name -> Set Name) -> Set Name -> [Name] -> Set Name
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Name -> Set Name -> Set Name) -> Set Name -> Name -> Set Name
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> Set Name -> Set Name
forall a. Ord a => a -> Set a -> Set a
Set.insert) Set Name
s [Name]
vars

nconName :: Lens' NCon Name
nconName :: (Name -> f Name) -> NCon -> f NCon
nconName Name -> f Name
f NCon
x = (Name -> NCon) -> f Name -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Name
y -> NCon
x {_nconName :: Name
_nconName = Name
y}) (Name -> f Name
f (NCon -> Name
_nconName NCon
x))

nconCxt :: Lens' NCon Cxt
nconCxt :: ([Type] -> f [Type]) -> NCon -> f NCon
nconCxt [Type] -> f [Type]
f NCon
x = ([Type] -> NCon) -> f [Type] -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Type]
y -> NCon
x {_nconCxt :: [Type]
_nconCxt = [Type]
y}) ([Type] -> f [Type]
f (NCon -> [Type]
_nconCxt NCon
x))

nconTypes :: Lens' NCon [Type]
nconTypes :: ([Type] -> f [Type]) -> NCon -> f NCon
nconTypes [Type] -> f [Type]
f NCon
x = ([Type] -> NCon) -> f [Type] -> f NCon
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Type]
y -> NCon
x {_nconTypes :: [Type]
_nconTypes = [Type]
y}) ([Type] -> f [Type]
f (NCon -> [Type]
_nconTypes NCon
x))


-- | Normalize a single 'Con' to its constructor name and field types.
normalizeCon :: D.ConstructorInfo -> NCon
normalizeCon :: ConstructorInfo -> NCon
normalizeCon ConstructorInfo
info = Name -> [Name] -> [Type] -> [Type] -> NCon
NCon (ConstructorInfo -> Name
D.constructorName ConstructorInfo
info)
                         (TyVarBndr -> Name
D.tvName (TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConstructorInfo -> [TyVarBndr]
D.constructorVars ConstructorInfo
info)
                         (ConstructorInfo -> [Type]
D.constructorContext ConstructorInfo
info)
                         (ConstructorInfo -> [Type]
D.constructorFields ConstructorInfo
info)


-- | Compute a prism's name by prefixing an underscore for normal
-- constructors and period for operators.
prismName :: Name -> Name
prismName :: Name -> Name
prismName = Bool -> Name -> Name
prismName' Bool
False

-- | Compute a prism's name with a special case for when the type
-- constructor matches one of the value constructors.
--
-- The overlapping flag wil be 'True' in the event that:
--
-- 1. We are generating the name of a classy prism for a
--    data type, and
-- 2. The data type shares a name with one of its
--    constructors (e.g., @data A = A@).
--
-- In such a scenario, we take care not to generate the same
-- prism name that the constructor receives (e.g., @_A@).
-- For prefix names, we accomplish this by adding an extra
-- underscore; for infix names, an extra dot.
prismName' ::
  Bool {- ^ overlapping constructor -} ->
  Name {- ^ type constructor        -} ->
  Name {- ^ prism name              -}
prismName' :: Bool -> Name -> Name
prismName' Bool
sameNameAsCon Name
n =
  case Name -> String
nameBase Name
n of
    [] -> String -> Name
forall a. HasCallStack => String -> a
error String
"prismName: empty name base?"
    nb :: String
nb@(Char
x:String
_) | Char -> Bool
isUpper Char
x -> String -> Name
mkName (Char -> String -> String
prefix Char
'_' String
nb)
             | Bool
otherwise -> String -> Name
mkName (Char -> String -> String
prefix Char
'.' String
nb) -- operator
  where
    prefix :: Char -> String -> String
    prefix :: Char -> String -> String
prefix Char
char String
str | Bool
sameNameAsCon = Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:String
str
                    | Bool
otherwise     =      Char
charChar -> String -> String
forall a. a -> [a] -> [a]
:String
str

-- | Quantify all the free variables in a type.
close :: Type -> TypeQ
close :: Type -> TypeQ
close Type
t = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV (Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
vs)) ([TypeQ] -> CxtQ
cxt[]) (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t)
  where
  vs :: Set Name
vs = Getting (Set Name) Type Name -> Type -> Set Name
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Name) Type Name
forall t. HasTypeVars t => Traversal' t Name
typeVars Type
t