TcInstDcls.lhs 58.9 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  Simon Peyton Jones committed Jun 07, 2012 22 23 24 25 26 27 import TcTyClsDecls( tcAddImplicits, tcAddFamInstCtxt, tcSynFamInstDecl, wrongKindOfFamily, tcFamTyPats, kcTyDefn, dataDeclChecks, tcConDecls, checkValidTyCon, badATErr, wrongATArgErr ) import TcClassDcl( tcClassDecl2, HsSigFun, lookupHsSig, mkHsSigFun, emptyHsSigs, findMethodBind, instantiateMethod, tcInstanceMethodBody )  dterei committed Jul 20, 2011 28 import TcPat ( addInlinePrags )  Ian Lynagh committed May 04, 2008 29 import TcRnMonad  Simon Marlow committed Oct 11, 2006 30 31 import TcMType import TcType  32 import BuildTyCl  Simon Marlow committed Oct 11, 2006 33 34 35 36 37 38 39 40 import Inst import InstEnv import FamInst import FamInstEnv import TcDeriv import TcEnv import TcHsType import TcUnify  dterei committed Jul 20, 2011 41 import MkCore ( nO_METHOD_BINDING_ERROR_ID )  Simon Peyton Jones committed Jun 27, 2012 42 import CoreSyn ( DFunArg(..) )  Simon Marlow committed Oct 11, 2006 43 import Type  Simon Peyton Jones committed Dec 05, 2011 44 import TcEvidence  Simon Marlow committed Oct 11, 2006 45 46 47 48 import TyCon import DataCon import Class import Var  Simon Peyton Jones committed Sep 01, 2011 49 import VarEnv  Simon Peyton Jones committed Dec 23, 2011 50 import VarSet ( mkVarSet, subVarSet, varSetElems )  51 import Pair  simonpj@microsoft.com committed Oct 29, 2009 52 import CoreUnfold ( mkDFunUnfolding )  Simon Peyton Jones committed Jun 27, 2012 53 import CoreSyn ( Expr(Var), CoreExpr )  dterei committed Jul 20, 2011 54 import PrelNames ( typeableClassNames )  dterei committed Jul 20, 2011 55 56 57 58  import Bag import BasicTypes import DynFlags  Simon Peyton Jones committed Jun 07, 2012 59 import ErrUtils  dterei committed Jul 20, 2011 60 import FastString  61 import Id  Simon Marlow committed Oct 11, 2006 62 63 64 import MkId import Name import NameSet  dterei committed Jul 20, 2011 65 import Outputable  Simon Marlow committed Oct 11, 2006 66 67 import SrcLoc import Util  dterei committed Jul 20, 2011 68   twanvl committed Jan 17, 2008 69 import Control.Monad  dterei committed Jul 20, 2011 70 import Maybes ( orElse )  partain committed Jan 08, 1996 71 72 73 \end{code} Typechecking instance declarations is done in two passes. The first  partain committed Mar 19, 1996 74 75 pass, made by @tcInstDecls1@, collects information to be used in the second pass.  partain committed Jan 08, 1996 76 77 78 79 80 81 82  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.  83 84 85 86 87 88  Note [How instance declarations are translated] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is how we translation instance declarations into Core Running example:  dterei committed Jul 20, 2011 89 90 91  class C a where op1, op2 :: Ix b => a -> b -> b op2 =  92   dterei committed Jul 20, 2011 93 94 95  instance C a => C [a] {-# INLINE [2] op1 #-} op1 =  96 ===>  dterei committed Jul 20, 2011 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114  -- 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 115  op1_i = /\a. \(d:C a).  dterei committed Jul 20, 2011 116 117 118 119 120 121 122 123 124 125 126 127  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 128  op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)  dterei committed Jul 20, 2011 129 130 131 132 133 134 135  -- 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  136   simonpj@microsoft.com committed Oct 29, 2009 137  -- Use a RULE to short-circuit applications of the class ops  dterei committed Jul 20, 2011 138  {-# RULE "op1@C[a]" forall a, d:C a.  simonpj@microsoft.com committed Oct 29, 2009 139 140  op1 [a] (df_i d) = op1_i a d #-}  141 142 Note [Instances and loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  143 * Note that df_i may be mutually recursive with both op1_i and op2_i.  dterei committed Jul 20, 2011 144  It's crucial that df_i is not chosen as the loop breaker, even  145 146 147 148 149 150  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 151  the first place.)  152 153 154  * 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 155  loop-breaker because df_i isn't), op1_i will ironically never be  simonpj@microsoft.com committed Nov 06, 2009 156 157 158 159  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  160 161 162 163 164 165 166 167 168 169 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 170 But it's tricky to make this work in practice, because it requires us to  171 inline both 'op2' and 'df'. But neither is keen to inline without having  dterei committed Jul 20, 2011 172 seen the other's result; and it's very easy to get code bloat (from the  173 174 175 big intermediate) if you inline a bit too much. Instead we use a cunning trick.  dterei committed Jul 20, 2011 176  * We arrange that 'df' and 'op2' NEVER inline.  177 178 179 180 181 182 183 184  * 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 185  a suitable constructor application -- inlining df "on the fly" as it  186 187 188 189 190 191 192 193 194 195 196 197  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 * We make 'df' CONLIKE, so that shared uses stil match; eg let d = df d1 d2 in ...(op2 d)...(op1 d)... Note [Single-method classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Jan 05, 2010 198 If the class has just one method (or, more accurately, just one element  simonpj@microsoft.com committed Nov 01, 2010 199 of {superclasses + methods}), then we use a different strategy.  200 201 202 203  class C a where op :: a -> a instance C a => C [a] where op =  simonpj@microsoft.com committed Nov 01, 2010 204 205 206 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.  207 208 209 210 211 212  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 213 214 215  MkC :: forall a. (a->a) -> C a MkC = /\a.\op. op |> (sym Co:C a)  simonpj@microsoft.com committed Nov 01, 2010 216 The clever RULE stuff doesn't work now, because ($df a d) isn't  dterei committed Jul 20, 2011 217 a constructor application, so exprIsConApp_maybe won't return  simonpj@microsoft.com committed Nov 01, 2010 218 Just .  219   simonpj@microsoft.com committed Nov 01, 2010 220 Instead, we simply rely on the fact that casts are cheap:  221   simonpj@microsoft.com committed Nov 01, 2010 222 $df :: forall a. C a => C [a]  dreixel committed Apr 28, 2011 223  {-# INLINE df #-} -- NB: INLINE this  simonpj@microsoft.com committed Nov 01, 2010 224 225  $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 226   simonpj@microsoft.com committed Nov 01, 2010 227 228 $cop_list :: forall a. C a => [a] -> [a] $cop_list =  simonpj@microsoft.com committed Jan 05, 2010 229   simonpj@microsoft.com committed Nov 01, 2010 230 231 232 233 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 234   simonpj@microsoft.com committed Nov 01, 2010 235 236 237 238 239 240 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 wasn't due to the indirction).  simonpj@microsoft.com committed Jan 05, 2010 241   dterei committed Jul 20, 2011 242 There is an awkward wrinkle though: we want to be very  simonpj@microsoft.com committed Nov 01, 2010 243 careful when we have  simonpj@microsoft.com committed Jan 05, 2010 244 245 246  instance C a => C [a] where {-# INLINE op #-} op = ...  simonpj@microsoft.com committed Aug 13, 2010 247 248 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  simonpj@microsoft.com committed Nov 01, 2010 249 dictionary and the list argument). So we nust not eta-expand$df  dterei committed Jul 20, 2011 250 above. We ensure that this doesn't happen by putting an INLINE  simonpj@microsoft.com committed Nov 01, 2010 251 252 pragma on the dfun itself; after all, it ends up being just a cast.  dterei committed Jul 20, 2011 253 There is one more dark corner to the INLINE story, even more deeply  simonpj@microsoft.com committed Nov 01, 2010 254 255 256 257 258 259 260 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 261   simonpj@microsoft.com committed Nov 01, 2010 262 263  class DeepSeq a where deepSeq :: a -> b -> b  264   simonpj@microsoft.com committed Nov 01, 2010 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291  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 292   simonpj@microsoft.com committed Sep 05, 2008 293 294 295 296 297 298 299 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 300  instance C [Int] where  simonpj@microsoft.com committed Sep 05, 2008 301 302 303 304 305 306 307  ... 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 308 instance.  simonpj@microsoft.com committed Sep 05, 2008 309   dterei committed Jul 20, 2011 310 Why is this justified? Because we generate a (C [a]) constraint in  simonpj@microsoft.com committed Sep 05, 2008 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 a context in which 'a' cannot be instantiated to anything that matches other overlapping instances, or else we would not be excecuting this 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 does the same thing; it shows up in module Fraction.hs  simonpj@microsoft.com committed Dec 13, 2010 328 329 330 331 332 333 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 334   335 336 337 Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our example  dterei committed Jul 20, 2011 338 339 340  class C a where op1, op2 :: Ix b => a -> b -> b op2 =  341   dterei committed Jul 20, 2011 342 343 344  instance C a => C [a] {-# INLINE [2] op1 #-} op1 =  345 346 347 348 349 350 351 352  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 353   simonpj committed Oct 03, 2000 354 355  %************************************************************************  Ian Lynagh committed May 04, 2008 356 %* *  simonpj committed Oct 03, 2000 357 \subsection{Extracting instance decls}  Ian Lynagh committed May 04, 2008 358 %* *  simonpj committed Oct 03, 2000 359 360 361 362 %************************************************************************ Gather up the instance declarations from their various sources  partain committed Jan 08, 1996 363 \begin{code}  Ian Lynagh committed May 04, 2008 364 365 366 367 368 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 369  [InstInfo Name], -- Source-code instance decls to process;  Ian Lynagh committed May 04, 2008 370 371  -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances  simonpj committed Sep 13, 2002 372   Simon Marlow committed Sep 21, 2011 373 tcInstDecls1 tycl_decls inst_decls deriv_decls  simonpj committed Sep 13, 2002 374  = checkNoErrs $ Simon Peyton Jones committed Jan 03, 2012 375 376 377 378  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 379  -- Do class and family instance declarations  Simon Peyton Jones committed Jun 07, 2012 380 381 382 383 384 385  ; 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 386   Simon Peyton Jones committed Apr 20, 2012 387  do { -- Compute instances from "deriving" clauses;  Simon Peyton Jones committed Jan 03, 2012 388 389 390 391  -- 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 392  failIfErrsM -- If the addInsts stuff gave any errors, don't  dterei committed Jul 20, 2011 393 394  -- try the deriving stuff, because that may give -- more errors still  dreixel committed Sep 26, 2011 395   Simon Peyton Jones committed Mar 02, 2012 396  ; traceTc "tcDeriving" empty  Simon Peyton Jones committed Apr 26, 2012 397  ; th_stage <- getStage -- See Note [Deriving inside TH brackets ]  dreixel committed Sep 26, 2011 398  ; (gbl_env, deriv_inst_info, deriv_binds)  Simon Peyton Jones committed Apr 26, 2012 399  <- if isBrackStage th_stage  Simon Peyton Jones committed Jun 07, 2012 400 401  then do { gbl_env <- getGblEnv ; return (gbl_env, emptyBag, emptyValBindsOut) }  Simon Peyton Jones committed Apr 26, 2012 402 403  else tcDeriving tycl_decls inst_decls deriv_decls  simonpj committed Apr 12, 2011 404   dterei committed Jul 20, 2011 405 406  -- 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 407  -- performed. Derived instances are OK.  Ian Lynagh committed Jan 19, 2012 408  ; dflags <- getDynFlags  dterei committed Jul 20, 2011 409  ; when (safeLanguageOn dflags)$  dterei committed Nov 01, 2011 410  mapM_ (\x -> when (typInstCheck x)  dterei committed Jul 20, 2011 411  (addErrAt (getSrcSpan $iSpec x) typInstErr))  Simon Peyton Jones committed Feb 06, 2012 412  local_infos  dterei committed Nov 01, 2011 413 414  -- As above but for Safe Inference mode. ; when (safeInferOn dflags)$  Simon Peyton Jones committed Feb 06, 2012 415  mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos  dterei committed Jul 20, 2011 416   dreixel committed Sep 26, 2011 417  ; return ( gbl_env  Simon Peyton Jones committed Feb 06, 2012 418  , bagToList deriv_inst_info ++ local_infos  Simon Peyton Jones committed Nov 29, 2011 419  , deriv_binds)  Simon Peyton Jones committed Jan 03, 2012 420  }}  dterei committed Jul 20, 2011 421  where  dterei committed Nov 01, 2011 422  typInstCheck ty = is_cls (iSpec ty) elem typeableClassNames  dterei committed Jul 20, 2011 423 424  typInstErr = ptext $sLit$ "Can't create hand written instances of Typeable in Safe" ++ " Haskell! Can only derive them"  simonpj committed Oct 09, 2003 425   Simon Peyton Jones committed Jan 03, 2012 426 427 addClsInsts :: [InstInfo Name] -> TcM a -> TcM a addClsInsts infos thing_inside  simonpj committed Apr 28, 2005 428  = tcExtendLocalInstEnv (map iSpec infos) thing_inside  chak@cse.unsw.edu.au. committed Sep 20, 2006 429   Simon Peyton Jones committed Jan 03, 2012 430 431 432 433 434 addFamInsts :: [FamInst] -> TcM a -> TcM a -- Extend (a) the family instance envt -- (b) the type envt with stuff from data type decls addFamInsts fam_insts thing_inside = tcExtendLocalFamInstEnv fam_insts $ pcapriotti committed Aug 20, 2012 435  tcExtendGlobalEnv things$  Simon Peyton Jones committed Mar 02, 2012 436 437  do { traceTc "addFamInsts" (pprFamInsts fam_insts) ; tcg_env <- tcAddImplicits things  Simon Peyton Jones committed Jan 03, 2012 438 439 440 441 442  ; 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 443 \end{code}  partain committed Mar 19, 1996 444   Simon Peyton Jones committed Apr 26, 2012 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 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 462 \begin{code}  Simon Peyton Jones committed Apr 20, 2012 463 464 tcLocalInstDecl :: LInstDecl Name -> TcM ([InstInfo Name], [FamInst])  Ian Lynagh committed May 04, 2008 465 466 467 468  -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context  Simon Peyton Jones committed Apr 20, 2012 469 tcLocalInstDecl (L loc (FamInstD { lid_inst = decl }))  Simon Peyton Jones committed Feb 06, 2012 470  = setSrcSpan loc $ Simon Peyton Jones committed Mar 22, 2012 471  tcAddFamInstCtxt decl$  Simon Peyton Jones committed Feb 06, 2012 472 473 474  do { fam_inst <- tcFamInstDecl TopLevel decl ; return ([], [fam_inst]) }  Simon Peyton Jones committed Apr 20, 2012 475 476 tcLocalInstDecl (L loc (ClsInstD { cid_poly_ty = poly_ty, cid_binds = binds , cid_sigs = uprags, cid_fam_insts = ats }))  dterei committed Jul 20, 2011 477  = setSrcSpan loc $ Ian Lynagh committed May 04, 2008 478 479 480 481 482 483  addErrCtxt (instDeclCtxt1 poly_ty)$ do { is_boot <- tcIsHsBoot ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr  dreixel committed Nov 11, 2011 484  ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty  Simon Peyton Jones committed Dec 23, 2011 485 486 487  ; let mini_env = mkVarEnv (classTyVars clas zip inst_tys) mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env  simonpj@microsoft.com committed Aug 27, 2008 488  -- Next, process any associated types.  batterseapower committed Sep 09, 2011 489  ; traceTc "tcLocalInstDecl" (ppr poly_ty)  Simon Peyton Jones committed Jan 03, 2012 490 491  ; fam_insts0 <- tcExtendTyVarEnv tyvars $mapAndRecoverM (tcAssocDecl clas mini_env) ats  Simon Peyton Jones committed Sep 01, 2011 492   dreixel committed Nov 11, 2011 493  -- Check for missing associated types and build them  batterseapower committed Sep 09, 2011 494  -- from their defaults (if available)  Simon Peyton Jones committed Mar 22, 2012 495  ; let defined_ats = mkNameSet$ map famInstDeclName ats  Simon Peyton Jones committed Dec 23, 2011 496   Simon Peyton Jones committed Jan 03, 2012 497  mk_deflt_at_instances :: ClassATItem -> TcM [FamInst]  Simon Peyton Jones committed Dec 23, 2011 498  mk_deflt_at_instances (fam_tc, defs)  batterseapower committed Sep 09, 2011 499  -- User supplied instances ==> everything is OK  Simon Peyton Jones committed Dec 23, 2011 500 501 502  | tyConName fam_tc elemNameSet defined_ats = return []  batterseapower committed Sep 09, 2011 503  -- No defaults ==> generate a warning  Simon Peyton Jones committed Dec 23, 2011 504 505 506 507  | null defs = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) ; return [] }  batterseapower committed Sep 09, 2011 508  -- No user instance, have defaults ==> instatiate them  Simon Peyton Jones committed Dec 23, 2011 509 510 511 512 513 514 515 516 517 518 519  -- 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 = forM defs $\(ATD _tvs pat_tys rhs _loc) -> 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' ; ASSERT( tyVarsOfType rhs' subVarSet tv_set' )  Simon Peyton Jones committed Jan 03, 2012 520  return (mkSynFamInst rep_tc_name tvs' fam_tc pat_tys' rhs') }  Simon Peyton Jones committed Dec 23, 2011 521   Simon Peyton Jones committed Jan 03, 2012 522  ; fam_insts1 <- mapM mk_deflt_at_instances (classATItems clas)  batterseapower committed Sep 09, 2011 523   Ian Lynagh committed May 04, 2008 524 525  -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.)  simonpj@microsoft.com committed Jul 01, 2008 526  ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)  dterei committed Jul 20, 2011 527  -- Dfun location is that of instance *header*  Simon Peyton Jones committed Sep 01, 2011 528   Ian Lynagh committed May 04, 2008 529  ; overlap_flag <- getOverlapFlag  Simon Peyton Jones committed Sep 01, 2011 530 531 532 533  ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys ispec = mkLocalInstance dfun overlap_flag inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }  Simon Peyton Jones committed Feb 06, 2012 534  ; return ( [inst_info], fam_insts0 ++ concat fam_insts1) }  simonpj committed Oct 03, 2000 535 536 \end{code}  Simon Peyton Jones committed Sep 09, 2011 537 538 539 540 541 542 543 544 545 546 547 548 %************************************************************************ %* * 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}  Simon Peyton Jones committed Mar 22, 2012 549 tcFamInstDecl :: TopLevelFlag -> FamInstDecl Name -> TcM FamInst  Simon Peyton Jones committed Sep 09, 2011 550 tcFamInstDecl top_lvl decl  Simon Peyton Jones committed Jan 03, 2012 551  = do { -- Type family instances require -XTypeFamilies  Simon Peyton Jones committed Sep 09, 2011 552  -- and can't (currently) be in an hs-boot file  dreixel committed Nov 11, 2011 553  ; traceTc "tcFamInstDecl" (ppr decl)  Simon Peyton Jones committed Mar 22, 2012 554  ; let fam_tc_lname = fid_tycon decl  Simon Peyton Jones committed Sep 09, 2011 555 556 557 558 559 560 561 562 563 564 565 566 567 568  ; 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 ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; when (isTopLevel top_lvl && isTyConAssoc fam_tc) (addErr$ assocInClassErr fam_tc_lname) -- Now check the type/data instance itself -- This is where type and data decls are treated separately  Simon Peyton Jones committed Jan 03, 2012 569  ; tcFamInstDecl1 fam_tc decl }  Simon Peyton Jones committed Sep 09, 2011 570   Simon Peyton Jones committed Mar 22, 2012 571 tcFamInstDecl1 :: TyCon -> FamInstDecl Name -> TcM FamInst  Simon Peyton Jones committed Sep 09, 2011 572 573  -- "type instance"  Simon Peyton Jones committed Mar 22, 2012 574 575 tcFamInstDecl1 fam_tc decl@(FamInstDecl { fid_tycon = fam_tc_name , fid_defn = TySynonym {} })  dreixel committed Nov 11, 2011 576 577  = do { -- (1) do the work of verifying the synonym ; (t_tvs, t_typats, t_rhs) <- tcSynFamInstDecl fam_tc decl  Simon Peyton Jones committed Sep 09, 2011 578 579 580 581 582  -- (2) check the well-formedness of the instance ; checkValidFamInst t_typats t_rhs -- (3) construct representation tycon  Simon Peyton Jones committed Mar 22, 2012 583  ; rep_tc_name <- newFamInstAxiomName fam_tc_name t_typats  Simon Peyton Jones committed Jan 03, 2012 584 585  ; return (mkSynFamInst rep_tc_name t_tvs fam_tc t_typats t_rhs) }  Simon Peyton Jones committed Sep 09, 2011 586 587  -- "newtype instance" and "data instance"  Simon Peyton Jones committed Mar 22, 2012 588 589 590 591 592 tcFamInstDecl1 fam_tc (FamInstDecl { fid_pats = pats , fid_tycon = fam_tc_name , fid_defn = defn@TyData { td_ND = new_or_data, td_cType = cType , td_ctxt = ctxt, td_cons = cons } })  dreixel committed Nov 11, 2011 593  = do { -- Check that the family declaration is for the right kind  Simon Peyton Jones committed Sep 09, 2011 594 595 596  checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc)  dreixel committed Nov 11, 2011 597  -- Kind check type patterns  Simon Peyton Jones committed Mar 22, 2012 598  ; tcFamTyPats fam_tc pats (kcTyDefn defn) $ Simon Peyton Jones committed Mar 02, 2012 599  \tvs' pats' res_kind -> do  Simon Peyton Jones committed Sep 09, 2011 600   dreixel committed Nov 11, 2011 601 602 603 604 605 606  -- Check that left-hand side contains no type family applications -- (vanilla synonyms are fine, though, and we checked for -- foralls earlier) { mapM_ checkTyFamFreeness pats' -- Result kind must be '*' (otherwise, we have too few patterns)  Simon Peyton Jones committed Mar 02, 2012 607  ; checkTc (isLiftedTypeKind res_kind)$ tooFewParmsErr (tyConArity fam_tc)  Simon Peyton Jones committed Sep 09, 2011 608   Simon Peyton Jones committed Mar 02, 2012 609  ; stupid_theta <- tcHsContext ctxt  Simon Peyton Jones committed Mar 22, 2012 610  ; dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons  Simon Peyton Jones committed Sep 09, 2011 611   dreixel committed Nov 11, 2011 612  -- Construct representation tycon  Simon Peyton Jones committed Mar 22, 2012 613  ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'  Simon Peyton Jones committed Jan 03, 2012 614  ; axiom_name <- newImplicitBinder rep_tc_name mkInstTyCoOcc  Simon Peyton Jones committed Sep 09, 2011 615  ; let ex_ok = True -- Existentials ok for type families!  Simon Peyton Jones committed Jan 03, 2012 616 617 618 619  orig_res_ty = mkTyConApp fam_tc pats' ; (rep_tc, fam_inst) <- fixM $\ ~(rec_rep_tc, _) -> do { data_cons <- tcConDecls new_or_data ex_ok rec_rep_tc  dreixel committed Nov 11, 2011 620  (tvs', orig_res_ty) cons  Simon Peyton Jones committed Jan 03, 2012 621 622 623 624 625 626  ; 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) ; let fam_inst = mkDataFamInst axiom_name tvs' fam_tc pats' rep_tc parent = FamInstTyCon (famInstAxiom fam_inst) fam_tc pats'  Ian Lynagh committed Feb 16, 2012 627  rep_tc = buildAlgTyCon rep_tc_name tvs' cType stupid_theta tc_rhs  Simon Peyton Jones committed Jan 03, 2012 628  Recursive h98_syntax parent  Simon Peyton Jones committed Sep 09, 2011 629 630 631 632 633  -- 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 03, 2012 634 635 636 637 638  ; return (rep_tc, fam_inst) } -- Remember to check validity; no recursion to worry about here ; checkValidTyCon rep_tc ; return fam_inst } }  dreixel committed Nov 11, 2011 639  where  Simon Peyton Jones committed Jan 03, 2012 640  h98_syntax = case cons of -- All constructors have same shape  Simon Peyton Jones committed Sep 09, 2011 641 642 643 644 645  L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False _ -> True ----------------  Simon Peyton Jones committed Mar 22, 2012 646 647 648 tcAssocDecl :: Class -- ^ Class of associated type -> VarEnv Type -- ^ Instantiation of class TyVars -> LFamInstDecl Name -- ^ RHS  Simon Peyton Jones committed Jan 03, 2012 649  -> TcM FamInst  Simon Peyton Jones committed Sep 09, 2011 650 651 tcAssocDecl clas mini_env (L loc decl) = setSrcSpan loc$  Simon Peyton Jones committed Mar 22, 2012 652  tcAddFamInstCtxt decl $ Simon Peyton Jones committed Jan 03, 2012 653 654 655  do { fam_inst <- tcFamInstDecl NotTopLevel decl ; let (fam_tc, at_tys) = famInstLHS fam_inst  Simon Peyton Jones committed Sep 09, 2011 656 657  -- Check that the associated type comes from this class ; checkTc (Just clas == tyConAssoc_maybe fam_tc)  Simon Peyton Jones committed Jan 03, 2012 658  (badATErr (className clas) (tyConName fam_tc))  Simon Peyton Jones committed Sep 09, 2011 659   dreixel committed Nov 11, 2011 660  -- See Note [Checking consistent instantiation] in TcTyClsDecls  Simon Peyton Jones committed Sep 09, 2011 661 662  ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys  Simon Peyton Jones committed Jan 03, 2012 663  ; return fam_inst }  Simon Peyton Jones committed Sep 09, 2011 664 665 666 667 668  where check_arg fam_tc_tv at_ty | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv = checkTc (inst_ty eqType at_ty) (wrongATArgErr at_ty inst_ty)  Simon Peyton Jones committed Jan 03, 2012 669 670  -- No need to instantiate here, becuase the axiom -- uses the same type variables as the assocated class  Simon Peyton Jones committed Sep 09, 2011 671 672 673 674 675 676  | otherwise = return () -- Allow non-type-variable instantiation -- See Note [Associated type instances] \end{code}  partain committed Jan 08, 1996 677 %************************************************************************  Ian Lynagh committed May 04, 2008 678 %* *  simonpj@microsoft.com committed Sep 05, 2008 679  Type-checking instance declarations, pass 2  Ian Lynagh committed May 04, 2008 680 %* *  partain committed Jan 08, 1996 681 682 683 %************************************************************************ \begin{code}  simonpj@microsoft.com committed Jul 01, 2008 684 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]  simonpj@microsoft.com committed Jul 07, 2010 685  -> TcM (LHsBinds Id)  Ian Lynagh committed May 04, 2008 686 687 -- (a) From each class declaration, -- generate any default-method bindings  simonpj committed Oct 09, 2003 688 -- (b) From each instance decl  Ian Lynagh committed May 04, 2008 689 -- generate the dfun binding  simonpj committed Oct 09, 2003 690 691  tcInstDecls2 tycl_decls inst_decls  Ian Lynagh committed May 04, 2008 692  = do { -- (a) Default methods from class decls  simonpj@microsoft.com committed Oct 29, 2009 693  let class_decls = filter (isClassDecl . unLoc) tycl_decls  simonpj@microsoft.com committed Jul 07, 2010 694  ; dm_binds_s <- mapM tcClassDecl2 class_decls  simonpj@microsoft.com committed Jul 21, 2010 695  ; let dm_binds = unionManyBags dm_binds_s  dterei committed Jul 20, 2011 696   Ian Lynagh committed May 04, 2008 697  -- (b) instance declarations  dterei committed Jul 20, 2011 698 699 700  ; 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 701  ; inst_binds_s <- tcExtendLetEnv TopLevel dm_ids$  simonpj@microsoft.com committed Jul 21, 2010 702  mapM tcInstDecl2 inst_decls  Ian Lynagh committed May 04, 2008 703 704  -- Done  simonpj@microsoft.com committed Jul 21, 2010 705  ; return (dm_binds unionBags unionManyBags inst_binds_s) }  partain committed Jan 08, 1996 706 707 \end{code}  simonpj@microsoft.com committed Jul 21, 2010 708 709 710 711 712 713 714 715 716 717 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 718 So right here in tcInstDecls2 we must re-extend the type envt with  simonpj@microsoft.com committed Jul 21, 2010 719 the default method Ids replete with their INLINE pragmas. Urk.  simonmar committed Feb 23, 2001 720   partain committed Jan 08, 1996 721 \begin{code}  simonpj@microsoft.com committed Dec 13, 2010 722 723 724 725 726 727  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 728  addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ simonpj@microsoft.com committed Dec 13, 2010 729  do { -- Instantiate the instance decl with skolem constants  simonpj@microsoft.com committed Jan 12, 2011 730  ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)  dimitris committed May 17, 2011 731 732 733  -- 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 734  ; let (clas, inst_tys) = tcSplitDFunHead inst_head  Simon Peyton Jones committed Jun 27, 2012 735  (class_tyvars, sc_theta, _, op_items) = classBigSig clas  simonpj@microsoft.com committed Dec 13, 2010 736  sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta  Simon Peyton Jones committed Jun 27, 2012 737   Simon Peyton Jones committed Jun 22, 2011 738  ; dfun_ev_vars <- newEvVars dfun_theta  simonpj@microsoft.com committed Dec 13, 2010 739   Simon Peyton Jones committed Jun 27, 2012 740 741  ; (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 742 743 744  -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas]  Simon Peyton Jones committed Jan 18, 2012 745  ; spec_inst_info <- tcSpecInstPrags dfun_id ibinds  simonpj@microsoft.com committed Oct 29, 2009 746 747  -- Typecheck the methods  dterei committed Jul 20, 2011 748  ; (meth_ids, meth_binds)  simonpj@microsoft.com committed Dec 13, 2010 749 750 751 752 753  <- 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 754  inst_tys spec_inst_info  simonpj@microsoft.com committed Dec 13, 2010 755  op_items ibinds  simonpj@microsoft.com committed Dec 31, 2008 756   simonpj@microsoft.com committed Jan 05, 2010 757  -- Create the result bindings  batterseapower committed Sep 06, 2011 758  ; self_dict <- newDict clas inst_tys  simonpj@microsoft.com committed Dec 21, 2010 759 760  ; let class_tc = classTyCon clas [dict_constr] = tyConDataCons class_tc  Simon Peyton Jones committed Jun 22, 2011 761 762  dict_bind = mkVarBind self_dict (L loc con_app_args)  simonpj@microsoft.com committed Jan 05, 2010 763 764 765 766  -- 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 767  -- member) are dealt with by the common MkId.mkDataConWrapId  dterei committed Jul 20, 2011 768 769 770 771  -- 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 772 773  con_app_tys = wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr)  Simon Peyton Jones committed Jun 27, 2012 774  con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys  Simon Peyton Jones committed Jun 22, 2011 775 776 777 778 779 780  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 781  inst_tv_tys = mkTyVarTys inst_tyvars  Simon Peyton Jones committed Jun 22, 2011 782  arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys  simonpj@microsoft.com committed Jan 05, 2010 783   dterei committed Jul 20, 2011 784 785 786  -- 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 787 788 789 790  dfun_id_w_fun | isNewTyCon class_tc = dfun_id setInlinePragma alwaysInlinePragma { inl_sat = Just 0 } | otherwise  Simon Peyton Jones committed Jun 22, 2011 791  = dfun_id setIdUnfolding mkDFunUnfolding dfun_ty dfun_args  simonpj@microsoft.com committed Dec 21, 2010 792  setInlinePragma dfunInlinePragma  Simon Peyton Jones committed Jun 22, 2011 793   Simon Peyton Jones committed Jun 27, 2012 794 795  dfun_args :: [DFunArg CoreExpr] dfun_args = sc_dfun_args ++ map (DFunPolyArg . Var) meth_ids  simonpj@microsoft.com committed Jan 05, 2010 796   Simon Peyton Jones committed Aug 16, 2011 797  export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id_w_fun  Simon Peyton Jones committed Jan 18, 2012 798 799  , abe_mono = self_dict, abe_prags = noSpecPrags } -- NB: noSpecPrags, see Note [SPECIALISE instance pragmas]  simonpj@microsoft.com committed Dec 13, 2010 800  main_bind = AbsBinds { abs_tvs = inst_tyvars  simonpj@microsoft.com committed Sep 13, 2010 801  , abs_ev_vars = dfun_ev_vars  Simon Peyton Jones committed Aug 16, 2011 802  , abs_exports = [export]  Simon Peyton Jones committed Jun 27, 2012 803  , abs_ev_binds = sc_binds  simonpj@microsoft.com committed Sep 13, 2010 804  , abs_binds = unitBag dict_bind }  simonpj@microsoft.com committed Jan 05, 2010 805   simonpj@microsoft.com committed Dec 13, 2010 806  ; return (unitBag (L loc main_bind) unionBags  Simon Peyton Jones committed Jun 27, 2012 807  listToBag meth_binds)  simonpj@microsoft.com committed Jan 05, 2010 808  }  simonpj@microsoft.com committed Dec 13, 2010 809 810 811 812 813  where dfun_ty = idType dfun_id dfun_id = instanceDFunId ispec loc = getSrcSpan dfun_id  Simon Peyton Jones committed Dec 12, 2011 814 ------------------------------  Simon Peyton Jones committed Jun 27, 2012 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 tcSuperClasses :: DFunId -> [TcTyVar] -> [EvVar] -> TcThetaType -> TcM (TcEvBinds, [EvVar], [DFunArg CoreExpr]) -- See Note [Silent superclass arguments] tcSuperClasses dfun_id inst_tyvars dfun_ev_vars sc_theta = do { -- Check that all superclasses can be deduced from -- the originally-specified dfun arguments ; (sc_binds, sc_evs) <- checkConstraints InstSkol inst_tyvars orig_ev_vars$ emitWanteds ScOrigin sc_theta ; if null inst_tyvars && null dfun_ev_vars then return (sc_binds, sc_evs, map (DFunPolyArg . Var) sc_evs) else return (emptyTcEvBinds, sc_lam_args, sc_dfun_args) } where n_silent = dfunNSilent dfun_id n_tv_args = length inst_tyvars orig_ev_vars = drop n_silent dfun_ev_vars (sc_lam_args, sc_dfun_args) = unzip (map (find n_tv_args dfun_ev_vars) sc_theta) find _ [] pred = pprPanic "tcInstDecl2" (ppr dfun_id $$ppr (idType dfun_id)$$ ppr pred) find i (ev:evs) pred | pred eqPred evVarPred ev = (ev, DFunLamArg i) | otherwise = find (i+1) evs pred ----------------------  Simon Peyton Jones committed Mar 02, 2012 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcSigInfo) mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id = do { uniq <- newUnique ; loc <- getSrcSpanM ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name ; local_meth_name <- newLocalName sel_name -- Base the local_meth_name on the selector name, becuase -- type errors from tcInstanceMethodBody come from here ; local_meth_sig <- case lookupHsSig sig_fn sel_name of Just hs_ty -- There is a signature in the instance declaration -> do { sig_ty <- check_inst_sig hs_ty ; instTcTySig hs_ty sig_ty local_meth_name } Nothing -- No type signature -> instTcTySigFromId loc (mkLocalId local_meth_name local_meth_ty) -- Absent a type sig, there are no new scoped type variables here -- Only the ones from the instance decl itself, which are already -- in scope. Example: -- class C a where { op :: forall b. Eq b => ... } -- instance C [c] where { op = } -- In , 'c' is scope but 'b' is not! ; let meth_id = mkLocalId meth_name meth_ty ; return (meth_id, local_meth_sig) }  Simon Peyton Jones committed Dec 12, 2011 866  where  Simon Peyton Jones committed Mar 02, 2012 867 868 869 870 871 872 873 874 875 876  sel_name = idName sel_id local_meth_ty = instantiateMethod clas sel_id inst_tys meth_ty = mkForAllTys tyvars $mkPiTypes dfun_ev_vars local_meth_ty -- Check that any type signatures have exactly the right type check_inst_sig hs_ty@(L loc _) = setSrcSpan loc$ do { sig_ty <- tcHsSigType (FunSigCtxt sel_name) hs_ty ; inst_sigs <- xoptM Opt_InstanceSigs ; if inst_sigs then  Simon Peyton Jones committed Jan 03, 2013 877 878  unless (sig_ty eqType local_meth_ty) (badInstSigErr sel_name local_meth_ty)  Simon Peyton Jones committed Mar 02, 2012 879 880 881  else addErrTc (misplacedInstSig sel_name hs_ty) ; return sig_ty }  Simon Peyton Jones committed Dec 12, 2011 882   Simon Peyton Jones committed Jan 03, 2013 883 badInstSigErr :: Name -> Type -> TcM ()  Simon Peyton Jones committed Dec 12, 2011 884 badInstSigErr meth ty  Simon Peyton Jones committed Jan 03, 2013 885 886 887 888 889 890 891 892 893 894  = do { env0 <- tcInitTidyEnv ; let tidy_ty = tidyType env0 ty -- Tidy the type using the ambient TidyEnv, -- to avoid apparent name capture (Trac #7475) -- class C a where { op :: a -> b } -- instance C (a->b) where -- op :: forall x. x -- op = ...blah... ; addErrTc (hang (ptext (sLit "Method signature does not match class; it should be")) 2 (pprPrefixName meth <+> dcolon <+> ppr tidy_ty)) }  Simon Peyton Jones committed Dec 12, 2011 895   Simon Peyton Jones committed Mar 02, 2012 896 897 misplacedInstSig :: Name -> LHsType Name -> SDoc misplacedInstSig name hs_ty  Simon Peyton Jones committed Dec 12, 2011 898  = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))  Simon Peyton Jones committed Mar 02, 2012 899  2 (hang (pprPrefixName name)  Simon Peyton Jones committed Dec 12, 2011 900 901 902  2 (dcolon <+> ppr hs_ty)) , ptext (sLit "(Use -XInstanceSigs to allow this)") ]  simonpj@microsoft.com committed Sep 13, 2010 903 ------------------------------  simonpj@microsoft.com committed Dec 13, 2010 904 tcSpecInstPrags :: DFunId -> InstBindings Name  simonpj@microsoft.com committed Sep 13, 2010 905 906 907 908 909 910  -> TcM ([Located TcSpecPrag], PragFun) tcSpecInstPrags _ (NewTypeDerived {}) = return ([], \_ -> []) tcSpecInstPrags dfun_id (VanillaInst binds uprags _) = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) \$ filter isSpecInstLSig uprags  dterei committed Jul 20, 2011 911  -- The filter removes the pragmas for methods  simonpj@microsoft.com committed Sep 13, 2010 912  ; return (spec_inst_prags, mkPragFun uprags binds) }  913 \end{code}  simonpj committed Oct 18, 2002 914   Simon Peyton Jones committed Jun 27, 2012 915 916 917 918 919 920 921 922 923 924 925 Note [Silent superclass arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ See Trac #3731, #4809, #5751, #5913, #6117, which all describe somewhat more complicated situations, but ones encountered in practice. THE PROBLEM The problem is that it is all too easy to create a class whose superclass is bottom when it should not be.  simonpj@microsoft.com committed Dec 13, 2010 926 927 928 929 Consider the following (extreme) situation: class C a => D a where ... instance D [a] => D [a] where ... Although this looks wrong (assume D [a] to prove D [a]), it is only a  Simon Peyton Jones committed Jun 22, 2011 930 931 932 more extreme case of what happens with recursive dictionaries, and it can, just about, make sense because the methods do some work before recursing.  simonpj@microsoft.com committed Dec 13, 2010 933   simonpj@microsoft.com committed Dec 21, 2010 934 To implement the dfun we must generate code for the superclass C [a],  Simon Peyton Jones committed Jun 22, 2011 935 936 which we had better not get by superclass selection from the supplied argument:  simonpj@microsoft.com committed Dec 21, 2010 937 938  dfun :: forall a. D [a] -> D [a] dfun = \d::D [a] -> MkD (scsel d) ..  simonpj@microsoft.com committed Dec 13, 2010 939   Simon Peyton Jones committed Jun 27, 2012 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 Otherwise if we later encounter a situation where we have a [Wanted] dw::D [a] we might solve it thus: dw := dfun dw Which is all fine except that now ** the superclass C is bottom **! THE SOLUTION Our solution to this problem "silent superclass arguments". We pass to each dfun some silent superclass arguments’’, which are the immediate superclasses of the dictionary we are trying to construct. In our example: dfun :: forall a. C [a] -> D [a] -> D [a] dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... Notice teh extra (dc :: C [a]) argument compared to the previous version. This gives us: ----------------------------------------------------------- DFun Superclass Invariant ~~~~~~~~~~~~~~~~~~~~~~~~ In the body of a DFun, every superclass argument to the returned dictionary is either * one of the arguments of the DFun, or * constant, bound at top level ----------------------------------------------------------- This net effect is that it is safe to treat a dfun application as wrapping a dictionary constructor around its arguments (in particular, a dfun never picks superclasses from the arguments under the dictionary constructor). No superclass is hidden inside a dfun application. The extra arguments required to satisfy the DFun Superclass Invariant always come first, and are called the "silent" arguments. DFun types are built (only) by MkId.mkDictFunId, so that is where we decide what silent arguments are to be added. In our example, if we had [Wanted] dw :: D [a] we would get via the instance: dw := dfun d1 d2 [Wanted] (d1 :: C [a]) [Wanted] (d2 :: D [a]) And now, though we *can* solve: d2 := dw That's fine; and we solve d1:C[a] separately.  simonpj@microsoft.com committed Dec 13, 2010 985   dterei committed Jul 20, 2011 986