ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcInstDecls]{Typechecking instance declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcInstDcls (
  10         tcInstDecls1,
  11         tcInstDecls2,
  12         processInstBinds
  13     ) where
  14
  15
  16 IMP_Ubiq()
  17
  18 import HsSyn            ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
  19                           FixityDecl, IfaceSig, Sig(..),
  20                           SpecInstSig(..), HsBinds(..), Bind(..),
  21                           MonoBinds(..), GRHSsAndBinds, Match,
  22                           InPat(..), OutPat(..), HsExpr(..), HsLit(..),
  23                           Stmt, DoOrListComp, ArithSeqInfo, Fake, Fixity,
  24                           HsType(..), HsTyVar )
  25 import RnHsSyn          ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
  26                           SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl),
  27                           SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl)
  28                         )
  29 import TcHsSyn          ( TcIdOcc(..), SYN_IE(TcHsBinds),
  30                           SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
  31                           mkHsTyLam, mkHsTyApp,
  32                           mkHsDictLam, mkHsDictApp )
  33
  34
  35 import TcMonad
  36 import RnMonad          ( SYN_IE(RnNameSupply) )
  37 import Inst             ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
  38                           newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
  39 import TcBinds          ( tcPragmaSigs, checkSigTyVars )
  40 import TcDeriv          ( tcDeriving )
  41 import TcEnv            ( tcLookupClass, newLocalId, tcExtendGlobalTyVars )
  42 import SpecEnv          ( SpecEnv )
  43 import TcGRHSs          ( tcGRHSsAndBinds )
  44 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
  45 import TcKind           ( TcKind, unifyKind )
  46 import TcMatches        ( tcMatchesFun )
  47 import TcMonoType       ( tcTyVarScope, tcContext, tcHsTypeKind )
  48 import TcSimplify       ( tcSimplifyAndCheck )
  49 import TcType           ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
  50                           tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
  51                         )
  52 import Unify            ( unifyTauTy, unifyTauTyLists )
  53
  54
  55 import Bag              ( emptyBag, unitBag, unionBags, unionManyBags,
  56                           concatBag, foldBag, bagToList )
  57 import CmdLineOpts      ( opt_GlasgowExts, opt_CompilingGhcInternals,
  58                           opt_OmitDefaultInstanceMethods,
  59                           opt_SpecialiseOverloaded
  60                         )
  61 import Class            ( GenClass, GenClassOp,
  62                           classBigSig, classOps, classOpLocalType,
  63                           classOpTagByOccName_maybe
  64                           )
  65 import Id               ( GenId, idType, isDefaultMethodId_maybe, isNullaryDataCon, dataConArgTys )
  66 import PrelInfo         ( isCcallishClass )
  67 import ListSetOps       ( minusList )
  68 import Maybes           ( maybeToBool, expectJust )
  69 import Name             ( getOccString, occNameString, moduleString, isLocallyDefined, OccName, Name{--O only-} )
  70 import PrelVals         ( nO_EXPLICIT_METHOD_ERROR_ID )
  71 import PprType          ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
  72                           pprParendGenType
  73                         )
  74 import PprStyle
  75 import SrcLoc           ( SrcLoc )
  76 import Pretty
  77 import TyCon            ( isSynTyCon, derivedFor )
  78 import Type             ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
  79                           splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
  80                           getTyCon_maybe, maybeAppTyCon,
  81                           maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
  82                         )
  83 import TyVar            ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
  84 import TysPrim          ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
  85 import TysWiredIn       ( stringTy )
  86 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey )
  87 import Util             ( zipEqual, panic, pprPanic, pprTrace )
  88 \end{code}
  89
  90 Typechecking instance declarations is done in two passes. The first
  91 pass, made by @tcInstDecls1@, collects information to be used in the
  92 second pass.
  93
  94 This pre-processed info includes the as-yet-unprocessed bindings
  95 inside the instance declaration.  These are type-checked in the second
  96 pass, when the class-instance envs and GVE contain all the info from
  97 all the instance and value decls.  Indeed that's the reason we need
  98 two passes over the instance decls.
  99
 100
 101 Here is the overall algorithm.
 102 Assume that we have an instance declaration
 103
 104     instance c => k (t tvs) where b
 105
 106 \begin{enumerate}
 107 \item
 108 $LIE_c$ is the LIE for the context of class $c$
 109 \item
 110 $betas_bar$ is the free variables in the class method type, excluding the
 111    class variable
 112 \item
 113 $LIE_cop$ is the LIE constraining a particular class method
 114 \item
 115 $tau_cop$ is the tau type of a class method
 116 \item
 117 $LIE_i$ is the LIE for the context of instance $i$
 118 \item
 119 $X$ is the instance constructor tycon
 120 \item
 121 $gammas_bar$ is the set of type variables of the instance
 122 \item
 123 $LIE_iop$ is the LIE for a particular class method instance
 124 \item
 125 $tau_iop$ is the tau type for this instance of a class method
 126 \item
 127 $alpha$ is the class variable
 128 \item
 129 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 130 \item
 131 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 132 \end{enumerate}
 133
 134 ToDo: Update the list above with names actually in the code.
 135
 136 \begin{enumerate}
 137 \item
 138 First, make the LIEs for the class and instance contexts, which means
 139 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 140 and make LIElistI and LIEI.
 141 \item
 142 Then process each method in turn.
 143 \item
 144 order the instance methods according to the ordering of the class methods
 145 \item
 146 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 147 \item
 148 Create final dictionary function from bindings generated already
 149 \begin{pseudocode}
 150 df = lambda inst_tyvars
 151        lambda LIEI
 152          let Bop1
 153              Bop2
 154              ...
 155              Bopn
 156          and dbinds_super
 157               in <op1,op2,...,opn,sd1,...,sdm>
 158 \end{pseudocode}
 159 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 160 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 161 \end{enumerate}
 162
 163 \begin{code}
 164 tcInstDecls1 :: [RenamedHsDecl]
 165              -> Module                  -- module name for deriving
 166              -> RnNameSupply                    -- for renaming derivings
 167              -> TcM s (Bag InstInfo,
 168                        RenamedHsBinds,
 169                        PprStyle -> Pretty)
 170
 171 tcInstDecls1 decls mod_name rn_name_supply
 172   =     -- Do the ordinary instance declarations
 173     mapNF_Tc (tcInstDecl1 mod_name)
 174              [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
 175     let
 176         decl_inst_info = unionManyBags inst_info_bags
 177     in
 178         -- Handle "derived" instances; note that we only do derivings
 179         -- for things in this module; we ignore deriving decls from
 180         -- interfaces! We pass fixities, because they may be used
 181         -- in deriving Read and Show.
 182     tcDeriving mod_name rn_name_supply decl_inst_info
 183                         `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 184
 185     let
 186         full_inst_info = deriv_inst_info `unionBags` decl_inst_info
 187     in
 188     returnTc (full_inst_info, deriv_binds, ddump_deriv)
 189
 190
 191 tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
 192
 193 tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
 194   =     -- Prime error recovery, set source location
 195     recoverNF_Tc (returnNF_Tc emptyBag) $
 196     tcAddSrcLoc src_loc                 $
 197
 198         -- Look things up
 199     tcLookupClass class_name            `thenTc` \ (clas_kind, clas) ->
 200
 201         -- Typecheck the context and instance type
 202     tcTyVarScope tyvar_names (\ tyvars ->
 203         tcContext context               `thenTc` \ theta ->
 204         tcHsTypeKind inst_ty            `thenTc` \ (tau_kind, tau) ->
 205         unifyKind clas_kind tau_kind    `thenTc_`
 206         returnTc (tyvars, theta, tau)
 207     )                                   `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
 208
 209         -- Check for respectable instance type
 210     scrutiniseInstanceType dfun_name clas inst_tau
 211                                         `thenTc` \ (inst_tycon,arg_tys) ->
 212
 213         -- Make the dfun id and constant-method ids
 214     mkInstanceRelatedIds dfun_name
 215                          clas inst_tyvars inst_tau inst_theta
 216                                         `thenNF_Tc` \ (dfun_id, dfun_theta) ->
 217
 218     returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
 219                                 dfun_theta dfun_id
 220                                 binds src_loc uprags))
 221   where
 222     (tyvar_names, context, dict_ty) = case poly_ty of
 223                                         HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty)
 224                                         other                      -> ([],  [],  poly_ty)
 225     (class_name, inst_ty) = case dict_ty of
 226                                 MonoDictTy cls ty -> (cls,ty)
 227                                 other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty)
 228 \end{code}
 229
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 \subsection{Type-checking instance declarations, pass 2}
 234 %*                                                                      *
 235 %************************************************************************
 236
 237 \begin{code}
 238 tcInstDecls2 :: Bag InstInfo
 239              -> NF_TcM s (LIE s, TcHsBinds s)
 240
 241 tcInstDecls2 inst_decls
 242   = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyBinds)) inst_decls
 243   where
 244     combine tc1 tc2 = tc1       `thenNF_Tc` \ (lie1, binds1) ->
 245                       tc2       `thenNF_Tc` \ (lie2, binds2) ->
 246                       returnNF_Tc (lie1 `plusLIE` lie2,
 247                                    binds1 `ThenBinds` binds2)
 248 \end{code}
 249
 250
 251 ======= New documentation starts here (Sept 92)  ==============
 252
 253 The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
 254 the dictionary function for this instance declaration.  For example
 255 \begin{verbatim}
 256         instance Foo a => Foo [a] where
 257                 op1 x = ...
 258                 op2 y = ...
 259 \end{verbatim}
 260 might generate something like
 261 \begin{verbatim}
 262         dfun.Foo.List dFoo_a = let op1 x = ...
 263                                    op2 y = ...
 264                                in
 265                                    Dict [op1, op2]
 266 \end{verbatim}
 267
 268 HOWEVER, if the instance decl has no context, then it returns a
 269 bigger @HsBinds@ with declarations for each method.  For example
 270 \begin{verbatim}
 271         instance Foo [a] where
 272                 op1 x = ...
 273                 op2 y = ...
 274 \end{verbatim}
 275 might produce
 276 \begin{verbatim}
 277         dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
 278         const.Foo.op1.List a x = ...
 279         const.Foo.op2.List a y = ...
 280 \end{verbatim}
 281 This group may be mutually recursive, because (for example) there may
 282 be no method supplied for op2 in which case we'll get
 283 \begin{verbatim}
 284         const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
 285 \end{verbatim}
 286 that is, the default method applied to the dictionary at this type.
 287
 288 What we actually produce in either case is:
 289
 290         AbsBinds [a] [dfun_theta_dicts]
 291                  [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
 292                  { d = (sd1,sd2, ..., op1, op2, ...)
 293                    op1 = ...
 294                    op2 = ...
 295                  }
 296
 297 The "maybe" says that we only ask AbsBinds to make global constant methods
 298 if the dfun_theta is empty.
 299
 300
 301 For an instance declaration, say,
 302
 303         instance (C1 a, C2 b) => C (T a b) where
 304                 ...
 305
 306 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 307 function whose type is
 308
 309         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 310
 311 Notice that we pass it the superclass dictionaries at the instance type; this
 312 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 313 is the @dfun_theta@ below.
 314
 315 First comes the easy case of a non-local instance decl.
 316
 317 \begin{code}
 318 tcInstDecl2 :: InstInfo
 319             -> NF_TcM s (LIE s, TcHsBinds s)
 320
 321 tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 322                       inst_decl_theta dfun_theta
 323                       dfun_id monobinds
 324                       locn uprags)
 325   | not (isLocallyDefined dfun_id)
 326   = returnNF_Tc (emptyLIE, EmptyBinds)
 327
 328   | otherwise
 329   =      -- Prime error recovery
 330     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds))   $
 331     tcAddSrcLoc locn                                    $
 332
 333         -- Get the class signature
 334     tcInstSigTyVars inst_tyvars         `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
 335     let
 336         (class_tyvar,
 337          super_classes, sc_sel_ids,
 338          class_ops, op_sel_ids, defm_ids) = classBigSig clas
 339     in
 340     tcInstType tenv inst_ty             `thenNF_Tc` \ inst_ty' ->
 341     tcInstTheta tenv dfun_theta         `thenNF_Tc` \ dfun_theta' ->
 342     tcInstTheta tenv inst_decl_theta    `thenNF_Tc` \ inst_decl_theta' ->
 343     let
 344         sc_theta'        = super_classes `zip` repeat inst_ty'
 345         origin           = InstanceDeclOrigin
 346         mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
 347     in
 348          -- Create dictionary Ids from the specified instance contexts.
 349     newDicts origin sc_theta'           `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
 350     newDicts origin dfun_theta'         `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
 351     newDicts origin inst_decl_theta'    `thenNF_Tc` \ (inst_decl_dicts, _) ->
 352     newDicts origin [(clas,inst_ty')]   `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
 353
 354          -- Create method variables
 355     mapAndUnzipNF_Tc mk_method op_sel_ids       `thenNF_Tc` \ (meth_insts_s, meth_ids) ->
 356
 357          -- Collect available Insts
 358     let
 359         inst_tyvars_set' = mkTyVarSet inst_tyvars'
 360
 361         avail_insts      -- These insts are in scope; quite a few, eh?
 362           = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
 363
 364         mk_method_expr
 365           = makeInstanceDeclDefaultMethodExpr locn clas meth_ids defm_ids inst_ty' this_dict_id
 366     in
 367     tcExtendGlobalTyVars inst_tyvars_set' (
 368         processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
 369     )                                   `thenTc` \ (insts_needed, method_mbinds) ->
 370     let
 371         -- Create the dict and method binds
 372         dict_bind
 373             = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
 374
 375         dict_and_method_binds
 376             = dict_bind `AndMonoBinds` method_mbinds
 377
 378     in
 379         -- Check the overloading constraints of the methods and superclasses
 380     tcAddErrCtxt (bindSigCtxt meth_ids) (
 381         tcSimplifyAndCheck
 382                  inst_tyvars_set'                       -- Local tyvars
 383                  avail_insts
 384                  (sc_dicts `unionBags` insts_needed)    -- Need to get defns for all these
 385     )                                    `thenTc` \ (const_lie, super_binds) ->
 386
 387         -- Check that we *could* construct the superclass dictionaries,
 388         -- even though we are *actually* going to pass the superclass dicts in;
 389         -- the check ensures that the caller will never have a problem building
 390         -- them.
 391     tcAddErrCtxt superClassSigCtxt (
 392     tcSimplifyAndCheck
 393                  inst_tyvars_set'               -- Local tyvars
 394                  inst_decl_dicts                -- The instance dictionaries available
 395                  sc_dicts                       -- The superclass dicationaries reqd
 396     )                                   `thenTc_`
 397                                                 -- Ignore the result; we're only doing
 398                                                 -- this to make sure it can be done.
 399
 400         -- Now process any SPECIALIZE pragmas for the methods
 401     let
 402         spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
 403     in
 404     tcPragmaSigs spec_sigs              `thenTc` \ (_, spec_binds, spec_lie) ->
 405     let
 406         -- Complete the binding group, adding any spec_binds
 407         inst_binds
 408           = AbsBinds
 409                  inst_tyvars'
 410                  dfun_arg_dicts_ids
 411                  [(this_dict_id, RealId dfun_id)]
 412                  super_binds
 413                  (RecBind dict_and_method_binds)
 414
 415             `ThenBinds`
 416             spec_binds
 417     in
 418
 419     returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 420 \end{code}
 421
 422 The next function makes a default method which calls the global default method, at
 423 the appropriate instance type.
 424
 425 See the notes under default decls in TcClassDcl.lhs.
 426
 427 \begin{code}
 428 makeInstanceDeclDefaultMethodExpr
 429         :: SrcLoc
 430         -> Class
 431         -> [TcIdOcc s]
 432         -> [Id]
 433         -> TcType s
 434         -> TcIdOcc s
 435         -> Int
 436         -> NF_TcM s (TcExpr s)
 437
 438 makeInstanceDeclDefaultMethodExpr src_loc clas meth_ids defm_ids inst_ty this_dict tag
 439   | not defm_is_err             -- Not sure that the default method is just error message
 440   =     -- def_op_id = defm_id inst_ty this_dict
 441     returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
 442
 443   | otherwise           -- There's definitely no default decl in the class,
 444                         -- so we produce a warning, and a better run=time error message too
 445   = warnTc True (omitDefaultMethodWarn clas_op clas_name inst_ty)
 446                                         `thenNF_Tc_`
 447
 448     returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
 449                        (HsLitOut (HsString (_PK_ error_msg)) stringTy))
 450   where
 451     idx     = tag - 1
 452     meth_id = meth_ids !! idx
 453     defm_id = defm_ids  !! idx
 454
 455     Just (_, _, defm_is_err) = isDefaultMethodId_maybe defm_id
 456
 457     error_msg = ppShow 80 (ppSep [ppr PprForUser clas_op, ppPStr SLIT("at"), ppr PprForUser src_loc])
 458
 459     clas_op = (classOps clas) !! idx
 460     clas_name = getOccString clas
 461 \end{code}
 462
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsection{Processing each method}
 468 %*                                                                      *
 469 %************************************************************************
 470
 471 @processInstBinds@ returns a @MonoBinds@ which binds
 472 all the method ids (which are passed in).  It is used
 473         - both for instance decls,
 474         - and to compile the default-method declarations in a class decl.
 475
 476 Any method ids which don't have a binding have a suitable default
 477 binding created for them. The actual right-hand side used is
 478 created using a function which is passed in, because the right thing to
 479 do differs between instance and class decls.
 480
 481 \begin{code}
 482 processInstBinds
 483         :: Class
 484         -> (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
 485         -> LIE s                           -- available Insts
 486         -> [TcIdOcc s]                     -- Local method ids in tag order
 487                                            --   (instance tyvars are free in their types)
 488         -> RenamedMonoBinds
 489         -> TcM s (LIE s,                   -- These are required
 490                   TcMonoBinds s)
 491
 492 processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds
 493   =
 494          -- Process the explicitly-given method bindings
 495     processInstBinds1 clas avail_insts method_ids monobinds
 496                         `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 497
 498          -- Find the methods not handled, and make default method bindings for them.
 499     let
 500         unmentioned_tags = [1.. length method_ids] `minusList` tags
 501     in
 502     mapNF_Tc mk_default_method unmentioned_tags
 503                         `thenNF_Tc` \ default_bind_list ->
 504
 505     returnTc (insts_needed_in_methods,
 506               foldr AndMonoBinds method_binds default_bind_list)
 507   where
 508         -- From a tag construct us the passed-in function to construct
 509         -- the binding for the default method
 510     mk_default_method tag = mk_default_method_rhs tag   `thenNF_Tc` \ rhs ->
 511                             returnNF_Tc (VarMonoBind (method_ids !! (tag-1)) rhs)
 512 \end{code}
 513
 514 \begin{code}
 515 processInstBinds1
 516         :: Class
 517         -> LIE s                -- available Insts
 518         -> [TcIdOcc s]          -- Local method ids in tag order (instance tyvars are free),
 519         -> RenamedMonoBinds
 520         -> TcM s ([Int],        -- Class-op tags accounted for
 521                   LIE s,        -- These are required
 522                   TcMonoBinds s)
 523
 524 processInstBinds1 clas avail_insts method_ids EmptyMonoBinds
 525   = returnTc ([], emptyLIE, EmptyMonoBinds)
 526
 527 processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2)
 528   = processInstBinds1 clas avail_insts method_ids mb1
 529                                  `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
 530     processInstBinds1 clas avail_insts method_ids mb2
 531                                  `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
 532     returnTc (op_tags1 ++ op_tags2,
 533               dicts1 `unionBags` dicts2,
 534               AndMonoBinds method_binds1 method_binds2)
 535 \end{code}
 536
 537 \begin{code}
 538 processInstBinds1 clas avail_insts method_ids mbind
 539   =
 540     -- Find what class op is being defined here.  The complication is
 541     -- that we could have a PatMonoBind or a FunMonoBind.  If the
 542     -- former, it should only bind a single variable, or else we're in
 543     -- trouble (I'm not sure what the static semantics of methods
 544     -- defined in a pattern binding with multiple patterns is!)
 545     -- Renamer has reduced us to these two cases.
 546     let
 547         (op,locn) = case mbind of
 548                       FunMonoBind op _ _ locn          -> (op, locn)
 549                       PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 550
 551         occ     = getOccName op
 552         origin  = InstanceDeclOrigin
 553     in
 554     tcAddSrcLoc locn                     $
 555
 556     -- Make a method id for the method
 557     let
 558         maybe_tag  = classOpTagByOccName_maybe clas occ
 559         (Just tag) = maybe_tag
 560         method_id  = method_ids !! (tag-1)
 561         method_ty  = tcIdType method_id
 562     in
 563     -- check that the method mentioned is actually in the class:
 564     checkMaybeTc maybe_tag (instMethodNotInClassErr occ clas) `thenTc_`
 565
 566     tcInstTcType method_ty              `thenNF_Tc` \ (method_tyvars, method_rho) ->
 567     let
 568         (method_theta, method_tau) = splitRhoTy method_rho
 569     in
 570     newDicts origin method_theta        `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 571
 572     case (method_tyvars, method_dict_ids) of
 573
 574       ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
 575
 576                 -- Type check the method itself
 577         tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 578         returnTc ([tag], lieIop, mbind')
 579
 580       other ->  -- It's a locally-polymorphic and/or overloaded method; UGH!
 581
 582                 -- Make a new id for (a) the local, non-overloaded method
 583                 -- and               (b) the locally-overloaded method
 584                 -- The latter is needed just so we can return an AbsBinds wrapped
 585                 -- up inside a MonoBinds.
 586
 587
 588                 -- Make the method_tyvars into signature tyvars so they
 589                 -- won't get unified with anything.
 590         tcInstSigTyVars method_tyvars           `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
 591         unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars)        `thenTc_`
 592
 593         newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
 594         newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
 595         let
 596             tc_local_id = TcId local_id
 597             tc_copy_id  = TcId copy_id
 598             sig_tyvar_set = mkTyVarSet sig_tyvars
 599         in
 600                 -- Typecheck the method
 601         tcMethodBind tc_local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 602
 603                 -- Check the overloading part of the signature.
 604
 605         -- =========== POSSIBLE BUT NOT DONE =================
 606                 -- Simplify everything fully, even though some
 607                 -- constraints could "really" be left to the next
 608                 -- level out. The case which forces this is
 609                 --
 610                 --      class Foo a where { op :: Bar a => a -> a }
 611                 --
 612                 -- Here we must simplify constraints on "a" to catch all
 613                 -- the Bar-ish things.
 614
 615                 -- We don't do this because it's currently illegal Haskell (not sure why),
 616                 -- and because the local type of the method would have a context at
 617                 -- the front with no for-all, which confuses the hell out of everything!
 618         -- ====================================================
 619
 620         tcAddErrCtxt (methodSigCtxt op method_ty) (
 621             checkSigTyVars
 622                 sig_tyvars method_tau                           `thenTc_`
 623
 624           tcSimplifyAndCheck
 625                 sig_tyvar_set
 626                 (method_dicts `plusLIE` avail_insts)
 627                 lieIop
 628         )                                        `thenTc` \ (f_dicts, dict_binds) ->
 629
 630
 631         returnTc ([tag],
 632                   f_dicts,
 633                   VarMonoBind method_id
 634                          (HsLet
 635                              (AbsBinds
 636                                 method_tyvars
 637                                 method_dict_ids
 638                                 [(tc_local_id, tc_copy_id)]
 639                                 dict_binds
 640                                 (NonRecBind mbind'))
 641                              (HsVar tc_copy_id)))
 642 \end{code}
 643
 644 \begin{code}
 645 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
 646              -> TcM s (TcMonoBinds s, LIE s)
 647
 648 tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
 649   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
 650     returnTc (FunMonoBind meth_id inf rhs' locn, lie)
 651
 652 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
 653   -- pat is sure to be a (VarPatIn op)
 654   = tcAddErrCtxt (patMonoBindsCtxt pbind) $
 655     tcGRHSsAndBinds grhss_and_binds     `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
 656     unifyTauTy meth_ty rhs_ty           `thenTc_`
 657     returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
 658 \end{code}
 659
 660
 661 %************************************************************************
 662 %*                                                                      *
 663 \subsection{Type-checking specialise instance pragmas}
 664 %*                                                                      *
 665 %************************************************************************
 666
 667 \begin{code}
 668 {- LATER
 669 tcSpecInstSigs :: E -> CE -> TCE
 670                -> Bag InstInfo          -- inst decls seen (declared and derived)
 671                -> [RenamedSpecInstSig]  -- specialise instance upragmas
 672                -> TcM (Bag InstInfo)    -- new, overlapped, inst decls
 673
 674 tcSpecInstSigs e ce tce inst_infos []
 675   = returnTc emptyBag
 676
 677 tcSpecInstSigs e ce tce inst_infos sigs
 678   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 679     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 680     returnTc spec_inst_infos
 681   where
 682     tc_inst_spec_sigs inst_mapper []
 683       = returnNF_Tc emptyBag
 684     tc_inst_spec_sigs inst_mapper (sig:sigs)
 685       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 686         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 687         returnNF_Tc (info_sig `unionBags` info_sigs)
 688
 689 tcSpecInstSig :: E -> CE -> TCE
 690               -> Bag InstInfo
 691               -> InstanceMapper
 692               -> RenamedSpecInstSig
 693               -> NF_TcM (Bag InstInfo)
 694
 695 tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc)
 696   = recoverTc emptyBag                  (
 697     tcAddSrcLoc src_loc                 (
 698     let
 699         clas = lookupCE ce class_name -- Renamer ensures this can't fail
 700
 701         -- Make some new type variables, named as in the specialised instance type
 702         ty_names                          = extractHsTyNames ???is_tyvarish_name??? ty
 703         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
 704     in
 705     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
 706                                 `thenTc` \ inst_ty ->
 707     let
 708         maybe_tycon = case maybeAppDataTyCon inst_ty of
 709                          Just (tc,_,_) -> Just tc
 710                          Nothing       -> Nothing
 711
 712         maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos
 713     in
 714         -- Check that we have a local instance declaration to specialise
 715     checkMaybeTc maybe_unspec_inst
 716             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
 717
 718         -- Create tvs to substitute for tmpls while simplifying the context
 719     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
 720     let
 721         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
 722                        _ _ binds _ uprag) = maybe_unspec_inst
 723
 724         subst = case matchTy unspec_inst_ty inst_ty of
 725                      Just subst -> subst
 726                      Nothing    -> panic "tcSpecInstSig:matchTy"
 727
 728         subst_theta    = instantiateThetaTy subst unspec_theta
 729         subst_tv_theta = instantiateThetaTy tv_e subst_theta
 730
 731         mk_spec_origin clas ty
 732           = InstanceSpecOrigin inst_mapper clas ty src_loc
 733         -- I'm VERY SUSPICIOUS ABOUT THIS
 734         -- the inst-mapper is in a knot at this point so it's no good
 735         -- looking at it in tcSimplify...
 736     in
 737     tcSimplifyThetas mk_spec_origin subst_tv_theta
 738                                 `thenTc` \ simpl_tv_theta ->
 739     let
 740         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 741
 742         tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
 743         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
 744     in
 745     mkInstanceRelatedIds
 746                          clas inst_tmpls inst_ty simpl_theta uprag
 747                                 `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 748
 749     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
 750     (if sw_chkr SpecialiseTrace then
 751         pprTrace "Specialised Instance: "
 752         (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
 753                           if null simpl_theta then ppNil else ppPStr SLIT("=>"),
 754                           ppr PprDebug clas,
 755                           pprParendGenType PprDebug inst_ty],
 756                    ppCat [ppPStr SLIT("        derived from:"),
 757                           if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
 758                           if null unspec_theta then ppNil else ppPStr SLIT("=>"),
 759                           ppr PprDebug clas,
 760                           pprParendGenType PprDebug unspec_inst_ty]])
 761     else id) (
 762
 763     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
 764                                 dfun_theta dfun_id
 765                                 binds src_loc uprag))
 766     )))
 767
 768
 769 lookup_unspec_inst clas maybe_tycon inst_infos
 770   = case filter (match_info match_inst_ty) (bagToList inst_infos) of
 771         []       -> Nothing
 772         (info:_) -> Just info
 773   where
 774     match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
 775       = from_here && clas == inst_clas &&
 776         match_ty inst_ty && is_plain_instance inst_ty
 777
 778     match_inst_ty = case maybe_tycon of
 779                       Just tycon -> match_tycon tycon
 780                       Nothing    -> match_fun
 781
 782     match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
 783           Just (inst_tc,_,_) -> tycon == inst_tc
 784           Nothing            -> False
 785
 786     match_fun inst_ty = isFunType inst_ty
 787
 788
 789 is_plain_instance inst_ty
 790   = case (maybeAppDataTyCon inst_ty) of
 791       Just (_,tys,_) -> all isTyVarTemplateTy tys
 792       Nothing        -> case maybeUnpackFunTy inst_ty of
 793                           Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
 794                           Nothing         -> error "TcInstDecls:is_plain_instance"
 795 -}
 796 \end{code}
 797
 798
 799 Checking for a decent instance type
 800 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 801 @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints:
 802 it must normally look like: @instance Foo (Tycon a b c ...) ...@
 803
 804 The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
 805 flag is on, or (2)~the instance is imported (they must have been
 806 compiled elsewhere). In these cases, we let them go through anyway.
 807
 808 We can also have instances for functions: @instance Foo (a -> b) ...@.
 809
 810 \begin{code}
 811 scrutiniseInstanceType dfun_name clas inst_tau
 812         -- TYCON CHECK
 813   | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
 814   = failTc (instTypeErr inst_tau)
 815
 816         -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
 817   | not (isLocallyDefined dfun_name)
 818   = returnTc (inst_tycon,arg_tys)
 819
 820         -- TYVARS CHECK
 821   | not (all isTyVarTy arg_tys ||
 822          opt_GlasgowExts)
 823   = failTc (instTypeErr inst_tau)
 824
 825         -- DERIVING CHECK
 826         -- It is obviously illegal to have an explicit instance
 827         -- for something that we are also planning to `derive'
 828         -- Though we can have an explicit instance which is more
 829         -- specific than the derived instance
 830   | clas `derivedFor` inst_tycon
 831     && all isTyVarTy arg_tys
 832   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 833
 834   |     -- CCALL CHECK
 835         -- A user declaration of a CCallable/CReturnable instance
 836         -- must be for a "boxed primitive" type.
 837     (uniqueOf clas == cCallableClassKey   && not (ccallable_type   inst_tau)) ||
 838     (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
 839   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 840
 841   | otherwise
 842   = returnTc (inst_tycon,arg_tys)
 843
 844   where
 845     (possible_tycon, arg_tys) = splitAppTys inst_tau
 846     inst_tycon_maybe          = getTyCon_maybe possible_tycon
 847     inst_tycon                = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
 848
 849 -- These conditions come directly from what the DsCCall is capable of.
 850 -- Totally grotesque.  Green card should solve this.
 851
 852 ccallable_type   ty = isPrimType ty ||                          -- Allow CCallable Int# etc
 853                       maybeToBool (maybeBoxedPrimType ty) ||    -- Ditto Int etc
 854                       ty `eqTy` stringTy ||
 855                       byte_arr_thing
 856   where
 857     byte_arr_thing = case maybeAppDataTyCon ty of
 858                         Just (tycon, ty_args, [data_con]) ->
 859 --                              pprTrace "cc1" (ppSep [ppr PprDebug tycon, ppr PprDebug data_con,
 860 --                                                     ppSep (map (ppr PprDebug) data_con_arg_tys)])(
 861                                 length data_con_arg_tys == 2 &&
 862                                 maybeToBool maybe_arg2_tycon &&
 863 --                              pprTrace "cc2" (ppSep [ppr PprDebug arg2_tycon]) (
 864                                 (arg2_tycon == byteArrayPrimTyCon ||
 865                                  arg2_tycon == mutableByteArrayPrimTyCon)
 866 --                              ))
 867                              where
 868                                 data_con_arg_tys = dataConArgTys data_con ty_args
 869                                 (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
 870                                 maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
 871                                 Just (arg2_tycon,_) = maybe_arg2_tycon
 872
 873                         other -> False
 874
 875 creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
 876                         -- Or, a data type with a single nullary constructor
 877                       case (maybeAppDataTyCon ty) of
 878                         Just (tycon, tys_applied, [data_con])
 879                                 -> isNullaryDataCon data_con
 880                         other -> False
 881 \end{code}
 882
 883 \begin{code}
 884
 885 instTypeErr ty sty
 886   = case ty of
 887       SynTy tc _ _ -> ppBesides [ppPStr SLIT("The type synonym `"), ppr sty tc, rest_of_msg]
 888       TyVarTy tv   -> ppBesides [ppPStr SLIT("The type variable `"), ppr sty tv, rest_of_msg]
 889       other        -> ppBesides [ppPStr SLIT("The type `"), ppr sty ty, rest_of_msg]
 890   where
 891     rest_of_msg = ppPStr SLIT("' cannot be used as an instance type.")
 892
 893 derivingWhenInstanceExistsErr clas tycon sty
 894   = ppHang (ppBesides [ppPStr SLIT("Deriving class `"),
 895                        ppr sty clas,
 896                        ppPStr SLIT("' type `"), ppr sty tycon, ppChar '\''])
 897          4 (ppPStr SLIT("when an explicit instance exists"))
 898
 899 derivingWhenInstanceImportedErr inst_mod clas tycon sty
 900   = ppHang (ppBesides [ppPStr SLIT("Deriving class `"),
 901                        ppr sty clas,
 902                        ppPStr SLIT("' type `"), ppr sty tycon, ppChar '\''])
 903          4 (ppBesides [ppPStr SLIT("when an instance declared in module `"),
 904                        pp_mod, ppPStr SLIT("' has been imported")])
 905   where
 906     pp_mod = ppBesides [ppPStr SLIT("module `"), ppPStr inst_mod, ppChar '\'']
 907
 908 nonBoxedPrimCCallErr clas inst_ty sty
 909   = ppHang (ppPStr SLIT("Unacceptable instance type for ccall-ish class"))
 910          4 (ppBesides [ ppPStr SLIT("class `"), ppr sty clas, ppPStr SLIT("' type `"),
 911                         ppr sty inst_ty, ppChar '\''])
 912
 913 omitDefaultMethodWarn clas_op clas_name inst_ty sty
 914   = ppCat [ppPStr SLIT("Warning: Omitted default method for"),
 915            ppr sty clas_op, ppPStr SLIT("in instance"),
 916            ppStr clas_name, pprParendGenType sty inst_ty]
 917
 918 instMethodNotInClassErr occ clas sty
 919   = ppHang (ppPStr SLIT("Instance mentions a method not in the class"))
 920          4 (ppBesides [ppPStr SLIT("class `"), ppr sty clas, ppPStr SLIT("' method `"),
 921                        ppr sty occ, ppChar '\''])
 922
 923 patMonoBindsCtxt pbind sty
 924   = ppHang (ppPStr SLIT("In a pattern binding:"))
 925          4 (ppr sty pbind)
 926
 927 methodSigCtxt name ty sty
 928   = ppHang (ppBesides [ppPStr SLIT("When matching the definition of class method `"),
 929                        ppr sty name, ppPStr SLIT("' to its signature :") ])
 930          4 (ppr sty ty)
 931
 932 bindSigCtxt method_ids sty
 933   = ppHang (ppPStr SLIT("When checking type signatures for: "))
 934          4 (ppInterleave (ppStr ", ") (map (ppr sty) method_ids))
 935
 936 superClassSigCtxt sty
 937   = ppPStr SLIT("When checking superclass constraints on instance declaration")
 938
 939 \end{code}