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