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 Util             ( equivClasses, assertPanic )
  36 import Outputable
  37 \end{code}
  38
  39     instance c => k (t tvs) where b
  40
  41 \begin{code}
  42 data InstInfo
  43   = InstInfo
  44       Class             -- Class, k
  45       [TyVar]           -- Type variables, tvs
  46       [Type]            -- The types at which the class is being instantiated
  47       ThetaType         -- inst_decl_theta: the original context, c, from the
  48                         --   instance declaration.  It constrains (some of)
  49                         --   the TyVars above
  50       Id                -- The dfun id
  51       RenamedMonoBinds  -- Bindings, b
  52       SrcLoc            -- Source location assoc'd with this instance's defn
  53       [RenamedSig]      -- User pragmas recorded for generating specialised instances
  54 \end{code}
  55
  56
  57 %************************************************************************
  58 %*                                                                      *
  59 \subsection{Creating instance related Ids}
  60 %*                                                                      *
  61 %************************************************************************
  62
  63 A tiny function which doesn't belong anywhere else.
  64 It makes a nasty mutual-recursion knot if you put it in Class.
  65
  66 \begin{code}
  67 classDataCon :: Class -> DataCon
  68 classDataCon clas = case tyConDataCons (classTyCon clas) of
  69                       (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
  70 \end{code}
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{Converting instance info into suitable InstEnvs}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 buildInstanceEnvs :: Bag InstInfo
  80                   -> NF_TcM s InstanceMapper
  81
  82 buildInstanceEnvs info
  83   = let
  84         icmp :: InstInfo -> InstInfo -> Ordering
  85         (InstInfo c1 _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _)
  86           = c1 `compare` c2
  87
  88         info_by_class = equivClasses icmp (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}