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