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