1{-# LANGUAGE CPP #-} 2#ifdef TRUSTWORTHY 3# if MIN_VERSION_template_haskell(2,12,0) 4{-# LANGUAGE Safe #-} 5# else 6{-# LANGUAGE Trustworthy #-} 7# endif 8#endif 9 10#include "lens-common.h" 11 12----------------------------------------------------------------------------- 13-- | 14-- Module : Control.Lens.Internal.TH 15-- Copyright : (C) 2013-2016 Edward Kmett and Eric Mertens 16-- License : BSD-style (see the file LICENSE) 17-- Maintainer : Edward Kmett <ekmett@gmail.com> 18-- Stability : experimental 19-- Portability : non-portable 20-- 21---------------------------------------------------------------------------- 22module Control.Lens.Internal.TH where 23 24import Data.Functor.Contravariant 25import qualified Data.Set as Set 26import Data.Set (Set) 27import Language.Haskell.TH 28import qualified Language.Haskell.TH.Datatype as D 29import qualified Language.Haskell.TH.Datatype.TyVarBndr as D 30import Language.Haskell.TH.Syntax 31#ifndef CURRENT_PACKAGE_KEY 32import Data.Version (showVersion) 33import Paths_lens (version) 34#endif 35 36-- | Apply arguments to a type constructor 37appsT :: TypeQ -> [TypeQ] -> TypeQ 38appsT = foldl appT 39 40-- | Apply arguments to a function 41appsE1 :: ExpQ -> [ExpQ] -> ExpQ 42appsE1 = foldl appE 43 44-- | Construct a tuple type given a list of types. 45toTupleT :: [TypeQ] -> TypeQ 46toTupleT [x] = x 47toTupleT xs = appsT (tupleT (length xs)) xs 48 49-- | Construct a tuple value given a list of expressions. 50toTupleE :: [ExpQ] -> ExpQ 51toTupleE [x] = x 52toTupleE xs = tupE xs 53 54-- | Construct a tuple pattern given a list of patterns. 55toTupleP :: [PatQ] -> PatQ 56toTupleP [x] = x 57toTupleP xs = tupP xs 58 59-- | Apply arguments to a type constructor. 60conAppsT :: Name -> [Type] -> Type 61conAppsT conName = foldl AppT (ConT conName) 62 63-- | Generate many new names from a given base name. 64newNames :: String {- ^ base name -} -> Int {- ^ count -} -> Q [Name] 65newNames base n = sequence [ newName (base++show i) | i <- [1..n] ] 66 67-- | Decompose an applied type into its individual components. For example, this: 68-- 69-- @ 70-- Either Int Char 71-- @ 72-- 73-- would be unfolded to this: 74-- 75-- @ 76-- ('ConT' ''Either, ['ConT' ''Int, 'ConT' ''Char]) 77-- @ 78-- 79-- This function ignores explicit parentheses and visible kind applications. 80unfoldType :: Type -> (Type, [Type]) 81unfoldType = go [] 82 where 83 go :: [Type] -> Type -> (Type, [Type]) 84 go acc (ForallT _ _ ty) = go acc ty 85 go acc (AppT ty1 ty2) = go (ty2:acc) ty1 86 go acc (SigT ty _) = go acc ty 87#if MIN_VERSION_template_haskell(2,11,0) 88 go acc (ParensT ty) = go acc ty 89#endif 90#if MIN_VERSION_template_haskell(2,15,0) 91 go acc (AppKindT ty _) = go acc ty 92#endif 93 go acc ty = (ty, acc) 94 95-- Construct a 'Type' using the datatype's type constructor and type 96-- parameters. Unlike 'D.datatypeType', kind signatures are preserved to 97-- some extent. (See the comments for 'dropSigsIfNonDataFam' below for more 98-- details on this.) 99datatypeTypeKinded :: D.DatatypeInfo -> Type 100datatypeTypeKinded di 101 = foldl AppT (ConT (D.datatypeName di)) 102 $ dropSigsIfNonDataFam 103 $ D.datatypeInstTypes di 104 where 105 {- 106 In an effort to prevent users from having to enable KindSignatures every 107 time that they use lens' TH functionality, we strip off reified kind 108 annotations from when: 109 110 1. The kind of a type does not contain any kind variables. If it *does* 111 contain kind variables, we want to preserve them so that we can generate 112 type signatures that preserve the dependency order of kind and type 113 variables. (The data types in test/T917.hs contain examples where this 114 is important.) This will require enabling `PolyKinds`, but since 115 `PolyKinds` implies `KindSignatures`, we can at least accomplish two 116 things at once. 117 2. The data type is not an instance of a data family. We make an exception 118 for data family instances, since the presence or absence of a kind 119 annotation can be the difference between typechecking or not. 120 (See T917DataFam in tests/T917.hs for an example.) Moreover, the 121 `TypeFamilies` extension implies `KindSignatures`. 122 -} 123 dropSigsIfNonDataFam :: [Type] -> [Type] 124 dropSigsIfNonDataFam 125 | isDataFamily (D.datatypeVariant di) = id 126 | otherwise = map dropSig 127 128 dropSig :: Type -> Type 129 dropSig (SigT t k) | null (D.freeVariables k) = t 130 dropSig t = t 131 132-- | Template Haskell wants type variables declared in a forall, so 133-- we find all free type variables in a given type and declare them. 134quantifyType :: Cxt -> Type -> Type 135quantifyType = quantifyType' Set.empty 136 137-- | This function works like 'quantifyType' except that it takes 138-- a list of variables to exclude from quantification. 139quantifyType' :: Set Name -> Cxt -> Type -> Type 140quantifyType' exclude c t = ForallT vs c t 141 where 142 vs = filter (\tvb -> D.tvName tvb `Set.notMember` exclude) 143 $ D.changeTVFlags D.SpecifiedSpec 144 $ D.freeVariablesWellScoped (t:concatMap predTypes c) -- stable order 145 146 predTypes :: Pred -> [Type] 147#if MIN_VERSION_template_haskell(2,10,0) 148 predTypes p = [p] 149#else 150 predTypes (ClassP _ ts) = ts 151 predTypes (EqualP t1 t2) = [t1, t2] 152#endif 153 154-- | Convert a 'TyVarBndr' into its corresponding 'Type'. 155tvbToType :: D.TyVarBndr_ flag -> Type 156tvbToType = D.elimTV VarT (SigT . VarT) 157 158-- | Peel off a kind signature from a Type (if it has one). 159unSigT :: Type -> Type 160unSigT (SigT t _) = t 161unSigT t = t 162 163isDataFamily :: D.DatatypeVariant -> Bool 164isDataFamily D.Datatype = False 165isDataFamily D.Newtype = False 166isDataFamily D.DataInstance = True 167isDataFamily D.NewtypeInstance = True 168 169------------------------------------------------------------------------ 170-- Manually quoted names 171------------------------------------------------------------------------ 172-- By manually generating these names we avoid needing to use the 173-- TemplateHaskell language extension when compiling the lens library. 174-- This allows the library to be used in stage1 cross-compilers. 175 176lensPackageKey :: String 177#ifdef CURRENT_PACKAGE_KEY 178lensPackageKey = CURRENT_PACKAGE_KEY 179#else 180lensPackageKey = "lens-" ++ showVersion version 181#endif 182 183mkLensName_tc :: String -> String -> Name 184mkLensName_tc = mkNameG_tc lensPackageKey 185 186mkLensName_v :: String -> String -> Name 187mkLensName_v = mkNameG_v lensPackageKey 188 189traversalTypeName :: Name 190traversalTypeName = mkLensName_tc "Control.Lens.Type" "Traversal" 191 192traversal'TypeName :: Name 193traversal'TypeName = mkLensName_tc "Control.Lens.Type" "Traversal'" 194 195lensTypeName :: Name 196lensTypeName = mkLensName_tc "Control.Lens.Type" "Lens" 197 198lens'TypeName :: Name 199lens'TypeName = mkLensName_tc "Control.Lens.Type" "Lens'" 200 201isoTypeName :: Name 202isoTypeName = mkLensName_tc "Control.Lens.Type" "Iso" 203 204iso'TypeName :: Name 205iso'TypeName = mkLensName_tc "Control.Lens.Type" "Iso'" 206 207getterTypeName :: Name 208getterTypeName = mkLensName_tc "Control.Lens.Type" "Getter" 209 210foldTypeName :: Name 211foldTypeName = mkLensName_tc "Control.Lens.Type" "Fold" 212 213prismTypeName :: Name 214prismTypeName = mkLensName_tc "Control.Lens.Type" "Prism" 215 216prism'TypeName :: Name 217prism'TypeName = mkLensName_tc "Control.Lens.Type" "Prism'" 218 219reviewTypeName :: Name 220reviewTypeName = mkLensName_tc "Control.Lens.Type" "Review" 221 222wrappedTypeName :: Name 223wrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Wrapped" 224 225unwrappedTypeName :: Name 226unwrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Unwrapped" 227 228rewrappedTypeName :: Name 229rewrappedTypeName = mkLensName_tc "Control.Lens.Wrapped" "Rewrapped" 230 231_wrapped'ValName :: Name 232_wrapped'ValName = mkLensName_v "Control.Lens.Wrapped" "_Wrapped'" 233 234isoValName :: Name 235isoValName = mkLensName_v "Control.Lens.Iso" "iso" 236 237prismValName :: Name 238prismValName = mkLensName_v "Control.Lens.Prism" "prism" 239 240untoValName :: Name 241untoValName = mkLensName_v "Control.Lens.Review" "unto" 242 243phantomValName :: Name 244phantomValName = mkLensName_v "Control.Lens.Internal.TH" "phantom2" 245 246phantom2 :: (Functor f, Contravariant f) => f a -> f b 247phantom2 = phantom 248{-# INLINE phantom2 #-} 249 250composeValName :: Name 251composeValName = mkNameG_v "base" "GHC.Base" "." 252 253idValName :: Name 254idValName = mkNameG_v "base" "GHC.Base" "id" 255 256fmapValName :: Name 257fmapValName = mkNameG_v "base" "GHC.Base" "fmap" 258 259#if MIN_VERSION_base(4,8,0) 260pureValName :: Name 261pureValName = mkNameG_v "base" "GHC.Base" "pure" 262 263apValName :: Name 264apValName = mkNameG_v "base" "GHC.Base" "<*>" 265#else 266pureValName :: Name 267pureValName = mkNameG_v "base" "Control.Applicative" "pure" 268 269apValName :: Name 270apValName = mkNameG_v "base" "Control.Applicative" "<*>" 271#endif 272 273rightDataName :: Name 274rightDataName = mkNameG_d "base" "Data.Either" "Right" 275 276leftDataName :: Name 277leftDataName = mkNameG_d "base" "Data.Either" "Left" 278 279 280------------------------------------------------------------------------ 281-- Support for generating inline pragmas 282------------------------------------------------------------------------ 283 284inlinePragma :: Name -> [DecQ] 285inlinePragma methodName = [pragInlD methodName Inline FunLike AllPhases] 286