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