TcInstDcls.lhs 67 KB
 partain committed Jan 08, 1996 1 %  Simon Marlow committed Oct 11, 2006 2 % (c) The University of Glasgow 2006  simonm committed Dec 02, 1998 3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  partain committed Jan 08, 1996 4 %  Simon Marlow committed Oct 11, 2006 5 6  TcInstDecls: Typechecking instance declarations  partain committed Jan 08, 1996 7 8  \begin{code}  Ian Lynagh committed Nov 04, 2011 9 10 11 12 13 14 15 {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces -- for details  simonpj committed Oct 09, 2003 16 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where  partain committed Jan 08, 1996 17   dterei committed Jul 20, 2011 18 19 #include "HsVersions.h"  simonmar committed Dec 10, 2003 20 import HsSyn  Simon Marlow committed Oct 11, 2006 21 import TcBinds  eir@cis.upenn.edu committed Dec 21, 2012 22 23 24 import TcTyClsDecls( tcAddImplicits, tcAddTyFamInstCtxt, tcAddDataFamInstCtxt, tcAddFamInstCtxt, tcSynFamInstDecl, wrongKindOfFamily, tcFamTyPats, kcDataDefn, dataDeclChecks,  Simon Peyton Jones committed Jun 07, 2012 25 26 27 28  tcConDecls, checkValidTyCon, badATErr, wrongATArgErr ) import TcClassDcl( tcClassDecl2, HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs, findMethodBind, instantiateMethod, tcInstanceMethodBody )  dterei committed Jul 20, 2011 29 import TcPat ( addInlinePrags )  Ian Lynagh committed May 04, 2008 30 import TcRnMonad  Simon Peyton Jones committed Jan 08, 2013 31 import TcValidity  Simon Marlow committed Oct 11, 2006 32 33 import TcMType import TcType  Simon Peyton Jones committed Jan 28, 2013 34 import Coercion( mkSingleCoAxiom, mkBranchedCoAxiom, pprCoAxBranch )  35 import BuildTyCl  Simon Marlow committed Oct 11, 2006 36 37 38 39 40 41 42 43 import Inst import InstEnv import FamInst import FamInstEnv import TcDeriv import TcEnv import TcHsType import TcUnify  Simon Peyton Jones committed Jan 29, 2013 44 import Unify ( tcMatchTyX )  dterei committed Jul 20, 2011 45 import MkCore ( nO_METHOD_BINDING_ERROR_ID )  Simon Peyton Jones committed Jun 27, 2012 46 import CoreSyn ( DFunArg(..) )  Simon Marlow committed Oct 11, 2006 47 import Type  Simon Peyton Jones committed Dec 05, 2011 48 import TcEvidence  Simon Marlow committed Oct 11, 2006 49 import TyCon  eir@cis.upenn.edu committed Dec 21, 2012 50 import CoAxiom  Simon Marlow committed Oct 11, 2006 51 52 53 import DataCon import Class import Var  Simon Peyton Jones committed Sep 01, 2011 54 import VarEnv  Simon Peyton Jones committed Dec 23, 2011 55 import VarSet ( mkVarSet, subVarSet, varSetElems )  56 import Pair  simonpj@microsoft.com committed Oct 29, 2009 57 import CoreUnfold ( mkDFunUnfolding )  Simon Peyton Jones committed Jun 27, 2012 58 import CoreSyn ( Expr(Var), CoreExpr )  dterei committed Jul 20, 2011 59 import PrelNames ( typeableClassNames )  dterei committed Jul 20, 2011 60 61 62 63  import Bag import BasicTypes import DynFlags  Simon Peyton Jones committed Jun 07, 2012 64 import ErrUtils  dterei committed Jul 20, 2011 65 import FastString  66 import Id  Simon Marlow committed Oct 11, 2006 67 68 69 import MkId import Name import NameSet  dterei committed Jul 20, 2011 70 import Outputable  Simon Marlow committed Oct 11, 2006 71 72 import SrcLoc import Util  dterei committed Jul 20, 2011 73   twanvl committed Jan 17, 2008 74 import Control.Monad  dterei committed Jul 20, 2011 75 import Maybes ( orElse )  partain committed Jan 08, 1996 76 77 78 \end{code} Typechecking instance declarations is done in two passes. The first  partain committed Mar 19, 1996 79 80 pass, made by @tcInstDecls1@, collects information to be used in the second pass.  partain committed Jan 08, 1996 81 82 83 84 85 86 87  This pre-processed info includes the as-yet-unprocessed bindings inside the instance declaration. These are type-checked in the second pass, when the class-instance envs and GVE contain all the info from all the instance and value decls. Indeed that's the reason we need two passes over the instance decls.  88 89 90 91 92 93  Note [How instance declarations are translated] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is how we translation instance declarations into Core Running example:  dterei committed Jul 20, 2011 94 95 96  class C a where op1, op2 :: Ix b => a -> b -> b op2 =  97   dterei committed Jul 20, 2011 98 99 100  instance C a => C [a] {-# INLINE [2] op1 #-} op1 =  101 ===>  dterei committed Jul 20, 2011 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119  -- Method selectors op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b op1 = ... op2 = ... -- Default methods get the 'self' dictionary as argument -- so they can call other methods at the same type -- Default methods get the same type as their method selector $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b$dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). -- NB: type variables 'a' and 'b' are *both* in scope in -- Note [Tricky type variable scoping] -- A top-level definition for each instance method -- Here op1_i, op2_i are the "instance method Ids" -- The INLINE pragma comes from the user pragma {-# INLINE [2] op1_i #-} -- From the instance decl bindings op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b  dterei committed Jul 20, 2011 120  op1_i = /\a. \(d:C a).  dterei committed Jul 20, 2011 121 122 123 124 125 126 127 128 129 130 131 132  let this :: C [a] this = df_i a d -- Note [Subtle interaction of recursion and overlap] local_op1 :: forall b. Ix b => [a] -> b -> b local_op1 = -- Source code; run the type checker on this -- NB: Type variable 'a' (but not 'b') is in scope in -- Note [Tricky type variable scoping] in local_op1 a d  dterei committed Jul 20, 2011 133  op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)  dterei committed Jul 20, 2011 134 135 136 137 138 139 140  -- The dictionary function itself {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions df_i :: forall a. C a -> C [a] df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d) -- But see Note [Default methods in instances] -- We can't apply the type checker to the default-method call  141   simonpj@microsoft.com committed Oct 29, 2009 142  -- Use a RULE to short-circuit applications of the class ops  dterei committed Jul 20, 2011 143  {-# RULE "op1@C[a]" forall a, d:C a.  simonpj@microsoft.com committed Oct 29, 2009 144 145  op1 [a] (df_i d) = op1_i a d #-}  146 147 Note [Instances and loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  148 * Note that df_i may be mutually recursive with both op1_i and op2_i.  dterei committed Jul 20, 2011 149  It's crucial that df_i is not chosen as the loop breaker, even  150 151 152 153 154 155  though op1_i has a (user-specified) INLINE pragma. * Instead the idea is to inline df_i into op1_i, which may then select methods from the MkC record, and thereby break the recursion with df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at the same type, it won't mention df_i, so there won't be recursion in  dterei committed Jul 20, 2011 156  the first place.)  157 158 159  * If op1_i is marked INLINE by the user there's a danger that we won't inline df_i in it, and that in turn means that (since it'll be a  dterei committed Jul 20, 2011 160  loop-breaker because df_i isn't), op1_i will ironically never be  simonpj@microsoft.com committed Nov 06, 2009 161 162 163 164  inlined. But this is OK: the recursion breaking happens by way of a RULE (the magic ClassOp rule above), and RULES work inside InlineRule unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils  165 166 167 168 169 170 171 172 173 174 Note [ClassOp/DFun selection] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ One thing we see a lot is stuff like op2 (df d1 d2) where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both* 'op2' and 'df' to get case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of MkD _ op2 _ _ _ -> op2 And that will reduce to ($cop2 d1 d2) which is what we wanted.  dterei committed Jul 20, 2011 175 But it's tricky to make this work in practice, because it requires us to  176 inline both 'op2' and 'df'. But neither is keen to inline without having  dterei committed Jul 20, 2011 177 seen the other's result; and it's very easy to get code bloat (from the  178 179 180 big intermediate) if you inline a bit too much. Instead we use a cunning trick.  dterei committed Jul 20, 2011 181  * We arrange that 'df' and 'op2' NEVER inline.  182 183 184 185 186 187 188 189  * We arrange that 'df' is ALWAYS defined in the sylised form df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ... * We give 'df' a magical unfolding (DFunUnfolding [$cop1,$cop2, ..]) that lists its methods. * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return  dterei committed Jul 20, 2011 190  a suitable constructor application -- inlining df "on the fly" as it  191 192 193 194 195 196  were. * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece iff its argument satisfies exprIsConApp_maybe. This is done in MkId mkDictSelId  Gabor Greif committed Nov 16, 2012 197  * We make 'df' CONLIKE, so that shared uses still match; eg  198 199 200 201 202  let d = df d1 d2 in ...(op2 d)...(op1 d)... Note [Single-method classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Jan 05, 2010 203 If the class has just one method (or, more accurately, just one element  simonpj@microsoft.com committed Nov 01, 2010 204 of {superclasses + methods}), then we use a different strategy.  205 206 207 208  class C a where op :: a -> a instance C a => C [a] where op =  simonpj@microsoft.com committed Nov 01, 2010 209 210 211 We translate the class decl into a newtype, which just gives a top-level axiom. The "constructor" MkC expands to a cast, as does the class-op selector.  212 213 214 215 216 217  axiom Co:C a :: C a ~ (a->a) op :: forall a. C a -> (a -> a) op a d = d |> (Co:C a)  simonpj@microsoft.com committed Jan 05, 2010 218 219 220  MkC :: forall a. (a->a) -> C a MkC = /\a.\op. op |> (sym Co:C a)  simonpj@microsoft.com committed Nov 01, 2010 221 The clever RULE stuff doesn't work now, because ($df a d) isn't  dterei committed Jul 20, 2011 222 a constructor application, so exprIsConApp_maybe won't return  simonpj@microsoft.com committed Nov 01, 2010 223 Just .  224   simonpj@microsoft.com committed Nov 01, 2010 225 Instead, we simply rely on the fact that casts are cheap:  226   simonpj@microsoft.com committed Nov 01, 2010 227 $df :: forall a. C a => C [a]  dreixel committed Apr 28, 2011 228  {-# INLINE df #-} -- NB: INLINE this  simonpj@microsoft.com committed Nov 01, 2010 229 230  $df = /\a. \d. MkC [a] ($cop_list a d) = $cop_list |> forall a. C a -> (sym (Co:C [a]))  simonpj@microsoft.com committed Aug 13, 2010 231   simonpj@microsoft.com committed Nov 01, 2010 232 233 $cop_list :: forall a. C a => [a] -> [a] $cop_list =  simonpj@microsoft.com committed Jan 05, 2010 234   simonpj@microsoft.com committed Nov 01, 2010 235 236 237 238 So if we see (op ($df a d)) we'll inline 'op' and '$df', since both are simply casts, and good things happen.  simonpj@microsoft.com committed Jan 05, 2010 239   simonpj@microsoft.com committed Nov 01, 2010 240 241 242 243 244 Why do we use this different strategy? Because otherwise we end up with non-inlined dictionaries that look like$df = $cop |> blah which adds an extra indirection to every use, which seems stupid. See Trac #4138 for an example (although the regression reported there  Simon Peyton Jones committed Aug 14, 2012 245 wasn't due to the indirection).  simonpj@microsoft.com committed Jan 05, 2010 246   dterei committed Jul 20, 2011 247 There is an awkward wrinkle though: we want to be very  simonpj@microsoft.com committed Nov 01, 2010 248 careful when we have  simonpj@microsoft.com committed Jan 05, 2010 249 250 251  instance C a => C [a] where {-# INLINE op #-} op = ...  simonpj@microsoft.com committed Aug 13, 2010 252 253 then we'll get an INLINE pragma on$cop_list but it's important that $cop_list only inlines when it's applied to *two* arguments (the  Gabor Greif committed Nov 16, 2012 254 dictionary and the list argument). So we must not eta-expand$df  dterei committed Jul 20, 2011 255 above. We ensure that this doesn't happen by putting an INLINE  simonpj@microsoft.com committed Nov 01, 2010 256 257 pragma on the dfun itself; after all, it ends up being just a cast.  dterei committed Jul 20, 2011 258 There is one more dark corner to the INLINE story, even more deeply  simonpj@microsoft.com committed Nov 01, 2010 259 260 261 262 263 264 265 buried. Consider this (Trac #3772): class DeepSeq a => C a where gen :: Int -> a instance C a => C [a] where gen n = ...  simonpj@microsoft.com committed Aug 13, 2010 266   simonpj@microsoft.com committed Nov 01, 2010 267 268  class DeepSeq a where deepSeq :: a -> b -> b  269   simonpj@microsoft.com committed Nov 01, 2010 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296  instance DeepSeq a => DeepSeq [a] where {-# INLINE deepSeq #-} deepSeq xs b = foldr deepSeq b xs That gives rise to these defns: $cdeepSeq :: DeepSeq a -> [a] -> b -> b -- User INLINE( 3 args )!$cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] -- DFun (with auto INLINE pragma)$fDeepSeq[] a d = $cdeepSeq a d |> blah$cp1 a d :: C a => DeepSep [a] -- We don't want to eta-expand this, lest -- $cdeepSeq gets inlined in it!$cp1 a d = $fDeepSep[] a (scsel a d)$fC[] :: C a => C [a] -- Ordinary DFun $fC[] a d = MkC ($cp1 a d) ($cgen a d) Here$cp1 is the code that generates the superclass for C [a]. The issue is this: we must not eta-expand $cp1 either, or else$fDeepSeq[] and then $cdeepSeq will inline there, which is definitely wrong. Like on the dfun, we solve this by adding an INLINE pragma to$cp1.  simonpj@microsoft.com committed Aug 13, 2010 297   simonpj@microsoft.com committed Sep 05, 2008 298 299 300 301 302 303 304 Note [Subtle interaction of recursion and overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this class C a where { op1,op2 :: a -> a } instance C a => C [a] where op1 x = op2 x ++ op2 x op2 x = ...  simonpj@microsoft.com committed Sep 13, 2010 305  instance C [Int] where  simonpj@microsoft.com committed Sep 05, 2008 306 307 308 309 310 311 312  ... When type-checking the C [a] instance, we need a C [a] dictionary (for the call of op2). If we look up in the instance environment, we find an overlap. And in *general* the right thing is to complain (see Note [Overlapping instances] in InstEnv). But in *this* case it's wrong to complain, because we just want to delegate to the op2 of this same  dterei committed Jul 20, 2011 313 instance.  simonpj@microsoft.com committed Sep 05, 2008 314   dterei committed Jul 20, 2011 315 Why is this justified? Because we generate a (C [a]) constraint in  simonpj@microsoft.com committed Sep 05, 2008 316 a context in which 'a' cannot be instantiated to anything that matches  Gabor Greif committed Nov 16, 2012 317 other overlapping instances, or else we would not be executing this  simonpj@microsoft.com committed Sep 05, 2008 318 319 320 321 322 323 324 325 326 327 328 329 330 version of op1 in the first place. It might even be a bit disguised: nullFail :: C [a] => [a] -> [a] nullFail x = op2 x ++ op2 x instance C a => C [a] where op1 x = nullFail x Precisely this is used in package 'regex-base', module Context.hs. See the overlapping instances for RegexContext, and the fact that they call 'nullFail' just like the example above. The DoCon package also  Gabor Greif committed Nov 16, 2012 331 does the same thing; it shows up in module Fraction.hs.  simonpj@microsoft.com committed Sep 05, 2008 332   simonpj@microsoft.com committed Dec 13, 2010 333 334 335 336 337 338 Conclusion: when typechecking the methods in a C [a] instance, we want to treat the 'a' as an *existential* type variable, in the sense described by Note [Binding when looking up instances]. That is why isOverlappableTyVar responds True to an InstSkol, which is the kind of skolem we use in tcInstDecl2.  simonpj@microsoft.com committed Sep 05, 2008 339   340 341 342 Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our example  dterei committed Jul 20, 2011 343 344 345  class C a where op1, op2 :: Ix b => a -> b -> b op2 =  346   dterei committed Jul 20, 2011 347 348 349  instance C a => C [a] {-# INLINE [2] op1 #-} op1 =  350 351 352 353 354 355 356 357  note that 'a' and 'b' are *both* in scope in , but only 'a' is in scope in . In particular, we must make sure that 'b' is in scope when typechecking . This is achieved by subFunTys, which brings appropriate tyvars into scope. This happens for both and for , but that doesn't matter: the *renamer* will have complained if 'b' is mentioned in .  partain committed Jan 08, 1996 358   simonpj committed Oct 03, 2000 359 360  %************************************************************************  Ian Lynagh committed May 04, 2008 361 %* *  simonpj committed Oct 03, 2000 362 \subsection{Extracting instance decls}  Ian Lynagh committed May 04, 2008 363 %* *  simonpj committed Oct 03, 2000 364 365 366 367 %************************************************************************ Gather up the instance declarations from their various sources  partain committed Jan 08, 1996 368 \begin{code}  Ian Lynagh committed May 04, 2008 369 370 371 372 373 tcInstDecls1 -- Deal with both source-code and imported instance decls :: [LTyClDecl Name] -- For deriving stuff -> [LInstDecl Name] -- Source code instance decls -> [LDerivDecl Name] -- Source code stand-alone deriving decls -> TcM (TcGblEnv, -- The full inst env  simonpj@microsoft.com committed Jul 01, 2008 374  [InstInfo Name], -- Source-code instance decls to process;  Ian Lynagh committed May 04, 2008 375 376  -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances  simonpj committed Sep 13, 2002 377   Simon Marlow committed Sep 21, 2011 378 tcInstDecls1 tycl_decls inst_decls deriv_decls  simonpj committed Sep 13, 2002 379  = checkNoErrs $ Simon Peyton Jones committed Jan 03, 2012 380 381 382 383  do { -- Stop if addInstInfos etc discovers any errors -- (they recover, so that we get more than one error each -- round)  Simon Peyton Jones committed Apr 20, 2012 384  -- Do class and family instance declarations  Simon Peyton Jones committed Jun 07, 2012 385 386 387 388 389 390  ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls ; let (local_infos_s, fam_insts_s) = unzip stuff local_infos = concat local_infos_s fam_insts = concat fam_insts_s ; addClsInsts local_infos$ addFamInsts fam_insts $ Simon Peyton Jones committed Jan 03, 2012 391   Simon Peyton Jones committed Apr 20, 2012 392  do { -- Compute instances from "deriving" clauses;  Simon Peyton Jones committed Jan 03, 2012 393 394 395 396  -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible -- NB: class instance declarations can contain derivings as -- part of associated data type declarations  Simon Peyton Jones committed Apr 20, 2012 397  failIfErrsM -- If the addInsts stuff gave any errors, don't  dterei committed Jul 20, 2011 398 399  -- try the deriving stuff, because that may give -- more errors still  dreixel committed Sep 26, 2011 400   Simon Peyton Jones committed Mar 02, 2012 401  ; traceTc "tcDeriving" empty  Simon Peyton Jones committed Apr 26, 2012 402  ; th_stage <- getStage -- See Note [Deriving inside TH brackets ]  dreixel committed Sep 26, 2011 403  ; (gbl_env, deriv_inst_info, deriv_binds)  Simon Peyton Jones committed Apr 26, 2012 404  <- if isBrackStage th_stage  Simon Peyton Jones committed Jun 07, 2012 405 406  then do { gbl_env <- getGblEnv ; return (gbl_env, emptyBag, emptyValBindsOut) }  Simon Peyton Jones committed Apr 26, 2012 407 408  else tcDeriving tycl_decls inst_decls deriv_decls  simonpj committed Apr 12, 2011 409   dterei committed Jul 20, 2011 410 411  -- Check that if the module is compiled with -XSafe, there are no -- hand written instances of Typeable as then unsafe casts could be  dreixel committed Sep 26, 2011 412  -- performed. Derived instances are OK.  Ian Lynagh committed Jan 19, 2012 413  ; dflags <- getDynFlags  dterei committed Jul 20, 2011 414  ; when (safeLanguageOn dflags)$  dterei committed Nov 01, 2011 415  mapM_ (\x -> when (typInstCheck x)  dterei committed Jul 20, 2011 416  (addErrAt (getSrcSpan $iSpec x) typInstErr))  Simon Peyton Jones committed Feb 06, 2012 417  local_infos  dterei committed Nov 01, 2011 418 419  -- As above but for Safe Inference mode. ; when (safeInferOn dflags)$  Simon Peyton Jones committed Feb 06, 2012 420  mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos  dterei committed Jul 20, 2011 421   dreixel committed Sep 26, 2011 422  ; return ( gbl_env  Simon Peyton Jones committed Feb 06, 2012 423  , bagToList deriv_inst_info ++ local_infos  Simon Peyton Jones committed Nov 29, 2011 424  , deriv_binds)  Simon Peyton Jones committed Jan 03, 2012 425  }}  dterei committed Jul 20, 2011 426  where  Simon Peyton Jones committed Jan 01, 2013 427  typInstCheck ty = is_cls_nm (iSpec ty) elem typeableClassNames  dterei committed Jul 20, 2011 428 429  typInstErr = ptext $sLit$ "Can't create hand written instances of Typeable in Safe" ++ " Haskell! Can only derive them"  simonpj committed Oct 09, 2003 430   Simon Peyton Jones committed Jan 03, 2012 431 432 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a addClsInsts infos thing_inside  simonpj committed Apr 28, 2005 433  = tcExtendLocalInstEnv (map iSpec infos) thing_inside  chak@cse.unsw.edu.au. committed Sep 20, 2006 434   eir@cis.upenn.edu committed Dec 21, 2012 435 addFamInsts :: [FamInst Branched] -> TcM a -> TcM a  Simon Peyton Jones committed Jan 03, 2012 436 437 438 439 -- Extend (a) the family instance envt -- (b) the type envt with stuff from data type decls addFamInsts fam_insts thing_inside = tcExtendLocalFamInstEnv fam_insts $ eir@cis.upenn.edu committed Dec 21, 2012 440  tcExtendGlobalEnv things$  Simon Peyton Jones committed Mar 02, 2012 441 442  do { traceTc "addFamInsts" (pprFamInsts fam_insts) ; tcg_env <- tcAddImplicits things  Simon Peyton Jones committed Jan 03, 2012 443 444 445 446 447  ; setGblEnv tcg_env thing_inside } where axioms = map famInstAxiom fam_insts tycons = famInstsRepTyCons fam_insts things = map ATyCon tycons ++ map ACoAxiom axioms  SamB committed Nov 10, 2006 448 \end{code}  partain committed Mar 19, 1996 449   Simon Peyton Jones committed Apr 26, 2012 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 Note [Deriving inside TH brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a declaration bracket [d| data T = A | B deriving( Show ) |] there is really no point in generating the derived code for deriving( Show) and then type-checking it. This will happen at the call site anyway, and the type check should never fail! Moreover (Trac #6005) the scoping of the generated code inside the bracket does not seem to work out. The easy solution is simply not to generate the derived instances at all. (A less brutal solution would be to generate them with no bindings.) This will become moot when we shift to the new TH plan, so the brutal solution will do.  simonpj committed Oct 03, 2000 467 \begin{code}  Simon Peyton Jones committed Apr 20, 2012 468 tcLocalInstDecl :: LInstDecl Name  eir@cis.upenn.edu committed Dec 21, 2012 469  -> TcM ([InstInfo Name], [FamInst Branched])  Ian Lynagh committed May 04, 2008 470 471 472 473  -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context  eir@cis.upenn.edu committed Dec 21, 2012 474 tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))  Simon Peyton Jones committed Feb 06, 2012 475  = setSrcSpan loc $ eir@cis.upenn.edu committed Dec 21, 2012 476 477  tcAddTyFamInstCtxt decl$ do { fam_tc <- tcFamInstDeclCombined TopLevel (tyFamInstDeclLName decl)  eir@cis.upenn.edu committed Jan 05, 2013 478  ; fam_inst <- tcTyFamInstDecl Nothing fam_tc (L loc decl)  Simon Peyton Jones committed Feb 06, 2012 479 480  ; return ([], [fam_inst]) }  eir@cis.upenn.edu committed Dec 21, 2012 481 482 483 484 tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl })) = setSrcSpan loc $tcAddDataFamInstCtxt decl$ do { fam_tc <- tcFamInstDeclCombined TopLevel (dfid_tycon decl)  eir@cis.upenn.edu committed Jan 05, 2013 485  ; fam_inst <- tcDataFamInstDecl Nothing fam_tc (L loc decl)  eir@cis.upenn.edu committed Dec 21, 2012 486 487 488 489 490 491 492 493 494 495 496 497  ; return ([], [toBranchedFamInst fam_inst]) } tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) = setSrcSpan loc $do { (insts, fam_insts) <- tcClsInstDecl decl ; return (insts, map toBranchedFamInst fam_insts) } tcClsInstDecl :: ClsInstDecl Name -> TcM ([InstInfo Name], [FamInst Unbranched]) tcClsInstDecl (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_datafam_insts = adts }) = addErrCtxt (instDeclCtxt1 poly_ty)$  Ian Lynagh committed May 04, 2008 498 499 500 501 502  do { is_boot <- tcIsHsBoot ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr  dreixel committed Nov 11, 2011 503  ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty  Simon Peyton Jones committed Dec 23, 2011 504 505 506  ; let mini_env = mkVarEnv (classTyVars clas zip inst_tys) mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env  simonpj@microsoft.com committed Aug 27, 2008 507  -- Next, process any associated types.  batterseapower committed Sep 09, 2011 508  ; traceTc "tcLocalInstDecl" (ppr poly_ty)  eir@cis.upenn.edu committed Dec 21, 2012 509  ; tyfam_insts0 <- tcExtendTyVarEnv tyvars $ eir@cis.upenn.edu committed Jan 05, 2013 510  mapAndRecoverM (tcAssocTyDecl clas mini_env) ats  eir@cis.upenn.edu committed Dec 21, 2012 511  ; datafam_insts <- tcExtendTyVarEnv tyvars$  eir@cis.upenn.edu committed Jan 05, 2013 512  mapAndRecoverM (tcAssocDataDecl clas mini_env) adts  Simon Peyton Jones committed Sep 01, 2011 513   dreixel committed Nov 11, 2011 514  -- Check for missing associated types and build them  batterseapower committed Sep 09, 2011 515  -- from their defaults (if available)  eir@cis.upenn.edu committed Dec 21, 2012 516 517  ; let defined_ats = mkNameSet $map (tyFamInstDeclName . unLoc) ats defined_adts = mkNameSet$ map (unLoc . dfid_tycon . unLoc) adts  Simon Peyton Jones committed Dec 23, 2011 518   eir@cis.upenn.edu committed Dec 21, 2012 519  mk_deflt_at_instances :: ClassATItem -> TcM [FamInst Unbranched]  Simon Peyton Jones committed Dec 23, 2011 520  mk_deflt_at_instances (fam_tc, defs)  batterseapower committed Sep 09, 2011 521  -- User supplied instances ==> everything is OK  eir@cis.upenn.edu committed Dec 21, 2012 522 523  | tyConName fam_tc elemNameSet defined_ats || tyConName fam_tc elemNameSet defined_adts  Simon Peyton Jones committed Dec 23, 2011 524 525  = return []  batterseapower committed Sep 09, 2011 526  -- No defaults ==> generate a warning  Simon Peyton Jones committed Dec 23, 2011 527 528 529 530  | null defs = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) ; return [] }  batterseapower committed Sep 09, 2011 531  -- No user instance, have defaults ==> instatiate them  Simon Peyton Jones committed Dec 23, 2011 532 533 534 535  -- Example: class C a where { type F a b :: *; type F a b = () } -- instance C [x] -- Then we want to generate the decl: type F [x] b = () | otherwise  Simon Peyton Jones committed Jan 28, 2013 536  = forM defs $\(CoAxBranch { cab_lhs = pat_tys, cab_rhs = rhs }) ->  Simon Peyton Jones committed Dec 23, 2011 537 538 539 540 541  do { let pat_tys' = substTys mini_subst pat_tys rhs' = substTy mini_subst rhs tv_set' = tyVarsOfTypes pat_tys' tvs' = varSetElems tv_set' ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'  Simon Peyton Jones committed Jan 28, 2013 542  ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs'  Simon Peyton Jones committed Dec 23, 2011 543  ; ASSERT( tyVarsOfType rhs' subVarSet tv_set' )  Simon Peyton Jones committed Jan 28, 2013 544  newFamInst SynFamilyInst False {- group -} axiom }  Simon Peyton Jones committed Dec 23, 2011 545   eir@cis.upenn.edu committed Dec 21, 2012 546  ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)  batterseapower committed Sep 09, 2011 547   Ian Lynagh committed May 04, 2008 548 549  -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.)  simonpj@microsoft.com committed Jul 01, 2008 550  ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)  dterei committed Jul 20, 2011 551  -- Dfun location is that of instance *header*  Simon Peyton Jones committed Sep 01, 2011 552   Ian Lynagh committed May 04, 2008 553  ; overlap_flag <- getOverlapFlag  Simon Peyton Jones committed Jan 01, 2013 554  ; (subst, tyvars') <- tcInstSkolTyVars tyvars  Simon Peyton Jones committed Sep 01, 2011 555  ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys  Simon Peyton Jones committed Jan 01, 2013 556 557 558  ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys) -- Be sure to freshen those type variables, -- so they are sure not to appear in any lookup  Simon Peyton Jones committed Sep 01, 2011 559 560  inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }  eir@cis.upenn.edu committed Dec 21, 2012 561  ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) }  Simon Peyton Jones committed Jan 29, 2013 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584  -------------- tcAssocTyDecl :: Class -- Class of associated type -> VarEnv Type -- Instantiation of class TyVars -> LTyFamInstDecl Name -> TcM (FamInst Unbranched) tcAssocTyDecl clas mini_env ldecl@(L loc decl) = setSrcSpan loc$ tcAddTyFamInstCtxt decl $do { fam_tc <- tcFamInstDeclCombined NotTopLevel (tyFamInstDeclLName decl) ; fam_inst <- tcTyFamInstDecl (Just (clas, mini_env)) fam_tc ldecl ; return$ toUnbranchedFamInst fam_inst } -------------- tcAssocDataDecl :: Class -- ^ Class of associated type -> VarEnv Type -- ^ Instantiation of class TyVars -> LDataFamInstDecl Name -- ^ RHS -> TcM (FamInst Unbranched) tcAssocDataDecl clas mini_env ldecl@(L loc decl) = setSrcSpan loc $tcAddDataFamInstCtxt decl$ do { fam_tc <- tcFamInstDeclCombined NotTopLevel (dfid_tycon decl) ; tcDataFamInstDecl (Just (clas, mini_env)) fam_tc ldecl }  simonpj committed Oct 03, 2000 585 586 \end{code}  Simon Peyton Jones committed Sep 09, 2011 587 588 589 590 591 592 593 594 595 596 597 598 %************************************************************************ %* * Type checking family instances %* * %************************************************************************ Family instances are somewhat of a hybrid. They are processed together with class instance heads, but can contain data constructors and hence they share a lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code}  eir@cis.upenn.edu committed Dec 21, 2012 599 600 tcFamInstDeclCombined :: TopLevelFlag -> Located Name -> TcM TyCon tcFamInstDeclCombined top_lvl fam_tc_lname  Simon Peyton Jones committed Jan 03, 2012 601  = do { -- Type family instances require -XTypeFamilies  Simon Peyton Jones committed Sep 09, 2011 602  -- and can't (currently) be in an hs-boot file  eir@cis.upenn.edu committed Dec 21, 2012 603  ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)  Simon Peyton Jones committed Sep 09, 2011 604 605 606 607 608 609 610 611 612 613 614  ; type_families <- xoptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc type_families $badFamInstDecl fam_tc_lname ; checkTc (not is_boot)$ badBootFamInstDeclErr -- Look up the family TyCon and check for validity including -- check that toplevel type instances are not for associated types. ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname ; when (isTopLevel top_lvl && isTyConAssoc fam_tc) (addErr $assocInClassErr fam_tc_lname)  eir@cis.upenn.edu committed Dec 21, 2012 615  ; return fam_tc }  Simon Peyton Jones committed Sep 09, 2011 616   eir@cis.upenn.edu committed Jan 05, 2013 617 618 tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applicable -> TyCon -> LTyFamInstDecl Name -> TcM (FamInst Branched)  Simon Peyton Jones committed Sep 09, 2011 619  -- "type instance"  eir@cis.upenn.edu committed Jan 05, 2013 620 tcTyFamInstDecl mb_clsinfo fam_tc (L loc decl@(TyFamInstDecl { tfid_group = group }))  Simon Peyton Jones committed Sep 18, 2012 621  = do { -- (0) Check it's an open type family  Simon Peyton Jones committed Sep 21, 2012 622 623 624  checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) ; checkTc (isOpenSynFamilyTyCon fam_tc)  Simon Peyton Jones committed Sep 18, 2012 625 626  (notOpenFamily fam_tc)  eir@cis.upenn.edu committed Dec 21, 2012 627  -- (1) do the work of verifying the synonym group  Simon Peyton Jones committed Jan 28, 2013 628  ; co_ax_branches <- tcSynFamInstDecl fam_tc decl  eir@cis.upenn.edu committed Dec 21, 2012 629   Simon Peyton Jones committed Jan 28, 2013 630  -- (2) check for validity and inaccessibility  Simon Peyton Jones committed Jan 29, 2013 631  ; foldlM_ check_valid_branch [] co_ax_branches  eir@cis.upenn.edu committed Dec 21, 2012 632   Simon Peyton Jones committed Jan 28, 2013 633  -- (3) construct coercion axiom  eir@cis.upenn.edu committed Dec 21, 2012 634 635  ; rep_tc_name <- newFamInstAxiomName loc (tyFamInstDeclName decl)  Simon Peyton Jones committed Jan 28, 2013 636 637 638  (map cab_lhs co_ax_branches) ; let axiom = mkBranchedCoAxiom rep_tc_name fam_tc co_ax_branches ; newFamInst SynFamilyInst group axiom }  Simon Peyton Jones committed Jan 02, 2013 639  where  Simon Peyton Jones committed Jan 29, 2013 640 641 642 643 644 645  check_valid_branch :: [CoAxBranch] -- previous -> CoAxBranch -- current -> TcM [CoAxBranch] -- current : previous check_valid_branch prev_branches cur_branch@(CoAxBranch { cab_tvs = t_tvs, cab_lhs = t_typats , cab_rhs = t_rhs, cab_loc = loc })  Simon Peyton Jones committed Jan 02, 2013 646  = setSrcSpan loc$  Simon Peyton Jones committed Jan 29, 2013 647  do { -- Check the well-formedness of the instance  Simon Peyton Jones committed Jan 02, 2013 648 649  checkValidTyFamInst fam_tc t_tvs t_typats t_rhs  Simon Peyton Jones committed Jan 29, 2013 650 651  -- Check that type patterns match the class instance head ; checkConsistentFamInst mb_clsinfo (ptext (sLit "type")) fam_tc t_tvs t_typats  eir@cis.upenn.edu committed Jan 05, 2013 652   Simon Peyton Jones committed Jan 29, 2013 653 654 655 656  -- Check whether the branch is dominated by earlier -- ones and hence is inaccessible ; when (t_typats isDominatedBy prev_branches) $addErrTc$ inaccessibleCoAxBranch fam_tc cur_branch  Simon Peyton Jones committed Jan 02, 2013 657 658 659  ; return $cur_branch : prev_branches }  eir@cis.upenn.edu committed Jan 05, 2013 660 661 tcDataFamInstDecl :: Maybe (Class, VarEnv Type) -> TyCon -> LDataFamInstDecl Name -> TcM (FamInst Unbranched)  Simon Peyton Jones committed Sep 09, 2011 662  -- "newtype instance" and "data instance"  eir@cis.upenn.edu committed Jan 05, 2013 663 664 665 666 667 668 tcDataFamInstDecl mb_clsinfo fam_tc (L loc (DataFamInstDecl { dfid_pats = pats , dfid_tycon = fam_tc_name , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType , dd_ctxt = ctxt, dd_cons = cons } }))  Simon Peyton Jones committed Jan 29, 2013 669 670  = setSrcSpan loc$ do { -- Check that the family declaration is for the right kind  Simon Peyton Jones committed Sep 09, 2011 671 672 673  checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)  dreixel committed Nov 11, 2011 674  -- Kind check type patterns  eir@cis.upenn.edu committed Dec 21, 2012 675  ; tcFamTyPats fam_tc pats (kcDataDefn defn) $ Simon Peyton Jones committed Mar 02, 2012 676  \tvs' pats' res_kind -> do  Simon Peyton Jones committed Sep 09, 2011 677   Simon Peyton Jones committed Jan 29, 2013 678  { -- Check that left-hand side contains no type family applications  dreixel committed Nov 11, 2011 679  -- (vanilla synonyms are fine, though, and we checked for  Simon Peyton Jones committed Jan 29, 2013 680 681 682 683  -- foralls earlier) checkValidFamPats fam_tc tvs' pats' -- Check that type patterns match class instance head, if any ; checkConsistentFamInst mb_clsinfo (ppr new_or_data) fam_tc tvs' pats'  dreixel committed Nov 11, 2011 684 685  -- Result kind must be '*' (otherwise, we have too few patterns)  Simon Peyton Jones committed Mar 02, 2012 686  ; checkTc (isLiftedTypeKind res_kind)$ tooFewParmsErr (tyConArity fam_tc)  Simon Peyton Jones committed Sep 09, 2011 687   Simon Peyton Jones committed Mar 02, 2012 688  ; stupid_theta <- tcHsContext ctxt  Simon Peyton Jones committed Dec 14, 2012 689  ; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons  Simon Peyton Jones committed Sep 09, 2011 690   dreixel committed Nov 11, 2011 691  -- Construct representation tycon  Simon Peyton Jones committed Mar 22, 2012 692  ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'  Simon Peyton Jones committed Jan 03, 2012 693  ; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc  Simon Peyton Jones committed Dec 14, 2012 694  ; let orig_res_ty = mkTyConApp fam_tc pats'  Simon Peyton Jones committed Jan 03, 2012 695 696  ; (rep_tc, fam_inst) <- fixM $\ ~(rec_rep_tc, _) ->  Simon Peyton Jones committed Dec 14, 2012 697  do { data_cons <- tcConDecls new_or_data rec_rep_tc  dreixel committed Nov 11, 2011 698  (tvs', orig_res_ty) cons  Simon Peyton Jones committed Jan 03, 2012 699 700 701 702  ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)  eir@cis.upenn.edu committed Jan 05, 2013 703  -- freshen tyvars  Simon Peyton Jones committed Jan 28, 2013 704 705 706 707  ; let axiom = mkSingleCoAxiom axiom_name tvs' fam_tc pats' (mkTyConApp rep_tc (mkTyVarTys tvs')) parent = FamInstTyCon axiom fam_tc pats' rep_tc = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs  Simon Peyton Jones committed Jan 25, 2013 708 709 710  Recursive False -- No promotable to the kind level h98_syntax parent  Simon Peyton Jones committed Sep 09, 2011 711 712 713 714 715  -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion.  Simon Peyton Jones committed Jan 28, 2013 716  ; fam_inst <- newFamInst (DataFamilyInst rep_tc) False axiom  Simon Peyton Jones committed Jan 03, 2012 717 718 719 720 721  ; return (rep_tc, fam_inst) } -- Remember to check validity; no recursion to worry about here ; checkValidTyCon rep_tc ; return fam_inst } }  Simon Peyton Jones committed Jan 29, 2013 722 \end{code}  Simon Peyton Jones committed Sep 09, 2011 723 724   Simon Peyton Jones committed Jan 29, 2013 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 Note [Associated type instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We allow this: class C a where type T x a instance C Int where type T (S y) Int = y type T Z Int = Char Note that a) The variable 'x' is not bound by the class decl b) 'x' is instantiated to a non-type-variable in the instance c) There are several type instance decls for T in the instance All this is fine. Of course, you can't give any *more* instances  Gabor Greif committed Jan 30, 2013 740 for (T ty Int) elsewhere, because it's an *associated* type.  Simon Peyton Jones committed Jan 29, 2013 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798  Note [Checking consistent instantiation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ class C a b where type T a x b instance C [p] Int type T [p] y Int = (p,y,y) -- Induces the family instance TyCon -- type TR p y = (p,y,y) So we * Form the mini-envt from the class type variables a,b to the instance decl types [p],Int: [a->[p], b->Int] * Look at the tyvars a,x,b of the type family constructor T (it shares tyvars with the class C) * Apply the mini-evnt to them, and check that the result is consistent with the instance types [p] y Int We do *not* assume (at this point) the the bound variables of the assoicated type instance decl are the same as for the parent instance decl. So, for example, instance C [p] Int type T [q] y Int = ... would work equally well. Reason: making the *kind* variables line up is much harder. Example (Trac #7282): class Foo (xs :: [k]) where type Bar xs :: * instance Foo '[] where type Bar '[] = Int Here the instance decl really looks like instance Foo k ('[] k) where type Bar k ('[] k) = Int but the k's are not scoped, and hence won't match Uniques. So instead we just match structure, with tcMatchTyX, and check that distinct type variales match 1-1 with distinct type variables. HOWEVER, we *still* make the instance type variables scope over the type instances, to pick up non-obvious kinds. Eg class Foo (a :: k) where type F a instance Foo (b :: k -> k) where type F b = Int Here the instance is kind-indexed and really looks like type F (k->k) (b::k->k) = Int But if the 'b' didn't scope, we would make F's instance too poly-kinded. \begin{code} checkConsistentFamInst :: Maybe ( Class , VarEnv Type ) -- ^ Class of associated type -- and instantiation of class TyVars  eir@cis.upenn.edu committed Jan 05, 2013 799 800  -> SDoc -- ^ "flavor" of the instance -> TyCon -- ^ Family tycon  Simon Peyton Jones committed Jan 29, 2013 801  -> [TyVar] -- ^ Type variables of the family instance  eir@cis.upenn.edu committed Jan 05, 2013 802  -> [Type] -- ^ Type patterns from instance  eir@cis.upenn.edu committed Dec 21, 2012 803  -> TcM ()  Simon Peyton Jones committed Jan 29, 2013 804 805 806 807 808 809 -- See Note [Checking consistent instantiation] checkConsistentFamInst Nothing _ _ _ _ = return () checkConsistentFamInst (Just (clas, mini_env)) flav fam_tc at_tvs at_tys = tcAddFamInstCtxt flav (tyConName fam_tc)$ do { -- Check that the associated type indeed comes from this class  eir@cis.upenn.edu committed Jan 05, 2013 810  checkTc (Just clas == tyConAssoc_maybe fam_tc)  Simon Peyton Jones committed Jan 03, 2012 811  (badATErr (className clas) (tyConName fam_tc))  Simon Peyton Jones committed Sep 09, 2011 812   Simon Peyton Jones committed Jan 29, 2013 813 814 815 816 817  -- See Note [Checking consistent instantiation] in TcTyClsDecls -- Check right to left, so that we spot type variable -- inconsistencies before (more confusing) kind variables ; discardResult $foldrM check_arg emptyTvSubst$ tyConTyVars fam_tc zip at_tys }  Simon Peyton Jones committed Sep 09, 2011 818  where  Simon Peyton Jones committed Jan 29, 2013 819 820 821 822  at_tv_set = mkVarSet at_tvs check_arg :: (TyVar, Type) -> TvSubst -> TcM TvSubst check_arg (fam_tc_tv, at_ty) subst  Simon Peyton Jones committed Sep 09, 2011 823  | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv  Simon Peyton Jones committed Jan 29, 2013 824 825 826  = case tcMatchTyX at_tv_set subst at_ty inst_ty of Just subst | all_distinct subst -> return subst _ -> failWithTc $wrongATArgErr at_ty inst_ty  Gabor Greif committed Jan 30, 2013 827  -- No need to instantiate here, because the axiom  Simon Peyton Jones committed Jan 03, 2012 828  -- uses the same type variables as the assocated class  Simon Peyton Jones committed Sep 09, 2011 829  | otherwise  Simon Peyton Jones committed Jan 29, 2013 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844  = return subst -- Allow non-type-variable instantiation -- See Note [Associated type instances] all_distinct :: TvSubst -> Bool -- True if all the variables mapped the substitution -- map to *distinct* type *variables* all_distinct subst = go [] at_tvs where go _ [] = True go acc (tv:tvs) = case lookupTyVar subst tv of Nothing -> go acc tvs Just ty | Just tv' <- tcGetTyVar_maybe ty , tv' notElem acc -> go (tv' : acc) tvs _other -> False  Simon Peyton Jones committed Sep 09, 2011 845 846 847 \end{code}  partain committed Jan 08, 1996 848 %************************************************************************  Ian Lynagh committed May 04, 2008 849 %* *  simonpj@microsoft.com committed Sep 05, 2008 850  Type-checking instance declarations, pass 2  Ian Lynagh committed May 04, 2008 851 %* *  partain committed Jan 08, 1996 852 853 854 %************************************************************************ \begin{code}  simonpj@microsoft.com committed Jul 01, 2008 855 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]  simonpj@microsoft.com committed Jul 07, 2010 856  -> TcM (LHsBinds Id)  Ian Lynagh committed May 04, 2008 857 858 -- (a) From each class declaration, -- generate any default-method bindings  simonpj committed Oct 09, 2003 859 -- (b) From each instance decl  Ian Lynagh committed May 04, 2008 860 -- generate the dfun binding  simonpj committed Oct 09, 2003 861 862  tcInstDecls2 tycl_decls inst_decls  Ian Lynagh committed May 04, 2008 863  = do { -- (a) Default methods from class decls  simonpj@microsoft.com committed Oct 29, 2009 864  let class_decls = filter (isClassDecl . unLoc) tycl_decls  simonpj@microsoft.com committed Jul 07, 2010 865  ; dm_binds_s <- mapM tcClassDecl2 class_decls  simonpj@microsoft.com committed Jul 21, 2010 866  ; let dm_binds = unionManyBags dm_binds_s  dterei committed Jul 20, 2011 867   Ian Lynagh committed May 04, 2008 868  -- (b) instance declarations  dterei committed Jul 20, 2011 869 870 871  ; let dm_ids = collectHsBindsBinders dm_binds -- Add the default method Ids (again) -- See Note [Default methods and instances]  Simon Peyton Jones committed Aug 16, 2011 872  ; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids$  simonpj@microsoft.com committed Jul 21, 2010 873  mapM tcInstDecl2 inst_decls  Ian Lynagh committed May 04, 2008 874 875  -- Done  simonpj@microsoft.com committed Jul 21, 2010 876  ; return (dm_binds unionBags unionManyBags inst_binds_s) }  partain committed Jan 08, 1996 877 878 \end{code}  simonpj@microsoft.com committed Jul 21, 2010 879 880 881 882 883 884 885 886 887 888 See Note [Default methods and instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The default method Ids are already in the type environment (see Note [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they don't have their InlinePragmas yet. Usually that would not matter, because the simplifier propagates information from binding site to use. But, unusually, when compiling instance decls we *copy* the INLINE pragma from the default method to the method for that particular operation (see Note [INLINE and default methods] below).  batterseapower committed Sep 09, 2011 889 So right here in tcInstDecls2 we must re-extend the type envt with  simonpj@microsoft.com committed Jul 21, 2010 890 the default method Ids replete with their INLINE pragmas. Urk.  simonmar committed Feb 23, 2001 891   partain committed Jan 08, 1996 892 \begin{code}  simonpj@microsoft.com committed Dec 13, 2010 893 894 895 896 897 898  tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) = recoverM (return emptyLHsBinds) $setSrcSpan loc$  dterei committed Jul 20, 2011 899  addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ simonpj@microsoft.com committed Dec 13, 2010 900  do { -- Instantiate the instance decl with skolem constants  simonpj@microsoft.com committed Jan 12, 2011 901  ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)  dimitris committed May 17, 2011 902 903 904  -- We instantiate the dfun_id with superSkolems. -- See Note [Subtle interaction of recursion and overlap] -- and Note [Binding when looking up instances]  simonpj@microsoft.com committed Dec 13, 2010 905  ; let (clas, inst_tys) = tcSplitDFunHead inst_head  Simon Peyton Jones committed Jun 27, 2012 906  (class_tyvars, sc_theta, _, op_items) = classBigSig clas  simonpj@microsoft.com committed Dec 13, 2010 907  sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta  Simon Peyton Jones committed Jun 27, 2012 908   Simon Peyton Jones committed Jun 22, 2011 909  ; dfun_ev_vars <- newEvVars dfun_theta  simonpj@microsoft.com committed Dec 13, 2010 910   Simon Peyton Jones committed Jun 27, 2012 911 912  ; (sc_binds, sc_ev_vars, sc_dfun_args) <- tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta'  simonpj@microsoft.com committed Oct 29, 2009 913 914 915  -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas]  Simon Peyton Jones committed Jan 18, 2012 916  ; spec_inst_info <- tcSpecInstPrags dfun_id ibinds  simonpj@microsoft.com committed Oct 29, 2009 917 918  -- Typecheck the methods  dterei committed Jul 20, 2011 919  ; (meth_ids, meth_binds)  simonpj@microsoft.com committed Dec 13, 2010 920 921 922 923 924  <- tcExtendTyVarEnv inst_tyvars$ -- The inst_tyvars scope over the 'where' part -- Those tyvars are inside the dfun_id's type, which is a bit -- bizarre, but OK so long as you realise it! tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars  Simon Peyton Jones committed Jan 18, 2012 925  inst_tys spec_inst_info  simonpj@microsoft.com committed Dec 13, 2010 926  op_items ibinds  simonpj@microsoft.com committed Dec 31, 2008 927   simonpj@microsoft.com committed Jan 05, 2010 928  -- Create the result bindings  batterseapower committed Sep 06, 2011 929  ; self_dict <- newDict clas inst_tys  simonpj@microsoft.com committed Dec 21, 2010 930 931  ; let class_tc = classTyCon clas [dict_constr] = tyConDataCons class_tc  Simon Peyton Jones committed Jun 22, 2011 932 933  dict_bind = mkVarBind self_dict (L loc con_app_args)  simonpj@microsoft.com committed Jan 05, 2010 934 935 936 937  -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because -- it means that the special cases (e.g. dictionary with only one  dterei committed Jul 20, 2011 938  -- member) are dealt with by the common MkId.mkDataConWrapId  dterei committed Jul 20, 2011 939 940 941 942  -- code rather than needing to be repeated here. -- con_app_tys = MkD ty1 ty2 -- con_app_scs = MkD ty1 ty2 sc1 sc2 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2  Simon Peyton Jones committed Jun 22, 2011 943 944  con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr)  Simon Peyton Jones committed Jun 27, 2012 945  con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys  Simon Peyton Jones committed Jun 22, 2011 946 947 948 949 950 951  con_app_args = foldl mk_app con_app_scs \$ map (wrapId arg_wrapper) meth_ids mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id mk_app fun arg = HsApp (L loc fun) (L loc arg)  Simon Peyton Jones committed Jun 27, 2012 952  inst_tv_tys = mkTyVarTys inst_tyvars  Simon Peyton Jones committed Jun 22, 2011 953  arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys  simonpj@microsoft.com committed Jan 05, 2010 954   dterei committed Jul 20, 2011 955 956 957  -- Do not inline the dfun; instead give it a magic DFunFunfolding -- See Note [ClassOp/DFun selection] -- See also note [Single-method classes]  simonpj@microsoft.com committed Dec 21, 2010 958 959 960 961  dfun_id_w_fun | isNewTyCon class_tc = dfun_id setInlinePragma alwaysInlinePragma { inl_sat = Just 0 } | otherwise  Simon Peyton Jones committed Jun 22, 2011 962  = dfun_id setIdUnfolding mkDFunUnfolding dfun_ty dfun_args  simonpj@microsoft.com committed Dec 21, 2010 963  setInlinePragma dfunInlinePragma  Simon Peyton Jones committed Jun 22, 2011 964   Simon Peyton Jones committed Jun 27, 2012 965 966  dfun_args :: [DFunArg CoreExpr] dfun_args = sc_dfun_args ++ map (DFunPolyArg . Var) meth_ids  simonpj@microsoft.com committed Jan 05, 2010 967   Simon Peyton Jones committed Aug 16, 2011 968  export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun  <