ghc/compiler/basicTypes/Inst.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Inst (
  10         Inst(..), InstOrigin(..), OverloadedLit(..),
  11
  12         mkDict, mkMethod, mkLitInst,
  13         getInstUniType,
  14 --UNUSED:       getInstLocalName,
  15         getInstOrigin, getDictClassAndType,
  16 --UNUSED:       instantiateInst,
  17         applySubstToInst,
  18         apply_to_Inst,  -- not for general use, please
  19         extractTyVarsFromInst, extractConstrainedTyVarsFromInst,
  20         matchesInst,
  21         isTyVarDict,
  22 --UNUSED: isNullaryTyConDict,
  23         instBindingRequired, instCanBeGeneralised,
  24
  25         -- and to make the interface self-sufficient...
  26         Class, ClassOp, ArithSeqInfo, RenamedArithSeqInfo(..),
  27         Literal, InPat, RenamedPat(..), Expr, RenamedExpr(..),
  28         Id, Name, SrcLoc, Subst, PrimKind,
  29         TyVar, TyVarTemplate, TyCon, UniType, Unique, InstTemplate,
  30         InstanceMapper(..), ClassInstEnv(..), MatchEnv(..)
  31
  32         IF_ATTACK_PRAGMAS(COMMA isTyVarTy)
  33     ) where
  34
  35 import AbsSyn
  36 import AbsUniType
  37 import Id               ( eqId, applySubstToId,
  38                           getInstNamePieces, getIdUniType,
  39                           Id
  40                         )
  41 import InstEnv
  42 import ListSetOps
  43 import Maybes           ( Maybe(..) )
  44 import Outputable
  45 import Pretty
  46 import SrcLoc           ( mkUnknownSrcLoc, SrcLoc )
  47 import Subst            ( applySubstToTy, Subst )
  48 import Util
  49 \end{code}
  50
  51
  52 %************************************************************************
  53 %*                                                                      *
  54 \subsection[Inst-types]{@Inst@ types}
  55 %*                                                                      *
  56 %************************************************************************
  57
  58 An @Inst@ is either a dictionary, an instance of an overloaded
  59 literal, or an instance of an overloaded value.  We call the latter a
  60 ``method'' even though it may not correspond to a class operation.
  61 For example, we might have an instance of the @double@ function at
  62 type Int, represented by
  63
  64         Method 34 doubleId [Int] origin
  65
  66 \begin{code}
  67 data Inst
  68   = Dict
  69         Unique
  70         Class           -- The type of the dict is (c t), where
  71         UniType         -- c is the class and t the unitype;
  72         InstOrigin
  73
  74   | Method
  75         Unique
  76         Id              -- (I expect) be a global, local, or ClassOpId.
  77                         -- Inside instance decls (only) it can also be an InstId!
  78                         -- The id needn't be completely polymorphic,
  79         [UniType]       -- The types to which its polymorphic tyvars
  80                         --      should be instantiated
  81                         --      These types may not saturate the Id's foralls.
  82         InstOrigin
  83
  84   | LitInst
  85         Unique
  86         OverloadedLit
  87         UniType         -- the type at which the literal is used
  88         InstOrigin      -- always a literal; but more convenient to carry this around
  89
  90 mkDict   = Dict
  91 mkMethod = Method
  92 mkLitInst= LitInst
  93
  94 data OverloadedLit
  95   = OverloadedIntegral   Integer        -- the number
  96                          Id Id          -- cached fromInt, fromInteger
  97   | OverloadedFractional Rational       -- the number
  98                          Id             -- cached fromRational
  99
 100 {- UNUSED:
 101 getInstLocalName (Dict _ clas _ _) = getLocalName clas
 102 getInstLocalName (Method _ id _ _) = getLocalName id
 103 -}
 104
 105 -- this is used for error messages
 106 getDictClassAndType :: Inst -> (Class, UniType)
 107 getDictClassAndType (Dict _ clas ty _)  = (clas, ty)
 108
 109 getInstUniType :: Inst -> UniType
 110 getInstUniType (Dict _ clas ty _)  = mkDictTy clas ty
 111 getInstUniType (LitInst _ _ ty _)  = ty
 112 getInstUniType (Method _ id tys _)
 113   = instantiateTauTy (tyvars `zip` tys) tau_ty
 114   where
 115     (tyvars, theta, tau_ty) = splitType (getIdUniType id)
 116         -- Note that we ignore the overloading; this is
 117         -- an INSTANCE of an overloaded operation
 118 \end{code}
 119
 120 @applySubstToInst@ doesn't make any assumptions, but @instantiateInst@
 121 assumes that the @Id@ in a @Method@ is fully polymorphic (ie has no free
 122 tyvars)
 123
 124 \begin{code}
 125 {- UNUSED:
 126 instantiateInst :: [(TyVarTemplate, UniType)] -> Inst -> Inst
 127
 128 instantiateInst tenv (Dict uniq clas ty orig)
 129   = Dict uniq clas (instantiateTy tenv ty) orig
 130
 131 instantiateInst tenv (Method uniq id tys orig)
 132   = --False:ASSERT(idHasNoFreeTyVars id)
 133     Method uniq id (map (instantiateTy tenv) tys) orig
 134
 135 instantiateInst tenv (LitInst u lit ty orig)
 136   = LitInst u lit (instantiateTy tenv ty) orig
 137 -}
 138
 139 -----------------------------------------------------------------
 140 -- too bad we can't use apply_to_Inst
 141
 142 applySubstToInst subst (Dict uniq clas ty orig)
 143   = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 144     (s2, Dict uniq clas new_ty orig) }
 145
 146 applySubstToInst subst (Method uniq id tys orig)
 147   -- NB: *must* zap "id" in the typechecker
 148   = case (applySubstToId subst id)          of { (s2, new_id)  ->
 149     case (mapAccumL applySubstToTy s2 tys)  of { (s3, new_tys) ->
 150     (s3, Method uniq new_id new_tys orig) }}
 151
 152 applySubstToInst subst (LitInst u lit ty orig)
 153   = case (applySubstToTy subst ty) of { (s2, new_ty) ->
 154     (s2, LitInst u lit new_ty orig) }
 155
 156 -----------------------------------------------------------------
 157 apply_to_Inst :: (UniType -> UniType) -> Inst -> Inst
 158
 159 apply_to_Inst ty_fn (Dict uniq clas ty orig)
 160   = Dict uniq clas (ty_fn ty) orig
 161
 162 apply_to_Inst ty_fn (Method uniq id tys orig)
 163   = --FALSE: ASSERT(idHasNoFreeTyVars id)
 164     Method uniq id (map ty_fn tys) orig
 165
 166 apply_to_Inst ty_fn (LitInst u lit ty orig)
 167   = LitInst u lit (ty_fn ty) orig
 168 \end{code}
 169
 170 \begin{code}
 171 extractTyVarsFromInst, extractConstrainedTyVarsFromInst :: Inst -> [TyVar]
 172
 173 extractTyVarsFromInst (Dict _ _ ty _)    = extractTyVarsFromTy  ty
 174 extractTyVarsFromInst (Method _ _ tys _) = extractTyVarsFromTys tys
 175 extractTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy  ty
 176
 177 extractConstrainedTyVarsFromInst (Dict _ _ ty _)    = extractTyVarsFromTy  ty
 178 extractConstrainedTyVarsFromInst (LitInst _ _ ty _) = extractTyVarsFromTy  ty
 179
 180 -- `Method' is different!
 181 extractConstrainedTyVarsFromInst (Method _ m tys _)
 182   = foldr unionLists [] (zipWith xxx tvs tys)
 183   where
 184     (tvs,theta,tau_ty) = splitType (getIdUniType m)
 185
 186     constrained_tvs
 187       = foldr unionLists [] [extractTyVarTemplatesFromTy t | (_,t) <- theta ]
 188
 189     xxx tv ty | tv `elem` constrained_tvs = extractTyVarsFromTy ty
 190               | otherwise                 = []
 191 \end{code}
 192
 193 @matchesInst@ checks when two @Inst@s are instances of the same
 194 thing at the same type, even if their uniques differ.
 195
 196 \begin{code}
 197 matchesInst :: Inst -> Inst -> Bool
 198 matchesInst (Dict _ clas1 ty1 _) (Dict _ clas2 ty2 _)
 199   = clas1 == clas2 && ty1 == ty2
 200 matchesInst (Method _ id1 tys1 _) (Method _ id2 tys2 _)
 201   = id1 `eqId` id2 && tys1 == tys2
 202 matchesInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
 203   = lit1 `eq` lit2 && ty1 == ty2
 204   where
 205     (OverloadedIntegral   i1 _ _) `eq` (OverloadedIntegral   i2 _ _) = i1 == i2
 206     (OverloadedFractional f1 _)   `eq` (OverloadedFractional f2 _)   = f1 == f2
 207     _                             `eq` _                             = False
 208
 209 matchesInst other1 other2 = False
 210 \end{code}
 211
 212
 213 \begin{code}
 214 isTyVarDict :: Inst -> Bool
 215 isTyVarDict (Dict _ _ ty _) = isTyVarTy ty
 216 isTyVarDict other           = False
 217
 218 {- UNUSED:
 219 isNullaryTyConDict :: Inst -> Bool
 220 isNullaryTyConDict (Dict _ _ ty _)
 221   = case (getUniDataTyCon_maybe ty) of
 222       Just (tycon, [], _)   -> True             -- NB null args to tycon
 223       other                 -> False
 224 -}
 225 \end{code}
 226
 227 Two predicates which deal with the case where
 228 class constraints don't necessarily result in bindings.
 229 The first tells whether an @Inst@ must be witnessed by an
 230 actual binding; the second tells whether an @Inst@ can be
 231 generalised over.
 232
 233 \begin{code}
 234 instBindingRequired :: Inst -> Bool
 235 instBindingRequired inst
 236   = case get_origin_really inst of
 237         CCallOrigin _ _ _ -> False      -- No binding required
 238         LitLitOrigin  _ _ -> False
 239         other             -> True
 240
 241 instCanBeGeneralised :: Inst -> Bool
 242 instCanBeGeneralised inst
 243   = case get_origin_really inst of
 244         CCallOrigin _ _ _ -> False      -- Can't be generalised
 245         LitLitOrigin  _ _ -> False      -- Can't be generalised
 246         other             -> True
 247 \end{code}
 248
 249 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 250 relevant in error messages.
 251
 252 \begin{code}
 253 -- ToDo: this instance might be nukable (maybe not: used for error msgs)
 254
 255 instance Outputable Inst where
 256     ppr PprForUser (LitInst _ lit _ _)
 257       = case lit of
 258           OverloadedIntegral   i _ _ -> ppInteger i
 259 #if __GLASGOW_HASKELL__ <= 22
 260           OverloadedFractional f _   -> ppDouble (fromRational f) -- ToDo: better
 261 #else
 262           OverloadedFractional f _   -> ppRational f
 263 #endif
 264
 265     ppr sty inst
 266       = ppIntersperse (ppChar '.') (map ppPStr (getInstNamePieces True inst))
 267 \end{code}
 268
 269
 270 %************************************************************************
 271 %*                                                                      *
 272 \subsection[Inst-origin]{The @InstOrigin@ type}
 273 %*                                                                      *
 274 %************************************************************************
 275
 276 The @InstOrigin@ type gives information about where a dictionary came from.
 277 This is important for decent error message reporting because dictionaries
 278 don't appear in the original source code.  Doubtless this type will evolve...
 279
 280 \begin{code}
 281 data InstOrigin
 282   = OccurrenceOf        Id      -- Occurrence of an overloaded identifier
 283                         SrcLoc
 284
 285   | InstanceDeclOrigin  SrcLoc  -- Typechecking an instance decl
 286
 287   | LiteralOrigin       Literal -- Occurrence of a literal
 288                         SrcLoc  -- (now redundant? ToDo)
 289
 290   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 291                         SrcLoc
 292
 293   | SignatureOrigin             -- A dict created from a type signature
 294                                 -- I don't expect this ever to appear in
 295                                 -- an error message so I can't be bothered
 296                                 -- to give it a source location...
 297
 298   | ClassDeclOrigin     SrcLoc  -- Manufactured during a class decl
 299
 300   | DerivingOrigin      InstanceMapper
 301                         Class
 302                         Bool    -- True <=> deriving for *functions*;
 303                                 -- do *not* look at the TyCon! [WDP 94/09]
 304                         TyCon
 305                         SrcLoc
 306
 307         -- During "deriving" operations we have an ever changing
 308         -- mapping of classes to instances, so we record it inside the
 309         -- origin information.  This is a bit of a hack, but it works
 310         -- fine.  (Simon is to blame [WDP].)
 311
 312   | InstanceSpecOrigin  InstanceMapper
 313                         Class   -- in a SPECIALIZE instance pragma
 314                         UniType
 315                         SrcLoc
 316
 317         -- When specialising instances the instance info attached to
 318         -- each class is not yet ready, so we record it inside the
 319         -- origin information.  This is a bit of a hack, but it works
 320         -- fine.  (Patrick is to blame [WDP].)
 321
 322   | DefaultDeclOrigin   SrcLoc  -- Related to a `default' declaration
 323
 324   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 325                         SrcLoc
 326
 327         -- Argument or result of a ccall
 328         -- Dictionaries with this origin aren't actually mentioned in the
 329         -- translated term, and so need not be bound.  Nor should they
 330         -- be abstracted over.
 331   | CCallOrigin         SrcLoc
 332                         String                  -- CCall label
 333                         (Maybe RenamedExpr)     -- Nothing if it's the result
 334                                                 -- Just arg, for an argument
 335
 336   | LitLitOrigin        SrcLoc
 337                         String  -- the litlit
 338
 339   | UnknownOrigin       -- Help! I give up...
 340 \end{code}
 341
 342 \begin{code}
 343 get_origin_really (Dict   u clas ty origin) = origin
 344 get_origin_really (Method u clas ty origin) = origin
 345 get_origin_really (LitInst u lit ty origin) = origin
 346
 347 getInstOrigin inst
 348   = let origin = get_origin_really inst
 349     in  get_orig origin
 350   where
 351     get_orig :: InstOrigin -> (SrcLoc, PprStyle -> Pretty)
 352
 353     get_orig (OccurrenceOf id loc)
 354       = (loc, \ sty -> ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
 355                                   ppr sty id, ppChar '\''])
 356     get_orig (InstanceDeclOrigin loc)
 357       = (loc, \ sty -> ppStr "in an instance declaration")
 358     get_orig (LiteralOrigin lit loc)
 359       = (loc, \ sty -> ppCat [ppStr "at an overloaded literal:", ppr sty lit])
 360     get_orig (ArithSeqOrigin seq loc)
 361       = (loc, \ sty -> ppCat [ppStr "at an arithmetic sequence:", ppr sty seq])
 362     get_orig SignatureOrigin
 363       = (mkUnknownSrcLoc, \ sty -> ppStr "in a type signature")
 364     get_orig (ClassDeclOrigin loc)
 365       = (loc, \ sty -> ppStr "in a class declaration")
 366     get_orig (DerivingOrigin _ clas is_function tycon loc)
 367       = (loc, \ sty -> ppBesides [ppStr "in a `deriving' clause; class \"",
 368                                   ppr sty clas,
 369                                   if is_function
 370                                   then ppStr "\"; type: functions"
 371                                   else ppBeside (ppStr "\"; offending type \"") (ppr sty tycon),
 372                                   ppStr "\""])
 373     get_orig (InstanceSpecOrigin _ clas ty loc)
 374       = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
 375                                   ppr sty clas, ppStr "\" type: ", ppr sty ty])
 376     get_orig (DefaultDeclOrigin loc)
 377       = (loc, \ sty -> ppStr "in a `default' declaration")
 378     get_orig (ValSpecOrigin name loc)
 379       = (loc, \ sty -> ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
 380                                   ppr sty name, ppStr "'"])
 381     get_orig (CCallOrigin loc clabel Nothing{-ccall result-})
 382       = (loc, \ sty -> ppBesides [ppStr "in the result of the _ccall_ to `",
 383                         ppStr clabel, ppStr "'"])
 384     get_orig (CCallOrigin loc clabel (Just arg_expr))
 385       = (loc, \ sty -> ppBesides [ppStr "in an argument in the _ccall_ to `",
 386                         ppStr clabel, ppStr "', namely: ", ppr sty arg_expr])
 387     get_orig (LitLitOrigin loc s)
 388       = (loc, \ sty -> ppBesides [ppStr "in this ``literal-literal'': ", ppStr s])
 389     get_orig UnknownOrigin
 390       = (mkUnknownSrcLoc, \ sty -> ppStr "in... oops -- I don't know where the overloading came from!")
 391 \end{code}