ghc/compiler/typecheck/TcInstDcls.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcInstDecls]{Typechecking instance declarations}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcInstDcls (
  10         tcInstDecls1, tcInstDecls2,
  11         tcSpecInstSigs,
  12         buildInstanceEnvs, processInstBinds,
  13         mkInstanceRelatedIds,
  14         InstInfo(..)
  15     ) where
  16
  17 IMPORT_Trace            -- ToDo:rm debugging
  18 import Outputable
  19 import Pretty
  20
  21 import TcMonad          -- typechecking monad machinery
  22 import TcMonadFns       ( newDicts, newMethod, newLocalWithGivenTy,
  23                           newClassOpLocals, copyTyVars,
  24                           applyTcSubstAndCollectTyVars
  25                         )
  26 import AbsSyn           -- the stuff being typechecked
  27
  28 import AbsUniType
  29 import BackSubst        ( applyTcSubstToBinds )
  30 import Bag              ( emptyBag, unitBag, unionBags, bagToList )
  31 import CE               ( lookupCE, CE(..) )
  32 import CmdLineOpts      ( GlobalSwitch(..) )
  33 import GenSpecEtc       ( checkSigTyVars )
  34 import E                ( mkE, getE_CE, getE_TCE, growE_LVE, tvOfE, LVE(..), E )
  35 import Errors           ( dupInstErr, derivingWhenInstanceExistsErr,
  36                           preludeInstanceErr, nonBoxedPrimCCallErr,
  37                           specInstUnspecInstNotFoundErr,
  38                           Error(..), UnifyErrContext(..)
  39                         )
  40 import HsPragmas        -- ****** NEED TO SEE CONSTRUCTORS ******
  41 import Id               -- lots of things
  42 import IdInfo           -- ditto
  43 import Inst             ( Inst, InstOrigin(..) )
  44 import InstEnv
  45 import Maybes           ( catMaybes, mkLookupFun, maybeToBool, Maybe(..) )
  46 import Name             ( getTagFromClassOpName )
  47 import NameTypes        ( fromPrelude )
  48 import LIE              ( nullLIE, mkLIE, unMkLIE, plusLIE, LIE )
  49 import ListSetOps       ( minusList )
  50 import TCE              ( TCE(..), UniqFM )
  51 import TVE              ( mkTVE, TVE(..) )
  52 import Spec             ( specTy )
  53 import TcContext        ( tcContext )
  54 import TcGRHSs          ( tcGRHSsAndBinds )
  55 import TcMatches        ( tcMatchesFun )
  56 import TcMonoType       ( tcInstanceType )
  57 import TcPragmas        ( tcDictFunPragmas, tcGenPragmas )
  58 import TcSimplify       ( tcSimplifyAndCheck, tcSimplifyThetas )
  59 import Unify            ( unifyTauTy )
  60 import Unique           ( cCallableClassKey, cReturnableClassKey )
  61 import Util
  62 \end{code}
  63
  64 Typechecking instance declarations is done in two passes. The first
  65 pass, made by @tcInstDecls1@,
  66 collects information to be used in the second pass.
  67
  68 This pre-processed info includes the as-yet-unprocessed bindings
  69 inside the instance declaration.  These are type-checked in the second
  70 pass, when the class-instance envs and GVE contain all the info from
  71 all the instance and value decls.  Indeed that's the reason we need
  72 two passes over the instance decls.
  73
  74     instance c => k (t tvs) where b
  75
  76 \begin{code}
  77 data InstInfo
  78   = InstInfo
  79       Class             -- Class, k
  80       [TyVarTemplate]   -- Type variables, tvs
  81       UniType           -- The type at which the class is being
  82                         --   instantiated
  83       ThetaType         -- inst_decl_theta: the original context from the
  84                         --   instance declaration.  It constrains (some of)
  85                         --   the TyVarTemplates above
  86       ThetaType         -- dfun_theta: the inst_decl_theta, plus one
  87                         --   element for each superclass; the "Mark
  88                         --   Jones optimisation"
  89       Id                -- The dfun id
  90       [Id]              -- Constant methods (either all or none)
  91       RenamedMonoBinds  -- Bindings, b
  92       Bool              -- True <=> local instance decl
  93       FAST_STRING       -- Name of module where this instance was
  94                         -- defined.
  95       SrcLoc            -- Source location assoc'd with this instance's defn
  96       [RenamedSig]      -- User pragmas recorded for generating specilaised instances
  97 \end{code}
  98
  99
 100 Here is the overall algorithm.  Assume that
 101
 102 \begin{enumerate}
 103 \item
 104 $LIE_c$ is the LIE for the context of class $c$
 105 \item
 106 $betas_bar$ is the free variables in the class method type, excluding the
 107    class variable
 108 \item
 109 $LIE_cop$ is the LIE constraining a particular class method
 110 \item
 111 $tau_cop$ is the tau type of a class method
 112 \item
 113 $LIE_i$ is the LIE for the context of instance $i$
 114 \item
 115 $X$ is the instance constructor tycon
 116 \item
 117 $gammas_bar$ is the set of type variables of the instance
 118 \item
 119 $LIE_iop$ is the LIE for a particular class method instance
 120 \item
 121 $tau_iop$ is the tau type for this instance of a class method
 122 \item
 123 $alpha$ is the class variable
 124 \item
 125 $LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
 126 \item
 127 $tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
 128 \end{enumerate}
 129
 130 ToDo: Update the list above with names actually in the code.
 131
 132 \begin{enumerate}
 133 \item
 134 First, make the LIEs for the class and instance contexts, which means
 135 instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
 136 and make LIElistI and LIEI.
 137 \item
 138 Then process each method in turn.
 139 \item
 140 order the instance methods according to the ordering of the class methods
 141 \item
 142 express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
 143 \item
 144 Create final dictionary function from bindings generated already
 145 \begin{pseudocode}
 146 df = lambda inst_tyvars
 147        lambda LIEI
 148          let Bop1
 149              Bop2
 150              ...
 151              Bopn
 152          and dbinds_super
 153               in <op1,op2,...,opn,sd1,...,sdm>
 154 \end{pseudocode}
 155 Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 156 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 157 \end{enumerate}
 158
 159 \begin{code}
 160 tcInstDecls1 :: E -> CE -> TCE -> [RenamedInstDecl] -> NF_TcM (Bag InstInfo)
 161
 162 tcInstDecls1 e ce tce [] = returnNF_Tc emptyBag
 163
 164 tcInstDecls1 e ce tce (inst_decl : rest)
 165   = tc_inst_1 inst_decl         `thenNF_Tc` \ infos1 ->
 166     tcInstDecls1 e ce tce rest  `thenNF_Tc` \ infos2 ->
 167     returnNF_Tc (infos1 `unionBags` infos2)
 168   where
 169     tc_inst_1 (InstDecl context class_name ty binds from_here modname imod uprags pragmas src_loc)
 170       =
 171             -- Prime error recovery and substitution pruning
 172         recoverTc emptyBag                      (
 173         addSrcLocTc src_loc                     (
 174
 175         let
 176             clas = lookupCE ce class_name -- Renamer ensures this can't fail
 177
 178             for_ccallable_or_creturnable
 179               = class_name == cCallableClass || class_name == cReturnableClass
 180               where
 181                cCallableClass   = PreludeClass cCallableClassKey   bottom
 182                cReturnableClass = PreludeClass cReturnableClassKey bottom
 183                bottom           = panic "for_ccallable_etc"
 184
 185             -- Make some new type variables, named as in the instance type
 186             ty_names            = extractMonoTyNames (==) ty
 187             (tve,inst_tyvars,_) = mkTVE ty_names
 188         in
 189             -- Check the instance type, including its syntactic constraints
 190         babyTcMtoTcM (tcInstanceType ce tce tve from_here src_loc ty)
 191                 `thenTc` \ inst_ty ->
 192
 193             -- DEAL WITH THE INSTANCE CONTEXT
 194         babyTcMtoTcM (tcContext ce tce tve context) `thenTc` \ theta ->
 195
 196             -- SOME BORING AND TURGID CHECKING:
 197         let
 198             inst_for_function_type = isFunType inst_ty
 199                 -- sigh; it happens; must avoid tickling inst_tycon
 200
 201             inst_tycon_maybe = getUniDataTyCon_maybe inst_ty
 202
 203             inst_tycon = case inst_tycon_maybe of
 204                            Just (xx,_,_) -> xx
 205                            Nothing       -> panic "tcInstDecls1:inst_tycon"
 206         in
 207             -------------------------------------------------------------
 208             -- It is illegal for a normal user's module to declare an
 209             -- instance for a Prelude-class/Prelude-type instance:
 210         checkTc (from_here                    -- really an inst decl in this module
 211                  && fromPreludeCore clas      -- prelude class
 212                  && (inst_for_function_type   -- prelude type
 213                      || fromPreludeCore inst_tycon)
 214                  && not (fromPrelude modname) -- we aren't compiling a Prelude mod
 215                 )
 216                 (preludeInstanceErr clas inst_ty src_loc) `thenTc_`
 217
 218             -------------------------------------------------------------
 219             -- It is obviously illegal to have an explicit instance
 220             -- for something that we are also planning to `derive'.
 221             -- Note that an instance decl coming in from outside
 222             -- is probably just telling us about the derived instance
 223             -- (ToDo: actually check, if possible), so we mustn't flag
 224             -- it as an error.
 225         checkTc (from_here
 226                  && not inst_for_function_type
 227                  && clas `derivedFor` inst_tycon)
 228                 (derivingWhenInstanceExistsErr clas inst_tycon) `thenTc_`
 229
 230             -------------------------------------------------------------
 231             -- A user declaration of a _CCallable/_CReturnable instance
 232             -- must be for a "boxed primitive" type.
 233         getSwitchCheckerTc      `thenNF_Tc` \ sw_chkr ->
 234         checkTc (for_ccallable_or_creturnable
 235                  && from_here                       -- instance defined here
 236                  && not (sw_chkr CompilingPrelude)  -- which allows anything
 237                  && (inst_for_function_type ||      -- a *function*??? hah!
 238                   not (maybeToBool (maybeBoxedPrimType inst_ty))))   -- naughty, naughty
 239                 (nonBoxedPrimCCallErr clas inst_ty src_loc) `thenTc_`
 240
 241             -- END OF TURGIDITY; back to real fun
 242             -------------------------------------------------------------
 243
 244         if (not inst_for_function_type && clas `derivedFor` inst_tycon) then
 245             -- Don't use this InstDecl; tcDeriv will make the
 246             -- InstInfo to be used in later processing.
 247             returnTc emptyBag
 248
 249         else
 250                 -- Make the dfun id and constant-method ids
 251             mkInstanceRelatedIds e
 252                         from_here pragmas src_loc
 253                         clas inst_tyvars inst_ty theta uprags
 254                                 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 255
 256             returnTc ( unitBag (
 257               InstInfo clas inst_tyvars inst_ty theta
 258                        dfun_theta dfun_id const_meth_ids
 259                        binds from_here modname src_loc uprags
 260             ))
 261         ))
 262 \end{code}
 263
 264
 265 Common bit of code shared with @tcDeriving@:
 266 \begin{code}
 267 mkInstanceRelatedIds e
 268                 from_here inst_pragmas locn
 269                 clas
 270                 inst_tyvars inst_ty inst_decl_theta uprags
 271   = getUniqueTc                         `thenNF_Tc` \ uniq ->
 272     let
 273         (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
 274
 275         super_class_theta = super_classes `zip` (repeat inst_ty)
 276
 277
 278         dfun_theta = case inst_decl_theta of
 279
 280                         []    -> []     -- If inst_decl_theta is empty, then we don't
 281                                         -- want to have any dict arguments, so that we can
 282                                         -- expose the constant methods.
 283
 284                         other -> inst_decl_theta ++ super_class_theta
 285                                         -- Otherwise we pass the superclass dictionaries to
 286                                         -- the dictionary function; the Mark Jones optimisation.
 287
 288         dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
 289     in
 290     fixNF_Tc ( \ rec_dfun_id ->
 291         babyTcMtoNF_TcM (
 292             tcDictFunPragmas e dfun_ty rec_dfun_id inst_pragmas
 293         )                       `thenNF_Tc` \ dfun_id_info ->
 294
 295         returnNF_Tc (mkDictFunId uniq clas inst_ty dfun_ty from_here dfun_id_info)
 296     ) `thenNF_Tc` \ dfun_id ->
 297
 298         -- Make the constant-method ids, if there are no type variables involved
 299     (if not (null inst_tyvars)  -- ToDo: could also do this if theta is null...
 300      then
 301         returnNF_Tc []
 302      else
 303         let
 304             inline_mes = [ getTagFromClassOpName v | (InlineSig v _ _) <- uprags ]
 305
 306             mk_const_meth op uniq
 307               = mkConstMethodId
 308                         uniq
 309                         clas op inst_ty
 310                         meth_ty from_here info
 311               where
 312                 is_elem = isIn "mkInstanceRelatedIds"
 313
 314                 info    = if tag `is_elem` inline_mes
 315                           then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
 316                           else noIdInfo
 317
 318                 tenv    = [(class_tyvar, inst_ty)]
 319                 tag     = getClassOpTag op
 320                 op_ty   = getClassOpLocalType op
 321                 meth_ty = instantiateTy tenv op_ty
 322                           -- If you move to a null-theta version, you need a
 323                           -- mkForallTy inst_tyvars here
 324
 325             mk_constm_w_info (op, u, (name, prags)) -- ToDo: chk name?
 326               = fixNF_Tc ( \ rec_constm_id ->
 327
 328                     babyTcMtoNF_TcM (tcGenPragmas e (Just meth_ty) rec_constm_id prags)
 329                                 `thenNF_Tc` \ id_info ->
 330
 331                     returnNF_Tc (mkConstMethodId u clas op inst_ty meth_ty
 332                                         from_here id_info)
 333                 )
 334               where
 335                 tenv    = [(class_tyvar, inst_ty)]
 336                 op_ty   = getClassOpLocalType op
 337                 meth_ty = instantiateTy tenv op_ty
 338
 339         in
 340         getUniquesTc (length class_ops) `thenNF_Tc` \ constm_uniqs ->
 341         (case inst_pragmas of
 342            ConstantInstancePragma _ name_pragma_pairs ->
 343              mapNF_Tc mk_constm_w_info (zip3 class_ops constm_uniqs name_pragma_pairs)
 344
 345            other_inst_pragmas ->
 346              returnNF_Tc (zipWith mk_const_meth class_ops constm_uniqs)
 347         )
 348     )           `thenNF_Tc` \ const_meth_ids ->
 349
 350     returnTc (dfun_id, dfun_theta, const_meth_ids)
 351 \end{code}
 352
 353
 354 %************************************************************************
 355 %*                                                                      *
 356 \subsection{Converting instance info into suitable InstEnvs}
 357 %*                                                                      *
 358 %************************************************************************
 359
 360 \begin{code}
 361 buildInstanceEnvs :: Bag InstInfo
 362                   -> TcM InstanceMapper
 363
 364 buildInstanceEnvs info
 365   = let
 366         cmp :: InstInfo -> InstInfo -> TAG_
 367         (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `cmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
 368           = if c1 == c2 then EQ_ else if c1 < c2 then LT_ else GT_
 369
 370         info_by_class = equivClasses cmp (bagToList info)
 371     in
 372     mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
 373     let
 374         class_lookup_maybe_fn
 375             :: Class
 376             -> Maybe (ClassInstEnv, (ClassOp -> SpecEnv))
 377         class_lookup_fn
 378             :: InstanceMapper
 379
 380         class_lookup_maybe_fn = mkLookupFun (==) inst_env_entries
 381
 382         class_lookup_fn c
 383           = case class_lookup_maybe_fn c of
 384               Nothing -> (nullMEnv, \ o -> nullSpecEnv)
 385               Just xx -> xx
 386     in
 387     returnTc class_lookup_fn
 388 \end{code}
 389
 390 \begin{code}
 391 buildInstanceEnv :: [InstInfo]          -- Non-empty, and all for same class
 392                  -> TcM (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
 393
 394 buildInstanceEnv inst_infos@(info_for_one@(InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : rest)
 395   = let
 396         ops       = getClassOps clas
 397         no_of_ops = length ops
 398     in
 399     foldlTc addClassInstance
 400             (nullMEnv, nOfThem no_of_ops nullSpecEnv)
 401             inst_infos      `thenTc` \ (class_inst_env, op_inst_envs) ->
 402     let
 403         class_op_maybe_fn :: ClassOp -> Maybe SpecEnv
 404         class_op_fn       :: ClassOp -> SpecEnv
 405
 406         class_op_maybe_fn = mkLookupFun (==) (ops `zip` op_inst_envs)
 407                         -- They compare by ClassOp tags
 408         class_op_fn op
 409           = case class_op_maybe_fn op of
 410               Nothing -> nullSpecEnv
 411               Just xx -> xx
 412     in
 413     returnTc (clas, (class_inst_env, class_op_fn))
 414 \end{code}
 415
 416 \begin{code}
 417 addClassInstance
 418     :: (ClassInstEnv, [SpecEnv])
 419     -> InstInfo
 420     -> TcM (ClassInstEnv, [SpecEnv])    -- One SpecEnv for each class op
 421
 422 addClassInstance
 423     (class_inst_env, op_spec_envs)
 424     (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta dfun_id const_meth_ids _ _ _ src_loc _)
 425   =     -- Insert into the class_inst_env first
 426     checkMaybeErrTc (addClassInst clas class_inst_env inst_ty dfun_id inst_tyvars dfun_theta src_loc)
 427                     dupInstErr          `thenTc` \ class_inst_env' ->
 428     let
 429          -- Adding the classop instances can't fail if the class instance itself didn't
 430          op_spec_envs' = case const_meth_ids of
 431                            []    -> op_spec_envs
 432                            other -> zipWith add_const_meth op_spec_envs const_meth_ids
 433     in
 434     returnTc (class_inst_env', op_spec_envs')
 435   where
 436     add_const_meth spec_env meth_id
 437       = addOneToSpecEnv spec_env (SpecInfo (Just inst_ty:nothings) 1 meth_id)
 438       where
 439         (const_meth_tyvars,_) = splitForalls (getIdUniType meth_id)
 440         nothings = [Nothing | _ <- const_meth_tyvars]
 441         -- This only works if the constant method id only has its local polymorphism.
 442         -- If you want to have constant methods for
 443         --                              instance Foo (a,b,c) where
 444         --                                      op x = ...
 445         -- then the constant method will be polymorphic in a,b,c, and
 446         -- the SpecInfo will need to be elaborated.
 447 \end{code}
 448
 449
 450 %************************************************************************
 451 %*                                                                      *
 452 \subsection{Type-checking instance declarations, pass 2}
 453 %*                                                                      *
 454 %************************************************************************
 455
 456 \begin{code}
 457 tcInstDecls2 :: E
 458              -> Bag InstInfo
 459              -> NF_TcM (LIE, TypecheckedBinds)
 460
 461 tcInstDecls2 e inst_decls
 462   = let
 463         -- Get type variables free in environment. Sadly, there may be
 464         -- some, because of the dreaded monomorphism restriction
 465         free_tyvars = tvOfE e
 466     in
 467     tcInstDecls2_help e free_tyvars (bagToList inst_decls)
 468
 469 tcInstDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
 470
 471 tcInstDecls2_help e free_tyvars (inst_decl:inst_decls)
 472  = tcInstDecl2       e free_tyvars inst_decl    `thenNF_Tc` \ (lie1, binds1) ->
 473    tcInstDecls2_help e free_tyvars inst_decls   `thenNF_Tc` \ (lie2, binds2) ->
 474    returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
 475 \end{code}
 476
 477
 478 ======= New documentation starts here (Sept 92)  ==============
 479
 480 The main purpose of @tcInstDecl2@ is to return a @Binds@ which defines
 481 the dictionary function for this instance declaration.  For example
 482 \begin{verbatim}
 483         instance Foo a => Foo [a] where
 484                 op1 x = ...
 485                 op2 y = ...
 486 \end{verbatim}
 487 might generate something like
 488 \begin{verbatim}
 489         dfun.Foo.List dFoo_a = let op1 x = ...
 490                                    op2 y = ...
 491                                in
 492                                    Dict [op1, op2]
 493 \end{verbatim}
 494
 495 HOWEVER, if the instance decl has no type variables, then it returns a
 496 bigger @Binds@ with declarations for each method.  For example
 497 \begin{verbatim}
 498         instance Foo Int where
 499                 op1 x = ...
 500                 op2 y = ...
 501 \end{verbatim}
 502 might produce
 503 \begin{verbatim}
 504         dfun.Foo.Int = Dict [Foo.op1.Int, Foo.op2.Int]
 505         Foo.op1.Int x = ...
 506         Foo.op2.Int y = ...
 507 \end{verbatim}
 508 This group may be mutually recursive, because (for example) there may
 509 be no method supplied for op2 in which case we'll get
 510 \begin{verbatim}
 511         Foo.op2.Int = default.Foo.op2 dfun.Foo.Int
 512 \end{verbatim}
 513 that is, the default method applied to the dictionary at this type.
 514
 515 \begin{code}
 516 tcInstDecl2 :: E
 517             -> [TyVar]          -- Free in the environment
 518             -> InstInfo
 519             -> NF_TcM (LIE, TypecheckedBinds)
 520 \end{code}
 521
 522 First comes the easy case of a non-local instance decl.
 523
 524 \begin{code}
 525 tcInstDecl2 e free_tyvars (InstInfo _ _ _ _ _ _ _ _ False{-not this module-} _ _ _)
 526   = returnNF_Tc (nullLIE, EmptyBinds)
 527 \end{code}
 528
 529 Now the case of a general local instance.  For an instance declaration, say,
 530
 531         instance (C1 a, C2 b) => C (T a b) where
 532                 ...
 533
 534 where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
 535 function whose type is
 536
 537         (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
 538
 539 Notice that we pass it the superclass dictionaries at the instance type; this
 540 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 541 is the @dfun_theta@ below.
 542
 543 \begin{code}
 544 tcInstDecl2
 545     e free_tyvars
 546     (InstInfo clas template_tyvars inst_ty_tmpl inst_decl_theta dfun_theta
 547               dfun_id const_meth_ids monobinds True{-from here-} _ locn _)
 548   = let
 549         origin = InstanceDeclOrigin locn
 550     in
 551     recoverTc (nullLIE, EmptyBinds)     (
 552     addSrcLocTc locn                    (
 553     pruneSubstTc free_tyvars            (
 554
 555         -- Get the class signature
 556     let (class_tyvar,
 557          super_classes, sc_sel_ids,
 558          class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
 559     in
 560          -- Prime error recovery and substitution pruning. Instantiate
 561          -- dictionaries from the specified instance context. These
 562          -- dicts will be passed into the dictionary-construction
 563          -- function.
 564     copyTyVars template_tyvars  `thenNF_Tc` \ (inst_env, inst_tyvars, inst_tyvar_tys) ->
 565     let
 566         inst_ty          = instantiateTy inst_env inst_ty_tmpl
 567
 568         inst_decl_theta' = instantiateThetaTy inst_env inst_decl_theta
 569         dfun_theta'      = instantiateThetaTy inst_env dfun_theta
 570         sc_theta'        = super_classes `zip` (repeat inst_ty)
 571     in
 572     newDicts origin sc_theta'                   `thenNF_Tc` \ sc_dicts' ->
 573     newDicts origin dfun_theta'                 `thenNF_Tc` \ dfun_arg_dicts' ->
 574     newDicts origin inst_decl_theta'            `thenNF_Tc` \ inst_decl_dicts' ->
 575     let
 576         sc_dicts'_ids        = map mkInstId sc_dicts'
 577         dfun_arg_dicts'_ids = map mkInstId dfun_arg_dicts'
 578     in
 579         -- Instantiate the dictionary being constructed
 580         -- and the dictionary-construction function
 581     newDicts origin [(clas,inst_ty)]            `thenNF_Tc` \ [this_dict] ->
 582     let
 583         this_dict_id = mkInstId this_dict
 584     in
 585          -- Instantiate method variables
 586     listNF_Tc [ newMethodId sel_id inst_ty origin locn
 587               | sel_id <- op_sel_ids
 588               ]                                 `thenNF_Tc` \ method_ids ->
 589     let
 590         method_insts = catMaybes (map isInstId_maybe method_ids)
 591         -- Extract Insts from those method ids which have them (most do)
 592         -- See notes on newMethodId
 593     in
 594          -- Collect available dictionaries
 595     let avail_insts =    -- These insts are in scope; quite a few, eh?
 596             [this_dict]         ++
 597             method_insts        ++
 598             dfun_arg_dicts'
 599     in
 600     processInstBinds e free_tyvars
 601          (makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty)
 602          inst_tyvars avail_insts method_ids monobinds
 603                                          `thenTc` \ (insts_needed, method_mbinds) ->
 604          -- Complete the binding group
 605     let this_dict_bind
 606             = VarMonoBind this_dict_id (Dictionary sc_dicts'_ids method_ids)
 607         dict_and_method_binds
 608             = this_dict_bind `AndMonoBinds` method_mbinds
 609     in
 610         -- Check the overloading constraints of the methods and superclasses
 611         -- The global tyvars must be a fixed point of the substitution
 612     applyTcSubstAndCollectTyVars free_tyvars  `thenNF_Tc` \ real_free_tyvars ->
 613     tcSimplifyAndCheck
 614                  True                           -- Top level
 615                  real_free_tyvars               -- Global tyvars
 616                  inst_tyvars                    -- Local tyvars
 617                  avail_insts
 618                  (sc_dicts' ++ insts_needed)    -- Need to get defns for all these
 619                  (BindSigCtxt method_ids)
 620                                          `thenTc` \ (const_insts, super_binds) ->
 621
 622         -- Check that we *could* construct the superclass dictionaries,
 623         -- even though we are *actually* going to pass the superclass dicts in;
 624         -- the check ensures that the caller will never have a problem building
 625         -- them.
 626     tcSimplifyAndCheck
 627                  False                          -- Doesn't matter; more efficient this way
 628                  real_free_tyvars               -- Global tyvars
 629                  inst_tyvars                    -- Local tyvars
 630                  inst_decl_dicts'               -- The instance dictionaries available
 631                  sc_dicts'                      -- The superclass dicationaries reqd
 632                  SuperClassSigCtxt
 633                                                  `thenTc_`
 634                                                 -- Ignore the result; we're only doing
 635                                                 -- this to make sure it can be done.
 636
 637         -- Create the dictionary function binding itself
 638     let inst_binds
 639           = AbsBinds
 640                  inst_tyvars
 641                  dfun_arg_dicts'_ids
 642                  ((this_dict_id,dfun_id) : (method_ids `zip` const_meth_ids))
 643                         -- const_meth_ids will often be empty
 644                  super_binds
 645                  (RecBind dict_and_method_binds)
 646     in
 647
 648          -- Back-substitute
 649     applyTcSubstToBinds inst_binds `thenNF_Tc` \ final_inst_binds ->
 650
 651     returnTc (mkLIE const_insts, final_inst_binds)
 652     )))
 653 \end{code}
 654
 655 @mkMethodId@ manufactures an id for a local method.
 656 It's rather turgid stuff, because there are two cases:
 657
 658   (a) For methods with no local polymorphism, we can make an Inst of the
 659       class-op selector function and a corresp InstId;
 660       which is good because then other methods which call
 661       this one will do so directly.
 662
 663   (b) For methods with local polymorphism, we can't do this.  For example,
 664
 665          class Foo a where
 666                 op :: (Num b) => a -> b -> a
 667
 668       Here the type of the class-op-selector is
 669
 670         forall a b. (Foo a, Num b) => a -> b -> a
 671
 672       The locally defined method at (say) type Float will have type
 673
 674         forall b. (Num b) => Float -> b -> Float
 675
 676       and the one is not an instance of the other.
 677
 678       So for these we just make a local (non-Inst) id with a suitable type.
 679
 680 How disgusting.
 681
 682 \begin{code}
 683 newMethodId sel_id inst_ty origin loc
 684   = let (sel_tyvars,sel_theta,sel_tau) = splitType (getIdUniType sel_id)
 685         (_:meth_theta) = sel_theta      -- The local theta is all except the
 686                                         -- first element of the context
 687     in
 688        case sel_tyvars of
 689         -- Ah! a selector for a class op with no local polymorphism
 690         -- Build an Inst for this
 691         [clas_tyvar] -> newMethod origin sel_id [inst_ty]       `thenNF_Tc` \ inst ->
 692                         returnNF_Tc (mkInstId inst)
 693
 694         -- Ho! a selector for a class op with local polymorphism.
 695         -- Just make a suitably typed local id for this
 696         (clas_tyvar:local_tyvars) ->
 697                 let
 698                     method_ty = instantiateTy [(clas_tyvar,inst_ty)]
 699                                     (mkSigmaTy local_tyvars meth_theta sel_tau)
 700                 in
 701                 getUniqueTc             `thenNF_Tc` \ uniq ->
 702                 returnNF_Tc (mkUserLocal (getOccurrenceName sel_id) uniq method_ty loc)
 703 \end{code}
 704
 705 This function makes a default method which calls the global default method, at
 706 the appropriate instance type.
 707
 708 See the notes under default decls in TcClassDcl.lhs.
 709
 710 \begin{code}
 711 makeInstanceDeclDefaultMethodExpr
 712         :: InstOrigin
 713         -> Id
 714         -> [ClassOp]
 715         -> [Id]
 716         -> UniType
 717         -> Int
 718         -> NF_TcM TypecheckedExpr
 719
 720 makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty tag
 721   = let
 722         (tyvar_tmpls, local_theta, _) = splitType (getClassOpLocalType class_op)
 723     in
 724     copyTyVars tyvar_tmpls      `thenNF_Tc` \ (inst_env, tyvars, tys) ->
 725     let
 726         inst_theta = instantiateThetaTy inst_env local_theta
 727     in
 728     newDicts origin inst_theta  `thenNF_Tc` \ local_dict_insts ->
 729     let
 730         local_dicts = map mkInstId local_dict_insts
 731     in
 732     returnNF_Tc (
 733       mkTyLam tyvars (
 734         mkDictLam local_dicts (
 735           mkDictApp (mkTyApp (Var defm_id)
 736                              (inst_ty : tys))
 737                     (this_dict_id:local_dicts)))
 738     )
 739  where
 740     idx      = tag - 1
 741     class_op = class_ops !! idx
 742     defm_id  = defm_ids  !! idx
 743 \end{code}
 744
 745
 746 %************************************************************************
 747 %*                                                                      *
 748 \subsection{Processing each method}
 749 %*                                                                      *
 750 %************************************************************************
 751
 752 @processInstBinds@ returns a @MonoBinds@ which binds
 753 all the method ids (which are passed in).  It is used
 754         - both for instance decls,
 755         - and to compile the default-method declarations in a class decl.
 756
 757 Any method ids which don't have a binding have a suitable default
 758 binding created for them. The actual right-hand side used is
 759 created using a function which is passed in, because the right thing to
 760 do differs between instance and class decls.
 761
 762 \begin{code}
 763 processInstBinds
 764         :: E
 765         -> [TyVar]                         -- Free in envt
 766
 767         -> (Int -> NF_TcM TypecheckedExpr) -- Function to make
 768                                            -- default method
 769
 770         -> [TyVar]                         -- Tyvars for this instance decl
 771
 772         -> [Inst]                          -- available Insts
 773
 774         -> [Id]                            -- Local method ids
 775                                            --   (instance tyvars are free
 776                                            --   in their types),
 777                                            --   in tag order
 778         -> RenamedMonoBinds
 779
 780         -> TcM ([Inst],                 -- These are required
 781                 TypecheckedMonoBinds)
 782
 783 processInstBinds e free_tyvars mk_method_expr inst_tyvars
 784                  avail_insts method_ids monobinds
 785   =
 786          -- Process the explicitly-given method bindings
 787     processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids monobinds
 788          `thenTc` (\ (tags, insts_needed_in_methods, method_binds) ->
 789
 790          -- Find the methods not handled, and make default method bindings for them.
 791     let unmentioned_tags = [1.. length method_ids] `minusList` tags
 792     in
 793     makeDefaultMethods mk_method_expr unmentioned_tags method_ids
 794                                          `thenNF_Tc`    (\ default_monobinds ->
 795
 796     returnTc (insts_needed_in_methods,
 797               method_binds `AndMonoBinds` default_monobinds)
 798     ))
 799 \end{code}
 800
 801 \begin{code}
 802 processInstBinds1
 803         :: E
 804         -> [TyVar]              -- Global free tyvars
 805         -> [TyVar]              -- Tyvars for this instance decl
 806         -> [Inst]               -- available Insts
 807         -> [Id]                 -- Local method ids (instance tyvars are free),
 808                                 --      in tag order
 809         -> RenamedMonoBinds
 810         -> TcM ([Int],          -- Class-op tags accounted for
 811                 [Inst],         -- These are required
 812                 TypecheckedMonoBinds)
 813
 814 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids EmptyMonoBinds
 815   = returnTc ([], [], EmptyMonoBinds)
 816
 817 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
 818   = processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb1
 819                                  `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
 820     processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb2
 821                                  `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
 822     returnTc (op_tags1 ++ op_tags2,
 823               dicts1 ++ dicts2,
 824               AndMonoBinds method_binds1 method_binds2)
 825 \end{code}
 826
 827 \begin{code}
 828 processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mbind
 829   =
 830     -- Find what class op is being defined here.  The complication is
 831     -- that we could have a PatMonoBind or a FunMonoBind.  If the
 832     -- former, it should only bind a single variable, or else we're in
 833     -- trouble (I'm not sure what the static semantics of methods
 834     -- defined in a pattern binding with multiple patterns is!)
 835     -- Renamer has reduced us to these two cases.
 836     let
 837         (op,locn) = case mbind of
 838                       FunMonoBind op _ locn            -> (op, locn)
 839                       PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 840
 841         origin = InstanceDeclOrigin locn
 842     in
 843     addSrcLocTc locn                     (
 844
 845     -- Make a method id for the method
 846     let tag       = getTagFromClassOpName op
 847         method_id = method_ids !! (tag-1)
 848         method_ty = getIdUniType method_id
 849     in
 850     specTy origin method_ty  `thenNF_Tc` \ (method_tyvars, method_dicts, method_tau) ->
 851
 852         -- Build the result
 853     case (method_tyvars, method_dicts) of
 854
 855       ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
 856
 857                 -- Type check the method itself
 858         tcMethodBind e method_id method_tau mbind    `thenTc` \ (mbind', lieIop) ->
 859
 860                 -- Make sure that the instance tyvars havn't been
 861                 -- unified with each other or with the method tyvars.
 862                 -- The global tyvars must be a fixed point of the substitution
 863         applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
 864         checkSigTyVars real_free_tyvars inst_tyvars method_tau method_tau
 865                               (MethodSigCtxt op method_tau) `thenTc_`
 866
 867         returnTc ([tag], unMkLIE lieIop, mbind')
 868
 869       other ->  -- It's a locally-polymorphic and/or overloaded method; UGH!
 870
 871                  -- Make a new id for (a) the local, non-overloaded method
 872                  -- and               (b) the locally-overloaded method
 873                  -- The latter is needed just so we can return an AbsBinds wrapped
 874                  -- up inside a MonoBinds.
 875         newLocalWithGivenTy op method_tau       `thenNF_Tc` \ local_meth_id ->
 876         newLocalWithGivenTy op method_ty        `thenNF_Tc` \ copy_meth_id ->
 877
 878                 -- Typecheck the method
 879         tcMethodBind e local_meth_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 880
 881                 -- Make sure that the instance tyvars haven't been
 882                 -- unified with each other or with the method tyvars.
 883                 -- The global tyvars must be a fixed point of the substitution
 884         applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
 885         checkSigTyVars real_free_tyvars (method_tyvars ++ inst_tyvars) method_tau method_tau
 886                               (MethodSigCtxt op method_tau) `thenTc_`
 887
 888                 -- Check the overloading part of the signature.
 889                 -- Simplify everything fully, even though some
 890                 -- constraints could "really" be left to the next
 891                 -- level out. The case which forces this is
 892                 --
 893                 --      class Foo a where { op :: Bar a => a -> a }
 894                 --
 895                 -- Here we must simplify constraints on "a" to catch all
 896                 -- the Bar-ish things.
 897         tcSimplifyAndCheck
 898                 False                   -- Not top level
 899                 real_free_tyvars
 900                 (inst_tyvars ++ method_tyvars)
 901                 (method_dicts ++ avail_insts)
 902                 (unMkLIE lieIop)
 903                 (MethodSigCtxt op method_ty)    `thenTc` \ (f_dicts, dict_binds) ->
 904
 905         returnTc ([tag],
 906                   f_dicts,
 907                   VarMonoBind method_id
 908                          (Let
 909                              (AbsBinds
 910                                 method_tyvars
 911                                 (map mkInstId method_dicts)
 912                                 [(local_meth_id, copy_meth_id)]
 913                                 dict_binds
 914                                 (NonRecBind mbind'))
 915                              (Var copy_meth_id)))
 916     )
 917 \end{code}
 918
 919 \begin{code}
 920 tcMethodBind :: E -> Id -> UniType -> RenamedMonoBinds
 921             -> TcM (TypecheckedMonoBinds, LIE)
 922
 923 tcMethodBind e meth_id meth_ty (FunMonoBind name matches locn)
 924   = addSrcLocTc locn                             (
 925     tcMatchesFun e name meth_ty matches `thenTc` \ (rhs', lie) ->
 926     returnTc (FunMonoBind meth_id rhs' locn, lie)
 927     )
 928
 929 tcMethodBind e meth_id meth_ty (PatMonoBind pat grhss_and_binds locn)
 930   -- pat is sure to be a (VarPatIn op)
 931   = addSrcLocTc locn                             (
 932     tcGRHSsAndBinds e grhss_and_binds   `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
 933     unifyTauTy meth_ty rhs_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
 934     returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
 935     )
 936 \end{code}
 937
 938
 939 Creates bindings for the default methods, being the application of the
 940 appropriate global default method to the type of this instance decl.
 941
 942 \begin{code}
 943 makeDefaultMethods
 944         :: (Int -> NF_TcM TypecheckedExpr)      -- Function to make
 945                                                 -- default method
 946         -> [Int]                                -- Tags for methods required
 947         -> [Id]                                 -- Method names to bind, in tag order
 948         -> NF_TcM TypecheckedMonoBinds
 949
 950
 951 makeDefaultMethods mk_method_expr [] method_ids
 952   = returnNF_Tc EmptyMonoBinds
 953
 954 makeDefaultMethods mk_method_expr (tag:tags) method_ids
 955   = mk_method_expr tag                                `thenNF_Tc` \ rhs ->
 956     makeDefaultMethods mk_method_expr tags method_ids `thenNF_Tc` \ meth_binds ->
 957
 958     returnNF_Tc ((VarMonoBind method_id rhs) `AndMonoBinds` meth_binds)
 959   where
 960     method_id = method_ids !! (tag-1)
 961 \end{code}
 962
 963 %************************************************************************
 964 %*                                                                      *
 965 \subsection{Type-checking specialise instance pragmas}
 966 %*                                                                      *
 967 %************************************************************************
 968
 969 \begin{code}
 970 tcSpecInstSigs :: E -> CE -> TCE
 971                -> Bag InstInfo                          -- inst decls seen (declared and derived)
 972                -> [RenamedSpecialisedInstanceSig]       -- specialise instance upragmas
 973                -> TcM (Bag InstInfo)                    -- new, overlapped, inst decls
 974
 975 tcSpecInstSigs e ce tce inst_infos []
 976   = returnTc emptyBag
 977
 978 tcSpecInstSigs e ce tce inst_infos sigs
 979   = buildInstanceEnvs inst_infos        `thenTc`    \ inst_mapper ->
 980     tc_inst_spec_sigs inst_mapper sigs  `thenNF_Tc` \ spec_inst_infos ->
 981     returnTc spec_inst_infos
 982   where
 983     tc_inst_spec_sigs inst_mapper []
 984       = returnNF_Tc emptyBag
 985     tc_inst_spec_sigs inst_mapper (sig:sigs)
 986       = tcSpecInstSig e ce tce inst_infos inst_mapper sig       `thenNF_Tc` \ info_sig ->
 987         tc_inst_spec_sigs inst_mapper sigs                      `thenNF_Tc` \ info_sigs ->
 988         returnNF_Tc (info_sig `unionBags` info_sigs)
 989
 990 tcSpecInstSig :: E -> CE -> TCE
 991               -> Bag InstInfo
 992               -> InstanceMapper
 993               -> RenamedSpecialisedInstanceSig
 994               -> NF_TcM (Bag InstInfo)
 995
 996 tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc)
 997   = recoverTc emptyBag                  (
 998     addSrcLocTc src_loc                 (
 999     let
1000         clas = lookupCE ce class_name -- Renamer ensures this can't fail
1001
1002         -- Make some new type variables, named as in the specialised instance type
1003         ty_names                          = extractMonoTyNames (==) ty
1004         (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
1005     in
1006     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
1007                                 `thenTc` \ inst_ty ->
1008     let
1009         tycon = case getUniDataTyCon_maybe inst_ty of
1010                      Just (tc,_,_) -> tc
1011                      Nothing       -> panic "tcSpecInstSig:inst_tycon"
1012
1013         maybe_unspec_inst = lookup_unspec_inst clas tycon inst_infos
1014     in
1015         -- Check that we have a local instance declaration to specialise
1016     checkMaybeTc maybe_unspec_inst
1017             (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
1018
1019         -- Create tvs to substitute for tmpls while simplifying the context
1020     copyTyVars inst_tmpls       `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
1021     let
1022         Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
1023                        _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
1024
1025         subst = case matchTy unspec_inst_ty inst_ty of
1026                      Just subst -> subst
1027                      Nothing    -> panic "tcSpecInstSig:matchTy"
1028
1029         subst_theta    = instantiateThetaTy subst unspec_theta
1030         subst_tv_theta = instantiateThetaTy tv_e subst_theta
1031
1032         mk_spec_origin clas ty
1033           = InstanceSpecOrigin inst_mapper clas ty src_loc
1034     in
1035     tcSimplifyThetas mk_spec_origin subst_tv_theta
1036                                 `thenTc` \ simpl_tv_theta ->
1037     let
1038         simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
1039
1040         tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys
1041         tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
1042     in
1043     mkInstanceRelatedIds e True{-from here-} NoInstancePragmas src_loc
1044                          clas inst_tmpls inst_ty simpl_theta uprag
1045                                 `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
1046
1047     getSwitchCheckerTc          `thenNF_Tc` \ sw_chkr ->
1048     (if sw_chkr SpecialiseTrace then
1049         pprTrace "Specialised Instance: "
1050                  (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
1051                                    if null simpl_theta then ppNil else ppStr "=>",
1052                                    ppr PprDebug clas,
1053                                    pprParendUniType PprDebug inst_ty],
1054                             ppCat [ppStr "        derived from:",
1055                                    if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
1056                                    if null unspec_theta then ppNil else ppStr "=>",
1057                                    ppr PprDebug clas,
1058                                    pprParendUniType PprDebug unspec_inst_ty]])
1059      else id) (
1060
1061     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
1062                                 dfun_theta dfun_id const_meth_ids
1063                                 binds True{-from here-} mod src_loc uprag))
1064     )))
1065
1066
1067 lookup_unspec_inst clas tycon inst_infos
1068   = case filter match_info (bagToList inst_infos) of
1069         []       -> Nothing
1070         (info:_) -> Just info
1071   where
1072     match_info (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
1073       = from_here && clas == inst_clas && inst_ty_matches_tycon
1074       where
1075         inst_ty_matches_tycon = case (getUniDataTyCon_maybe inst_ty) of
1076           Just (inst_tc,tys,_) -> tycon == inst_tc && all isTyVarTemplateTy tys
1077           Nothing              -> False
1078
1079 \end{code}