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