1{-# Language CPP, DeriveDataTypeable #-} 2 3#if MIN_VERSION_base(4,4,0) 4#define HAS_GENERICS 5{-# Language DeriveGeneric #-} 6#endif 7 8{-| 9Module : Language.Haskell.TH.Datatype 10Description : Backwards-compatible interface to reified information about datatypes. 11Copyright : Eric Mertens 2017 12License : ISC 13Maintainer : emertens@gmail.com 14 15This module provides a flattened view of information about data types 16and newtypes that can be supported uniformly across multiple versions 17of the template-haskell package. 18 19Sample output for @'reifyDatatype' ''Maybe@ 20 21@ 22'DatatypeInfo' 23 { 'datatypeContext' = [] 24 , 'datatypeName' = GHC.Base.Maybe 25 , 'datatypeVars' = [ 'KindedTV' a_3530822107858468866 'StarT' ] 26 , 'datatypeInstTypes' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ] 27 , 'datatypeVariant' = 'Datatype' 28 , 'datatypeCons' = 29 [ 'ConstructorInfo' 30 { 'constructorName' = GHC.Base.Nothing 31 , 'constructorVars' = [] 32 , 'constructorContext' = [] 33 , 'constructorFields' = [] 34 , 'constructorStrictness' = [] 35 , 'constructorVariant' = 'NormalConstructor' 36 } 37 , 'ConstructorInfo' 38 { 'constructorName' = GHC.Base.Just 39 , 'constructorVars' = [] 40 , 'constructorContext' = [] 41 , 'constructorFields' = [ 'VarT' a_3530822107858468866 ] 42 , 'constructorStrictness' = [ 'FieldStrictness' 43 'UnspecifiedUnpackedness' 44 'Lazy' 45 ] 46 , 'constructorVariant' = 'NormalConstructor' 47 } 48 ] 49 } 50@ 51 52Datatypes declared with GADT syntax are normalized to constructors with existentially 53quantified type variables and equality constraints. 54 55-} 56module Language.Haskell.TH.Datatype 57 ( 58 -- * Types 59 DatatypeInfo(..) 60 , ConstructorInfo(..) 61 , DatatypeVariant(..) 62 , ConstructorVariant(..) 63 , FieldStrictness(..) 64 , Unpackedness(..) 65 , Strictness(..) 66 67 -- * Normalization functions 68 , reifyDatatype 69 , reifyConstructor 70 , reifyRecord 71 , normalizeInfo 72 , normalizeDec 73 , normalizeCon 74 75 -- * 'DatatypeInfo' lookup functions 76 , lookupByConstructorName 77 , lookupByRecordName 78 79 -- * Type variable manipulation 80 , TypeSubstitution(..) 81 , quantifyType 82 , freeVariablesWellScoped 83 , freshenFreeVariables 84 85 -- * 'Pred' functions 86 , equalPred 87 , classPred 88 , asEqualPred 89 , asClassPred 90 91 -- * Backward compatible data definitions 92 , dataDCompat 93 , newtypeDCompat 94 , tySynInstDCompat 95 , pragLineDCompat 96 , arrowKCompat 97 98 -- * Strictness annotations 99 , isStrictAnnot 100 , notStrictAnnot 101 , unpackedAnnot 102 103 -- * Type simplification 104 , resolveTypeSynonyms 105 , resolveKindSynonyms 106 , resolvePredSynonyms 107 , resolveInfixT 108 109 -- * Fixities 110 , reifyFixityCompat 111 , showFixity 112 , showFixityDirection 113 114 -- * Convenience functions 115 , unifyTypes 116 , tvName 117 , tvKind 118 , datatypeType 119 ) where 120 121import Data.Data (Typeable, Data) 122import Data.Foldable (foldMap, foldl') 123import Data.List (nub, find, union, (\\)) 124import Data.Map (Map) 125import qualified Data.Map as Map 126import Data.Maybe 127import qualified Data.Set as Set 128import Data.Set (Set) 129import qualified Data.Traversable as T 130import Control.Monad 131import Language.Haskell.TH 132#if MIN_VERSION_template_haskell(2,11,0) 133 hiding (Extension(..)) 134#endif 135import Language.Haskell.TH.Datatype.Internal 136import Language.Haskell.TH.Lib (arrowK, starK) -- needed for th-2.4 137 138#ifdef HAS_GENERICS 139import GHC.Generics (Generic) 140#endif 141 142#if !MIN_VERSION_base(4,8,0) 143import Control.Applicative (Applicative(..), (<$>)) 144import Data.Monoid (Monoid(..)) 145#endif 146 147-- | Normalized information about newtypes and data types. 148-- 149-- 'DatatypeInfo' contains two fields, 'datatypeVars' and 'datatypeInstTypes', 150-- which encode information about the argument types. The simplest explanation 151-- is that 'datatypeVars' contains all the type /variables/ bound by the data 152-- type constructor, while 'datatypeInstTypes' contains the type /arguments/ 153-- to the data type constructor. To be more precise: 154-- 155-- * For ADTs declared with @data@ and @newtype@, it will likely be the case 156-- that 'datatypeVars' and 'datatypeInstTypes' coincide. For instance, given 157-- @newtype Id a = MkId a@, in the 'DatatypeInfo' for @Id@ we would 158-- have @'datatypeVars' = ['KindedTV' a 'StarT']@ and 159-- @'datatypeInstVars' = ['SigT' ('VarT' a) 'StarT']@. 160-- 161-- ADTs that leverage @PolyKinds@ may have more 'datatypeVars' than 162-- 'datatypeInstTypes'. For instance, given @data Proxy (a :: k) = MkProxy@, 163-- in the 'DatatypeInfo' for @Proxy@ we would have 164-- @'datatypeVars' = ['KindedTV' k 'StarT', 'KindedTV' a ('VarT' k)]@ (since 165-- there are two variables, @k@ and @a@), whereas 166-- @'datatypeInstTypes' = ['SigT' ('VarT' a) ('VarT' k)]@, since there is 167-- only one explicit type argument to @Proxy@. 168-- 169-- * For @data instance@s and @newtype instance@s of data families, 170-- 'datatypeVars' and 'datatypeInstTypes' can be quite different. Here is 171-- an example to illustrate the difference: 172-- 173-- @ 174-- data family F a b 175-- data instance F (Maybe c) (f x) = MkF c (f x) 176-- @ 177-- 178-- Then in the 'DatatypeInfo' for @F@'s data instance, we would have: 179-- 180-- @ 181-- 'datatypeVars' = [ 'KindedTV' c 'StarT' 182-- , 'KindedTV' f 'StarT' 183-- , 'KindedTV' x 'StarT' ] 184-- 'datatypeInstTypes' = [ 'AppT' ('ConT' ''Maybe) ('VarT' c) 185-- , 'AppT' ('VarT' f) ('VarT' x) ] 186-- @ 187data DatatypeInfo = DatatypeInfo 188 { datatypeContext :: Cxt -- ^ Data type context (deprecated) 189 , datatypeName :: Name -- ^ Type constructor 190 , datatypeVars :: [TyVarBndr] -- ^ Type parameters 191 , datatypeInstTypes :: [Type] -- ^ Argument types 192 , datatypeVariant :: DatatypeVariant -- ^ Extra information 193 , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information 194 } 195 deriving (Show, Eq, Typeable, Data 196#ifdef HAS_GENERICS 197 ,Generic 198#endif 199 ) 200 201-- | Possible variants of data type declarations. 202data DatatypeVariant 203 = Datatype -- ^ Type declared with @data@ 204 | Newtype -- ^ Type declared with @newtype@ 205 | DataInstance -- ^ Type declared with @data instance@ 206 | NewtypeInstance -- ^ Type declared with @newtype instance@ 207 deriving (Show, Read, Eq, Ord, Typeable, Data 208#ifdef HAS_GENERICS 209 ,Generic 210#endif 211 ) 212 213-- | Normalized information about constructors associated with newtypes and 214-- data types. 215data ConstructorInfo = ConstructorInfo 216 { constructorName :: Name -- ^ Constructor name 217 , constructorVars :: [TyVarBndr] -- ^ Constructor type parameters 218 , constructorContext :: Cxt -- ^ Constructor constraints 219 , constructorFields :: [Type] -- ^ Constructor fields 220 , constructorStrictness :: [FieldStrictness] -- ^ Constructor fields' strictness 221 -- (Invariant: has the same length 222 -- as constructorFields) 223 , constructorVariant :: ConstructorVariant -- ^ Extra information 224 } 225 deriving (Show, Eq, Typeable, Data 226#ifdef HAS_GENERICS 227 ,Generic 228#endif 229 ) 230 231-- | Possible variants of data constructors. 232data ConstructorVariant 233 = NormalConstructor -- ^ Constructor without field names 234 | InfixConstructor -- ^ Constructor without field names that is 235 -- declared infix 236 | RecordConstructor [Name] -- ^ Constructor with field names 237 deriving (Show, Eq, Ord, Typeable, Data 238#ifdef HAS_GENERICS 239 ,Generic 240#endif 241 ) 242 243-- | Normalized information about a constructor field's @UNPACK@ and 244-- strictness annotations. 245-- 246-- Note that the interface for reifying strictness in Template Haskell changed 247-- considerably in GHC 8.0. The presentation in this library mirrors that which 248-- can be found in GHC 8.0 or later, whereas previously, unpackedness and 249-- strictness were represented with a single data type: 250-- 251-- @ 252-- data Strict 253-- = IsStrict 254-- | NotStrict 255-- | Unpacked -- On GHC 7.4 or later 256-- @ 257-- 258-- For backwards compatibility, we retrofit these constructors onto the 259-- following three values, respectively: 260-- 261-- @ 262-- 'isStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'Strict' 263-- 'notStrictAnnot' = 'FieldStrictness' 'UnspecifiedUnpackedness' 'UnspecifiedStrictness' 264-- 'unpackedAnnot' = 'FieldStrictness' 'Unpack' 'Strict' 265-- @ 266data FieldStrictness = FieldStrictness 267 { fieldUnpackedness :: Unpackedness 268 , fieldStrictness :: Strictness 269 } 270 deriving (Show, Eq, Ord, Typeable, Data 271#ifdef HAS_GENERICS 272 ,Generic 273#endif 274 ) 275 276-- | Information about a constructor field's unpackedness annotation. 277data Unpackedness 278 = UnspecifiedUnpackedness -- ^ No annotation whatsoever 279 | NoUnpack -- ^ Annotated with @{\-\# NOUNPACK \#-\}@ 280 | Unpack -- ^ Annotated with @{\-\# UNPACK \#-\}@ 281 deriving (Show, Eq, Ord, Typeable, Data 282#ifdef HAS_GENERICS 283 ,Generic 284#endif 285 ) 286 287-- | Information about a constructor field's strictness annotation. 288data Strictness 289 = UnspecifiedStrictness -- ^ No annotation whatsoever 290 | Lazy -- ^ Annotated with @~@ 291 | Strict -- ^ Annotated with @!@ 292 deriving (Show, Eq, Ord, Typeable, Data 293#ifdef HAS_GENERICS 294 ,Generic 295#endif 296 ) 297 298isStrictAnnot, notStrictAnnot, unpackedAnnot :: FieldStrictness 299isStrictAnnot = FieldStrictness UnspecifiedUnpackedness Strict 300notStrictAnnot = FieldStrictness UnspecifiedUnpackedness UnspecifiedStrictness 301unpackedAnnot = FieldStrictness Unpack Strict 302 303-- | Construct a Type using the datatype's type constructor and type 304-- parameters. Kind signatures are removed. 305datatypeType :: DatatypeInfo -> Type 306datatypeType di 307 = foldl AppT (ConT (datatypeName di)) 308 $ map stripSigT 309 $ datatypeInstTypes di 310 311 312-- | Compute a normalized view of the metadata about a data type or newtype 313-- given a constructor. 314-- 315-- This function will accept any constructor (value or type) for a type 316-- declared with newtype or data. Value constructors must be used to 317-- lookup datatype information about /data instances/ and /newtype instances/, 318-- as giving the type constructor of a data family is often not enough to 319-- determine a particular data family instance. 320-- 321-- In addition, this function will also accept a record selector for a 322-- data type with a constructor which uses that record. 323-- 324-- GADT constructors are normalized into datatypes with explicit equality 325-- constraints. Note that no effort is made to distinguish between equalities of 326-- the same (homogeneous) kind and equalities between different (heterogeneous) 327-- kinds. For instance, the following GADT's constructors: 328-- 329-- @ 330-- data T (a :: k -> *) where 331-- MkT1 :: T Proxy 332-- MkT2 :: T Maybe 333-- @ 334-- 335-- will be normalized to the following equality constraints: 336-- 337-- @ 338-- AppT (AppT EqualityT (VarT a)) (ConT Proxy) -- MkT1 339-- AppT (AppT EqualityT (VarT a)) (ConT Maybe) -- MkT2 340-- @ 341-- 342-- But only the first equality constraint is well kinded, since in the second 343-- constraint, the kinds of @(a :: k -> *)@ and @(Maybe :: * -> *)@ are different. 344-- Trying to categorize which constraints need homogeneous or heterogeneous 345-- equality is tricky, so we leave that task to users of this library. 346-- 347-- This function will apply various bug-fixes to the output of the underlying 348-- @template-haskell@ library in order to provide a view of datatypes in 349-- as uniform a way as possible. 350reifyDatatype :: 351 Name {- ^ data type or constructor name -} -> 352 Q DatatypeInfo 353reifyDatatype n = normalizeInfo' "reifyDatatype" isReified =<< reify n 354 355-- | Compute a normalized view of the metadata about a constructor given its 356-- 'Name'. This is useful for scenarios when you don't care about the info for 357-- the enclosing data type. 358reifyConstructor :: 359 Name {- ^ constructor name -} -> 360 Q ConstructorInfo 361reifyConstructor conName = do 362 dataInfo <- reifyDatatype conName 363 return $ lookupByConstructorName conName dataInfo 364 365-- | Compute a normalized view of the metadata about a constructor given the 366-- 'Name' of one of its record selectors. This is useful for scenarios when you 367-- don't care about the info for the enclosing data type. 368reifyRecord :: 369 Name {- ^ record name -} -> 370 Q ConstructorInfo 371reifyRecord recordName = do 372 dataInfo <- reifyDatatype recordName 373 return $ lookupByRecordName recordName dataInfo 374 375-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the 376-- 'Name' of one of its constructors. 377lookupByConstructorName :: 378 Name {- ^ constructor name -} -> 379 DatatypeInfo {- ^ info for the datatype which has that constructor -} -> 380 ConstructorInfo 381lookupByConstructorName conName dataInfo = 382 case find ((== conName) . constructorName) (datatypeCons dataInfo) of 383 Just conInfo -> conInfo 384 Nothing -> error $ "Datatype " ++ nameBase (datatypeName dataInfo) 385 ++ " does not have a constructor named " ++ nameBase conName 386-- | Given a 'DatatypeInfo', find the 'ConstructorInfo' corresponding to the 387-- 'Name' of one of its constructors. 388lookupByRecordName :: 389 Name {- ^ record name -} -> 390 DatatypeInfo {- ^ info for the datatype which has that constructor -} -> 391 ConstructorInfo 392lookupByRecordName recordName dataInfo = 393 case find (conHasRecord recordName) (datatypeCons dataInfo) of 394 Just conInfo -> conInfo 395 Nothing -> error $ "Datatype " ++ nameBase (datatypeName dataInfo) 396 ++ " does not have any constructors with a " 397 ++ "record selector named " ++ nameBase recordName 398 399-- | Normalize 'Info' for a newtype or datatype into a 'DatatypeInfo'. 400-- Fail in 'Q' otherwise. 401normalizeInfo :: Info -> Q DatatypeInfo 402normalizeInfo = normalizeInfo' "normalizeInfo" isn'tReified 403 404normalizeInfo' :: String -> IsReifiedDec -> Info -> Q DatatypeInfo 405normalizeInfo' entry reifiedDec i = 406 case i of 407 PrimTyConI{} -> bad "Primitive type not supported" 408 ClassI{} -> bad "Class not supported" 409#if MIN_VERSION_template_haskell(2,11,0) 410 FamilyI DataFamilyD{} _ -> 411#elif MIN_VERSION_template_haskell(2,7,0) 412 FamilyI (FamilyD DataFam _ _ _) _ -> 413#else 414 TyConI (FamilyD DataFam _ _ _) -> 415#endif 416 bad "Use a value constructor to reify a data family instance" 417#if MIN_VERSION_template_haskell(2,7,0) 418 FamilyI _ _ -> bad "Type families not supported" 419#endif 420 TyConI dec -> normalizeDecFor reifiedDec dec 421#if MIN_VERSION_template_haskell(2,11,0) 422 DataConI name _ parent -> reifyParent name parent 423 -- NB: We do not pass the IsReifiedDec information here 424 -- because there's no point. We have no choice but to 425 -- call reify here, since we need to determine the 426 -- parent data type/family. 427#else 428 DataConI name _ parent _ -> reifyParent name parent 429#endif 430#if MIN_VERSION_template_haskell(2,11,0) 431 VarI recName recTy _ -> reifyRecordType recName recTy 432 -- NB: Similarly, we do not pass the IsReifiedDec 433 -- information here. 434#else 435 VarI recName recTy _ _ -> reifyRecordType recName recTy 436#endif 437 _ -> bad "Expected a type constructor" 438 where 439 bad msg = fail (entry ++ ": " ++ msg) 440 441 442reifyParent :: Name -> Name -> Q DatatypeInfo 443reifyParent con = reifyParentWith "reifyParent" p 444 where 445 p :: DatatypeInfo -> Bool 446 p info = con `elem` map constructorName (datatypeCons info) 447 448reifyRecordType :: Name -> Type -> Q DatatypeInfo 449reifyRecordType recName recTy = 450 let (_, _, argTys :|- _) = uncurryType recTy 451 in case argTys of 452 dataTy:_ -> decomposeDataType dataTy 453 _ -> notRecSelFailure 454 where 455 decomposeDataType :: Type -> Q DatatypeInfo 456 decomposeDataType ty = 457 do case decomposeType ty of 458 ConT parent :| _ -> reifyParentWith "reifyRecordType" p parent 459 _ -> notRecSelFailure 460 461 notRecSelFailure :: Q a 462 notRecSelFailure = fail $ 463 "reifyRecordType: Not a record selector type: " ++ 464 nameBase recName ++ " :: " ++ show recTy 465 466 p :: DatatypeInfo -> Bool 467 p info = any (conHasRecord recName) (datatypeCons info) 468 469reifyParentWith :: 470 String {- ^ prefix for error messages -} -> 471 (DatatypeInfo -> Bool) {- ^ predicate for finding the right 472 data family instance -} -> 473 Name {- ^ parent data type name -} -> 474 Q DatatypeInfo 475reifyParentWith prefix p n = 476 do info <- reify n 477 case info of 478#if !(MIN_VERSION_template_haskell(2,11,0)) 479 -- This unusual combination of Info and Dec is only possible to reify on 480 -- GHC 7.0 and 7.2, when you try to reify a data family. Because there's 481 -- no way to reify the data family *instances* on these versions of GHC, 482 -- we have no choice but to fail. 483 TyConI FamilyD{} -> dataFamiliesOnOldGHCsError 484#endif 485 TyConI dec -> normalizeDecFor isReified dec 486#if MIN_VERSION_template_haskell(2,7,0) 487 FamilyI dec instances -> 488 do let instances1 = map (repairDataFam dec) instances 489 instances2 <- mapM (normalizeDecFor isReified) instances1 490 case find p instances2 of 491 Just inst -> return inst 492 Nothing -> panic "lost the instance" 493#endif 494 _ -> panic "unexpected parent" 495 where 496 dataFamiliesOnOldGHCsError :: Q a 497 dataFamiliesOnOldGHCsError = fail $ 498 prefix ++ ": Data family instances can only be reified with GHC 7.4 or later" 499 500 panic :: String -> Q a 501 panic message = fail $ "PANIC: " ++ prefix ++ " " ++ message 502 503#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0)) 504 505-- A GHC 7.6-specific bug requires us to replace all occurrences of 506-- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. 507-- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. 508sanitizeStars :: Kind -> Kind 509sanitizeStars = go 510 where 511 go :: Kind -> Kind 512 go (AppT t1 t2) = AppT (go t1) (go t2) 513 go (SigT t k) = SigT (go t) (go k) 514 go (ConT n) | n == starKindName = StarT 515 go t = t 516 517-- A version of repairVarKindsWith that does much more extra work to 518-- (1) eta-expand missing type patterns, and (2) ensure that the kind 519-- signatures for these new type patterns match accordingly. 520repairVarKindsWith' :: [TyVarBndr] -> [Type] -> [Type] 521repairVarKindsWith' dvars ts = 522 let kindVars = freeVariables . map kindPart 523 kindPart (KindedTV _ k) = [k] 524 kindPart (PlainTV _ ) = [] 525 526 nparams = length dvars 527 kparams = kindVars dvars 528 (tsKinds,tsNoKinds) = splitAt (length kparams) ts 529 tsKinds' = map sanitizeStars tsKinds 530 extraTys = drop (length tsNoKinds) (bndrParams dvars) 531 ts' = tsNoKinds ++ extraTys -- eta-expand 532 in applySubstitution (Map.fromList (zip kparams tsKinds')) $ 533 repairVarKindsWith dvars ts' 534 535 536-- Sadly, Template Haskell's treatment of data family instances leaves much 537-- to be desired. Here are some problems that we have to work around: 538-- 539-- 1. On all versions of GHC, TH leaves off the kind signatures on the 540-- type patterns of data family instances where a kind signature isn't 541-- specified explicitly. Here, we can use the parent data family's 542-- type variable binders to reconstruct the kind signatures if they 543-- are missing. 544-- 2. On GHC 7.6 and 7.8, TH will eta-reduce data instances. We can find 545-- the missing type variables on the data constructor. 546-- 547-- We opt to avoid propagating these new type variables through to the 548-- constructor now, but we will return to this task in normalizeCon. 549repairDataFam :: 550 Dec {- ^ family declaration -} -> 551 Dec {- ^ instance declaration -} -> 552 Dec {- ^ instance declaration -} 553 554repairDataFam 555 (FamilyD _ _ dvars _) 556 (NewtypeInstD cx n ts con deriv) = 557 NewtypeInstD cx n (repairVarKindsWith' dvars ts) con deriv 558repairDataFam 559 (FamilyD _ _ dvars _) 560 (DataInstD cx n ts cons deriv) = 561 DataInstD cx n (repairVarKindsWith' dvars ts) cons deriv 562#else 563repairDataFam famD instD 564# if MIN_VERSION_template_haskell(2,15,0) 565 | DataFamilyD _ dvars _ <- famD 566 , NewtypeInstD cx mbInstVars nts k c deriv <- instD 567 , con :| ts <- decomposeType nts 568 = NewtypeInstD cx mbInstVars 569 (foldl' AppT con (repairVarKindsWith dvars ts)) 570 k c deriv 571 572 | DataFamilyD _ dvars _ <- famD 573 , DataInstD cx mbInstVars nts k c deriv <- instD 574 , con :| ts <- decomposeType nts 575 = DataInstD cx mbInstVars 576 (foldl' AppT con (repairVarKindsWith dvars ts)) 577 k c deriv 578# elif MIN_VERSION_template_haskell(2,11,0) 579 | DataFamilyD _ dvars _ <- famD 580 , NewtypeInstD cx n ts k c deriv <- instD 581 = NewtypeInstD cx n (repairVarKindsWith dvars ts) k c deriv 582 583 | DataFamilyD _ dvars _ <- famD 584 , DataInstD cx n ts k c deriv <- instD 585 = DataInstD cx n (repairVarKindsWith dvars ts) k c deriv 586# else 587 | FamilyD _ _ dvars _ <- famD 588 , NewtypeInstD cx n ts c deriv <- instD 589 = NewtypeInstD cx n (repairVarKindsWith dvars ts) c deriv 590 591 | FamilyD _ _ dvars _ <- famD 592 , DataInstD cx n ts c deriv <- instD 593 = DataInstD cx n (repairVarKindsWith dvars ts) c deriv 594# endif 595#endif 596repairDataFam _ instD = instD 597 598repairVarKindsWith :: [TyVarBndr] -> [Type] -> [Type] 599repairVarKindsWith = zipWith stealKindForType 600 601-- If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. 602stealKindForType :: TyVarBndr -> Type -> Type 603stealKindForType tvb t@VarT{} = SigT t (tvKind tvb) 604stealKindForType _ t = t 605 606-- | Normalize 'Dec' for a newtype or datatype into a 'DatatypeInfo'. 607-- Fail in 'Q' otherwise. 608-- 609-- Beware: 'normalizeDec' can have surprising behavior when it comes to fixity. 610-- For instance, if you have this quasiquoted data declaration: 611-- 612-- @ 613-- [d| infix 5 :^^: 614-- data Foo where 615-- (:^^:) :: Int -> Int -> Foo |] 616-- @ 617-- 618-- Then if you pass the 'Dec' for @Foo@ to 'normalizeDec' without splicing it 619-- in a previous Template Haskell splice, then @(:^^:)@ will be labeled a 'NormalConstructor' 620-- instead of an 'InfixConstructor'. This is because Template Haskell has no way to 621-- reify the fixity declaration for @(:^^:)@, so it must assume there isn't one. To 622-- work around this behavior, use 'reifyDatatype' instead. 623normalizeDec :: Dec -> Q DatatypeInfo 624normalizeDec = normalizeDecFor isn'tReified 625 626normalizeDecFor :: IsReifiedDec -> Dec -> Q DatatypeInfo 627normalizeDecFor isReified dec = 628 case dec of 629#if MIN_VERSION_template_haskell(2,12,0) 630 NewtypeD context name tyvars mbKind con _derives -> 631 normalizeDataD context name tyvars mbKind [con] Newtype 632 DataD context name tyvars mbKind cons _derives -> 633 normalizeDataD context name tyvars mbKind cons Datatype 634# if MIN_VERSION_template_haskell(2,15,0) 635 NewtypeInstD context mbTyvars nameInstTys mbKind con _derives -> 636 normalizeDataInstDPostTH2'15 "newtype" context mbTyvars nameInstTys 637 mbKind [con] NewtypeInstance 638 DataInstD context mbTyvars nameInstTys mbKind cons _derives -> 639 normalizeDataInstDPostTH2'15 "data" context mbTyvars nameInstTys 640 mbKind cons DataInstance 641# else 642 NewtypeInstD context name instTys mbKind con _derives -> 643 normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance 644 DataInstD context name instTys mbKind cons _derives -> 645 normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance 646# endif 647#elif MIN_VERSION_template_haskell(2,11,0) 648 NewtypeD context name tyvars mbKind con _derives -> 649 normalizeDataD context name tyvars mbKind [con] Newtype 650 DataD context name tyvars mbKind cons _derives -> 651 normalizeDataD context name tyvars mbKind cons Datatype 652 NewtypeInstD context name instTys mbKind con _derives -> 653 normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance 654 DataInstD context name instTys mbKind cons _derives -> 655 normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance 656#else 657 NewtypeD context name tyvars con _derives -> 658 normalizeDataD context name tyvars Nothing [con] Newtype 659 DataD context name tyvars cons _derives -> 660 normalizeDataD context name tyvars Nothing cons Datatype 661 NewtypeInstD context name instTys con _derives -> 662 normalizeDataInstDPreTH2'15 context name instTys Nothing [con] NewtypeInstance 663 DataInstD context name instTys cons _derives -> 664 normalizeDataInstDPreTH2'15 context name instTys Nothing cons DataInstance 665#endif 666 _ -> fail "normalizeDecFor: DataD or NewtypeD required" 667 where 668 -- We only need to repair reified declarations for data family instances. 669 repair13618' :: DatatypeInfo -> Q DatatypeInfo 670 repair13618' di@DatatypeInfo{datatypeVariant = variant} 671 | isReified && isFamInstVariant variant 672 = repair13618 di 673 | otherwise 674 = return di 675 676 -- Given a data type's instance types and kind, compute its free variables. 677 datatypeFreeVars :: [Type] -> Maybe Kind -> [TyVarBndr] 678 datatypeFreeVars instTys mbKind = 679 freeVariablesWellScoped $ instTys ++ 680#if MIN_VERSION_template_haskell(2,8,0) 681 maybeToList mbKind 682#else 683 [] -- No kind variables 684#endif 685 686 normalizeDataD :: Cxt -> Name -> [TyVarBndr] -> Maybe Kind 687 -> [Con] -> DatatypeVariant -> Q DatatypeInfo 688 normalizeDataD context name tyvars mbKind cons variant = 689 let params = bndrParams tyvars in 690 normalize' context name (datatypeFreeVars params mbKind) 691 params mbKind cons variant 692 693 normalizeDataInstDPostTH2'15 694 :: String -> Cxt -> Maybe [TyVarBndr] -> Type -> Maybe Kind 695 -> [Con] -> DatatypeVariant -> Q DatatypeInfo 696 normalizeDataInstDPostTH2'15 what context mbTyvars nameInstTys 697 mbKind cons variant = 698 case decomposeType nameInstTys of 699 ConT name :| instTys -> 700 normalize' context name 701 (fromMaybe (datatypeFreeVars instTys mbKind) mbTyvars) 702 instTys mbKind cons variant 703 _ -> fail $ "Unexpected " ++ what ++ " instance head: " ++ pprint nameInstTys 704 705 normalizeDataInstDPreTH2'15 706 :: Cxt -> Name -> [Type] -> Maybe Kind 707 -> [Con] -> DatatypeVariant -> Q DatatypeInfo 708 normalizeDataInstDPreTH2'15 context name instTys mbKind cons variant = 709 normalize' context name (datatypeFreeVars instTys mbKind) 710 instTys mbKind cons variant 711 712 -- The main worker of this function. 713 normalize' :: Cxt -> Name -> [TyVarBndr] -> [Type] -> Maybe Kind 714 -> [Con] -> DatatypeVariant -> Q DatatypeInfo 715 normalize' context name tvbs instTys mbKind cons variant = do 716 extra_tvbs <- mkExtraKindBinders $ fromMaybe starK mbKind 717 let tvbs' = tvbs ++ extra_tvbs 718 instTys' = instTys ++ bndrParams extra_tvbs 719 dec <- normalizeDec' isReified context name tvbs' instTys' cons variant 720 repair13618' $ giveDIVarsStarKinds dec 721 722-- | Create new kind variable binder names corresponding to the return kind of 723-- a data type. This is useful when you have a data type like: 724-- 725-- @ 726-- data Foo :: forall k. k -> Type -> Type where ... 727-- @ 728-- 729-- But you want to be able to refer to the type @Foo a b@. 730-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@, 731-- discover that is has two visible argument kinds, and return as a result 732-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@ 733-- are fresh type variable names. 734-- 735-- This expands kind synonyms if necessary. 736mkExtraKindBinders :: Kind -> Q [TyVarBndr] 737mkExtraKindBinders kind = do 738 kind' <- resolveKindSynonyms kind 739 let (_, _, args :|- _) = uncurryKind kind' 740 names <- replicateM (length args) (newName "x") 741 return $ zipWith KindedTV names args 742 743-- | Is a declaration for a @data instance@ or @newtype instance@? 744isFamInstVariant :: DatatypeVariant -> Bool 745isFamInstVariant dv = 746 case dv of 747 Datatype -> False 748 Newtype -> False 749 DataInstance -> True 750 NewtypeInstance -> True 751 752bndrParams :: [TyVarBndr] -> [Type] 753bndrParams = map $ \bndr -> 754 case bndr of 755 KindedTV t k -> SigT (VarT t) k 756 PlainTV t -> VarT t 757 758-- | Extract the kind from a 'TyVarBndr'. Assumes 'PlainTV' has kind @*@. 759tvKind :: TyVarBndr -> Kind 760tvKind (PlainTV _) = starK 761tvKind (KindedTV _ k) = k 762 763-- | Remove the outermost 'SigT'. 764stripSigT :: Type -> Type 765stripSigT (SigT t _) = t 766stripSigT t = t 767 768 769normalizeDec' :: 770 IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> 771 Cxt {- ^ Datatype context -} -> 772 Name {- ^ Type constructor -} -> 773 [TyVarBndr] {- ^ Type parameters -} -> 774 [Type] {- ^ Argument types -} -> 775 [Con] {- ^ Constructors -} -> 776 DatatypeVariant {- ^ Extra information -} -> 777 Q DatatypeInfo 778normalizeDec' reifiedDec context name params instTys cons variant = 779 do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params instTys variant) cons 780 return DatatypeInfo 781 { datatypeContext = context 782 , datatypeName = name 783 , datatypeVars = params 784 , datatypeInstTypes = instTys 785 , datatypeCons = cons' 786 , datatypeVariant = variant 787 } 788 789-- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of 790-- the type and parameters of the constructor, as well as whether the constructor 791-- is for a data family instance, as extracted from the outer 792-- 'Dec'. 793normalizeCon :: 794 Name {- ^ Type constructor -} -> 795 [TyVarBndr] {- ^ Type parameters -} -> 796 [Type] {- ^ Argument types -} -> 797 DatatypeVariant {- ^ Extra information -} -> 798 Con {- ^ Constructor -} -> 799 Q [ConstructorInfo] 800normalizeCon = normalizeConFor isn'tReified 801 802normalizeConFor :: 803 IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> 804 Name {- ^ Type constructor -} -> 805 [TyVarBndr] {- ^ Type parameters -} -> 806 [Type] {- ^ Argument types -} -> 807 DatatypeVariant {- ^ Extra information -} -> 808 Con {- ^ Constructor -} -> 809 Q [ConstructorInfo] 810normalizeConFor reifiedDec typename params instTys variant = 811 fmap (map giveCIVarsStarKinds) . dispatch 812 where 813 -- A GADT constructor is declared infix when: 814 -- 815 -- 1. Its name uses operator syntax (e.g., (:*:)) 816 -- 2. It has exactly two fields 817 -- 3. It has a programmer-supplied fixity declaration 818 checkGadtFixity :: [Type] -> Name -> Q ConstructorVariant 819 checkGadtFixity ts n = do 820#if MIN_VERSION_template_haskell(2,11,0) 821 -- Don't call reifyFixityCompat here! We need to be able to distinguish 822 -- between a default fixity and an explicit @infixl 9@. 823 mbFi <- return Nothing `recover` reifyFixity n 824 let userSuppliedFixity = isJust mbFi 825#else 826 -- On old GHCs, there is a bug where infix GADT constructors will 827 -- mistakenly be marked as (ForallC (NormalC ...)) instead of 828 -- (ForallC (InfixC ...)). This is especially annoying since on these 829 -- versions of GHC, Template Haskell doesn't grant the ability to query 830 -- whether a constructor was given a user-supplied fixity declaration. 831 -- Rather, you can only check the fixity that GHC ultimately decides on 832 -- for a constructor, regardless of whether it was a default fixity or 833 -- it was user-supplied. 834 -- 835 -- We can approximate whether a fixity was user-supplied by checking if 836 -- it is not equal to defaultFixity (infixl 9). Unfortunately, 837 -- there is no way to distinguish between a user-supplied fixity of 838 -- infixl 9 and the fixity that GHC defaults to, so we cannot properly 839 -- handle that case. 840 mbFi <- reifyFixityCompat n 841 let userSuppliedFixity = isJust mbFi && mbFi /= Just defaultFixity 842#endif 843 return $ if isInfixDataCon (nameBase n) 844 && length ts == 2 845 && userSuppliedFixity 846 then InfixConstructor 847 else NormalConstructor 848 849 -- Checks if a String names a valid Haskell infix data 850 -- constructor (i.e., does it begin with a colon?). 851 isInfixDataCon :: String -> Bool 852 isInfixDataCon (':':_) = True 853 isInfixDataCon _ = False 854 855 dispatch :: Con -> Q [ConstructorInfo] 856 dispatch = 857 let defaultCase :: Con -> Q [ConstructorInfo] 858 defaultCase = go [] [] False 859 where 860 go :: [TyVarBndr] 861 -> Cxt 862 -> Bool -- Is this a GADT? (see the documentation for 863 -- for checkGadtFixity) 864 -> Con 865 -> Q [ConstructorInfo] 866 go tyvars context gadt c = 867 case c of 868 NormalC n xs -> do 869 let (bangs, ts) = unzip xs 870 stricts = map normalizeStrictness bangs 871 fi <- if gadt 872 then checkGadtFixity ts n 873 else return NormalConstructor 874 return [ConstructorInfo n tyvars context ts stricts fi] 875 InfixC l n r -> 876 let (bangs, ts) = unzip [l,r] 877 stricts = map normalizeStrictness bangs in 878 return [ConstructorInfo n tyvars context ts stricts 879 InfixConstructor] 880 RecC n xs -> 881 let fns = takeFieldNames xs 882 stricts = takeFieldStrictness xs in 883 return [ConstructorInfo n tyvars context 884 (takeFieldTypes xs) stricts (RecordConstructor fns)] 885 ForallC tyvars' context' c' -> 886 go (tyvars'++tyvars) (context'++context) True c' 887#if MIN_VERSION_template_haskell(2,11,0) 888 GadtC ns xs innerType -> 889 let (bangs, ts) = unzip xs 890 stricts = map normalizeStrictness bangs in 891 gadtCase ns innerType ts stricts (checkGadtFixity ts) 892 RecGadtC ns xs innerType -> 893 let fns = takeFieldNames xs 894 stricts = takeFieldStrictness xs in 895 gadtCase ns innerType (takeFieldTypes xs) stricts 896 (const $ return $ RecordConstructor fns) 897 where 898 gadtCase = normalizeGadtC typename params instTys tyvars context 899#endif 900#if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0)) 901 dataFamCompatCase :: Con -> Q [ConstructorInfo] 902 dataFamCompatCase = go [] 903 where 904 go tyvars c = 905 case c of 906 NormalC n xs -> 907 let stricts = map (normalizeStrictness . fst) xs in 908 dataFamCase' n stricts NormalConstructor 909 InfixC l n r -> 910 let stricts = map (normalizeStrictness . fst) [l,r] in 911 dataFamCase' n stricts InfixConstructor 912 RecC n xs -> 913 let stricts = takeFieldStrictness xs in 914 dataFamCase' n stricts 915 (RecordConstructor (takeFieldNames xs)) 916 ForallC tyvars' context' c' -> 917 go (tyvars'++tyvars) c' 918 919 dataFamCase' :: Name -> [FieldStrictness] 920 -> ConstructorVariant 921 -> Q [ConstructorInfo] 922 dataFamCase' n stricts variant = do 923 mbInfo <- reifyMaybe n 924 case mbInfo of 925 Just (DataConI _ ty _ _) -> do 926 let (tyvars, context, argTys :|- returnTy) = uncurryType ty 927 returnTy' <- resolveTypeSynonyms returnTy 928 -- Notice that we've ignored the TyVarBndrs, Cxt and argument 929 -- Types from the Con argument above, as they might be scoped 930 -- over eta-reduced variables. Instead of trying to figure out 931 -- what the eta-reduced variables should be substituted with 932 -- post facto, we opt for the simpler approach of using the 933 -- context and argument types from the reified constructor 934 -- Info, which will at least be correctly scoped. This will 935 -- make the task of substituting those types with the variables 936 -- we put in place of the eta-reduced variables 937 -- (in normalizeDec) much easier. 938 normalizeGadtC typename params instTys tyvars context [n] 939 returnTy' argTys stricts (const $ return variant) 940 _ -> fail $ unlines 941 [ "normalizeCon: Cannot reify constructor " ++ nameBase n 942 , "You are likely calling normalizeDec on GHC 7.6 or 7.8 on a data family" 943 , "whose type variables have been eta-reduced due to GHC Trac #9692." 944 , "Unfortunately, without being able to reify the constructor's type," 945 , "there is no way to recover the eta-reduced type variables in general." 946 , "A recommended workaround is to use reifyDatatype instead." 947 ] 948 949 -- A very ad hoc way of determining if we need to perform some extra passes 950 -- to repair an eta-reduction bug for data family instances that only occurs 951 -- with GHC 7.6 and 7.8. We want to avoid doing these passes if at all possible, 952 -- since they require reifying extra information, and reifying during 953 -- normalization can be problematic for locally declared Template Haskell 954 -- splices (see ##22). 955 mightHaveBeenEtaReduced :: [Type] -> Bool 956 mightHaveBeenEtaReduced ts = 957 case unsnoc ts of 958 Nothing -> False 959 Just (initTs :|- lastT) -> 960 case varTName lastT of 961 Nothing -> False 962 Just n -> not (n `elem` freeVariables initTs) 963 964 -- If the list is empty returns 'Nothing', otherwise returns the 965 -- 'init' and the 'last'. 966 unsnoc :: [a] -> Maybe (NonEmptySnoc a) 967 unsnoc [] = Nothing 968 unsnoc (x:xs) = case unsnoc xs of 969 Just (a :|- b) -> Just ((x:a) :|- b) 970 Nothing -> Just ([] :|- x) 971 972 -- If a Type is a VarT, find Just its Name. Otherwise, return Nothing. 973 varTName :: Type -> Maybe Name 974 varTName (SigT t _) = varTName t 975 varTName (VarT n) = Just n 976 varTName _ = Nothing 977 978 in case variant of 979 -- On GHC 7.6 and 7.8, there's quite a bit of post-processing that 980 -- needs to be performed to work around an old bug that eta-reduces the 981 -- type patterns of data families (but only for reified data family instances). 982 DataInstance 983 | reifiedDec, mightHaveBeenEtaReduced instTys 984 -> dataFamCompatCase 985 NewtypeInstance 986 | reifiedDec, mightHaveBeenEtaReduced instTys 987 -> dataFamCompatCase 988 _ -> defaultCase 989#else 990 in defaultCase 991#endif 992 993#if MIN_VERSION_template_haskell(2,11,0) 994normalizeStrictness :: Bang -> FieldStrictness 995normalizeStrictness (Bang upk str) = 996 FieldStrictness (normalizeSourceUnpackedness upk) 997 (normalizeSourceStrictness str) 998 where 999 normalizeSourceUnpackedness :: SourceUnpackedness -> Unpackedness 1000 normalizeSourceUnpackedness NoSourceUnpackedness = UnspecifiedUnpackedness 1001 normalizeSourceUnpackedness SourceNoUnpack = NoUnpack 1002 normalizeSourceUnpackedness SourceUnpack = Unpack 1003 1004 normalizeSourceStrictness :: SourceStrictness -> Strictness 1005 normalizeSourceStrictness NoSourceStrictness = UnspecifiedStrictness 1006 normalizeSourceStrictness SourceLazy = Lazy 1007 normalizeSourceStrictness SourceStrict = Strict 1008#else 1009normalizeStrictness :: Strict -> FieldStrictness 1010normalizeStrictness IsStrict = isStrictAnnot 1011normalizeStrictness NotStrict = notStrictAnnot 1012# if MIN_VERSION_template_haskell(2,7,0) 1013normalizeStrictness Unpacked = unpackedAnnot 1014# endif 1015#endif 1016 1017normalizeGadtC :: 1018 Name {- ^ Type constructor -} -> 1019 [TyVarBndr] {- ^ Type parameters -} -> 1020 [Type] {- ^ Argument types -} -> 1021 [TyVarBndr] {- ^ Constructor parameters -} -> 1022 Cxt {- ^ Constructor context -} -> 1023 [Name] {- ^ Constructor names -} -> 1024 Type {- ^ Declared type of constructor -} -> 1025 [Type] {- ^ Constructor field types -} -> 1026 [FieldStrictness] {- ^ Constructor field strictness -} -> 1027 (Name -> Q ConstructorVariant) 1028 {- ^ Determine a constructor variant 1029 from its 'Name' -} -> 1030 Q [ConstructorInfo] 1031normalizeGadtC typename params instTys tyvars context names innerType 1032 fields stricts getVariant = 1033 do -- It's possible that the constructor has implicitly quantified type 1034 -- variables, such as in the following example (from #58): 1035 -- 1036 -- [d| data Foo where 1037 -- MkFoo :: a -> Foo |] 1038 -- 1039 -- normalizeGadtC assumes that all type variables have binders, however, 1040 -- so we use freeVariablesWellScoped to obtain the implicit type 1041 -- variables' binders before proceeding. 1042 let implicitTyvars = freeVariablesWellScoped 1043 [curryType tyvars context fields innerType] 1044 allTyvars = implicitTyvars ++ tyvars 1045 1046 -- Due to GHC Trac #13885, it's possible that the type variables bound by 1047 -- a GADT constructor will shadow those that are bound by the data type. 1048 -- This function assumes this isn't the case in certain parts (e.g., when 1049 -- mergeArguments is invoked), so we do an alpha-renaming of the 1050 -- constructor-bound variables before proceeding. See #36 for an example 1051 -- of what can go wrong if this isn't done. 1052 let conBoundNames = 1053 concatMap (\tvb -> tvName tvb:freeVariables (tvKind tvb)) allTyvars 1054 conSubst <- T.sequence $ Map.fromList [ (n, newName (nameBase n)) 1055 | n <- conBoundNames ] 1056 let conSubst' = fmap VarT conSubst 1057 renamedTyvars = 1058 map (\tvb -> case tvb of 1059 PlainTV n -> PlainTV (conSubst Map.! n) 1060 KindedTV n k -> KindedTV (conSubst Map.! n) 1061 (applySubstitution conSubst' k)) allTyvars 1062 renamedContext = applySubstitution conSubst' context 1063 renamedInnerType = applySubstitution conSubst' innerType 1064 renamedFields = applySubstitution conSubst' fields 1065 1066 innerType' <- resolveTypeSynonyms renamedInnerType 1067 case decomposeType innerType' of 1068 ConT innerTyCon :| ts | typename == innerTyCon -> 1069 1070 let (substName, context1) = 1071 closeOverKinds (kindsOfFVsOfTvbs renamedTyvars) 1072 (kindsOfFVsOfTvbs params) 1073 (mergeArguments instTys ts) 1074 subst = VarT <$> substName 1075 exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv) subst ] 1076 1077 exTyvars' = substTyVarBndrs subst exTyvars 1078 context2 = applySubstitution subst (context1 ++ renamedContext) 1079 fields' = applySubstitution subst renamedFields 1080 in sequence [ ConstructorInfo name exTyvars' context2 1081 fields' stricts <$> variantQ 1082 | name <- names 1083 , let variantQ = getVariant name 1084 ] 1085 1086 _ -> fail "normalizeGadtC: Expected type constructor application" 1087 1088{- 1089Extend a type variable renaming subtitution and a list of equality 1090predicates by looking into kind information as much as possible. 1091 1092Why is this necessary? Consider the following example: 1093 1094 data (a1 :: k1) :~: (b1 :: k1) where 1095 Refl :: forall k2 (a2 :: k2). a2 :~: a2 1096 1097After an initial call to mergeArguments, we will have the following 1098substitution and context: 1099 1100* Substitution: [a2 :-> a1] 1101* Context: (a2 ~ b1) 1102 1103We shouldn't stop there, however! We determine the existentially quantified 1104type variables of a constructor by filtering out those constructor-bound 1105variables which do not appear in the substitution that mergeArguments 1106returns. In this example, Refl's bound variables are k2 and a2. a2 appears 1107in the returned substitution, but k2 does not, which means that we would 1108mistakenly conclude that k2 is existential! 1109 1110Although we don't have the full power of kind inference to guide us here, we 1111can at least do the next best thing. Generally, the datatype-bound type 1112variables and the constructor type variable binders contain all of the kind 1113information we need, so we proceed as follows: 1114 11151. Construct a map from each constructor-bound variable to its kind. (Do the 1116 same for each datatype-bound variable). These maps are the first and second 1117 arguments to closeOverKinds, respectively. 11182. Call mergeArguments once on the GADT return type and datatype-bound types, 1119 and pass that in as the third argument to closeOverKinds. 11203. For each name-name pair in the supplied substitution, check if the first and 1121 second names map to kinds in the first and second kind maps in 1122 closeOverKinds, respectively. If so, associate the first kind with the 1123 second kind. 11244. For each kind association discovered in part (3), call mergeArguments 1125 on the lists of kinds. This will yield a kind substitution and kind 1126 equality context. 11275. If the kind substitution is non-empty, then go back to step (3) and repeat 1128 the process on the new kind substitution and context. 1129 1130 Otherwise, if the kind substitution is empty, then we have reached a fixed- 1131 point (i.e., we have closed over the kinds), so proceed. 11326. Union up all of the substitutions and contexts, and return those. 1133 1134This algorithm is not perfect, as it will only catch everything if all of 1135the kinds are explicitly mentioned somewhere (and not left quantified 1136implicitly). Thankfully, reifying data types via Template Haskell tends to 1137yield a healthy amount of kind signatures, so this works quite well in 1138practice. 1139-} 1140closeOverKinds :: Map Name Kind 1141 -> Map Name Kind 1142 -> (Map Name Name, Cxt) 1143 -> (Map Name Name, Cxt) 1144closeOverKinds domainFVKinds rangeFVKinds = go 1145 where 1146 go :: (Map Name Name, Cxt) -> (Map Name Name, Cxt) 1147 go (subst, context) = 1148 let substList = Map.toList subst 1149 (kindsInner, kindsOuter) = 1150 unzip $ 1151 mapMaybe (\(d, r) -> do d' <- Map.lookup d domainFVKinds 1152 r' <- Map.lookup r rangeFVKinds 1153 return (d', r')) 1154 substList 1155 (kindSubst, kindContext) = mergeArgumentKinds kindsOuter kindsInner 1156 (restSubst, restContext) 1157 = if Map.null kindSubst -- Fixed-point calculation 1158 then (Map.empty, []) 1159 else go (kindSubst, kindContext) 1160 finalSubst = Map.unions [subst, kindSubst, restSubst] 1161 finalContext = nub $ concat [context, kindContext, restContext] 1162 -- Use `nub` here in an effort to minimize the number of 1163 -- redundant equality constraints in the returned context. 1164 in (finalSubst, finalContext) 1165 1166-- Look into a list of types and map each free variable name to its kind. 1167kindsOfFVsOfTypes :: [Type] -> Map Name Kind 1168kindsOfFVsOfTypes = foldMap go 1169 where 1170 go :: Type -> Map Name Kind 1171 go (AppT t1 t2) = go t1 `Map.union` go t2 1172 go (SigT t k) = 1173 let kSigs = 1174#if MIN_VERSION_template_haskell(2,8,0) 1175 go k 1176#else 1177 Map.empty 1178#endif 1179 in case t of 1180 VarT n -> Map.insert n k kSigs 1181 _ -> go t `Map.union` kSigs 1182 1183 go (ForallT {}) = forallError 1184#if MIN_VERSION_template_haskell(2,16,0) 1185 go (ForallVisT {}) = forallError 1186#endif 1187 1188 go _ = Map.empty 1189 1190 forallError :: a 1191 forallError = error "`forall` type used in data family pattern" 1192 1193-- Look into a list of type variable binder and map each free variable name 1194-- to its kind (also map the names that KindedTVs bind to their respective 1195-- kinds). This function considers the kind of a PlainTV to be *. 1196kindsOfFVsOfTvbs :: [TyVarBndr] -> Map Name Kind 1197kindsOfFVsOfTvbs = foldMap go 1198 where 1199 go :: TyVarBndr -> Map Name Kind 1200 go (PlainTV n) = Map.singleton n starK 1201 go (KindedTV n k) = 1202 let kSigs = 1203#if MIN_VERSION_template_haskell(2,8,0) 1204 kindsOfFVsOfTypes [k] 1205#else 1206 Map.empty 1207#endif 1208 in Map.insert n k kSigs 1209 1210mergeArguments :: 1211 [Type] {- ^ outer parameters -} -> 1212 [Type] {- ^ inner parameters (specializations ) -} -> 1213 (Map Name Name, Cxt) 1214mergeArguments ns ts = foldr aux (Map.empty, []) (zip ns ts) 1215 where 1216 1217 aux (f `AppT` x, g `AppT` y) sc = 1218 aux (x,y) (aux (f,g) sc) 1219 1220 aux (VarT n,p) (subst, context) = 1221 case p of 1222 VarT m | m == n -> (subst, context) 1223 -- If the two variables are the same, don't bother extending 1224 -- the substitution. (This is purely an optimization.) 1225 | Just n' <- Map.lookup m subst 1226 , n == n' -> (subst, context) 1227 -- If a variable is already in a substitution and it maps 1228 -- to the variable that we are trying to unify with, then 1229 -- leave the context alone. (Not doing so caused #46.) 1230 | Map.notMember m subst -> (Map.insert m n subst, context) 1231 _ -> (subst, equalPred (VarT n) p : context) 1232 1233 aux (SigT x _, y) sc = aux (x,y) sc -- learn about kinds?? 1234 -- This matches *after* VarT so that we can compute a substitution 1235 -- that includes the kind signature. 1236 aux (x, SigT y _) sc = aux (x,y) sc 1237 1238 aux _ sc = sc 1239 1240-- | A specialization of 'mergeArguments' to 'Kind'. 1241-- Needed only for backwards compatibility with older versions of 1242-- @template-haskell@. 1243mergeArgumentKinds :: 1244 [Kind] -> 1245 [Kind] -> 1246 (Map Name Name, Cxt) 1247#if MIN_VERSION_template_haskell(2,8,0) 1248mergeArgumentKinds = mergeArguments 1249#else 1250mergeArgumentKinds _ _ = (Map.empty, []) 1251#endif 1252 1253-- | Expand all of the type synonyms in a type. 1254-- 1255-- Note that this function will drop parentheses as a side effect. 1256resolveTypeSynonyms :: Type -> Q Type 1257resolveTypeSynonyms t = 1258 let (f, xs) = decomposeTypeArgs t 1259 1260 notTypeSynCase :: Type -> Q Type 1261 notTypeSynCase ty = foldl appTypeArg ty <$> mapM resolveTypeArgSynonyms xs 1262 1263 expandCon :: Name -- The Name to check whether it is a type synonym or not 1264 -> Type -- The argument type to fall back on if the supplied 1265 -- Name isn't a type synonym 1266 -> Q Type 1267 expandCon n ty = do 1268 mbInfo <- reifyMaybe n 1269 case mbInfo of 1270 Just (TyConI (TySynD _ synvars def)) 1271 -> resolveTypeSynonyms $ expandSynonymRHS synvars (filterTANormals xs) def 1272 _ -> notTypeSynCase ty 1273 1274 in case f of 1275 ForallT tvbs ctxt body -> 1276 ForallT `fmap` mapM resolve_tvb_syns tvbs 1277 `ap` mapM resolvePredSynonyms ctxt 1278 `ap` resolveTypeSynonyms body 1279 SigT ty ki -> do 1280 ty' <- resolveTypeSynonyms ty 1281 ki' <- resolveKindSynonyms ki 1282 notTypeSynCase $ SigT ty' ki' 1283 ConT n -> expandCon n (ConT n) 1284#if MIN_VERSION_template_haskell(2,11,0) 1285 InfixT t1 n t2 -> do 1286 t1' <- resolveTypeSynonyms t1 1287 t2' <- resolveTypeSynonyms t2 1288 expandCon n (InfixT t1' n t2') 1289 UInfixT t1 n t2 -> do 1290 t1' <- resolveTypeSynonyms t1 1291 t2' <- resolveTypeSynonyms t2 1292 expandCon n (UInfixT t1' n t2') 1293#endif 1294#if MIN_VERSION_template_haskell(2,15,0) 1295 ImplicitParamT n t -> do 1296 ImplicitParamT n <$> resolveTypeSynonyms t 1297#endif 1298#if MIN_VERSION_template_haskell(2,16,0) 1299 ForallVisT tvbs body -> 1300 ForallVisT `fmap` mapM resolve_tvb_syns tvbs 1301 `ap` resolveTypeSynonyms body 1302#endif 1303 _ -> notTypeSynCase f 1304 1305-- | Expand all of the type synonyms in a 'TypeArg'. 1306resolveTypeArgSynonyms :: TypeArg -> Q TypeArg 1307resolveTypeArgSynonyms (TANormal t) = TANormal <$> resolveTypeSynonyms t 1308resolveTypeArgSynonyms (TyArg k) = TyArg <$> resolveKindSynonyms k 1309 1310-- | Expand all of the type synonyms in a 'Kind'. 1311resolveKindSynonyms :: Kind -> Q Kind 1312#if MIN_VERSION_template_haskell(2,8,0) 1313resolveKindSynonyms = resolveTypeSynonyms 1314#else 1315resolveKindSynonyms = return -- One simply couldn't put type synonyms into 1316 -- kinds on old versions of GHC. 1317#endif 1318 1319-- | Expand all of the type synonyms in a the kind of a 'TyVarBndr'. 1320resolve_tvb_syns :: TyVarBndr -> Q TyVarBndr 1321resolve_tvb_syns tvb@PlainTV{} = return tvb 1322resolve_tvb_syns (KindedTV n k) = KindedTV n <$> resolveKindSynonyms k 1323 1324expandSynonymRHS :: 1325 [TyVarBndr] {- ^ Substitute these variables... -} -> 1326 [Type] {- ^ ...with these types... -} -> 1327 Type {- ^ ...inside of this type. -} -> 1328 Type 1329expandSynonymRHS synvars ts def = 1330 let argNames = map tvName synvars 1331 (args,rest) = splitAt (length argNames) ts 1332 subst = Map.fromList (zip argNames args) 1333 in foldl AppT (applySubstitution subst def) rest 1334 1335-- | Expand all of the type synonyms in a 'Pred'. 1336resolvePredSynonyms :: Pred -> Q Pred 1337#if MIN_VERSION_template_haskell(2,10,0) 1338resolvePredSynonyms = resolveTypeSynonyms 1339#else 1340resolvePredSynonyms (ClassP n ts) = do 1341 mbInfo <- reifyMaybe n 1342 case mbInfo of 1343 Just (TyConI (TySynD _ synvars def)) 1344 -> resolvePredSynonyms $ typeToPred $ expandSynonymRHS synvars ts def 1345 _ -> ClassP n <$> mapM resolveTypeSynonyms ts 1346resolvePredSynonyms (EqualP t1 t2) = do 1347 t1' <- resolveTypeSynonyms t1 1348 t2' <- resolveTypeSynonyms t2 1349 return (EqualP t1' t2') 1350 1351typeToPred :: Type -> Pred 1352typeToPred t = 1353 let f :| xs = decomposeType t in 1354 case f of 1355 ConT n 1356 | n == eqTypeName 1357# if __GLASGOW_HASKELL__ == 704 1358 -- There's an unfortunate bug in GHC 7.4 where the (~) type is reified 1359 -- with an explicit kind argument. To work around this, we ignore it. 1360 , [_,t1,t2] <- xs 1361# else 1362 , [t1,t2] <- xs 1363# endif 1364 -> EqualP t1 t2 1365 | otherwise 1366 -> ClassP n xs 1367 _ -> error $ "typeToPred: Can't handle type " ++ show t 1368#endif 1369 1370-- | Decompose a type into a list of it's outermost applications. This process 1371-- forgets about infix application, explicit parentheses, and visible kind 1372-- applications. 1373-- 1374-- This operation should be used after all 'UInfixT' cases have been resolved 1375-- by 'resolveFixities' if the argument is being user generated. 1376-- 1377-- > t ~= foldl1 AppT (decomposeType t) 1378decomposeType :: Type -> NonEmpty Type 1379decomposeType t = 1380 case decomposeTypeArgs t of 1381 (f, x) -> f :| filterTANormals x 1382 1383-- | A variant of 'decomposeType' that preserves information about visible kind 1384-- applications by returning a 'NonEmpty' list of 'TypeArg's. 1385decomposeTypeArgs :: Type -> (Type, [TypeArg]) 1386decomposeTypeArgs = go [] 1387 where 1388 go :: [TypeArg] -> Type -> (Type, [TypeArg]) 1389 go args (AppT f x) = go (TANormal x:args) f 1390#if MIN_VERSION_template_haskell(2,11,0) 1391 go args (ParensT t) = go args t 1392#endif 1393#if MIN_VERSION_template_haskell(2,15,0) 1394 go args (AppKindT f x) = go (TyArg x:args) f 1395#endif 1396 go args t = (t, args) 1397 1398-- | An argument to a type, either a normal type ('TANormal') or a visible 1399-- kind application ('TyArg'). 1400data TypeArg 1401 = TANormal Type 1402 | TyArg Kind 1403 1404-- | Apply a 'Type' to a 'TypeArg'. 1405appTypeArg :: Type -> TypeArg -> Type 1406appTypeArg f (TANormal x) = f `AppT` x 1407appTypeArg f (TyArg _k) = 1408#if MIN_VERSION_template_haskell(2,15,0) 1409 f `AppKindT` _k 1410#else 1411 f -- VKA isn't supported, so conservatively drop the argument 1412#endif 1413 1414-- | Filter out all of the normal type arguments from a list of 'TypeArg's. 1415filterTANormals :: [TypeArg] -> [Type] 1416filterTANormals = mapMaybe f 1417 where 1418 f :: TypeArg -> Maybe Type 1419 f (TANormal t) = Just t 1420 f (TyArg {}) = Nothing 1421 1422-- 'NonEmpty' didn't move into base until recently. Reimplementing it locally 1423-- saves dependencies for supporting older GHCs 1424data NonEmpty a = a :| [a] 1425 1426data NonEmptySnoc a = [a] :|- a 1427 1428-- Decompose a function type into its context, argument types, 1429-- and return type. For instance, this 1430-- 1431-- forall a b. (Show a, b ~ Int) => (a -> b) -> Char -> Int 1432-- 1433-- becomes 1434-- 1435-- ([a, b], [Show a, b ~ Int], [a -> b, Char] :|- Int) 1436uncurryType :: Type -> ([TyVarBndr], Cxt, NonEmptySnoc Type) 1437uncurryType = go [] [] [] 1438 where 1439 go tvbs ctxt args (AppT (AppT ArrowT t1) t2) = go tvbs ctxt (t1:args) t2 1440 go tvbs ctxt args (ForallT tvbs' ctxt' t) = go (tvbs++tvbs') (ctxt++ctxt') args t 1441 go tvbs ctxt args t = (tvbs, ctxt, reverse args :|- t) 1442 1443-- | Decompose a function kind into its context, argument kinds, 1444-- and return kind. For instance, this 1445-- 1446-- forall a b. Maybe a -> Maybe b -> Type 1447-- 1448-- becomes 1449-- 1450-- ([a, b], [], [Maybe a, Maybe b] :|- Type) 1451uncurryKind :: Kind -> ([TyVarBndr], Cxt, NonEmptySnoc Kind) 1452#if MIN_VERSION_template_haskell(2,8,0) 1453uncurryKind = uncurryType 1454#else 1455uncurryKind = go [] 1456 where 1457 go args (ArrowK k1 k2) = go (k1:args) k2 1458 go args StarK = ([], [], reverse args :|- StarK) 1459#endif 1460 1461-- Reconstruct a function type from its type variable binders, context, 1462-- argument types and return type. 1463curryType :: [TyVarBndr] -> Cxt -> [Type] -> Type -> Type 1464curryType tvbs ctxt args res = 1465 ForallT tvbs ctxt $ foldr (\arg t -> ArrowT `AppT` arg `AppT` t) res args 1466 1467-- | Resolve any infix type application in a type using the fixities that 1468-- are currently available. Starting in `template-haskell-2.11` types could 1469-- contain unresolved infix applications. 1470resolveInfixT :: Type -> Q Type 1471 1472#if MIN_VERSION_template_haskell(2,11,0) 1473resolveInfixT (ForallT vs cx t) = ForallT <$> traverse (traverseTvbKind resolveInfixT) vs 1474 <*> mapM resolveInfixT cx 1475 <*> resolveInfixT t 1476resolveInfixT (f `AppT` x) = resolveInfixT f `appT` resolveInfixT x 1477resolveInfixT (ParensT t) = resolveInfixT t 1478resolveInfixT (InfixT l o r) = conT o `appT` resolveInfixT l `appT` resolveInfixT r 1479resolveInfixT (SigT t k) = SigT <$> resolveInfixT t <*> resolveInfixT k 1480resolveInfixT t@UInfixT{} = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t) 1481# if MIN_VERSION_template_haskell(2,15,0) 1482resolveInfixT (f `AppKindT` x) = appKindT (resolveInfixT f) (resolveInfixT x) 1483resolveInfixT (ImplicitParamT n t) 1484 = implicitParamT n $ resolveInfixT t 1485# endif 1486# if MIN_VERSION_template_haskell(2,16,0) 1487resolveInfixT (ForallVisT vs t) = ForallVisT <$> traverse (traverseTvbKind resolveInfixT) vs 1488 <*> resolveInfixT t 1489# endif 1490resolveInfixT t = return t 1491 1492gatherUInfixT :: Type -> InfixList 1493gatherUInfixT (UInfixT l o r) = ilAppend (gatherUInfixT l) o (gatherUInfixT r) 1494gatherUInfixT t = ILNil t 1495 1496-- This can fail due to incompatible fixities 1497resolveInfixT1 :: InfixList -> TypeQ 1498resolveInfixT1 = go [] 1499 where 1500 go :: [(Type,Name,Fixity)] -> InfixList -> TypeQ 1501 go ts (ILNil u) = return (foldl (\acc (l,o,_) -> ConT o `AppT` l `AppT` acc) u ts) 1502 go ts (ILCons l o r) = 1503 do ofx <- fromMaybe defaultFixity <$> reifyFixityCompat o 1504 let push = go ((l,o,ofx):ts) r 1505 case ts of 1506 (l1,o1,o1fx):ts' -> 1507 case compareFixity o1fx ofx of 1508 Just True -> go ((ConT o1 `AppT` l1 `AppT` l, o, ofx):ts') r 1509 Just False -> push 1510 Nothing -> fail (precedenceError o1 o1fx o ofx) 1511 _ -> push 1512 1513 compareFixity :: Fixity -> Fixity -> Maybe Bool 1514 compareFixity (Fixity n1 InfixL) (Fixity n2 InfixL) = Just (n1 >= n2) 1515 compareFixity (Fixity n1 InfixR) (Fixity n2 InfixR) = Just (n1 > n2) 1516 compareFixity (Fixity n1 _ ) (Fixity n2 _ ) = 1517 case compare n1 n2 of 1518 GT -> Just True 1519 LT -> Just False 1520 EQ -> Nothing 1521 1522 precedenceError :: Name -> Fixity -> Name -> Fixity -> String 1523 precedenceError o1 ofx1 o2 ofx2 = 1524 "Precedence parsing error: cannot mix ‘" ++ 1525 nameBase o1 ++ "’ [" ++ showFixity ofx1 ++ "] and ‘" ++ 1526 nameBase o2 ++ "’ [" ++ showFixity ofx2 ++ 1527 "] in the same infix type expression" 1528 1529data InfixList = ILCons Type Name InfixList | ILNil Type 1530 1531ilAppend :: InfixList -> Name -> InfixList -> InfixList 1532ilAppend (ILNil l) o r = ILCons l o r 1533ilAppend (ILCons l1 o1 r1) o r = ILCons l1 o1 (ilAppend r1 o r) 1534 1535#else 1536-- older template-haskell packages don't have UInfixT 1537resolveInfixT = return 1538#endif 1539 1540 1541-- | Render a 'Fixity' as it would appear in Haskell source. 1542-- 1543-- Example: @infixl 5@ 1544showFixity :: Fixity -> String 1545showFixity (Fixity n d) = showFixityDirection d ++ " " ++ show n 1546 1547 1548-- | Render a 'FixityDirection' like it would appear in Haskell source. 1549-- 1550-- Examples: @infixl@ @infixr@ @infix@ 1551showFixityDirection :: FixityDirection -> String 1552showFixityDirection InfixL = "infixl" 1553showFixityDirection InfixR = "infixr" 1554showFixityDirection InfixN = "infix" 1555 1556 1557-- | Extract the type variable name from a 'TyVarBndr' ignoring the 1558-- kind signature if one exists. 1559tvName :: TyVarBndr -> Name 1560tvName (PlainTV name ) = name 1561tvName (KindedTV name _) = name 1562 1563takeFieldNames :: [(Name,a,b)] -> [Name] 1564takeFieldNames xs = [a | (a,_,_) <- xs] 1565 1566#if MIN_VERSION_template_haskell(2,11,0) 1567takeFieldStrictness :: [(a,Bang,b)] -> [FieldStrictness] 1568#else 1569takeFieldStrictness :: [(a,Strict,b)] -> [FieldStrictness] 1570#endif 1571takeFieldStrictness xs = [normalizeStrictness a | (_,a,_) <- xs] 1572 1573takeFieldTypes :: [(a,b,Type)] -> [Type] 1574takeFieldTypes xs = [a | (_,_,a) <- xs] 1575 1576conHasRecord :: Name -> ConstructorInfo -> Bool 1577conHasRecord recName info = 1578 case constructorVariant info of 1579 NormalConstructor -> False 1580 InfixConstructor -> False 1581 RecordConstructor fields -> recName `elem` fields 1582 1583------------------------------------------------------------------------ 1584 1585-- | Add universal quantifier for all free variables in the type. This is 1586-- useful when constructing a type signature for a declaration. 1587-- This code is careful to ensure that the order of the variables quantified 1588-- is determined by their order of appearance in the type signature. (In 1589-- contrast with being dependent upon the Ord instance for 'Name') 1590quantifyType :: Type -> Type 1591quantifyType t 1592 | null tvbs 1593 = t 1594 | ForallT tvbs' ctxt' t' <- t -- Collapse two consecutive foralls (#63) 1595 = ForallT (tvbs ++ tvbs') ctxt' t' 1596 | otherwise 1597 = ForallT tvbs [] t 1598 where 1599 tvbs = freeVariablesWellScoped [t] 1600 1601-- | Take a list of 'Type's, find their free variables, and sort them 1602-- according to dependency order. 1603-- 1604-- As an example of how this function works, consider the following type: 1605-- 1606-- @ 1607-- Proxy (a :: k) 1608-- @ 1609-- 1610-- Calling 'freeVariables' on this type would yield @[a, k]@, since that is 1611-- the order in which those variables appear in a left-to-right fashion. But 1612-- this order does not preserve the fact that @k@ is the kind of @a@. Moreover, 1613-- if you tried writing the type @forall a k. Proxy (a :: k)@, GHC would reject 1614-- this, since GHC would demand that @k@ come before @a@. 1615-- 1616-- 'freeVariablesWellScoped' orders the free variables of a type in a way that 1617-- preserves this dependency ordering. If one were to call 1618-- 'freeVariablesWellScoped' on the type above, it would return 1619-- @[k, (a :: k)]@. (This is why 'freeVariablesWellScoped' returns a list of 1620-- 'TyVarBndr's instead of 'Name's, since it must make it explicit that @k@ 1621-- is the kind of @a@.) 1622-- 1623-- 'freeVariablesWellScoped' guarantees the free variables returned will be 1624-- ordered such that: 1625-- 1626-- 1. Whenever an explicit kind signature of the form @(A :: K)@ is 1627-- encountered, the free variables of @K@ will always appear to the left of 1628-- the free variables of @A@ in the returned result. 1629-- 1630-- 2. The constraint in (1) notwithstanding, free variables will appear in 1631-- left-to-right order of their original appearance. 1632-- 1633-- On older GHCs, this takes measures to avoid returning explicitly bound 1634-- kind variables, which was not possible before @TypeInType@. 1635freeVariablesWellScoped :: [Type] -> [TyVarBndr] 1636freeVariablesWellScoped tys = 1637 let fvs :: [Name] 1638 fvs = freeVariables tys 1639 1640 varKindSigs :: Map Name Kind 1641 varKindSigs = foldMap go_ty tys 1642 where 1643 go_ty :: Type -> Map Name Kind 1644 go_ty (ForallT tvbs ctxt t) = 1645 foldr (\tvb -> Map.delete (tvName tvb)) 1646 (foldMap go_pred ctxt `mappend` go_ty t) tvbs 1647 go_ty (AppT t1 t2) = go_ty t1 `mappend` go_ty t2 1648 go_ty (SigT t k) = 1649 let kSigs = 1650#if MIN_VERSION_template_haskell(2,8,0) 1651 go_ty k 1652#else 1653 mempty 1654#endif 1655 in case t of 1656 VarT n -> Map.insert n k kSigs 1657 _ -> go_ty t `mappend` kSigs 1658#if MIN_VERSION_template_haskell(2,15,0) 1659 go_ty (AppKindT t k) = go_ty t `mappend` go_ty k 1660 go_ty (ImplicitParamT _ t) = go_ty t 1661#endif 1662#if MIN_VERSION_template_haskell(2,16,0) 1663 go_ty (ForallVisT tvbs t) = 1664 foldr (\tvb -> Map.delete (tvName tvb)) (go_ty t) tvbs 1665#endif 1666 go_ty _ = mempty 1667 1668 go_pred :: Pred -> Map Name Kind 1669#if MIN_VERSION_template_haskell(2,10,0) 1670 go_pred = go_ty 1671#else 1672 go_pred (ClassP _ ts) = foldMap go_ty ts 1673 go_pred (EqualP t1 t2) = go_ty t1 `mappend` go_ty t2 1674#endif 1675 1676 -- | Do a topological sort on a list of tyvars, 1677 -- so that binders occur before occurrences 1678 -- E.g. given [ a::k, k::*, b::k ] 1679 -- it'll return a well-scoped list [ k::*, a::k, b::k ] 1680 -- 1681 -- This is a deterministic sorting operation 1682 -- (that is, doesn't depend on Uniques). 1683 -- 1684 -- It is also meant to be stable: that is, variables should not 1685 -- be reordered unnecessarily. 1686 scopedSort :: [Name] -> [Name] 1687 scopedSort = go [] [] 1688 1689 go :: [Name] -- already sorted, in reverse order 1690 -> [Set Name] -- each set contains all the variables which must be placed 1691 -- before the tv corresponding to the set; they are accumulations 1692 -- of the fvs in the sorted tvs' kinds 1693 1694 -- This list is in 1-to-1 correspondence with the sorted tyvars 1695 -- INVARIANT: 1696 -- all (\tl -> all (`isSubsetOf` head tl) (tail tl)) (tails fv_list) 1697 -- That is, each set in the list is a superset of all later sets. 1698 -> [Name] -- yet to be sorted 1699 -> [Name] 1700 go acc _fv_list [] = reverse acc 1701 go acc fv_list (tv:tvs) 1702 = go acc' fv_list' tvs 1703 where 1704 (acc', fv_list') = insert tv acc fv_list 1705 1706 insert :: Name -- var to insert 1707 -> [Name] -- sorted list, in reverse order 1708 -> [Set Name] -- list of fvs, as above 1709 -> ([Name], [Set Name]) -- augmented lists 1710 insert tv [] [] = ([tv], [kindFVSet tv]) 1711 insert tv (a:as) (fvs:fvss) 1712 | tv `Set.member` fvs 1713 , (as', fvss') <- insert tv as fvss 1714 = (a:as', fvs `Set.union` fv_tv : fvss') 1715 1716 | otherwise 1717 = (tv:a:as, fvs `Set.union` fv_tv : fvs : fvss) 1718 where 1719 fv_tv = kindFVSet tv 1720 1721 -- lists not in correspondence 1722 insert _ _ _ = error "scopedSort" 1723 1724 kindFVSet n = 1725 maybe Set.empty (Set.fromList . freeVariables) (Map.lookup n varKindSigs) 1726 ascribeWithKind n = 1727 maybe (PlainTV n) (KindedTV n) (Map.lookup n varKindSigs) 1728 1729 -- An annoying wrinkle: GHCs before 8.0 don't support explicitly 1730 -- quantifying kinds, so something like @forall k (a :: k)@ would be 1731 -- rejected. To work around this, we filter out any binders whose names 1732 -- also appear in a kind on old GHCs. 1733 isKindBinderOnOldGHCs 1734#if __GLASGOW_HASKELL__ >= 800 1735 = const False 1736#else 1737 = (`elem` kindVars) 1738 where 1739 kindVars = freeVariables $ Map.elems varKindSigs 1740#endif 1741 1742 in map ascribeWithKind $ 1743 filter (not . isKindBinderOnOldGHCs) $ 1744 scopedSort fvs 1745 1746-- | Substitute all of the free variables in a type with fresh ones 1747freshenFreeVariables :: Type -> Q Type 1748freshenFreeVariables t = 1749 do let xs = [ (n, VarT <$> newName (nameBase n)) | n <- freeVariables t] 1750 subst <- T.sequence (Map.fromList xs) 1751 return (applySubstitution subst t) 1752 1753 1754-- | Class for types that support type variable substitution. 1755class TypeSubstitution a where 1756 -- | Apply a type variable substitution. 1757 -- 1758 -- Note that 'applySubstitution' is /not/ capture-avoiding. To illustrate 1759 -- this, observe that if you call this function with the following 1760 -- substitution: 1761 -- 1762 -- * @b :-> a@ 1763 -- 1764 -- On the following 'Type': 1765 -- 1766 -- * @forall a. b@ 1767 -- 1768 -- Then it will return: 1769 -- 1770 -- * @forall a. a@ 1771 -- 1772 -- However, because the same @a@ type variable was used in the range of the 1773 -- substitution as was bound by the @forall@, the substituted @a@ is now 1774 -- captured by the @forall@, resulting in a completely different function. 1775 -- 1776 -- For @th-abstraction@'s purposes, this is acceptable, as it usually only 1777 -- deals with globally unique type variable 'Name's. If you use 1778 -- 'applySubstitution' in a context where the 'Name's aren't globally unique, 1779 -- however, be aware of this potential problem. 1780 applySubstitution :: Map Name Type -> a -> a 1781 -- | Compute the free type variables 1782 freeVariables :: a -> [Name] 1783 1784instance TypeSubstitution a => TypeSubstitution [a] where 1785 freeVariables = nub . concat . map freeVariables 1786 applySubstitution = fmap . applySubstitution 1787 1788instance TypeSubstitution Type where 1789 applySubstitution subst = go 1790 where 1791 go (ForallT tvs context t) = 1792 subst_tvbs tvs $ \subst' -> 1793 ForallT (map (mapTvbKind (applySubstitution subst')) tvs) 1794 (applySubstitution subst' context) 1795 (applySubstitution subst' t) 1796 go (AppT f x) = AppT (go f) (go x) 1797 go (SigT t k) = SigT (go t) (applySubstitution subst k) -- k could be Kind 1798 go (VarT v) = Map.findWithDefault (VarT v) v subst 1799#if MIN_VERSION_template_haskell(2,11,0) 1800 go (InfixT l c r) = InfixT (go l) c (go r) 1801 go (UInfixT l c r) = UInfixT (go l) c (go r) 1802 go (ParensT t) = ParensT (go t) 1803#endif 1804#if MIN_VERSION_template_haskell(2,15,0) 1805 go (AppKindT t k) = AppKindT (go t) (go k) 1806 go (ImplicitParamT n t) 1807 = ImplicitParamT n (go t) 1808#endif 1809#if MIN_VERSION_template_haskell(2,16,0) 1810 go (ForallVisT tvs t) = 1811 subst_tvbs tvs $ \subst' -> 1812 ForallVisT (map (mapTvbKind (applySubstitution subst')) tvs) 1813 (applySubstitution subst' t) 1814#endif 1815 go t = t 1816 1817 subst_tvbs :: [TyVarBndr] -> (Map Name Type -> a) -> a 1818 subst_tvbs tvs k = k $ foldl' (flip Map.delete) subst (map tvName tvs) 1819 1820 freeVariables t = 1821 case t of 1822 ForallT tvs context t' -> 1823 fvs_under_forall tvs (freeVariables context `union` freeVariables t') 1824 AppT f x -> freeVariables f `union` freeVariables x 1825 SigT t' k -> freeVariables t' `union` freeVariables k 1826 VarT v -> [v] 1827#if MIN_VERSION_template_haskell(2,11,0) 1828 InfixT l _ r -> freeVariables l `union` freeVariables r 1829 UInfixT l _ r -> freeVariables l `union` freeVariables r 1830 ParensT t' -> freeVariables t' 1831#endif 1832#if MIN_VERSION_template_haskell(2,15,0) 1833 AppKindT t k -> freeVariables t `union` freeVariables k 1834 ImplicitParamT _ t 1835 -> freeVariables t 1836#endif 1837#if MIN_VERSION_template_haskell(2,16,0) 1838 ForallVisT tvs t' 1839 -> fvs_under_forall tvs (freeVariables t') 1840#endif 1841 _ -> [] 1842 where 1843 fvs_under_forall :: [TyVarBndr] -> [Name] -> [Name] 1844 fvs_under_forall tvs fvs = 1845 (freeVariables (map tvKind tvs) `union` fvs) 1846 \\ map tvName tvs 1847 1848instance TypeSubstitution ConstructorInfo where 1849 freeVariables ci = 1850 (freeVariables (map tvKind (constructorVars ci)) 1851 `union` freeVariables (constructorContext ci) 1852 `union` freeVariables (constructorFields ci)) 1853 \\ (tvName <$> constructorVars ci) 1854 1855 applySubstitution subst ci = 1856 let subst' = foldl' (flip Map.delete) subst (map tvName (constructorVars ci)) in 1857 ci { constructorVars = map (mapTvbKind (applySubstitution subst')) 1858 (constructorVars ci) 1859 , constructorContext = applySubstitution subst' (constructorContext ci) 1860 , constructorFields = applySubstitution subst' (constructorFields ci) 1861 } 1862 1863mapTvbKind :: (Kind -> Kind) -> TyVarBndr -> TyVarBndr 1864mapTvbKind f tvb@PlainTV{} = tvb 1865mapTvbKind f (KindedTV n k) = KindedTV n (f k) 1866 1867traverseTvbKind :: Applicative f => (Kind -> f Kind) -> TyVarBndr -> f TyVarBndr 1868traverseTvbKind f tvb@PlainTV{} = pure tvb 1869traverseTvbKind f (KindedTV n k) = KindedTV n <$> f k 1870 1871-- 'Pred' became a type synonym for 'Type' 1872#if !MIN_VERSION_template_haskell(2,10,0) 1873instance TypeSubstitution Pred where 1874 freeVariables (ClassP _ xs) = freeVariables xs 1875 freeVariables (EqualP x y) = freeVariables x `union` freeVariables y 1876 1877 applySubstitution p (ClassP n xs) = ClassP n (applySubstitution p xs) 1878 applySubstitution p (EqualP x y) = EqualP (applySubstitution p x) 1879 (applySubstitution p y) 1880#endif 1881 1882-- 'Kind' became a type synonym for 'Type'. Previously there were no kind variables 1883#if !MIN_VERSION_template_haskell(2,8,0) 1884instance TypeSubstitution Kind where 1885 freeVariables _ = [] 1886 applySubstitution _ k = k 1887#endif 1888 1889-- | Substitutes into the kinds of type variable binders. 1890-- Not capture-avoiding. 1891substTyVarBndrs :: Map Name Type -> [TyVarBndr] -> [TyVarBndr] 1892substTyVarBndrs subst = map go 1893 where 1894 go tvb@(PlainTV {}) = tvb 1895 go (KindedTV n k) = KindedTV n (applySubstitution subst k) 1896 1897------------------------------------------------------------------------ 1898 1899combineSubstitutions :: Map Name Type -> Map Name Type -> Map Name Type 1900combineSubstitutions x y = Map.union (fmap (applySubstitution y) x) y 1901 1902-- | Compute the type variable substitution that unifies a list of types, 1903-- or fail in 'Q'. 1904-- 1905-- All infix issue should be resolved before using 'unifyTypes' 1906-- 1907-- Alpha equivalent quantified types are not unified. 1908unifyTypes :: [Type] -> Q (Map Name Type) 1909unifyTypes [] = return Map.empty 1910unifyTypes (t:ts) = 1911 do t':ts' <- mapM resolveTypeSynonyms (t:ts) 1912 let aux sub u = 1913 do sub' <- unify' (applySubstitution sub t') 1914 (applySubstitution sub u) 1915 return (combineSubstitutions sub sub') 1916 1917 case foldM aux Map.empty ts' of 1918 Right m -> return m 1919 Left (x,y) -> 1920 fail $ showString "Unable to unify types " 1921 . showsPrec 11 x 1922 . showString " and " 1923 . showsPrec 11 y 1924 $ "" 1925 1926unify' :: Type -> Type -> Either (Type,Type) (Map Name Type) 1927 1928unify' (VarT n) (VarT m) | n == m = pure Map.empty 1929unify' (VarT n) t | n `elem` freeVariables t = Left (VarT n, t) 1930 | otherwise = Right (Map.singleton n t) 1931unify' t (VarT n) | n `elem` freeVariables t = Left (VarT n, t) 1932 | otherwise = Right (Map.singleton n t) 1933 1934unify' (AppT f1 x1) (AppT f2 x2) = 1935 do sub1 <- unify' f1 f2 1936 sub2 <- unify' (applySubstitution sub1 x1) (applySubstitution sub1 x2) 1937 Right (combineSubstitutions sub1 sub2) 1938 1939-- Doesn't unify kind signatures 1940unify' (SigT t _) u = unify' t u 1941unify' t (SigT u _) = unify' t u 1942 1943-- only non-recursive cases should remain at this point 1944unify' t u 1945 | t == u = Right Map.empty 1946 | otherwise = Left (t,u) 1947 1948 1949-- | Construct an equality constraint. The implementation of 'Pred' varies 1950-- across versions of Template Haskell. 1951equalPred :: Type -> Type -> Pred 1952equalPred x y = 1953#if MIN_VERSION_template_haskell(2,10,0) 1954 AppT (AppT EqualityT x) y 1955#else 1956 EqualP x y 1957#endif 1958 1959-- | Construct a typeclass constraint. The implementation of 'Pred' varies 1960-- across versions of Template Haskell. 1961classPred :: Name {- ^ class -} -> [Type] {- ^ parameters -} -> Pred 1962classPred = 1963#if MIN_VERSION_template_haskell(2,10,0) 1964 foldl AppT . ConT 1965#else 1966 ClassP 1967#endif 1968 1969-- | Match a 'Pred' representing an equality constraint. Returns 1970-- arguments to the equality constraint if successful. 1971asEqualPred :: Pred -> Maybe (Type,Type) 1972#if MIN_VERSION_template_haskell(2,10,0) 1973asEqualPred (EqualityT `AppT` x `AppT` y) = Just (x,y) 1974asEqualPred (ConT eq `AppT` x `AppT` y) | eq == eqTypeName = Just (x,y) 1975#else 1976asEqualPred (EqualP x y) = Just (x,y) 1977#endif 1978asEqualPred _ = Nothing 1979 1980-- | Match a 'Pred' representing a class constraint. 1981-- Returns the classname and parameters if successful. 1982asClassPred :: Pred -> Maybe (Name, [Type]) 1983#if MIN_VERSION_template_haskell(2,10,0) 1984asClassPred t = 1985 case decomposeType t of 1986 ConT f :| xs | f /= eqTypeName -> Just (f,xs) 1987 _ -> Nothing 1988#else 1989asClassPred (ClassP f xs) = Just (f,xs) 1990asClassPred _ = Nothing 1991#endif 1992 1993------------------------------------------------------------------------ 1994 1995-- | If we are working with a 'Dec' obtained via 'reify' (as opposed to one 1996-- created from, say, [d| ... |] quotes), then we need to apply more hacks than 1997-- we otherwise would to sanitize the 'Dec'. See #28. 1998type IsReifiedDec = Bool 1999 2000isReified, isn'tReified :: IsReifiedDec 2001isReified = True 2002isn'tReified = False 2003 2004-- On old versions of GHC, reify would not give you kind signatures for 2005-- GADT type variables of kind *. To work around this, we insert the kinds 2006-- manually on any types without a signature. 2007 2008giveDIVarsStarKinds :: DatatypeInfo -> DatatypeInfo 2009giveDIVarsStarKinds info = 2010 info { datatypeVars = map giveTyVarBndrStarKind (datatypeVars info) 2011 , datatypeInstTypes = map giveTypeStarKind (datatypeInstTypes info) } 2012 2013giveCIVarsStarKinds :: ConstructorInfo -> ConstructorInfo 2014giveCIVarsStarKinds info = 2015 info { constructorVars = map giveTyVarBndrStarKind (constructorVars info) } 2016 2017giveTyVarBndrStarKind :: TyVarBndr -> TyVarBndr 2018giveTyVarBndrStarKind (PlainTV n) = KindedTV n starK 2019giveTyVarBndrStarKind tvb@KindedTV{} = tvb 2020 2021giveTypeStarKind :: Type -> Type 2022giveTypeStarKind t@(VarT n) = SigT t starK 2023giveTypeStarKind t = t 2024 2025-- | Prior to GHC 8.2.1, reify was broken for data instances and newtype 2026-- instances. This code attempts to detect the problem and repair it if 2027-- possible. 2028-- 2029-- The particular problem is that the type variables used in the patterns 2030-- while defining a data family instance do not completely match those 2031-- used when defining the fields of the value constructors beyond the 2032-- base names. This code attempts to recover the relationship between the 2033-- type variables. 2034-- 2035-- It is possible, however, to generate these kinds of declarations by 2036-- means other than reify. In these cases the name bases might not be 2037-- unique and the declarations might be well formed. In such a case this 2038-- code attempts to avoid altering the declaration. 2039-- 2040-- https://ghc.haskell.org/trac/ghc/ticket/13618 2041repair13618 :: DatatypeInfo -> Q DatatypeInfo 2042repair13618 info = 2043 do s <- T.sequence (Map.fromList substList) 2044 return info { datatypeCons = applySubstitution s (datatypeCons info) } 2045 2046 where 2047 used = freeVariables (datatypeCons info) 2048 bound = map tvName (datatypeVars info) 2049 free = used \\ bound 2050 2051 substList = 2052 [ (u, substEntry u vs) 2053 | u <- free 2054 , let vs = [v | v <- bound, nameBase v == nameBase u] 2055 ] 2056 2057 substEntry _ [v] = varT v 2058 substEntry u [] = fail ("Impossible free variable: " ++ show u) 2059 substEntry u _ = fail ("Ambiguous free variable: " ++ show u) 2060 2061------------------------------------------------------------------------ 2062 2063-- | Backward compatible version of 'dataD' 2064dataDCompat :: 2065 CxtQ {- ^ context -} -> 2066 Name {- ^ type constructor -} -> 2067 [TyVarBndr] {- ^ type parameters -} -> 2068 [ConQ] {- ^ constructor definitions -} -> 2069 [Name] {- ^ derived class names -} -> 2070 DecQ 2071#if MIN_VERSION_template_haskell(2,12,0) 2072dataDCompat c n ts cs ds = 2073 dataD c n ts Nothing cs 2074 (if null ds then [] else [derivClause Nothing (map conT ds)]) 2075#elif MIN_VERSION_template_haskell(2,11,0) 2076dataDCompat c n ts cs ds = 2077 dataD c n ts Nothing cs 2078 (return (map ConT ds)) 2079#else 2080dataDCompat = dataD 2081#endif 2082 2083-- | Backward compatible version of 'newtypeD' 2084newtypeDCompat :: 2085 CxtQ {- ^ context -} -> 2086 Name {- ^ type constructor -} -> 2087 [TyVarBndr] {- ^ type parameters -} -> 2088 ConQ {- ^ constructor definition -} -> 2089 [Name] {- ^ derived class names -} -> 2090 DecQ 2091#if MIN_VERSION_template_haskell(2,12,0) 2092newtypeDCompat c n ts cs ds = 2093 newtypeD c n ts Nothing cs 2094 (if null ds then [] else [derivClause Nothing (map conT ds)]) 2095#elif MIN_VERSION_template_haskell(2,11,0) 2096newtypeDCompat c n ts cs ds = 2097 newtypeD c n ts Nothing cs 2098 (return (map ConT ds)) 2099#else 2100newtypeDCompat = newtypeD 2101#endif 2102 2103-- | Backward compatible version of 'tySynInstD' 2104tySynInstDCompat :: 2105 Name {- ^ type family name -} -> 2106 Maybe [Q TyVarBndr] {- ^ type variable binders -} -> 2107 [TypeQ] {- ^ instance parameters -} -> 2108 TypeQ {- ^ instance result -} -> 2109 DecQ 2110#if MIN_VERSION_template_haskell(2,15,0) 2111tySynInstDCompat n mtvbs ps r = TySynInstD <$> (TySynEqn <$> mapM sequence mtvbs 2112 <*> foldl' appT (conT n) ps 2113 <*> r) 2114#elif MIN_VERSION_template_haskell(2,9,0) 2115tySynInstDCompat n _ ps r = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r) 2116#else 2117tySynInstDCompat n _ = tySynInstD n 2118#endif 2119 2120-- | Backward compatible version of 'pragLineD'. Returns 2121-- 'Nothing' if line pragmas are not suported. 2122pragLineDCompat :: 2123 Int {- ^ line number -} -> 2124 String {- ^ file name -} -> 2125 Maybe DecQ 2126#if MIN_VERSION_template_haskell(2,10,0) 2127pragLineDCompat ln fn = Just (pragLineD ln fn) 2128#else 2129pragLineDCompat _ _ = Nothing 2130#endif 2131 2132arrowKCompat :: Kind -> Kind -> Kind 2133#if MIN_VERSION_template_haskell(2,8,0) 2134arrowKCompat x y = arrowK `appK` x `appK` y 2135#else 2136arrowKCompat = arrowK 2137#endif 2138 2139------------------------------------------------------------------------ 2140 2141-- | Backwards compatibility wrapper for 'Fixity' lookup. 2142-- 2143-- In @template-haskell-2.11.0.0@ and later, the answer will always 2144-- be 'Just' of a fixity. 2145-- 2146-- Before @template-haskell-2.11.0.0@ it was only possible to determine 2147-- fixity information for variables, class methods, and data constructors. 2148-- In this case for type operators the answer could be 'Nothing', which 2149-- indicates that the answer is unavailable. 2150reifyFixityCompat :: Name -> Q (Maybe Fixity) 2151#if MIN_VERSION_template_haskell(2,11,0) 2152reifyFixityCompat n = recover (return Nothing) ((`mplus` Just defaultFixity) <$> reifyFixity n) 2153#else 2154reifyFixityCompat n = recover (return Nothing) $ 2155 do info <- reify n 2156 return $! case info of 2157 ClassOpI _ _ _ fixity -> Just fixity 2158 DataConI _ _ _ fixity -> Just fixity 2159 VarI _ _ _ fixity -> Just fixity 2160 _ -> Nothing 2161#endif 2162 2163-- | Call 'reify' and return @'Just' info@ if successful or 'Nothing' if 2164-- reification failed. 2165reifyMaybe :: Name -> Q (Maybe Info) 2166reifyMaybe n = return Nothing `recover` fmap Just (reify n) 2167