ghc/compiler/typecheck/TcInstUtil.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcInstUtil]{Utilities for typechecking instance declarations}
   5
   6 The bits common to TcInstDcls and TcDeriv.
   7
   8 \begin{code}
   9 module TcInstUtil (
  10         InstInfo(..),
  11         buildInstanceEnvs,
  12         classDataCon
  13     ) where
  14
  15 #include "HsVersions.h"
  16
  17 import RnHsSyn          ( RenamedMonoBinds, RenamedSig )
  18
  19 import CmdLineOpts      ( opt_AllowOverlappingInstances )
  20 import TcMonad
  21 import Inst             ( InstanceMapper )
  22
  23 import Bag              ( bagToList, Bag )
  24 import Class            ( ClassInstEnv, Class )
  25 import Var              ( TyVar, Id )
  26 import SpecEnv          ( emptySpecEnv, addToSpecEnv )
  27 import Maybes           ( MaybeErr(..), mkLookupFunDef )
  28 import Name             ( getSrcLoc )
  29 import SrcLoc           ( SrcLoc )
  30 import Type             ( ThetaType, Type )
  31 import PprType          ( pprConstraint )
  32 import Class            ( classTyCon )
  33 import DataCon          ( DataCon )
  34 import TyCon            ( tyConDataCons )
  35 import Unique           ( Unique, getUnique )
  36 import Util             ( equivClassesByUniq )
  37 import Outputable
  38 \end{code}
  39
  40     instance c => k (t tvs) where b
  41
  42 \begin{code}
  43 data InstInfo
  44   = InstInfo
  45       Class             -- Class, k
  46       [TyVar]           -- Type variables, tvs
  47       [Type]            -- The types at which the class is being instantiated
  48       ThetaType         -- inst_decl_theta: the original context, c, from the
  49                         --   instance declaration.  It constrains (some of)
  50                         --   the TyVars above
  51       Id                -- The dfun id
  52       RenamedMonoBinds  -- Bindings, b
  53       SrcLoc            -- Source location assoc'd with this instance's defn
  54       [RenamedSig]      -- User pragmas recorded for generating specialised instances
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection{Creating instance related Ids}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 A tiny function which doesn't belong anywhere else.
  65 It makes a nasty mutual-recursion knot if you put it in Class.
  66
  67 \begin{code}
  68 classDataCon :: Class -> DataCon
  69 classDataCon clas = case tyConDataCons (classTyCon clas) of
  70                       (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{Converting instance info into suitable InstEnvs}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 buildInstanceEnvs :: Bag InstInfo
  81                   -> NF_TcM s InstanceMapper
  82
  83 buildInstanceEnvs info
  84   = let
  85         i_uniq :: InstInfo -> Unique
  86         i_uniq (InstInfo c _ _ _ _ _ _ _) = getUnique c
  87
  88         info_by_class = equivClassesByUniq i_uniq (bagToList info)
  89     in
  90     mapNF_Tc buildInstanceEnv info_by_class    `thenNF_Tc` \ inst_env_entries ->
  91     let
  92         class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptySpecEnv
  93     in
  94     returnNF_Tc class_lookup_fn
  95 \end{code}
  96
  97 \begin{code}
  98 buildInstanceEnv :: [InstInfo]          -- Non-empty, and all for same class
  99                  -> NF_TcM s (Class, ClassInstEnv)
 100
 101 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
 102   = foldrNF_Tc addClassInstance
 103             emptySpecEnv
 104             inst_infos                          `thenNF_Tc` \ class_inst_env ->
 105     returnNF_Tc (clas, class_inst_env)
 106 \end{code}
 107
 108 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
 109 based on information from a single instance declaration.  It complains
 110 about any overlap with an existing instance.
 111
 112 \begin{code}
 113 addClassInstance
 114     :: InstInfo
 115     -> ClassInstEnv
 116     -> NF_TcM s ClassInstEnv
 117
 118 addClassInstance
 119     (InstInfo clas inst_tyvars inst_tys _
 120               dfun_id _ src_loc _)
 121     class_inst_env
 122   =     -- Add the instance to the class's instance environment
 123     case addToSpecEnv opt_AllowOverlappingInstances
 124                       class_inst_env inst_tyvars inst_tys dfun_id of
 125         Failed (ty', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, src_loc)
 126                                                                (ty', getSrcLoc dfun_id'))
 127                                                 `thenNF_Tc_`
 128                                      returnNF_Tc class_inst_env
 129
 130         Succeeded class_inst_env' -> returnNF_Tc class_inst_env'
 131 \end{code}
 132
 133 \begin{code}
 134 dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2)
 135         -- Overlapping/duplicate instances for given class; msg could be more glamourous
 136   = hang (ptext SLIT("Duplicate or overlapping instance declarations"))
 137          4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
 138                  nest 4 (sep [ptext SLIT("at")  <+> ppr locn1,
 139                               ptext SLIT("and") <+> ppr locn2])])
 140 \end{code}