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