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 #include "HsVersions.h"
  10
  11 module TcInstUtil (
  12         InstInfo(..),
  13         mkInstanceRelatedIds,
  14         buildInstanceEnvs
  15     ) where
  16
  17 IMP_Ubiq()
  18
  19 import HsSyn            ( MonoBinds, Fake, InPat, Sig )
  20 import RnHsSyn          ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
  21                           RenamedInstancePragmas(..) )
  22
  23 import TcMonad
  24 import Inst             ( SYN_IE(InstanceMapper) )
  25
  26 import Bag              ( bagToList, Bag )
  27 import Class            ( GenClass, SYN_IE(ClassInstEnv),
  28                           classBigSig, SYN_IE(Class)
  29                         )
  30 import CoreSyn          ( GenCoreExpr(..), mkValLam, mkTyApp )
  31 import Id               ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) )
  32 import MatchEnv         ( nullMEnv, insertMEnv )
  33 import Maybes           ( MaybeErr(..), mkLookupFunDef )
  34 import Name             ( getSrcLoc, Name{--O only-} )
  35 import PprType          ( GenClass, GenType, GenTyVar, pprParendType )
  36 import Pretty
  37 import SpecEnv          ( SpecEnv, nullSpecEnv, addOneToSpecEnv )
  38 import SrcLoc           ( SrcLoc )
  39 import Type             ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
  40                           instantiateTy, matchTy, SYN_IE(ThetaType),
  41                           SYN_IE(Type) )
  42 import TyVar            ( GenTyVar, SYN_IE(TyVar) )
  43 import Unique           ( Unique )
  44 import Util             ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
  45
  46 import Outputable
  47 \end{code}
  48
  49     instance c => k (t tvs) where b
  50
  51 \begin{code}
  52 data InstInfo
  53   = InstInfo
  54       Class             -- Class, k
  55       [TyVar]           -- Type variables, tvs
  56       Type              -- The type at which the class is being instantiated
  57       ThetaType         -- inst_decl_theta: the original context, c, from the
  58                         --   instance declaration.  It constrains (some of)
  59                         --   the TyVars above
  60       ThetaType         -- dfun_theta: the inst_decl_theta, plus one
  61                         --   element for each superclass; the "Mark
  62                         --   Jones optimisation"
  63       Id                -- The dfun id
  64       RenamedMonoBinds  -- Bindings, b
  65       SrcLoc            -- Source location assoc'd with this instance's defn
  66       [RenamedSig]      -- User pragmas recorded for generating specialised instances
  67 \end{code}
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection{Creating instance related Ids}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 \begin{code}
  76 mkInstanceRelatedIds :: Name            -- Name to use for the dict fun;
  77                      -> Class
  78                      -> [TyVar]
  79                      -> Type
  80                      -> ThetaType
  81                      -> (Id, ThetaType)
  82
  83 mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
  84   = (dfun_id, dfun_theta)
  85   where
  86     (_, super_classes, _, _, _) = classBigSig clas
  87     super_class_theta = super_classes `zip` repeat inst_ty
  88
  89     dfun_theta = case inst_decl_theta of
  90                         []    -> []     -- If inst_decl_theta is empty, then we don't
  91                                         -- want to have any dict arguments, so that we can
  92                                         -- expose the constant methods.
  93
  94                         other -> inst_decl_theta ++ super_class_theta
  95                                         -- Otherwise we pass the superclass dictionaries to
  96                                         -- the dictionary function; the Mark Jones optimisation.
  97
  98     dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
  99
 100     dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{Converting instance info into suitable InstEnvs}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 buildInstanceEnvs :: Bag InstInfo
 112                   -> TcM s InstanceMapper
 113
 114 buildInstanceEnvs info
 115   = let
 116         icmp :: InstInfo -> InstInfo -> TAG_
 117         (InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
 118           = c1 `cmp` c2
 119
 120         info_by_class = equivClasses icmp (bagToList info)
 121     in
 122     mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
 123     let
 124         class_lookup_fn = mkLookupFunDef (==) inst_env_entries nullMEnv
 125     in
 126     returnTc class_lookup_fn
 127 \end{code}
 128
 129 \begin{code}
 130 buildInstanceEnv :: [InstInfo]          -- Non-empty, and all for same class
 131                  -> TcM s (Class, ClassInstEnv)
 132
 133 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
 134   = foldlTc addClassInstance
 135             nullMEnv
 136             inst_infos                          `thenTc` \ class_inst_env ->
 137     returnTc (clas, class_inst_env)
 138 \end{code}
 139
 140 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
 141 based on information from a single instance declaration.  It complains
 142 about any overlap with an existing instance.
 143
 144 \begin{code}
 145 addClassInstance
 146     :: ClassInstEnv
 147     -> InstInfo
 148     -> TcM s ClassInstEnv
 149
 150 addClassInstance class_inst_env
 151     (InstInfo clas inst_tyvars inst_ty _ _
 152               dfun_id _ src_loc _)
 153   =     -- Add the instance to the class's instance environment
 154     case insertMEnv matchTy class_inst_env inst_ty dfun_id of
 155         Failed (ty', dfun_id')    -> recoverTc (returnTc class_inst_env) $
 156                                      dupInstFailure clas (inst_ty, src_loc)
 157                                                          (ty', getSrcLoc dfun_id');
 158         Succeeded class_inst_env' -> returnTc class_inst_env'
 159
 160 {-              OLD STUFF FOR CONSTANT METHODS
 161
 162         -- If there are any constant methods, then add them to
 163         -- the SpecEnv of each class op (ie selector)
 164         --
 165         -- Example.  class    Foo a     where { op :: Baz b => a -> b; ... }
 166         --           instance Foo (p,q) where { op (x,y) = ...       ; ... }
 167         --
 168         -- The class decl means that
 169         --      op :: forall a. Foo a => forall b. Baz b => a -> b
 170         --
 171         -- The constant method from the instance decl will be:
 172         --      op_Pair :: forall p q b. Baz b => (p,q) -> b
 173         --
 174         -- What we put in op's SpecEnv is
 175         --      (p,q) |-->  (\d::Foo (p,q) -> op_Pair p q)
 176         --
 177         -- Here, [p,q] are the inst_tyvars, and d is a dict whose only
 178         -- purpose is to cancel with the dict to which op is applied.
 179         --
 180         -- NOTE THAT this correctly deals with the case where there are
 181         -- constant methods even though there are type variables in the
 182         -- instance declaration.
 183
 184     tcGetUnique                         `thenNF_Tc` \ uniq ->
 185     let
 186       dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
 187                 -- Slightly disgusting, but it's only a placeholder for
 188                 -- a dictionary to be chucked away.
 189
 190       op_spec_envs' | null const_meth_ids = op_spec_envs
 191                     | otherwise           = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids
 192
 193       add_const_meth (op,spec_env) meth_id
 194         = (op, case addOneToSpecEnv spec_env [inst_ty] rhs of
 195                  Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
 196                  Succeeded spec_env' -> spec_env' )
 197         where
 198           rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
 199     in
 200     returnTc (class_inst_env', op_spec_envs')
 201                 END OF OLD STUFF -}
 202
 203 \end{code}
 204
 205 \begin{code}
 206 dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
 207         -- Overlapping/duplicate instances for given class; msg could be more glamourous
 208   = tcAddErrCtxt ctxt $
 209     failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
 210   where
 211     ctxt sty = sep [hsep [ptext SLIT("for"),
 212                           pprQuote sty $ \ sty -> ppr sty clas <+> pprParendType sty ty1],
 213                     nest 4 (sep [ptext SLIT("at")  <+> ppr sty locn1,
 214                                  ptext SLIT("and") <+> ppr sty locn2])]
 215 \end{code}