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 import Ubiq
  18
  19 import HsSyn            ( MonoBinds, Fake, InPat, Sig )
  20 import RnHsSyn          ( RenamedMonoBinds(..), RenamedSig(..),
  21                           RenamedInstancePragmas(..) )
  22
  23 import TcMonad          hiding ( rnMtoTcM )
  24 import Inst             ( InstanceMapper(..) )
  25
  26 import Bag              ( bagToList )
  27 import Class            ( GenClass, GenClassOp, ClassInstEnv(..),
  28                           classBigSig, classOps, classOpLocalType )
  29 import CoreSyn          ( GenCoreExpr(..), mkValLam, mkTyApp )
  30 import Id               ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
  31 import MatchEnv         ( nullMEnv, insertMEnv )
  32 import Maybes           ( MaybeErr(..), mkLookupFunDef )
  33 import Name             ( getSrcLoc, Name{--O only-} )
  34 import PprType          ( GenClass, GenType, GenTyVar )
  35 import Pretty
  36 import SpecEnv          ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
  37 import SrcLoc           ( SrcLoc )
  38 import Type             ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
  39                           splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
  40 import TyVar            ( GenTyVar )
  41 import Unique           ( Unique )
  42 import Util             ( equivClasses, zipWithEqual, panic )
  43
  44
  45 import IdInfo           ( noIdInfo )
  46 --import TcPragmas      ( tcDictFunPragmas, tcGenPragmas )
  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       [Id]              -- Constant methods (either all or none)
  65       RenamedMonoBinds  -- Bindings, b
  66       Bool              -- True <=> local instance decl
  67       (Maybe Module)    -- Name of module where this instance defined; Nothing => Prelude
  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 :: Bool
  80                      -> Maybe Module
  81                      -> RenamedInstancePragmas
  82                      -> Class
  83                      -> [TyVar]
  84                      -> Type
  85                      -> ThetaType
  86                      -> [RenamedSig]
  87                      -> TcM s (Id, ThetaType, [Id])
  88
  89 mkInstanceRelatedIds from_here inst_mod inst_pragmas
  90                      clas inst_tyvars inst_ty inst_decl_theta uprags
  91   =     -- MAKE THE DFUN ID
  92     let
  93         dfun_theta = case inst_decl_theta of
  94                         []    -> []     -- If inst_decl_theta is empty, then we don't
  95                                         -- want to have any dict arguments, so that we can
  96                                         -- expose the constant methods.
  97
  98                         other -> inst_decl_theta ++ super_class_theta
  99                                         -- Otherwise we pass the superclass dictionaries to
 100                                         -- the dictionary function; the Mark Jones optimisation.
 101
 102         dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
 103     in
 104     tcGetUnique                         `thenNF_Tc` \ dfun_uniq ->
 105     fixTc ( \ rec_dfun_id ->
 106
 107 {- LATER
 108         tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas
 109                                         `thenNF_Tc` \ dfun_pragma_info ->
 110         let
 111             dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
 112             dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv
 113         in
 114 -}
 115         let dfun_id_info = noIdInfo in  -- For now
 116
 117         returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here inst_mod dfun_id_info)
 118     ) `thenTc` \ dfun_id ->
 119
 120         -- MAKE THE CONSTANT-METHOD IDS
 121         -- if there are no type variables involved
 122     (if not (null inst_decl_theta)
 123      then
 124         returnTc []
 125      else
 126         mapTc mk_const_meth_id class_ops
 127     )                                   `thenTc` \ const_meth_ids ->
 128
 129     returnTc (dfun_id, dfun_theta, const_meth_ids)
 130   where
 131     (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
 132     tenv = [(class_tyvar, inst_ty)]
 133
 134     super_class_theta = super_classes `zip` (repeat inst_ty)
 135
 136     mk_const_meth_id op
 137         = tcGetUnique           `thenNF_Tc` \ uniq ->
 138           fixTc (\ rec_const_meth_id ->
 139
 140 {- LATER
 141                 -- Figure out the IdInfo from the pragmas
 142              (case assocMaybe opname_prag_pairs (getName op) of
 143                 Nothing   -> returnTc inline_info
 144                 Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag
 145              )                  `thenNF_Tc` \ id_info ->
 146 -}
 147              let id_info = noIdInfo     -- For now
 148              in
 149              returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
 150                                        from_here inst_mod id_info)
 151           )
 152         where
 153           op_ty       = classOpLocalType op
 154           meth_ty     = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
 155 {- LATER
 156           inline_me   = isIn "mkInstanceRelatedIds" op ops_to_inline
 157           inline_info = if inline_me
 158                         then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
 159                         else noIdInfo
 160
 161     opname_prag_pairs = case inst_pragmas of
 162                            ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs
 163                            other_inst_pragmas                       -> []
 164
 165     ops_to_inline = [op | (InlineSig op _) <- uprags]
 166 -}
 167 \end{code}
 168
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsection{Converting instance info into suitable InstEnvs}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 buildInstanceEnvs :: Bag InstInfo
 178                   -> TcM s InstanceMapper
 179
 180 buildInstanceEnvs info
 181   = let
 182         icmp :: InstInfo -> InstInfo -> TAG_
 183         (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
 184           = c1 `cmp` c2
 185
 186         info_by_class = equivClasses icmp (bagToList info)
 187     in
 188     mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
 189     let
 190         class_lookup_fn = mkLookupFunDef (==) inst_env_entries
 191                                          (nullMEnv, \ o -> nullSpecEnv)
 192     in
 193     returnTc class_lookup_fn
 194 \end{code}
 195
 196 \begin{code}
 197 buildInstanceEnv :: [InstInfo]          -- Non-empty, and all for same class
 198                  -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
 199
 200 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
 201   = foldlTc addClassInstance
 202             (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
 203             inst_infos
 204                                         `thenTc` \ (class_inst_env, op_inst_envs) ->
 205     returnTc (clas, (class_inst_env,
 206                      mkLookupFunDef (==) op_inst_envs
 207                                     (panic "buildInstanceEnv")))
 208 \end{code}
 209
 210 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
 211 based on information from a single instance declaration.  It complains
 212 about any overlap with an existing instance.
 213
 214 \begin{code}
 215 addClassInstance
 216     :: (ClassInstEnv, [(ClassOp,SpecEnv)])
 217     -> InstInfo
 218     -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
 219
 220 addClassInstance
 221     (class_inst_env, op_spec_envs)
 222     (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
 223               dfun_id const_meth_ids _ _ _ src_loc _)
 224   =
 225
 226 -- We only add specialised/overlapped instances
 227 -- if we are specialising the overloading
 228 -- ToDo ... This causes getConstMethodId errors!
 229 --
 230 --    if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
 231 --    then
 232 --      -- Drop this specialised/overlapped instance
 233 --      returnTc (class_inst_env, op_spec_envs)
 234 --    else
 235
 236         -- Add the instance to the class's instance environment
 237     case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
 238         Failed (ty', dfun_id')    -> failTc (dupInstErr clas (inst_ty, src_loc)
 239                                                              (ty', getSrcLoc dfun_id'));
 240         Succeeded class_inst_env' ->
 241
 242         -- If there are any constant methods, then add them to
 243         -- the SpecEnv of each class op (ie selector)
 244         --
 245         -- Example.  class    Foo a     where { op :: Baz b => a -> b }
 246         --           instance Foo (p,q) where { op (x,y) = ... }
 247         --
 248         -- The constant method from the instance decl will be:
 249         --      op_Pair :: forall p q b. Baz b => (p,q) -> b
 250         --
 251         -- What we put in op's SpecEnv is
 252         --      (p,q) b  |-->  (\d::Foo (p,q) -> op_Pair p q b)
 253         --
 254         -- Here, [p,q] are the inst_tyvars, and d is a dict whose only
 255         -- purpose is to cancel with the dict to which op is applied.
 256         --
 257         -- NOTE THAT this correctly deals with the case where there are
 258         -- constant methods even though there are type variables in the
 259         -- instance declaration.
 260
 261     tcGetUnique                         `thenNF_Tc` \ uniq ->
 262     let
 263       dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
 264                 -- Slightly disgusting, but it's only a placeholder for
 265                 -- a dictionary to be chucked away.
 266
 267       op_spec_envs' | null const_meth_ids = op_spec_envs
 268                     | otherwise           = zipWithEqual add_const_meth op_spec_envs const_meth_ids
 269
 270       add_const_meth (op,spec_env) meth_id
 271         = (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
 272                  Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
 273                  Succeeded spec_env' -> spec_env' )
 274         where
 275           (local_tyvars, _) = splitForAllTy (classOpLocalType op)
 276           local_tyvar_tys   = mkTyVarTys local_tyvars
 277           rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
 278                                                   (mkTyVarTys inst_tyvars))
 279                                          local_tyvar_tys)
 280     in
 281     returnTc (class_inst_env', op_spec_envs')
 282     }
 283 \end{code}
 284
 285 \begin{code}
 286 dupInstErr clas info1@(ty1, locn1) info2@(ty2, locn2) sty
 287         -- Overlapping/duplicate instances for given class; msg could be more glamourous
 288   = ppHang (ppBesides [ppStr "Duplicate/overlapping instances: class `", ppr sty clas, ppStr "'"])
 289          4 (showOverlap sty info1 info2)
 290
 291 showOverlap sty (ty1,loc1) (ty2,loc2)
 292   = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
 293            ppBesides [ppStr "at ", ppr sty loc1],
 294            ppBesides [ppStr "and ", ppr sty loc2]]
 295 \end{code}