1{-# Language CPP, DeriveDataTypeable #-}
2
3#if MIN_VERSION_base(4,4,0)
4#define HAS_GENERICS
5{-# Language DeriveGeneric #-}
6#endif
7
8#if MIN_VERSION_template_haskell(2,12,0)
9{-# Language Safe #-}
10#elif __GLASGOW_HASKELL__ >= 702
11{-# Language Trustworthy #-}
12#endif
13
14{-|
15Module      : Language.Haskell.TH.Datatype.TyVarBndr
16Description : Backwards-compatible type variable binders
17Copyright   : Eric Mertens 2020
18License     : ISC
19Maintainer  : emertens@gmail.com
20
21This module provides a backwards-compatible API for constructing and
22manipulating 'TyVarBndr's across multiple versions of the @template-haskell@
23package.
24
25-}
26module Language.Haskell.TH.Datatype.TyVarBndr (
27    -- * @TyVarBndr@-related types
28    TyVarBndr_
29  , TyVarBndrUnit
30  , TyVarBndrSpec
31  , Specificity(..)
32
33    -- * Constructing @TyVarBndr@s
34    -- ** @flag@-polymorphic
35  , plainTVFlag
36  , kindedTVFlag
37    -- ** @TyVarBndrUnit@
38  , plainTV
39  , kindedTV
40    -- ** @TyVarBndrSpec@
41  , plainTVInferred
42  , plainTVSpecified
43  , kindedTVInferred
44  , kindedTVSpecified
45
46    -- * Constructing @Specificity@
47  , inferredSpec
48  , specifiedSpec
49
50    -- * Modifying @TyVarBndr@s
51  , elimTV
52  , mapTV
53  , mapTVName
54  , mapTVFlag
55  , mapTVKind
56  , traverseTV
57  , traverseTVName
58  , traverseTVFlag
59  , traverseTVKind
60  , mapMTV
61  , mapMTVName
62  , mapMTVFlag
63  , mapMTVKind
64  , changeTVFlags
65
66    -- * Properties of @TyVarBndr@s
67  , tvName
68  , tvKind
69  ) where
70
71import Control.Applicative
72import Control.Monad
73import Data.Data (Typeable, Data)
74import Language.Haskell.TH.Lib
75import Language.Haskell.TH.Syntax
76
77#ifdef HAS_GENERICS
78import GHC.Generics (Generic)
79#endif
80
81-- | A type synonym for 'TyVarBndr'. This is the recommended way to refer to
82-- 'TyVarBndr's if you wish to achieve backwards compatibility with older
83-- versions of @template-haskell@, where 'TyVarBndr' lacked a @flag@ type
84-- parameter representing its specificity (if it has one).
85#if MIN_VERSION_template_haskell(2,17,0)
86type TyVarBndr_ flag = TyVarBndr flag
87#else
88type TyVarBndr_ flag = TyVarBndr
89
90-- | A 'TyVarBndr' where the specificity is irrelevant. This is used for
91-- 'TyVarBndr's that do not interact with visible type application.
92type TyVarBndrUnit = TyVarBndr
93
94-- | A 'TyVarBndr' with an explicit 'Specificity'. This is used for
95-- 'TyVarBndr's that interact with visible type application.
96type TyVarBndrSpec = TyVarBndr
97
98-- | Determines how a 'TyVarBndr' interacts with visible type application.
99data Specificity
100  = SpecifiedSpec -- ^ @a@. Eligible for visible type application.
101  | InferredSpec  -- ^ @{a}@. Not eligible for visible type application.
102  deriving (Show, Eq, Ord, Typeable, Data
103#ifdef HAS_GENERICS
104           ,Generic
105#endif
106           )
107
108inferredSpec :: Specificity
109inferredSpec = InferredSpec
110
111specifiedSpec :: Specificity
112specifiedSpec = SpecifiedSpec
113#endif
114
115-- | Construct a 'PlainTV' with the given @flag@.
116plainTVFlag :: Name -> flag -> TyVarBndr_ flag
117#if MIN_VERSION_template_haskell(2,17,0)
118plainTVFlag = PlainTV
119#else
120plainTVFlag n _ = PlainTV n
121#endif
122
123-- | Construct a 'PlainTV' with an 'InferredSpec'.
124plainTVInferred :: Name -> TyVarBndrSpec
125plainTVInferred n = plainTVFlag n InferredSpec
126
127-- | Construct a 'PlainTV' with a 'SpecifiedSpec'.
128plainTVSpecified :: Name -> TyVarBndrSpec
129plainTVSpecified n = plainTVFlag n SpecifiedSpec
130
131-- | Construct a 'KindedTV' with the given @flag@.
132kindedTVFlag :: Name -> flag -> Kind -> TyVarBndr_ flag
133#if MIN_VERSION_template_haskell(2,17,0)
134kindedTVFlag = KindedTV
135#else
136kindedTVFlag n _ kind = KindedTV n kind
137#endif
138
139-- | Construct a 'KindedTV' with an 'InferredSpec'.
140kindedTVInferred :: Name -> Kind -> TyVarBndrSpec
141kindedTVInferred n k = kindedTVFlag n InferredSpec k
142
143-- | Construct a 'KindedTV' with a 'SpecifiedSpec'.
144kindedTVSpecified :: Name -> Kind -> TyVarBndrSpec
145kindedTVSpecified n k = kindedTVFlag n SpecifiedSpec k
146
147-- | Case analysis for a 'TyVarBndr'. If the value is a @'PlainTV' n _@, apply
148-- the first function to @n@; if it is @'KindedTV' n _ k@, apply the second
149-- function to @n@ and @k@.
150elimTV :: (Name -> r) -> (Name -> Kind -> r) -> TyVarBndr_ flag -> r
151#if MIN_VERSION_template_haskell(2,17,0)
152elimTV ptv _ktv (PlainTV n _)    = ptv n
153elimTV _ptv ktv (KindedTV n _ k) = ktv n k
154#else
155elimTV ptv _ktv (PlainTV n)    = ptv n
156elimTV _ptv ktv (KindedTV n k) = ktv n k
157#endif
158
159-- | Map over the components of a 'TyVarBndr'.
160mapTV :: (Name -> Name) -> (flag -> flag') -> (Kind -> Kind)
161      -> TyVarBndr_ flag -> TyVarBndr_ flag'
162#if MIN_VERSION_template_haskell(2,17,0)
163mapTV fn fflag _fkind (PlainTV  n flag)      = PlainTV  (fn n) (fflag flag)
164mapTV fn fflag  fkind (KindedTV n flag kind) = KindedTV (fn n) (fflag flag) (fkind kind)
165#else
166mapTV fn _fflag _fkind (PlainTV  n)      = PlainTV  (fn n)
167mapTV fn _fflag  fkind (KindedTV n kind) = KindedTV (fn n) (fkind kind)
168#endif
169
170-- | Map over the 'Name' of a 'TyVarBndr'.
171mapTVName :: (Name -> Name) -> TyVarBndr_ flag -> TyVarBndr_ flag
172mapTVName fname = mapTV fname id id
173
174-- | Map over the @flag@ of a 'TyVarBndr'.
175mapTVFlag :: (flag -> flag') -> TyVarBndr_ flag -> TyVarBndr_ flag'
176#if MIN_VERSION_template_haskell(2,17,0)
177mapTVFlag = fmap
178#else
179mapTVFlag _ = id
180#endif
181
182-- | Map over the 'Kind' of a 'TyVarBndr'.
183mapTVKind :: (Kind -> Kind) -> TyVarBndr_ flag -> TyVarBndr_ flag
184mapTVKind fkind = mapTV id id fkind
185
186-- | Traverse the components of a 'TyVarBndr'.
187traverseTV :: Applicative f
188           => (Name -> f Name) -> (flag -> f flag') -> (Kind -> f Kind)
189           -> TyVarBndr_ flag -> f (TyVarBndr_ flag')
190#if MIN_VERSION_template_haskell(2,17,0)
191traverseTV fn fflag _fkind (PlainTV n flag) =
192  liftA2 PlainTV (fn n) (fflag flag)
193traverseTV fn fflag fkind (KindedTV n flag kind) =
194  liftA3 KindedTV (fn n) (fflag flag) (fkind kind)
195#else
196traverseTV fn _fflag _fkind (PlainTV n) =
197  PlainTV <$> fn n
198traverseTV fn _fflag fkind (KindedTV n kind) =
199  liftA2 KindedTV (fn n) (fkind kind)
200#endif
201
202-- | Traverse the 'Name' of a 'TyVarBndr'.
203traverseTVName :: Functor f
204               => (Name -> f Name)
205               -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
206#if MIN_VERSION_template_haskell(2,17,0)
207traverseTVName fn (PlainTV n flag) =
208  (\n' -> PlainTV n' flag) <$> fn n
209traverseTVName fn (KindedTV n flag kind) =
210  (\n' -> KindedTV n' flag kind) <$> fn n
211#else
212traverseTVName fn (PlainTV n) =
213  PlainTV <$> fn n
214traverseTVName fn (KindedTV n kind) =
215  (\n' -> KindedTV n' kind) <$> fn n
216#endif
217
218-- | Traverse the @flag@ of a 'TyVarBndr'.
219traverseTVFlag :: Applicative f
220               => (flag -> f flag')
221               -> TyVarBndr_ flag -> f (TyVarBndr_ flag')
222#if MIN_VERSION_template_haskell(2,17,0)
223traverseTVFlag fflag (PlainTV n flag) =
224  PlainTV n <$> fflag flag
225traverseTVFlag fflag (KindedTV n flag kind) =
226  (\flag' -> KindedTV n flag' kind) <$> fflag flag
227#else
228traverseTVFlag _ = pure
229#endif
230
231-- | Traverse the 'Kind' of a 'TyVarBndr'.
232traverseTVKind :: Applicative f
233               => (Kind -> f Kind)
234               -> TyVarBndr_ flag -> f (TyVarBndr_ flag)
235#if MIN_VERSION_template_haskell(2,17,0)
236traverseTVKind _fkind tvb@PlainTV{} =
237  pure tvb
238traverseTVKind fkind (KindedTV n flag kind) =
239  KindedTV n flag <$> fkind kind
240#else
241traverseTVKind _fkind tvb@PlainTV{} =
242  pure tvb
243traverseTVKind fkind (KindedTV n kind) =
244  KindedTV n <$> fkind kind
245#endif
246
247-- | Map over the components of a 'TyVarBndr' in a monadic fashion.
248--
249-- This is the same as 'traverseTV', but with a 'Monad' constraint. This is
250-- mainly useful for use with old versions of @base@ where 'Applicative' was
251-- not a superclass of 'Monad'.
252mapMTV :: Monad m
253       => (Name -> m Name) -> (flag -> m flag') -> (Kind -> m Kind)
254       -> TyVarBndr_ flag -> m (TyVarBndr_ flag')
255#if MIN_VERSION_template_haskell(2,17,0)
256mapMTV fn fflag _fkind (PlainTV n flag) =
257  liftM2 PlainTV (fn n) (fflag flag)
258mapMTV fn fflag fkind (KindedTV n flag kind) =
259  liftM3 KindedTV (fn n) (fflag flag) (fkind kind)
260#else
261mapMTV fn _fflag _fkind (PlainTV n) =
262  liftM PlainTV (fn n)
263mapMTV fn _fflag fkind (KindedTV n kind) =
264  liftM2 KindedTV (fn n) (fkind kind)
265#endif
266
267-- | Map over the 'Name' of a 'TyVarBndr' in a monadic fashion.
268--
269-- This is the same as 'traverseTVName', but with a 'Monad' constraint. This is
270-- mainly useful for use with old versions of @base@ where 'Applicative' was
271-- not a superclass of 'Monad'.
272mapMTVName :: Monad m
273           => (Name -> m Name)
274           -> TyVarBndr_ flag -> m (TyVarBndr_ flag)
275#if MIN_VERSION_template_haskell(2,17,0)
276mapMTVName fn (PlainTV n flag) =
277  liftM (\n' -> PlainTV n' flag) (fn n)
278mapMTVName fn (KindedTV n flag kind) =
279  liftM (\n' -> KindedTV n' flag kind) (fn n)
280#else
281mapMTVName fn (PlainTV n) =
282  liftM PlainTV (fn n)
283mapMTVName fn (KindedTV n kind) =
284  liftM (\n' -> KindedTV n' kind) (fn n)
285#endif
286
287-- | Map over the @flag@ of a 'TyVarBndr' in a monadic fashion.
288--
289-- This is the same as 'traverseTVFlag', but with a 'Monad' constraint. This is
290-- mainly useful for use with old versions of @base@ where 'Applicative' was
291-- not a superclass of 'Monad'.
292mapMTVFlag :: Monad m
293           => (flag -> m flag')
294           -> TyVarBndr_ flag -> m (TyVarBndr_ flag')
295#if MIN_VERSION_template_haskell(2,17,0)
296mapMTVFlag fflag (PlainTV n flag) =
297  liftM (PlainTV n) (fflag flag)
298mapMTVFlag fflag (KindedTV n flag kind) =
299  liftM (\flag' -> KindedTV n flag' kind) (fflag flag)
300#else
301mapMTVFlag _ = return
302#endif
303
304-- | Map over the 'Kind' of a 'TyVarBndr' in a monadic fashion.
305--
306-- This is the same as 'traverseTVKind', but with a 'Monad' constraint. This is
307-- mainly useful for use with old versions of @base@ where 'Applicative' was
308-- not a superclass of 'Monad'.
309mapMTVKind :: Monad m
310           => (Kind -> m Kind)
311           -> TyVarBndr_ flag -> m (TyVarBndr_ flag)
312#if MIN_VERSION_template_haskell(2,17,0)
313mapMTVKind _fkind tvb@PlainTV{} =
314  return tvb
315mapMTVKind fkind (KindedTV n flag kind) =
316  liftM (KindedTV n flag) (fkind kind)
317#else
318mapMTVKind _fkind tvb@PlainTV{} =
319  return tvb
320mapMTVKind fkind (KindedTV n kind) =
321  liftM (KindedTV n) (fkind kind)
322#endif
323
324-- | Set the flag in a list of 'TyVarBndr's. This is often useful in contexts
325-- where one needs to re-use a list of 'TyVarBndr's from one flag setting to
326-- another flag setting. For example, in order to re-use the 'TyVarBndr's bound
327-- by a 'DataD' in a 'ForallT', one can do the following:
328--
329-- @
330-- case x of
331--   'DataD' _ _ tvbs _ _ _ ->
332--     'ForallT' ('changeTVFlags' 'SpecifiedSpec' tvbs) ...
333-- @
334changeTVFlags :: newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
335#if MIN_VERSION_template_haskell(2,17,0)
336changeTVFlags newFlag = map (newFlag <$)
337#else
338changeTVFlags _ = id
339#endif
340
341-- | Extract the type variable name from a 'TyVarBndr', ignoring the
342-- kind signature if one exists.
343tvName :: TyVarBndr_ flag -> Name
344tvName = elimTV id (\n _ -> n)
345
346-- | Extract the kind from a 'TyVarBndr'. Assumes 'PlainTV' has kind @*@.
347tvKind :: TyVarBndr_ flag -> Kind
348tvKind = elimTV (\_ -> starK) (\_ k -> k)
349