ghc/compiler/typecheck/TcInstUtil.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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         mkInstanceRelatedIds,
  12         buildInstanceEnvs,
  13         classDataCon
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import RnHsSyn          ( RenamedMonoBinds, RenamedSig(..) )
  19
  20 import CmdLineOpts      ( opt_AllowOverlappingInstances )
  21 import TcMonad
  22 import Inst             ( InstanceMapper )
  23
  24 import Bag              ( bagToList, Bag )
  25 import Class            ( ClassInstEnv, Class, classBigSig )
  26 import MkId             ( mkDictFunId )
  27 import Id               ( Id )
  28 import SpecEnv          ( emptySpecEnv, addToSpecEnv )
  29 import Maybes           ( MaybeErr(..), mkLookupFunDef )
  30 import Name             ( getSrcLoc, Name )
  31 import SrcLoc           ( SrcLoc )
  32 import Type             ( mkSigmaTy, mkDictTy, instantiateThetaTy,
  33                           ThetaType, Type
  34                         )
  35 import PprType          ( pprConstraint )
  36 import Class            ( classTyCon )
  37 import TyCon            ( tyConDataCons )
  38 import TyVar            ( TyVar, zipTyVarEnv )
  39 import Unique           ( Unique )
  40 import Util             ( equivClasses, panic, assertPanic )
  41 import Outputable
  42 \end{code}
  43
  44     instance c => k (t tvs) where b
  45
  46 \begin{code}
  47 data InstInfo
  48   = InstInfo
  49       Class             -- Class, k
  50       [TyVar]           -- Type variables, tvs
  51       [Type]            -- The types at which the class is being instantiated
  52       ThetaType         -- inst_decl_theta: the original context, c, from the
  53                         --   instance declaration.  It constrains (some of)
  54                         --   the TyVars above
  55       ThetaType         -- dfun_theta: the inst_decl_theta, plus one
  56                         --   element for each superclass; the "Mark
  57                         --   Jones optimisation"
  58       Id                -- The dfun id
  59       RenamedMonoBinds  -- Bindings, b
  60       SrcLoc            -- Source location assoc'd with this instance's defn
  61       [RenamedSig]      -- User pragmas recorded for generating specialised instances
  62 \end{code}
  63
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsection{Creating instance related Ids}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 A tiny function which doesn't belong anywhere else.
  72 It makes a nasty mutual-recursion knot if you put it in Class.
  73
  74 \begin{code}
  75 classDataCon :: Class -> Id
  76 classDataCon clas = case tyConDataCons (classTyCon clas) of
  77                       (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{Creating instance related Ids}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 mkInstanceRelatedIds :: Name            -- Name to use for the dict fun;
  88                      -> Class
  89                      -> [TyVar]
  90                      -> [Type]
  91                      -> ThetaType
  92                      -> (Id, ThetaType)
  93
  94 mkInstanceRelatedIds dfun_name clas inst_tyvars inst_tys inst_decl_theta
  95   = (dfun_id, dfun_theta)
  96   where
  97     (class_tyvars, sc_theta, _, _, _) = classBigSig clas
  98     sc_theta' = instantiateThetaTy (zipTyVarEnv class_tyvars inst_tys) sc_theta
  99
 100     dfun_theta = case inst_decl_theta of
 101                         []    -> []     -- If inst_decl_theta is empty, then we don't
 102                                         -- want to have any dict arguments, so that we can
 103                                         -- expose the constant methods.
 104
 105                         other -> inst_decl_theta ++ sc_theta'
 106                                         -- Otherwise we pass the superclass dictionaries to
 107                                         -- the dictionary function; the Mark Jones optimisation.
 108
 109     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
 110
 111     dfun_id = mkDictFunId dfun_name dfun_ty clas inst_tys
 112 \end{code}
 113
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{Converting instance info into suitable InstEnvs}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 buildInstanceEnvs :: Bag InstInfo
 123                   -> NF_TcM s InstanceMapper
 124
 125 buildInstanceEnvs info
 126   = let
 127         icmp :: InstInfo -> InstInfo -> Ordering
 128         (InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
 129           = c1 `compare` c2
 130
 131         info_by_class = equivClasses icmp (bagToList info)
 132     in
 133     mapNF_Tc buildInstanceEnv info_by_class    `thenNF_Tc` \ inst_env_entries ->
 134     let
 135         class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptySpecEnv
 136     in
 137     returnNF_Tc class_lookup_fn
 138 \end{code}
 139
 140 \begin{code}
 141 buildInstanceEnv :: [InstInfo]          -- Non-empty, and all for same class
 142                  -> NF_TcM s (Class, ClassInstEnv)
 143
 144 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
 145   = foldrNF_Tc addClassInstance
 146             emptySpecEnv
 147             inst_infos                          `thenNF_Tc` \ class_inst_env ->
 148     returnNF_Tc (clas, class_inst_env)
 149 \end{code}
 150
 151 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
 152 based on information from a single instance declaration.  It complains
 153 about any overlap with an existing instance.
 154
 155 \begin{code}
 156 addClassInstance
 157     :: InstInfo
 158     -> ClassInstEnv
 159     -> NF_TcM s ClassInstEnv
 160
 161 addClassInstance
 162     (InstInfo clas inst_tyvars inst_tys _ _
 163               dfun_id _ src_loc _)
 164     class_inst_env
 165   =     -- Add the instance to the class's instance environment
 166     case addToSpecEnv opt_AllowOverlappingInstances
 167                       class_inst_env inst_tyvars inst_tys dfun_id of
 168         Failed (ty', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, src_loc)
 169                                                                (ty', getSrcLoc dfun_id'))
 170                                                 `thenNF_Tc_`
 171                                      returnNF_Tc class_inst_env
 172
 173         Succeeded class_inst_env' -> returnNF_Tc class_inst_env'
 174 \end{code}
 175
 176 \begin{code}
 177 dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2)
 178         -- Overlapping/duplicate instances for given class; msg could be more glamourous
 179   = hang (ptext SLIT("Duplicate or overlapping instance declarations"))
 180          4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
 181                  nest 4 (sep [ptext SLIT("at")  <+> ppr locn1,
 182                               ptext SLIT("and") <+> ppr locn2])])
 183 \end{code}