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