TcInstDcls.lhs 50.7 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}  simonpj committed Oct 09, 2003 9 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where  partain committed Jan 08, 1996 10   simonmar committed Dec 10, 2003 11 import HsSyn  Simon Marlow committed Oct 11, 2006 12 13 14 import TcBinds import TcTyClsDecls import TcClassDcl  15 import TcPat( addInlinePrags )  simonpj@microsoft.com committed Dec 13, 2010 16 import TcSimplify( simplifyTop )  Ian Lynagh committed May 04, 2008 17 import TcRnMonad  Simon Marlow committed Oct 11, 2006 18 19 20 21 22 23 import TcMType import TcType import Inst import InstEnv import FamInst import FamInstEnv  simonpj@microsoft.com committed Sep 14, 2010 24 import MkCore ( nO_METHOD_BINDING_ERROR_ID )  Simon Marlow committed Oct 11, 2006 25 26 import TcDeriv import TcEnv  simonpj@microsoft.com committed May 27, 2009 27 import RnSource ( addTcgDUs )  Simon Marlow committed Oct 11, 2006 28 29 30 31 32 33 34 35 import TcHsType import TcUnify import Type import Coercion import TyCon import DataCon import Class import Var  simonpj@microsoft.com committed Dec 13, 2010 36 import VarSet  simonpj@microsoft.com committed Sep 13, 2010 37 import CoreUtils ( mkPiTypes )  simonpj@microsoft.com committed Oct 29, 2009 38 import CoreUnfold ( mkDFunUnfolding )  simonpj@microsoft.com committed Dec 13, 2010 39 import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr )  40 import Id  Simon Marlow committed Oct 11, 2006 41 42 43 44 45 46 import MkId import Name import NameSet import DynFlags import SrcLoc import Util  simonm committed Jan 08, 1998 47 import Outputable  simonmar committed Dec 10, 2003 48 import Bag  Simon Marlow committed Oct 11, 2006 49 50 import BasicTypes import HscTypes  simonmar committed Apr 29, 2002 51 import FastString  simonpj@microsoft.com committed Sep 13, 2010 52 import Maybes ( orElse )  Simon Marlow committed Oct 11, 2006 53 import Data.Maybe  twanvl committed Jan 17, 2008 54 import Control.Monad  Simon Marlow committed Oct 11, 2006 55 import Data.List  56 57  #include "HsVersions.h"  partain committed Jan 08, 1996 58 59 60 \end{code} Typechecking instance declarations is done in two passes. The first  partain committed Mar 19, 1996 61 62 pass, made by @tcInstDecls1@, collects information to be used in the second pass.  partain committed Jan 08, 1996 63 64 65 66 67 68 69  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.  70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98  Note [How instance declarations are translated] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is how we translation instance declarations into Core Running example: class C a where op1, op2 :: Ix b => a -> b -> b op2 = instance C a => C [a] {-# INLINE [2] op1 #-} op1 = ===> -- 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"  simonpj@microsoft.com committed Oct 29, 2009 99  -- The INLINE pragma comes from the user pragma  100 101  {-# INLINE [2] op1_i #-} -- From the instance decl bindings op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b  simonpj@microsoft.com committed Sep 05, 2008 102  op1_i = /\a. \(d:C a).  simonpj@microsoft.com committed Sep 10, 2008 103 104  let this :: C [a] this = df_i a d  105  -- Note [Subtle interaction of recursion and overlap]  simonpj@microsoft.com committed Sep 10, 2008 106 107  local_op1 :: forall b. Ix b => [a] -> b -> b  simonpj@microsoft.com committed Sep 05, 2008 108 109 110 111 112  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]  simonpj@microsoft.com committed Sep 10, 2008 113  in local_op1 a d  114 115 116 117  op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) -- The dictionary function itself  simonpj@microsoft.com committed Oct 29, 2009 118  {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions  119  df_i :: forall a. C a -> C [a]  simonpj@microsoft.com committed Oct 29, 2009 120  df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)  121  -- But see Note [Default methods in instances]  simonpj@microsoft.com committed Sep 05, 2008 122  -- We can't apply the type checker to the default-method call  123   simonpj@microsoft.com committed Oct 29, 2009 124 125 126 127  -- Use a RULE to short-circuit applications of the class ops {-# RULE "op1@C[a]" forall a, d:C a. op1 [a] (df_i d) = op1_i a d #-}  128 129 Note [Instances and loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  130 131 132 133 134 135 136 137 138 139 140 141 142 * Note that df_i may be mutually recursive with both op1_i and op2_i. It's crucial that df_i is not chosen as the loop breaker, even 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 the first place.) * 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 loop-breaker because df_i isn't), op1_i will ironically never be  simonpj@microsoft.com committed Nov 06, 2009 143 144 145 146  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  147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 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. But it's tricky to make this work in practice, because it requires us to inline both 'op2' and 'df'. But neither is keen to inline without having seen the other's result; and it's very easy to get code bloat (from the big intermediate) if you inline a bit too much. Instead we use a cunning trick. * We arrange that 'df' and 'op2' NEVER inline. * 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 a suitable constructor application -- inlining df "on the fly" as it 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 185 If the class has just one method (or, more accurately, just one element  simonpj@microsoft.com committed Nov 01, 2010 186 of {superclasses + methods}), then we use a different strategy.  187 188 189 190  class C a where op :: a -> a instance C a => C [a] where op =  simonpj@microsoft.com committed Nov 01, 2010 191 192 193 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.  194 195 196 197 198 199  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 200 201 202  MkC :: forall a. (a->a) -> C a MkC = /\a.\op. op |> (sym Co:C a)  simonpj@microsoft.com committed Nov 01, 2010 203 204 205 The clever RULE stuff doesn't work now, because ($df a d) isn't a constructor application, so exprIsConApp_maybe won't return Just .  206   simonpj@microsoft.com committed Nov 01, 2010 207 Instead, we simply rely on the fact that casts are cheap:  208   simonpj@microsoft.com committed Nov 01, 2010 209 210 211 212 $df :: forall a. C a => C [a] {-# INLINE df #} -- NB: INLINE this $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 213   simonpj@microsoft.com committed Nov 01, 2010 214 215 $cop_list :: forall a. C a => [a] -> [a] $cop_list =  simonpj@microsoft.com committed Jan 05, 2010 216   simonpj@microsoft.com committed Nov 01, 2010 217 218 219 220 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 221   simonpj@microsoft.com committed Nov 01, 2010 222 223 224 225 226 227 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 228   simonpj@microsoft.com committed Nov 01, 2010 229 230 There is an awkward wrinkle though: we want to be very careful when we have  simonpj@microsoft.com committed Jan 05, 2010 231 232 233  instance C a => C [a] where {-# INLINE op #-} op = ...  simonpj@microsoft.com committed Aug 13, 2010 234 235 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 236 237 238 239 240 241 242 243 244 245 246 247 dictionary and the list argument). So we nust not eta-expand$df above. We ensure that this doesn't happen by putting an INLINE pragma on the dfun itself; after all, it ends up being just a cast. There is one more dark corner to the INLINE story, even more deeply 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 248   simonpj@microsoft.com committed Nov 01, 2010 249 250  class DeepSeq a where deepSeq :: a -> b -> b  251   simonpj@microsoft.com committed Nov 01, 2010 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278  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 279   simonpj@microsoft.com committed Sep 05, 2008 280 281 282 283 284 285 286 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 287  instance C [Int] where  simonpj@microsoft.com committed Sep 05, 2008 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314  ... 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 instance. Why is this justified? Because we generate a (C [a]) constraint in 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 315 316 317 318 319 320 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 321   322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our example class C a where op1, op2 :: Ix b => a -> b -> b op2 = instance C a => C [a] {-# INLINE [2] op1 #-} op1 = 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 340   simonpj committed Oct 03, 2000 341 342  %************************************************************************  Ian Lynagh committed May 04, 2008 343 %* *  simonpj committed Oct 03, 2000 344 \subsection{Extracting instance decls}  Ian Lynagh committed May 04, 2008 345 %* *  simonpj committed Oct 03, 2000 346 347 348 349 %************************************************************************ Gather up the instance declarations from their various sources  partain committed Jan 08, 1996 350 \begin{code}  Ian Lynagh committed May 04, 2008 351 352 353 354 355 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 356  [InstInfo Name], -- Source-code instance decls to process;  Ian Lynagh committed May 04, 2008 357 358  -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances  simonpj committed Sep 13, 2002 359   bjorn@bringert.net committed Sep 18, 2006 360 tcInstDecls1 tycl_decls inst_decls deriv_decls  simonpj committed Sep 13, 2002 361  = checkNoErrs $ chak@cse.unsw.edu.au. committed Sep 20, 2006 362  do { -- Stop if addInstInfos etc discovers any errors  Ian Lynagh committed May 04, 2008 363 364  -- (they recover, so that we get more than one error each -- round)  chak@cse.unsw.edu.au. committed Sep 20, 2006 365   Ian Lynagh committed May 04, 2008 366  -- (1) Do class and family instance declarations  simonpj@microsoft.com committed Jul 13, 2010 367 368  ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel)$ filter (isFamInstDecl . unLoc) tycl_decls  simonpj@microsoft.com committed Aug 27, 2008 369  ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls  chak@cse.unsw.edu.au. committed Sep 20, 2006 370   simonpj@microsoft.com committed Aug 27, 2008 371 372  ; let { (local_info, at_tycons_s) = unzip local_info_tycons  simonpj@microsoft.com committed Jan 02, 2009 373  ; at_idx_tycons = concat at_tycons_s ++ idx_tycons  Ian Lynagh committed May 04, 2008 374  ; clas_decls = filter (isClassDecl.unLoc) tycl_decls  simonpj@microsoft.com committed Jan 02, 2009 375  ; implicit_things = concatMap implicitTyThings at_idx_tycons  simonpj@microsoft.com committed Jul 07, 2010 376  ; aux_binds = mkRecSelBinds at_idx_tycons  Ian Lynagh committed May 04, 2008 377 378 379 380  } -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment  simonpj@microsoft.com committed Jan 02, 2009 381  ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $do {  chak@cse.unsw.edu.au. committed Sep 20, 2006 382   Ian Lynagh committed May 04, 2008 383  -- (3) Instances from generic class declarations  chak@cse.unsw.edu.au. committed Sep 20, 2006 384 385  ; generic_inst_info <- getGenericInstances clas_decls  Ian Lynagh committed May 04, 2008 386 387  -- Next, construct the instance environment so far, consisting -- of  simonpj@microsoft.com committed Jul 13, 2010 388 389 390  -- (a) local instance decls -- (b) generic instances -- (c) local family instance decls  simonpj@microsoft.com committed May 27, 2009 391 392 393  ; addInsts local_info$ addInsts generic_inst_info $addFamInsts at_idx_tycons$ do {  chak@cse.unsw.edu.au. committed Sep 20, 2006 394   Ian Lynagh committed May 04, 2008 395 396 397  -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible  chak@cse.unsw.edu.au. committed Jun 27, 2007 398 399  -- NB: class instance declarations can contain derivings as -- part of associated data type declarations  simonpj@microsoft.com committed Jun 06, 2008 400 401 402  failIfErrsM -- If the addInsts stuff gave any errors, don't -- try the deriving stuff, becuase that may give -- more errors still  simonpj@microsoft.com committed May 27, 2009 403 404  ; (deriv_inst_info, deriv_binds, deriv_dus) <- tcDeriving tycl_decls inst_decls deriv_decls  simonpj@microsoft.com committed Jan 02, 2009 405  ; gbl_env <- addInsts deriv_inst_info getGblEnv  simonpj@microsoft.com committed May 27, 2009 406  ; return ( addTcgDUs gbl_env deriv_dus,  Ian Lynagh committed May 04, 2008 407  generic_inst_info ++ deriv_inst_info ++ local_info,  simonpj@microsoft.com committed Jan 02, 2009 408  aux_binds plusHsValBinds deriv_binds)  simonpj@microsoft.com committed May 27, 2009 409  }}}  simonpj committed Oct 09, 2003 410   simonpj@microsoft.com committed Jul 01, 2008 411 addInsts :: [InstInfo Name] -> TcM a -> TcM a  simonpj committed Oct 09, 2003 412 addInsts infos thing_inside  simonpj committed Apr 28, 2005 413  = tcExtendLocalInstEnv (map iSpec infos) thing_inside  chak@cse.unsw.edu.au. committed Sep 20, 2006 414 415 416  addFamInsts :: [TyThing] -> TcM a -> TcM a addFamInsts tycons thing_inside  chak@cse.unsw.edu.au. committed Oct 10, 2006 417 418 419  = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside where mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon  Ian Lynagh committed May 04, 2008 420 421  mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts" (ppr tything)  SamB committed Nov 10, 2006 422 \end{code}  partain committed Mar 19, 1996 423   simonpj committed Oct 03, 2000 424 \begin{code}  Ian Lynagh committed May 04, 2008 425 tcLocalInstDecl1 :: LInstDecl Name  simonpj@microsoft.com committed Aug 27, 2008 426  -> TcM (InstInfo Name, [TyThing])  Ian Lynagh committed May 04, 2008 427 428 429 430  -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context  Ian Lynagh committed Jun 06, 2008 431 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))  simonpj@microsoft.com committed Aug 27, 2008 432  = setSrcSpan loc $ Ian Lynagh committed May 04, 2008 433 434 435 436 437 438  addErrCtxt (instDeclCtxt1 poly_ty)$ do { is_boot <- tcIsHsBoot ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr  simonpj@microsoft.com committed Dec 13, 2010 439 440  ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty ; checkValidInstance poly_ty tyvars theta clas inst_tys  simonpj@microsoft.com committed Aug 27, 2008 441 442 443  -- Next, process any associated types. ; idx_tycons <- recoverM (return []) $ simonpj@microsoft.com committed Jul 13, 2010 444 445  do { idx_tycons <- checkNoErrs$ mapAndRecoverM (tcFamInstDecl NotTopLevel) ats  simonpj@microsoft.com committed Aug 27, 2008 446 447 448  ; checkValidAndMissingATs clas (tyvars, inst_tys) (zip ats idx_tycons) ; return idx_tycons }  Ian Lynagh committed May 04, 2008 449 450 451  -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.)  simonpj@microsoft.com committed Jul 01, 2008 452 453  ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) -- Dfun location is that of instance *header*  Ian Lynagh committed May 04, 2008 454 455  ; overlap_flag <- getOverlapFlag ; let (eq_theta,dict_theta) = partition isEqPred theta  chak@cse.unsw.edu.au. committed Aug 28, 2007 456 457  theta' = eq_theta ++ dict_theta dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys  Ian Lynagh committed May 04, 2008 458  ispec = mkLocalInstance dfun overlap_flag  chak@cse.unsw.edu.au. committed Sep 20, 2006 459   simonpj@microsoft.com committed Dec 13, 2010 460  ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },  simonpj@microsoft.com committed Aug 27, 2008 461  idx_tycons)  chak@cse.unsw.edu.au. committed Sep 20, 2006 462  }  chak@cse.unsw.edu.au. committed Sep 20, 2006 463  where  chak@cse.unsw.edu.au. committed Sep 20, 2006 464 465 466 467  -- We pass in the source form and the type checked form of the ATs. We -- really need the source form only to be able to produce more informative -- error messages. checkValidAndMissingATs :: Class  Ian Lynagh committed May 04, 2008 468 469  -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT  simonpj@microsoft.com committed Aug 27, 2008 470  TyThing)] -- Core form of AT  Ian Lynagh committed May 04, 2008 471  -> TcM ()  chak@cse.unsw.edu.au. committed Sep 20, 2006 472 473  checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this  Ian Lynagh committed May 04, 2008 474 475  -- instance. ; let class_ats = map tyConName (classATs clas)  simonpj@microsoft.com committed Jan 03, 2007 476  defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ats  Ian Lynagh committed May 04, 2008 477 478 479 480 481 482 483 484 485 486 487  omitted = filterOut (elemNameSet defined_ats) class_ats ; warn <- doptM Opt_WarnMissingMethods ; mapM_ (warnTc warn . omittedATWarn) omitted -- Ensure that all AT indexes that correspond to class parameters -- coincide with the types in the instance head. All remaining -- AT arguments must be variables. Also raise an error for any -- type instances that are not associated with this class. ; mapM_ (checkIndexes clas inst_tys) ats }  simonpj@microsoft.com committed Dec 30, 2008 488  checkIndexes clas inst_tys (hsAT, ATyCon tycon)  chak@cse.unsw.edu.au. committed Sep 20, 2006 489 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!  simonpj@microsoft.com committed Dec 30, 2008 490 491 492  = checkIndexes' clas inst_tys hsAT (tyConTyVars tycon, snd . fromJust . tyConFamInst_maybe$ tycon)  chak@cse.unsw.edu.au. committed Sep 20, 2006 493 494 495 496  checkIndexes _ _ _ = panic "checkIndexes" checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys) = let atName = tcdName . unLoc $hsAT  Ian Lynagh committed May 04, 2008 497 498 499 500 501  in setSrcSpan (getLoc hsAT)$ addErrCtxt (atInstCtxt atName) $case find ((atName ==) . tyConName) (classATs clas) of Nothing -> addErrTc$ badATErr clas atName -- not in this class  simonpj@microsoft.com committed Dec 30, 2008 502  Just atycon ->  Ian Lynagh committed May 04, 2008 503 504 505 506 507 508 509  -- The following is tricky! We need to deal with three -- complications: (1) The AT possibly only uses a subset of -- the class parameters as indexes and those it uses may be in -- a different order; (2) the AT may have extra arguments, -- which must be type variables; and (3) variables in AT and -- instance head will be different Name's even if their -- source lexemes are identical.  simonpj@microsoft.com committed Dec 30, 2008 510 511 512 513 514 515 516  -- -- e.g. class C a b c where -- data D b a :: * -> * -- NB (1) b a, omits c -- instance C [x] Bool Char where -- data D Bool [x] v = MkD x [v] -- NB (2) v -- -- NB (3) the x in 'instance C...' have differnt -- -- Names to x's in 'data D...'  Ian Lynagh committed May 04, 2008 517 518 519 520 521 522 523 524 525 526 527 528 529  -- -- Re (1), poss' contains a permutation vector to extract the -- class parameters in the right order. -- -- Re (2), we wrap the (permuted) class parameters in a Maybe -- type and use Nothing for any extra AT arguments. (First -- equation of checkIndex' below.) -- -- Re (3), we replace any type variable in the AT parameters -- that has the same source lexeme as some variable in the -- instance types with the instance type variable sharing its -- source lexeme. --  simonpj@microsoft.com committed Sep 13, 2010 530 531 532 533 534 535 536 537 538 539 540 541 542  let poss :: [Int] -- For *associated* type families, gives the position -- of that 'TyVar' in the class argument list (0-indexed) -- e.g. class C a b c where { type F c a :: *->* } -- Then we get Just [2,0] poss = catMaybes [ tv elemIndex classTyVars clas | tv <- tyConTyVars atycon] -- We will get Nothings for the "extra" type -- variables in an associated data type -- e.g. class C a where { data D a :: *->* } -- here D gets arity 2 and has two tyvars relevantInstTys = map (instTys !!) poss  Ian Lynagh committed May 04, 2008 543 544 545 546 547 548 549  instArgs = map Just relevantInstTys ++ repeat Nothing -- extra arguments renaming = substSameTyVar atTvs instTvs in zipWithM_ checkIndex (substTys renaming atTys) instArgs checkIndex ty Nothing  chak@cse.unsw.edu.au. committed Sep 20, 2006 550 551  | isTyVarTy ty = return () | otherwise = addErrTc $mustBeVarArgErr ty  Ian Lynagh committed May 04, 2008 552  checkIndex ty (Just instTy)  chak@cse.unsw.edu.au. committed Sep 20, 2006 553 554 555  | ty tcEqType instTy = return () | otherwise = addErrTc$ wrongATArgErr ty instTy  Ian Lynagh committed May 04, 2008 556  listToNameSet = addListToNameSet emptyNameSet  chak@cse.unsw.edu.au. committed Sep 20, 2006 557 558  substSameTyVar [] _ = emptyTvSubst  Ian Lynagh committed May 04, 2008 559  substSameTyVar (tv:tvs) replacingTvs =  chak@cse.unsw.edu.au. committed Sep 20, 2006 560  let replacement = case find (tv sameLexeme) replacingTvs of  Ian Lynagh committed May 04, 2008 561 562  Nothing -> mkTyVarTy tv Just rtv -> mkTyVarTy rtv  chak@cse.unsw.edu.au. committed Sep 20, 2006 563  --  Ian Lynagh committed May 04, 2008 564 565  tv1 sameLexeme tv2 = nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)  chak@cse.unsw.edu.au. committed Sep 20, 2006 566 567  in extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement  simonpj committed Oct 03, 2000 568 569 \end{code}  partain committed Jan 08, 1996 570 571  %************************************************************************  Ian Lynagh committed May 04, 2008 572 %* *  simonpj@microsoft.com committed Sep 05, 2008 573  Type-checking instance declarations, pass 2  Ian Lynagh committed May 04, 2008 574 %* *  partain committed Jan 08, 1996 575 576 577 %************************************************************************ \begin{code}  simonpj@microsoft.com committed Jul 01, 2008 578 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]  simonpj@microsoft.com committed Jul 07, 2010 579  -> TcM (LHsBinds Id)  Ian Lynagh committed May 04, 2008 580 581 -- (a) From each class declaration, -- generate any default-method bindings  simonpj committed Oct 09, 2003 582 -- (b) From each instance decl  Ian Lynagh committed May 04, 2008 583 -- generate the dfun binding  simonpj committed Oct 09, 2003 584 585  tcInstDecls2 tycl_decls inst_decls  Ian Lynagh committed May 04, 2008 586  = do { -- (a) Default methods from class decls  simonpj@microsoft.com committed Oct 29, 2009 587  let class_decls = filter (isClassDecl . unLoc) tycl_decls  simonpj@microsoft.com committed Jul 07, 2010 588  ; dm_binds_s <- mapM tcClassDecl2 class_decls  simonpj@microsoft.com committed Jul 21, 2010 589  ; let dm_binds = unionManyBags dm_binds_s  simonpj@microsoft.com committed Oct 29, 2009 590   Ian Lynagh committed May 04, 2008 591  -- (b) instance declarations  simonpj@microsoft.com committed Jul 21, 2010 592 593 594 595 596  ; let dm_ids = collectHsBindsBinders dm_binds -- Add the default method Ids (again) -- See Note [Default methods and instances] ; inst_binds_s <- tcExtendIdEnv dm_ids $mapM tcInstDecl2 inst_decls  Ian Lynagh committed May 04, 2008 597 598  -- Done  simonpj@microsoft.com committed Jul 21, 2010 599  ; return (dm_binds unionBags unionManyBags inst_binds_s) }  partain committed Jan 08, 1996 600 601 \end{code}  simonpj@microsoft.com committed Jul 21, 2010 602 603 604 605 606 607 608 609 610 611 612 613 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). So right here in tcInstDecl2 we must re-extend the type envt with the default method Ids replete with their INLINE pragmas. Urk.  simonmar committed Feb 23, 2001 614   partain committed Jan 08, 1996 615 \begin{code}  simonpj@microsoft.com committed Dec 13, 2010 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645  tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- Returns a binding for the dfun tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) = recoverM (return emptyLHsBinds)$ setSrcSpan loc $addErrCtxt (instDeclCtxt2 (idType dfun_id))$ do { -- Instantiate the instance decl with skolem constants ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id) ; let (clas, inst_tys) = tcSplitDFunHead inst_head (class_tyvars, sc_theta, _, op_items) = classBigSig clas sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta n_ty_args = length inst_tyvars n_silent = dfunNSilent dfun_id (silent_theta, orig_theta) = splitAt n_silent dfun_theta ; silent_ev_vars <- mapM newSilentGiven silent_theta ; orig_ev_vars <- newEvVars orig_theta ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars ; (sc_binds, sc_dicts, sc_args) <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta' -- Check that any superclasses gotten from a silent arguemnt -- can be deduced from the originally-specified dfun arguments ; ct_loc <- getCtLoc ScOrigin ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $emitConstraints$ listToBag $[ WcEvVar (WantedEvVar sc ct_loc) | sc <- sc_dicts, isSilentEvVar sc ]  simonpj@microsoft.com committed Oct 29, 2009 646 647 648  -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas]  simonpj@microsoft.com committed Dec 13, 2010 649  ; spec_info <- tcSpecInstPrags dfun_id ibinds  simonpj@microsoft.com committed Oct 29, 2009 650 651  -- Typecheck the methods  simonpj@microsoft.com committed Sep 13, 2010 652  ; (meth_ids, meth_binds)  simonpj@microsoft.com committed Dec 13, 2010 653 654 655 656 657 658 659  <- 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 inst_tys spec_info op_items ibinds  simonpj@microsoft.com committed Dec 31, 2008 660   simonpj@microsoft.com committed Jan 05, 2010 661  -- Create the result bindings  simonpj@microsoft.com committed Dec 21, 2010 662 663 664 665 666 667 668 669  ; self_dict <- newEvVar (ClassP clas inst_tys) ; let class_tc = classTyCon clas [dict_constr] = tyConDataCons class_tc dict_bind = mkVarBind self_dict dict_rhs dict_rhs = foldl mk_app inst_constr $map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids inst_constr = L loc$ wrapId (mkWpTyApps inst_tys) (dataConWrapId dict_constr)  simonpj@microsoft.com committed Jan 05, 2010 670 671 672 673  -- 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  simonpj@microsoft.com committed Nov 01, 2010 674 675  -- member) are dealt with by the common MkId.mkDataConWrapId -- code rather than needing to be repeated here.  simonpj@microsoft.com committed Dec 13, 2010 676   simonpj@microsoft.com committed Dec 21, 2010 677 678 679 680  mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id mk_app fun arg = L loc (HsApp fun (L loc arg)) arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)  simonpj@microsoft.com committed Jan 05, 2010 681 682 683 684  -- 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 685 686 687 688 689 690 691  dfun_id_w_fun | isNewTyCon class_tc = dfun_id setInlinePragma alwaysInlinePragma { inl_sat = Just 0 } | otherwise = dfun_id setIdUnfolding mkDFunUnfolding dfun_ty (sc_args ++ meth_args) setInlinePragma dfunInlinePragma meth_args = map (DFunPolyArg . Var) meth_ids  simonpj@microsoft.com committed Jan 05, 2010 692   simonpj@microsoft.com committed Dec 13, 2010 693  main_bind = AbsBinds { abs_tvs = inst_tyvars  simonpj@microsoft.com committed Sep 13, 2010 694  , abs_ev_vars = dfun_ev_vars  simonpj@microsoft.com committed Dec 13, 2010 695 696  , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict, SpecPrags [] {- spec_inst_prags -})]  simonpj@microsoft.com committed Sep 13, 2010 697 698  , abs_ev_binds = emptyTcEvBinds , abs_binds = unitBag dict_bind }  simonpj@microsoft.com committed Jan 05, 2010 699   simonpj@microsoft.com committed Dec 13, 2010 700 701 702  ; return (unitBag (L loc main_bind) unionBags unionManyBags sc_binds unionBags listToBag meth_binds)  simonpj@microsoft.com committed Jan 05, 2010 703  }  simonpj@microsoft.com committed Dec 13, 2010 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731  where skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap] dfun_ty = idType dfun_id dfun_id = instanceDFunId ispec loc = getSrcSpan dfun_id ------------------------------ tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr) tcSuperClass n_ty_args ev_vars pred | Just (ev, i) <- find n_ty_args ev_vars = return (emptyBag, ev, DFunLamArg i) | otherwise = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) do { sc_dict <- newWantedEvVar pred ; loc <- getCtLoc ScOrigin ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc))) ; let ev_wrap = WpLet (EvBinds ev_binds) sc_bind = mkVarBind sc_dict (noLoc $(wrapId ev_wrap sc_dict)) ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) } -- It's very important to solve the superclass constraint *in isolation* -- so that it isn't generated by superclass selection from something else -- We then generate the (also rather degenerate) top-level binding: -- sc_dict = let sc_dict = in sc_dict -- where is generated by solving the implication constraint where find _ [] = Nothing find i (ev:evs) | pred tcEqPred evVarPred ev = Just (ev, i) | otherwise = find (i+1) evs  simonpj@microsoft.com committed Jan 05, 2010 732   simonpj@microsoft.com committed Sep 13, 2010 733 ------------------------------  simonpj@microsoft.com committed Dec 13, 2010 734 tcSpecInstPrags :: DFunId -> InstBindings Name  simonpj@microsoft.com committed Sep 13, 2010 735 736 737 738 739 740 741 742  -> 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 -- The filter removes the pragmas for methods ; return (spec_inst_prags, mkPragFun uprags binds) }  743 \end{code}  simonpj committed Oct 18, 2002 744   simonpj@microsoft.com committed Dec 13, 2010 745 746 747 748 749 750 751 752 Note [Silent Superclass Arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 more extreme case of what happens with recursive dictionaries.  simonpj@microsoft.com committed Dec 21, 2010 753 754 755 756 757 To implement the dfun we must generate code for the superclass C [a], which we can get by superclass selection from the supplied argument! So we’d generate: dfun :: forall a. D [a] -> D [a] dfun = \d::D [a] -> MkD (scsel d) ..  simonpj@microsoft.com committed Dec 13, 2010 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 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815  However this means that if we later encounter a situation where we have a [Wanted] dw::D [a] we could solve it thus: dw := dfun dw Although recursive, this binding would pass the TcSMonadisGoodRecEv check because it appears as guarded. But in reality, it will make a bottom superclass. The trouble is that isGoodRecEv can't "see" the superclass-selection inside dfun. Our solution to this problem is to change the way ‘dfuns’ are created for instances, so that we pass as first arguments to the 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 ... 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 means that no superclass is hidden inside a dfun application, so the counting argument in isGoodRecEv (more dfun calls than superclass selections) works correctly. 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. 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). 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]) [Derived] (d :: D [a]) [Derived] (scd :: C [a]) scd := scsel d [Derived] (scd2 :: C [a]) scd2 := scsel d2 And now, though we *can* solve: d2 := dw we will get an isGoodRecEv failure when we try to solve: d1 := scsel d or d1 := scsel d2 Test case SCLoop tests this fix.  simonpj@microsoft.com committed Oct 29, 2009 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 Note [SPECIALISE instance pragmas] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider instance (Ix a, Ix b) => Ix (a,b) where {-# SPECIALISE instance Ix (Int,Int) #-} range (x,y) = ... We do *not* want to make a specialised version of the dictionary function. Rather, we want specialised versions of each method. Thus we should generate something like this: $dfIx :: (Ix a, Ix x) => Ix (a,b) {- DFUN [$crange, ...] -} $dfIx da db = Ix ($crange da db) (...other methods...) $dfIxPair :: (Ix a, Ix x) => Ix (a,b) {- DFUN [$crangePair, ...] -} $dfIxPair = Ix ($crangePair da db) (...other methods...) $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)] {-# SPECIALISE$crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-} $crange da db = {-# RULE range ($dfIx da db) = $crange da db #-} Note that * The RULE is unaffected by the specialisation. We don't want to specialise$dfIx, because then it would need a specialised RULE which is a pain. The single RULE works fine at all specialisations. See Note [How instance declarations are translated] above * Instead, we want to specialise the *method*, $crange In practice, rather than faking up a SPECIALISE pragama for each method (which is painful, since we'd have to figure out its specialised type), we call tcSpecPrag *as if* were going to specialise$dfIx -- you can see that in the call to tcSpecInst. That generates a SpecPrag which, as it turns out, can be used unchanged for each method. The "it turns out" bit is delicate, but it works fine! \begin{code}  simonpj@microsoft.com committed Jan 06, 2010 859 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag  simonpj@microsoft.com committed Oct 29, 2009 860 861 862 tcSpecInst dfun_id prag@(SpecInstSig hs_ty) = addErrCtxt (spec_ctxt prag) $do { let name = idName dfun_id  simonpj@microsoft.com committed Dec 13, 2010 863 864 865 866 867  ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) (idType dfun_id) spec_dfun_ty  simonpj@microsoft.com committed Oct 07, 2010 868  ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }  simonpj@microsoft.com committed Oct 29, 2009 869 870 871 872 873  where spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag) tcSpecInst _ _ = panic "tcSpecInst" \end{code}  twanvl committed Jan 17, 2008 874   simonpj@microsoft.com committed Sep 05, 2008 875 876 877 878 879 %************************************************************************ %* * Type-checking an instance method %* * %************************************************************************  simonpj committed Oct 18, 2002 880   881 882 883 884 885 886 887 tcInstanceMethod - Make the method bindings, as a [(NonRec, HsBinds)], one per method - Remembering to use fresh Name (the instance method Name) as the binder - Bring the instance method Ids into scope, for the benefit of tcInstSig - Use sig_fn mapping instance method Name -> instance tyvars - Ditto prag_fn - Use tcValBinds to do the checking  Ian Lynagh committed May 04, 2008 888   889 \begin{code}  simonpj@microsoft.com committed Sep 13, 2010 890 891 892 tcInstanceMethods :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]  simonpj@microsoft.com committed Dec 13, 2010 893  -> ([Located TcSpecPrag], PragFun)  simonpj@microsoft.com committed Sep 13, 2010 894 895 896  -> [(Id, DefMeth)] -> InstBindings Name -> TcM ([Id], [LHsBind Id])  897 898  -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ...  simonpj@microsoft.com committed Sep 13, 2010 899 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys  simonpj@microsoft.com committed Dec 13, 2010 900  (spec_inst_prags, prag_fn)  simonpj@microsoft.com committed Sep 13, 2010 901 902  op_items (VanillaInst binds _ standalone_deriv) = mapAndUnzipM tc_item op_items  903  where  simonpj@microsoft.com committed Sep 13, 2010 904 905 906 907 908 909 910 911 912 913  ---------------------- tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id) tc_item (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of Just user_bind -> tc_body sel_id standalone_deriv user_bind Nothing -> tc_default sel_id dm_info ---------------------- tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id) tc_body sel_id generated_code rn_bind  simonpj@microsoft.com committed Sep 15, 2010 914  = add_meth_ctxt sel_id generated_code rn_bind$  simonpj@microsoft.com committed Sep 13, 2010 915 916  do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id  917  ; let prags = prag_fn (idName sel_id)  simonpj@microsoft.com committed Oct 07, 2010 918 919  ; meth_id1 <- addInlinePrags meth_id prags ; spec_prags <- tcSpecPrags meth_id1 prags  simonpj@microsoft.com committed Sep 13, 2010 920  ; bind <- tcInstanceMethodBody InstSkol  simonpj@microsoft.com committed Dec 13, 2010 921  tyvars dfun_ev_vars  simonpj@microsoft.com committed Oct 07, 2010 922 923  meth_id1 local_meth_id meth_sig_fn (mk_meth_spec_prags meth_id1 spec_prags)  simonpj@microsoft.com committed Sep 13, 2010 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950  rn_bind ; return (meth_id1, bind) } ---------------------- tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) tc_default sel_id GenDefMeth -- Derivable type classes stuff = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id ; tc_body sel_id False {- Not generated code? -} meth_bind } tc_default sel_id NoDefMeth -- No default method at all = do { warnMissingMethod sel_id ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; return (meth_id, mkVarBind meth_id $mkLHsWrap lam_wrapper error_rhs) } where error_rhs = L loc$ HsApp error_fun error_msg error_fun = L loc $wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars tc_default sel_id (DefMeth dm_name) -- A polymorphic default method = do { -- Build the typechecked version directly, -- without calling typecheck_method; -- see Note [Default methods in instances]  simonpj@microsoft.com committed Dec 13, 2010 951 952  -- Generate /\as.\ds. let self = df as ds -- in$dm inst_tys self  simonpj@microsoft.com committed Sep 13, 2010 953 954 955  -- The 'let' is necessary only because HsSyn doesn't allow -- you to apply a function to a dictionary *expression*.  simonpj@microsoft.com committed Dec 13, 2010 956 957 958 959  ; self_dict <- newEvVar (ClassP clas inst_tys) ; let self_ev_bind = EvBind self_dict $EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars  simonpj@microsoft.com committed Sep 13, 2010 960 961 962 963 964 965 966 967 968  ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; dm_id <- tcLookupId dm_name ; let dm_inline_prag = idInlinePragma dm_id rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys)$ HsVar dm_id meth_bind = L loc $VarBind { var_id = local_meth_id , var_rhs = L loc rhs  simonpj@microsoft.com committed Dec 13, 2010 969  , var_inline = False }  simonpj@microsoft.com committed Sep 13, 2010 970 971 972 973 974 975  meth_id1 = meth_id setInlinePragma dm_inline_prag -- Copy the inline pragma (if any) from the default -- method to this version. Note [INLINE and default methods] bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [( tyvars, meth_id1, local_meth_id  simonpj@microsoft.com committed Oct 07, 2010 976  , mk_meth_spec_prags meth_id1 [])]  simonpj@microsoft.com committed Dec 13, 2010 977  , abs_ev_binds = EvBinds (unitBag self_ev_bind)  simonpj@microsoft.com committed Sep 13, 2010 978 979 980 981 982 983 984 985 986  , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but -- currently they are rejected with -- "INLINE pragma lacks an accompanying binding" ; return (meth_id1, L loc bind) } ----------------------  simonpj@microsoft.com committed Oct 07, 2010 987 988 989 990 991 992 993 994 995 996 997 998  mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags -- Adapt the SPECIALISE pragmas to work for this method Id -- There are two sources: -- * spec_inst_prags: {-# SPECIALISE instance :: #-} -- These ones have the dfun inside, but [perhaps surprisingly] -- the correct wrapper -- * spec_prags_for_me: {-# SPECIALISE op :: #-} mk_meth_spec_prags meth_id spec_prags_for_me = SpecPrags (spec_prags_for_me ++ [ L loc (SpecPrag meth_id wrap inl) | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])  simonpj@microsoft.com committed Sep 13, 2010 999 1000  loc = getSrcSpan dfun_id meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"  simonpj@microsoft.com committed Oct 29, 2009 1001 1002 1003 1004 1005 1006 1007  -- But there are no scoped type variables from local_method_id -- 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!  simonpj@microsoft.com committed Dec 13, 2010 1008  -- For instance decls that come from standalone deriving clauses  simonpj@microsoft.com committed Jul 23, 2009 1009 1010  -- we want to print out the full source code if there's an error -- because otherwise the user won't see the code at all  simonpj@microsoft.com committed Sep 15, 2010 1011 1012  add_meth_ctxt sel_id generated_code rn_bind thing | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing  simonpj@microsoft.com committed Sep 13, 2010 1013 1014 1015 1016  | otherwise = thing tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys  simonpj@microsoft.com committed Dec 13, 2010 1017  _ op_items (NewTypeDerived coi _)  simonpj@microsoft.com committed Sep 13, 2010 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044  -- Running example: -- class Show b => Foo a b where -- op :: a -> b -> b -- newtype N a = MkN (Tree [a]) -- deriving instance (Show p, Foo Int p) => Foo Int (N p) -- -- NB: standalone deriving clause means -- -- that the contex is user-specified -- Hence op :: forall a b. Foo a b => a -> b -> b -- -- We're going to make an instance like -- instance (Show p, Foo Int p) => Foo Int (N p) -- op =$copT -- -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p --$copT p (d1:Show p) (d2:Foo Int p) -- = op Int (Tree [p]) rep_d |> op_co -- where -- rep_d :: Foo Int (Tree [p]) = ...d1...d2... -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p) -- We get op_co by substituting [Int/a] and [co/b] in type for op -- where co : [p] ~ T p -- -- Notice that the dictionary bindings "..d1..d2.." must be generated -- by the constraint solver, since the may be -- user-specified.  simonpj@microsoft.com committed Oct 21, 2010 1045  = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $ simonpj@microsoft.com committed Sep 13, 2010 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107  emitWanted ScOrigin rep_pred ; mapAndUnzipM (tc_item rep_d_stuff) op_items } where loc = getSrcSpan dfun_id inst_tvs = fst (tcSplitForAllTys (idType dfun_id)) Just (init_inst_tys, _) = snocView inst_tys rep_ty = fst (coercionKind co) -- [p] rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty]) -- co : [p] ~ T p co = substTyWith inst_tvs (mkTyVarTys tyvars)$ case coi of { IdCo ty -> ty ; ACo co -> mkSymCoercion co } ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) tc_item (rep_ev_binds, rep_d) (sel_id, _) = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id meth_bind = VarBind { var_id = local_meth_id , var_rhs = L loc meth_rhs , var_inline = False } bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [(tyvars, meth_id, local_meth_id, noSpecPrags)] , abs_ev_binds = rep_ev_binds , abs_binds = unitBag $L loc meth_bind } ; return (meth_id, L loc bind) } ---------------- mk_op_wrapper :: Id -> EvVar -> HsWrapper mk_op_wrapper sel_id rep_d = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty) <.> WpEvApp (EvId rep_d) <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) where (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id) (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho orElse pprPanic "tcInstanceMethods" (ppr sel_id) ---------------------- mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId) mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id = do { uniq <- newUnique ; 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 ; let meth_id = mkLocalId meth_name meth_ty local_meth_id = mkLocalId local_meth_name local_meth_ty ; return (meth_id, local_meth_id) } where local_meth_ty = instantiateMethod clas sel_id inst_tys meth_ty = mkForAllTys tyvars$ mkPiTypes dfun_ev_vars local_meth_ty sel_name = idName sel_id  simonpj@microsoft.com committed Sep 10, 2008 1108   simonpj@microsoft.com committed Sep 13, 2010 1109 ----------------------  simonpj@microsoft.com committed Sep 05, 2008 1110 1111 wrapId :: HsWrapper -> id -> HsExpr id wrapId wrapper id = mkHsWrap wrapper (HsVar id)  simonpj@microsoft.com committed Jul 23, 2009 1112   simonpj@microsoft.com committed Sep 15, 2010 1113 1114 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc derivBindCtxt sel_id clas tys _bind  simonpj@microsoft.com committed Sep 15, 2010 1115  = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)  simonpj@microsoft.com committed Sep 15, 2010 1116 1117 1118 1119 1120 1121  , nest 2 (ptext (sLit "in a standalone derived instance for") <+> quotes (pprClassPred clas tys) <> colon) , nest 2 $ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ] -- Too voluminous -- , nest 2$ pprSetDepth AllTheWay $ppr bind ]  simonpj@microsoft.com committed Oct 29, 2009 1122 1123 1124 1125 1126 1127 1128 1129 1130  warnMissingMethod :: Id -> TcM () warnMissingMethod sel_id = do { warn <- doptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods && not (startsWithUnderscore (getOccName sel_id))) -- Don't warn about _foo methods (ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)) }  simonpj committed Apr 02, 2002 1131 1132 \end{code}  simonpj@microsoft.com committed Oct 29, 2009 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 Note [Export helper functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We arrange to export the "helper functions" of an instance declaration, so that they are not subject to preInlineUnconditionally, even if their RHS is trivial. Reason: they are mentioned in the DFunUnfolding of the dict fun as Ids, not as CoreExprs, so we can't substitute a non-variable for them. We could change this by making DFunUnfoldings have CoreExprs, but it seems a bit simpler this way.  1144 1145 1146 Note [Default methods in instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this  simonpj committed Apr 02, 2002 1147   1148 1149  class Baz v x where foo :: x -> x  simonpj@microsoft.com committed Oct 29, 2009 1150  foo y =  simonpj committed May 04, 2001 1151   1152  instance Baz Int Int  simonpj committed May 04, 2001 1153   1154 From the class decl we get  simonpj committed May 04, 2001 1155   1156 $dmfoo :: forall v x. Baz v x => x -> x  simonpj@microsoft.com committed Oct 29, 2009 1157  $dmfoo y =  simonpj committed May 04, 2001 1158   simonpj@microsoft.com committed Jan 06, 2010 1159 1160 Notice that the type is ambiguous. That's fine, though. The instance decl generates  simonpj committed May 04, 2001 1161   simonpj@microsoft.com committed Oct 29, 2009 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 $dBazIntInt = MkBaz fooIntInt fooIntInt = $dmfoo Int Int$dBazIntInt BUT this does mean we must generate the dictionary translation of fooIntInt directly, rather than generating source-code and type-checking it. That was the bug in Trac #1061. In any case it's less work to generate the translated version! Note [INLINE and default methods] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~  simonpj@microsoft.com committed Jan 06, 2010 1172 1173 1174 Default methods need special case. They are supposed to behave rather like macros. For exmample  simonpj@microsoft.com committed Oct 29, 2009 1175 1176 1177 1178 1179 1180 1181  class Foo a where op1, op2 :: Bool -> a -> a {-# INLINE op1 #-} op1 b x = op2 (not b) x instance Foo Int where  simonpj@microsoft.com committed Jan 06, 2010 1182  -- op1 via default method  simonpj@microsoft.com committed Oct 29, 2009 1183  op2 b x =  simonpj@microsoft.com committed Jan 06, 2010 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199  The instance declaration should behave just as if 'op1' had been defined with the code, and INLINE pragma, from its original definition. That is, just as if you'd written instance Foo Int where op2 b x = {-# INLINE op1 #-} op1 b x = op2 (not b) x So for the above example we generate:  simonpj@microsoft.com committed Oct 29, 2009 1200 1201 1202  {-# INLINE $dmop1 #-}  simonpj@microsoft.com committed Jan 06, 2010 1203  --$dmop1 has an InlineCompulsory unfolding  simonpj@microsoft.com committed Oct 29, 2009 1204 1205 1206 1207 1208  $dmop1 d b x = op2 d (not b) x$fFooInt = MkD $cop1$cop2 {-# INLINE $cop1 #-}  simonpj@microsoft.com committed Jan 06, 2010 1209 $cop1 = $dmop1$fFooInt  simonpj@microsoft.com committed Oct 29, 2009 1210 1211 1212  \$cop2 =  simonpj@microsoft.com committed Jan 06, 2010 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 Note carefullly: `