{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
#ifdef TRUSTWORTHY
# if MIN_VERSION_template_haskell(2,12,0)
{-# LANGUAGE Safe #-}
# else
{-# LANGUAGE Trustworthy #-}
# endif
#endif
#include "lens-common.h"
module Control.Lens.Internal.TH
( module Control.Lens.Internal.TH
#if MIN_VERSION_template_haskell(2,21,0) || MIN_VERSION_th_abstraction(0,6,0)
, D.TyVarBndrVis
, D.bndrReq
#endif
) where
import Control.Lens.Iso
import Control.Lens.Prism
import Control.Lens.Review
import Control.Lens.Type
import Control.Lens.Wrapped
import Data.Functor.Contravariant
import qualified Data.Set as Set
import Data.Set (Set)
import Language.Haskell.TH
import qualified Language.Haskell.TH.Datatype as D
import qualified Language.Haskell.TH.Datatype.TyVarBndr as D
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Kind -> m Kind -> m Kind
appT
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE
toTupleT :: [TypeQ] -> TypeQ
toTupleT :: [TypeQ] -> TypeQ
toTupleT [TypeQ
x] = TypeQ
x
toTupleT [TypeQ]
xs = TypeQ -> [TypeQ] -> TypeQ
appsT (Int -> TypeQ
forall (m :: * -> *). Quote m => Int -> m Kind
tupleT ([TypeQ] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TypeQ]
xs)) [TypeQ]
xs
toTupleE :: [ExpQ] -> ExpQ
toTupleE :: [ExpQ] -> ExpQ
toTupleE [ExpQ
x] = ExpQ
x
toTupleE [ExpQ]
xs = [ExpQ] -> ExpQ
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
tupE [ExpQ]
xs
toTupleP :: [PatQ] -> PatQ
toTupleP :: [PatQ] -> PatQ
toTupleP [PatQ
x] = PatQ
x
toTupleP [PatQ]
xs = [PatQ] -> PatQ
forall (m :: * -> *). Quote m => [m Pat] -> m Pat
tupP [PatQ]
xs
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> [Kind] -> Kind
conAppsT Name
conName = (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT Name
conName)
newNames :: String -> Int -> Q [Name]
newNames :: String -> Int -> Q [Name]
newNames String
base Int
n = [Q Name] -> Q [Name]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName (String
baseString -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i) | Int
i <- [Int
1..Int
n] ]
unfoldType :: Type -> (Type, [Type])
unfoldType :: Kind -> (Kind, [Kind])
unfoldType = [Kind] -> Kind -> (Kind, [Kind])
go []
where
go :: [Type] -> Type -> (Type, [Type])
go :: [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc (ForallT [TyVarBndr Specificity]
_ [Kind]
_ Kind
ty) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
go [Kind]
acc (AppT Kind
ty1 Kind
ty2) = [Kind] -> Kind -> (Kind, [Kind])
go (Kind
ty2Kind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
acc) Kind
ty1
go [Kind]
acc (SigT Kind
ty Kind
_) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
go [Kind]
acc (ParensT Kind
ty) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
#if MIN_VERSION_template_haskell(2,15,0)
go [Kind]
acc (AppKindT Kind
ty Kind
_) = [Kind] -> Kind -> (Kind, [Kind])
go [Kind]
acc Kind
ty
#endif
go [Kind]
acc Kind
ty = (Kind
ty, [Kind]
acc)
datatypeTypeKinded :: D.DatatypeInfo -> Type
datatypeTypeKinded :: DatatypeInfo -> Kind
datatypeTypeKinded DatatypeInfo
di
= (Kind -> Kind -> Kind) -> Kind -> [Kind] -> Kind
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Kind -> Kind -> Kind
AppT (Name -> Kind
ConT (DatatypeInfo -> Name
D.datatypeName DatatypeInfo
di))
([Kind] -> Kind) -> [Kind] -> Kind
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Kind] -> [Kind]
dropSigsIfNonDataFam DatatypeInfo
di
([Kind] -> [Kind]) -> [Kind] -> [Kind]
forall a b. (a -> b) -> a -> b
$ DatatypeInfo -> [Kind]
D.datatypeInstTypes DatatypeInfo
di
dropSigsIfNonDataFam :: D.DatatypeInfo -> [Type] -> [Type]
dropSigsIfNonDataFam :: DatatypeInfo -> [Kind] -> [Kind]
dropSigsIfNonDataFam DatatypeInfo
di
| DatatypeVariant -> Bool
isDataFamily (DatatypeInfo -> DatatypeVariant
D.datatypeVariant DatatypeInfo
di) = [Kind] -> [Kind]
forall a. a -> a
id
| Bool
otherwise = (Kind -> Kind) -> [Kind] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
map Kind -> Kind
dropSig
where
dropSig :: Type -> Type
dropSig :: Kind -> Kind
dropSig (SigT Kind
t Kind
k) | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Kind -> [Name]
forall a. TypeSubstitution a => a -> [Name]
D.freeVariables Kind
k) = Kind
t
dropSig Kind
t = Kind
t
quantifyType :: Cxt -> Type -> Type
quantifyType :: [Kind] -> Kind -> Kind
quantifyType = Set Name -> [Kind] -> Kind -> Kind
quantifyType' Set Name
forall a. Set a
Set.empty
quantifyType' :: Set Name -> Cxt -> Type -> Type
quantifyType' :: Set Name -> [Kind] -> Kind -> Kind
quantifyType' Set Name
exclude [Kind]
c Kind
t = [TyVarBndr Specificity] -> [Kind] -> Kind -> Kind
ForallT [TyVarBndr Specificity]
vs [Kind]
c Kind
t
where
vs :: [TyVarBndr Specificity]
vs = (TyVarBndr Specificity -> Bool)
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TyVarBndr Specificity
tvb -> TyVarBndr Specificity -> Name
forall flag. TyVarBndr_ flag -> Name
D.tvName TyVarBndr Specificity
tvb Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
exclude)
([TyVarBndr Specificity] -> [TyVarBndr Specificity])
-> [TyVarBndr Specificity] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ Specificity -> [TyVarBndr_ ()] -> [TyVarBndr Specificity]
forall newFlag oldFlag.
newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
D.changeTVFlags Specificity
D.SpecifiedSpec
([TyVarBndr_ ()] -> [TyVarBndr Specificity])
-> [TyVarBndr_ ()] -> [TyVarBndr Specificity]
forall a b. (a -> b) -> a -> b
$ [Kind] -> [TyVarBndr_ ()]
D.freeVariablesWellScoped (Kind
tKind -> [Kind] -> [Kind]
forall a. a -> [a] -> [a]
:[Kind]
c)
tvbToType :: D.TyVarBndr_ flag -> Type
tvbToType :: forall flag. TyVarBndr_ flag -> Kind
tvbToType = (Name -> Kind) -> (Name -> Kind -> Kind) -> TyVarBndr_ flag -> Kind
forall r flag.
(Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
D.elimTV Name -> Kind
VarT (Kind -> Kind -> Kind
SigT (Kind -> Kind -> Kind) -> (Name -> Kind) -> Name -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Kind
VarT)
unSigT :: Type -> Type
unSigT :: Kind -> Kind
unSigT (SigT Kind
t Kind
_) = Kind
t
unSigT Kind
t = Kind
t
isDataFamily :: D.DatatypeVariant -> Bool
isDataFamily :: DatatypeVariant -> Bool
isDataFamily DatatypeVariant
D.Datatype = Bool
False
isDataFamily DatatypeVariant
D.Newtype = Bool
False
isDataFamily DatatypeVariant
D.DataInstance = Bool
True
isDataFamily DatatypeVariant
D.NewtypeInstance = Bool
True
#if MIN_VERSION_th_abstraction(0,5,0)
isDataFamily DatatypeVariant
D.TypeData = Bool
False
#endif
haskellKeywords :: Set String
haskellKeywords :: Set String
haskellKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList
[ String
"case", String
"class", String
"data", String
"default", String
"deriving", String
"do", String
"else"
#if __GLASGOW_HASKELL__ >= 910
, "forall"
#endif
, String
"foreign", String
"if", String
"import", String
"in", String
"infix", String
"infixl", String
"infixr"
, String
"instance", String
"let", String
"module", String
"newtype", String
"of", String
"then", String
"type"
, String
"where", String
"_"
]
explicitForAllKeywords :: Set String
explicitForAllKeywords :: Set String
explicitForAllKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"forall"]
recursiveDoKeywords :: Set String
recursiveDoKeywords :: Set String
recursiveDoKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"mdo", String
"rec"]
arrowsKeywords :: Set String
arrowsKeywords :: Set String
arrowsKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"proc", String
"rec"]
patternSynonymsKeywords :: Set String
patternSynonymsKeywords :: Set String
patternSynonymsKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"pattern"]
transformListCompKeywords :: Set String
transformListCompKeywords :: Set String
transformListCompKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"by", String
"using"]
staticPointersKeywords :: Set String
staticPointersKeywords :: Set String
staticPointersKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"static"]
roleAnnotationsKeywords :: Set String
roleAnnotationsKeywords :: Set String
roleAnnotationsKeywords = [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String
"role"]
ghcExtensionKeywords :: Set String
ghcExtensionKeywords :: Set String
ghcExtensionKeywords = [Set String] -> Set String
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
[ Set String
explicitForAllKeywords
, Set String
recursiveDoKeywords
, Set String
arrowsKeywords
, Set String
patternSynonymsKeywords
, Set String
transformListCompKeywords
, Set String
staticPointersKeywords
, Set String
roleAnnotationsKeywords
]
activeKeywords :: Q (Set String)
#if MIN_VERSION_template_haskell(2,12,0)
activeKeywords :: Q (Set String)
activeKeywords = do
Bool
explicitForAll <- [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> Q [Bool] -> Q Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Extension -> Q Bool) -> [Extension] -> Q [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Extension -> Q Bool
isExtEnabled
[ Extension
ExplicitForAll, Extension
RankNTypes, Extension
ScopedTypeVariables ]
Bool
recursiveDo <- Extension -> Q Bool
isExtEnabled Extension
RecursiveDo
Bool
arrows <- Extension -> Q Bool
isExtEnabled Extension
Arrows
Bool
patternSynonyms <- Extension -> Q Bool
isExtEnabled Extension
PatternSynonyms
Bool
transformListComp <- Extension -> Q Bool
isExtEnabled Extension
TransformListComp
Bool
staticPointers <- Extension -> Q Bool
isExtEnabled Extension
StaticPointers
Set String -> Q (Set String)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set String -> Q (Set String)) -> Set String -> Q (Set String)
forall a b. (a -> b) -> a -> b
$ [Set String] -> Set String
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set String] -> Set String) -> [Set String] -> Set String
forall a b. (a -> b) -> a -> b
$
[ Set String
haskellKeywords ]
[Set String] -> [Set String] -> [Set String]
forall a. [a] -> [a] -> [a]
++ [ Set String
explicitForAllKeywords | Bool
explicitForAll ]
[Set String] -> [Set String] -> [Set String]
forall a. [a] -> [a] -> [a]
++ [ Set String
recursiveDoKeywords | Bool
recursiveDo ]
[Set String] -> [Set String] -> [Set String]
forall a. [a] -> [a] -> [a]
++ [ Set String
arrowsKeywords | Bool
arrows ]
[Set String] -> [Set String] -> [Set String]
forall a. [a] -> [a] -> [a]
++ [ Set String
patternSynonymsKeywords | Bool
patternSynonyms ]
[Set String] -> [Set String] -> [Set String]
forall a. [a] -> [a] -> [a]
++ [ Set String
transformListCompKeywords | Bool
transformListComp ]
[Set String] -> [Set String] -> [Set String]
forall a. [a] -> [a] -> [a]
++ [ Set String
staticPointersKeywords | Bool
staticPointers ]
#else
activeKeywords = return haskellKeywords
#endif
avoidName :: Set String -> Name -> Name
avoidName :: Set String -> Name -> Name
avoidName Set String
names Name
n
| Name -> String
nameBase Name
n String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
names = String -> Name
mkName (Name -> String
nameBase Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_")
| Bool
otherwise = Name
n
#if !(MIN_VERSION_template_haskell(2,21,0)) && !(MIN_VERSION_th_abstraction(0,6,0))
type TyVarBndrVis = D.TyVarBndr_ ()
bndrReq :: ()
bndrReq = ()
#endif
traversalTypeName :: Name
traversalTypeName :: Name
traversalTypeName = ''Traversal
traversal'TypeName :: Name
traversal'TypeName :: Name
traversal'TypeName = ''Traversal'
lensTypeName :: Name
lensTypeName :: Name
lensTypeName = ''Lens
lens'TypeName :: Name
lens'TypeName :: Name
lens'TypeName = ''Lens'
isoTypeName :: Name
isoTypeName :: Name
isoTypeName = ''Iso
iso'TypeName :: Name
iso'TypeName :: Name
iso'TypeName = ''Iso'
getterTypeName :: Name
getterTypeName :: Name
getterTypeName = ''Getter
foldTypeName :: Name
foldTypeName :: Name
foldTypeName = ''Fold
prismTypeName :: Name
prismTypeName :: Name
prismTypeName = ''Prism
prism'TypeName :: Name
prism'TypeName :: Name
prism'TypeName = ''Prism'
reviewTypeName :: Name
reviewTypeName :: Name
reviewTypeName = ''Review
wrappedTypeName :: Name
wrappedTypeName :: Name
wrappedTypeName = ''Wrapped
unwrappedTypeName :: Name
unwrappedTypeName :: Name
unwrappedTypeName = ''Unwrapped
rewrappedTypeName :: Name
rewrappedTypeName :: Name
rewrappedTypeName = ''Rewrapped
_wrapped'ValName :: Name
_wrapped'ValName :: Name
_wrapped'ValName = '_Wrapped'
isoValName :: Name
isoValName :: Name
isoValName = 'iso
prismValName :: Name
prismValName :: Name
prismValName = 'prism
untoValName :: Name
untoValName :: Name
untoValName = 'unto
phantomValName :: Name
phantomValName :: Name
phantomValName = 'phantom2
phantom2 :: (Functor f, Contravariant f) => f a -> f b
phantom2 :: forall (f :: * -> *) a b.
(Functor f, Contravariant f) =>
f a -> f b
phantom2 = f a -> f b
forall (f :: * -> *) a b.
(Functor f, Contravariant f) =>
f a -> f b
phantom
{-# INLINE phantom2 #-}
composeValName :: Name
composeValName :: Name
composeValName = '(.)
idValName :: Name
idValName :: Name
idValName = 'id
fmapValName :: Name
fmapValName :: Name
fmapValName = 'fmap
pureValName :: Name
pureValName :: Name
pureValName = 'pure
apValName :: Name
apValName :: Name
apValName = '(<*>)
rightDataName :: Name
rightDataName :: Name
rightDataName = 'Right
leftDataName :: Name
leftDataName :: Name
leftDataName = 'Left
inlinePragma :: Name -> [DecQ]
inlinePragma :: Name -> [DecQ]
inlinePragma Name
methodName = [Name -> Inline -> RuleMatch -> Phases -> DecQ
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD Name
methodName Inline
Inline RuleMatch
FunLike Phases
AllPhases]