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