{-# LANGUAGE CPP #-}
#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 where
import Data.Functor.Contravariant
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import qualified Data.Map as Map
import qualified Data.Set as Set
#ifndef CURRENT_PACKAGE_KEY
import Data.Version (showVersion)
import Paths_lens (version)
#endif
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT :: TypeQ -> [TypeQ] -> TypeQ
appsT = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 :: ExpQ -> [ExpQ] -> ExpQ
appsE1 = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE
toTupleT :: [TypeQ] -> TypeQ
toTupleT :: [TypeQ] -> TypeQ
toTupleT [TypeQ
x] = TypeQ
x
toTupleT [TypeQ]
xs = TypeQ -> [TypeQ] -> TypeQ
appsT (Int -> TypeQ
tupleT ([TypeQ] -> 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
tupE [ExpQ]
xs
toTupleP :: [PatQ] -> PatQ
toTupleP :: [PatQ] -> PatQ
toTupleP [PatQ
x] = PatQ
x
toTupleP [PatQ]
xs = [PatQ] -> PatQ
tupP [PatQ]
xs
conAppsT :: Name -> [Type] -> Type
conAppsT :: Name -> [Type] -> Type
conAppsT Name
conName = (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
conName)
bndrName :: TyVarBndr -> Name
bndrName :: TyVarBndr -> Name
bndrName (PlainTV Name
n ) = Name
n
bndrName (KindedTV Name
n Type
_) = Name
n
fromSet :: (k -> v) -> Set.Set k -> Map.Map k v
#if MIN_VERSION_containers(0,5,0)
fromSet :: (k -> v) -> Set k -> Map k v
fromSet = (k -> v) -> Set k -> Map k v
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet
#else
fromSet f x = Map.fromDistinctAscList [ (k,f k) | k <- Set.toAscList x ]
#endif
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)
sequence [ String -> Q 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 :: Type -> (Type, [Type])
unfoldType = [Type] -> Type -> (Type, [Type])
go []
where
go :: [Type] -> Type -> (Type, [Type])
go :: [Type] -> Type -> (Type, [Type])
go [Type]
acc (ForallT [TyVarBndr]
_ [Type]
_ Type
ty) = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
go [Type]
acc (AppT Type
ty1 Type
ty2) = [Type] -> Type -> (Type, [Type])
go (Type
ty2Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
acc) Type
ty1
go [Type]
acc (SigT Type
ty Type
_) = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#if MIN_VERSION_template_haskell(2,11,0)
go [Type]
acc (ParensT Type
ty) = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#endif
#if MIN_VERSION_template_haskell(2,15,0)
go [Type]
acc (AppKindT Type
ty Type
_) = [Type] -> Type -> (Type, [Type])
go [Type]
acc Type
ty
#endif
go [Type]
acc Type
ty = (Type
ty, [Type]
acc)
lensPackageKey :: String
#ifdef CURRENT_PACKAGE_KEY
lensPackageKey :: String
lensPackageKey = CURRENT_PACKAGE_KEY
#else
lensPackageKey = "lens-" ++ showVersion version
#endif
mkLensName_tc :: String -> String -> Name
mkLensName_tc :: String -> String -> Name
mkLensName_tc = String -> String -> String -> Name
mkNameG_tc String
lensPackageKey
mkLensName_v :: String -> String -> Name
mkLensName_v :: String -> String -> Name
mkLensName_v = String -> String -> String -> Name
mkNameG_v String
lensPackageKey
traversalTypeName :: Name
traversalTypeName :: Name
traversalTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Traversal"
traversal'TypeName :: Name
traversal'TypeName :: Name
traversal'TypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Traversal'"
lensTypeName :: Name
lensTypeName :: Name
lensTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Lens"
lens'TypeName :: Name
lens'TypeName :: Name
lens'TypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Lens'"
isoTypeName :: Name
isoTypeName :: Name
isoTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Iso"
iso'TypeName :: Name
iso'TypeName :: Name
iso'TypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Iso'"
getterTypeName :: Name
getterTypeName :: Name
getterTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Getter"
foldTypeName :: Name
foldTypeName :: Name
foldTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Fold"
prismTypeName :: Name
prismTypeName :: Name
prismTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Prism"
prism'TypeName :: Name
prism'TypeName :: Name
prism'TypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Prism'"
reviewTypeName :: Name
reviewTypeName :: Name
reviewTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Type" String
"Review"
wrappedTypeName :: Name
wrappedTypeName :: Name
wrappedTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Wrapped" String
"Wrapped"
unwrappedTypeName :: Name
unwrappedTypeName :: Name
unwrappedTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Wrapped" String
"Unwrapped"
rewrappedTypeName :: Name
rewrappedTypeName :: Name
rewrappedTypeName = String -> String -> Name
mkLensName_tc String
"Control.Lens.Wrapped" String
"Rewrapped"
_wrapped'ValName :: Name
_wrapped'ValName :: Name
_wrapped'ValName = String -> String -> Name
mkLensName_v String
"Control.Lens.Wrapped" String
"_Wrapped'"
isoValName :: Name
isoValName :: Name
isoValName = String -> String -> Name
mkLensName_v String
"Control.Lens.Iso" String
"iso"
prismValName :: Name
prismValName :: Name
prismValName = String -> String -> Name
mkLensName_v String
"Control.Lens.Prism" String
"prism"
untoValName :: Name
untoValName :: Name
untoValName = String -> String -> Name
mkLensName_v String
"Control.Lens.Review" String
"unto"
phantomValName :: Name
phantomValName :: Name
phantomValName = String -> String -> Name
mkLensName_v String
"Control.Lens.Internal.TH" String
"phantom2"
phantom2 :: (Functor f, Contravariant f) => f a -> f b
phantom2 :: 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 = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"."
idValName :: Name
idValName :: Name
idValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"id"
fmapValName :: Name
fmapValName :: Name
fmapValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"fmap"
#if MIN_VERSION_base(4,8,0)
pureValName :: Name
pureValName :: Name
pureValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"pure"
apValName :: Name
apValName :: Name
apValName = String -> String -> String -> Name
mkNameG_v String
"base" String
"GHC.Base" String
"<*>"
#else
pureValName :: Name
pureValName = mkNameG_v "base" "Control.Applicative" "pure"
apValName :: Name
apValName = mkNameG_v "base" "Control.Applicative" "<*>"
#endif
rightDataName :: Name
rightDataName :: Name
rightDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Data.Either" String
"Right"
leftDataName :: Name
leftDataName :: Name
leftDataName = String -> String -> String -> Name
mkNameG_d String
"base" String
"Data.Either" String
"Left"
inlinePragma :: Name -> [DecQ]
#ifdef INLINING
#if MIN_VERSION_template_haskell(2,8,0)
# ifdef OLD_INLINE_PRAGMAS
inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase Inline False)]
# else
inlinePragma :: Name -> [DecQ]
inlinePragma Name
methodName = [Name -> Inline -> RuleMatch -> Phases -> DecQ
pragInlD Name
methodName Inline
Inline RuleMatch
FunLike Phases
AllPhases]
# endif
#else
inlinePragma methodName = [pragInlD methodName (inlineSpecNoPhase True False)]
#endif
#else
inlinePragma _ = []
#endif