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