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         buildInstanceEnv,
  12         instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon, classDataCon,
  13         pprInstInfo
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 import RnHsSyn          ( RenamedMonoBinds, RenamedSig )
  19 import HsTypes          ( toHsType )
  20
  21 import CmdLineOpts      ( opt_AllowOverlappingInstances )
  22 import TcMonad
  23 import TcEnv            ( InstEnv, emptyInstEnv, addToInstEnv )
  24 import Bag              ( bagToList, Bag )
  25 import Class            ( Class )
  26 import Var              ( TyVar, Id, idName )
  27 import Maybes           ( MaybeErr(..) )
  28 import Name             ( getSrcLoc, nameModule, isLocallyDefined, toRdrName )
  29 import SrcLoc           ( SrcLoc )
  30 import Type             ( Type, ThetaType, splitTyConApp_maybe, mkSigmaTy, mkDictTy )
  31 import PprType          ( pprConstraint )
  32 import Class            ( classTyCon )
  33 import DataCon          ( DataCon )
  34 import TyCon            ( TyCon, tyConDataCons )
  35 import Outputable
  36 \end{code}
  37
  38     instance c => k (t tvs) where b
  39
  40 \begin{code}
  41 data InstInfo
  42   = InstInfo
  43       Class             -- Class, k
  44       [TyVar]           -- Type variables, tvs
  45       [Type]            -- The types at which the class is being instantiated
  46       ThetaType         -- inst_decl_theta: the original context, c, from the
  47                         --   instance declaration.  It constrains (some of)
  48                         --   the TyVars above
  49       Id                -- The dfun id
  50       RenamedMonoBinds  -- Bindings, b
  51       SrcLoc            -- Source location assoc'd with this instance's defn
  52       [RenamedSig]      -- User pragmas recorded for generating specialised instances
  53
  54 pprInstInfo (InstInfo clas tvs tys inst_decl_theta _ mbinds _ _)
  55  = vcat [ptext SLIT("InstInfo:") <+> ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas tys)),
  56          nest 4 (ppr mbinds)]
  57
  58 instInfoClass :: InstInfo -> Class
  59 instInfoClass (InstInfo clas _ _ _ _ _ _ _) = clas
  60
  61 simpleInstInfoTy :: InstInfo -> Type
  62 simpleInstInfoTy (InstInfo _ _ [ty] _ _ _ _ _) = ty
  63
  64 simpleInstInfoTyCon :: InstInfo -> TyCon
  65   -- Gets the type constructor for a simple instance declaration,
  66   -- i.e. one of the form       instance (...) => C (T a b c) where ...
  67 simpleInstInfoTyCon inst
  68    = case splitTyConApp_maybe (simpleInstInfoTy inst) of
  69         Just (tycon, _) -> tycon
  70 \end{code}
  71
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection{Creating instance related Ids}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 A tiny function which doesn't belong anywhere else.
  80 It makes a nasty mutual-recursion knot if you put it in Class.
  81
  82 \begin{code}
  83 classDataCon :: Class -> DataCon
  84 classDataCon clas = case tyConDataCons (classTyCon clas) of
  85                       (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
  86 \end{code}
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection{Converting instance info into suitable InstEnvs}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 \begin{code}
  95 buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv
  96
  97 buildInstanceEnv info = --pprTrace "BuildInstanceEnv" (ppr info)
  98                         foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
  99 \end{code}
 100
 101 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
 102 based on information from a single instance declaration.  It complains
 103 about any overlap with an existing instance.
 104
 105 \begin{code}
 106 addClassInstance
 107     :: InstInfo
 108     -> InstEnv
 109     -> NF_TcM s InstEnv
 110
 111 addClassInstance
 112     (InstInfo clas inst_tyvars inst_tys _
 113               dfun_id _ src_loc _)
 114     inst_env
 115   =     -- Add the instance to the class's instance environment
 116     case addToInstEnv opt_AllowOverlappingInstances
 117                       inst_env clas inst_tyvars inst_tys dfun_id of
 118         Failed (tys', dfun_id')    -> addErrTc (dupInstErr clas (inst_tys, dfun_id)
 119                                                                 (tys',     dfun_id'))
 120                                                 `thenNF_Tc_`
 121                                      returnNF_Tc inst_env
 122
 123         Succeeded inst_env' -> returnNF_Tc inst_env'
 124 \end{code}
 125
 126 \begin{code}
 127 dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2)
 128         -- Overlapping/duplicate instances for given class; msg could be more glamourous
 129   = hang (ptext SLIT("Duplicate or overlapping instance declarations"))
 130          4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
 131                  nest 4 (sep [ppr_loc dfun1, ptext SLIT("and") <+> ppr_loc dfun2])])
 132   where
 133     ppr_loc dfun
 134         | isLocallyDefined dfun = ptext SLIT("defined at")           <+> ppr (getSrcLoc dfun)
 135         | otherwise             = ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun)))
 136 \end{code}