ghc/compiler/envs/InstEnv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
   3 %
   4 \section[InstEnv]{Instance environments}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module InstEnv (
  10         -- these types could use some abstractification (??? ToDo)
  11         ClassInstEnv(..), -- OLD: IdInstEnv(..),
  12         InstTemplate, InstTy,
  13         MethodInstInfo(..),     -- needs to be exported? (ToDo)
  14         InstanceMapper(..),     -- widely-used synonym
  15
  16 --      instMethod, instTemplate, -- no need to export
  17         addClassInst, {- NOT USED addConstMethInst, -}
  18         lookupInst,
  19         lookupClassInstAtSimpleType,
  20         lookupNoBindInst,
  21         mkInstSpecEnv,
  22
  23         MatchEnv(..),   -- mk more abstract (??? ToDo)
  24         nullMEnv,
  25 --      mkMEnv, lookupMEnv, matchMEnv, insertMEnv, -- no need to export
  26
  27         -- and to make the interface self-sufficient...
  28         Class, ClassOp, CoreExpr, Expr, TypecheckedPat, Id,
  29         Inst, InstOrigin, Maybe, MaybeErr, TyVarTemplate, TyCon,
  30         UniType, SplitUniqSupply, SpecInfo, SpecEnv
  31     ) where
  32
  33 IMPORT_Trace            -- ToDo: rm (debugging)
  34
  35 import AbsPrel          ( intTyCon, --wordTyCon, addrTyCon,
  36                           floatTyCon, doubleTyCon, charDataCon, intDataCon,
  37                           wordDataCon, addrDataCon, floatDataCon,
  38                           doubleDataCon,
  39                           intPrimTyCon, doublePrimTyCon
  40                         )
  41 import AbsSyn           -- TypecheckedExpr, etc.
  42 import AbsUniType
  43 import Id
  44 import IdInfo
  45 import Inst
  46 import Maybes           -- most of it
  47 import Outputable       ( isExported )
  48 import PlainCore        -- PlainCoreExpr, etc.
  49 import Pretty
  50 import PrimKind         -- rather grubby import (ToDo?)
  51 import SplitUniq
  52 import Util
  53 \end{code}
  54
  55 %************************************************************************
  56 %*                                                                      *
  57 \subsection[InstEnv-types]{Type declarations}
  58 %*                                                                      *
  59 %************************************************************************
  60
  61 \begin{code}
  62 type InstanceMapper
  63   = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
  64
  65 type ClassInstEnv
  66   = MatchEnv UniType InstTemplate       -- Instances of dicts
  67
  68 data InstTemplate
  69   = MkInstTemplate
  70         Id              -- A fully polymorphic Id; it is the function
  71                         -- which produces the Id instance or dict from
  72                         -- the pieces specified by the rest of the
  73                         -- template.  Its SrcLoc tells where the
  74                         -- instance was defined.
  75         [UniType]       -- Apply it to these types, suitably instantiated
  76         [InstTy]        -- and instances of these things
  77
  78 type MethodInstInfo = (Id, [UniType], InstTemplate) -- Specifies a method instance
  79 \end{code}
  80
  81 There is an important consistency constraint between the @MatchEnv@s
  82 in and the @InstTemplate@s inside them: the @UniType@(s) which is/are
  83 the key for the @MatchEnv@ must contain only @TyVarTemplates@, and
  84 these must be a superset of the @TyVarTemplates@ mentioned in the
  85 corresponding @InstTemplate@.
  86
  87 Reason: the lookup process matches the key against the desired value,
  88 returning a substitution which is used to instantiate the template.
  89
  90 \begin{code}
  91 data InstTy
  92   = DictTy      Class UniType
  93   | MethodTy    Id    [UniType]
  94 \end{code}
  95
  96         MkInstTemplate f tvs insts
  97
  98 says that, given a particular mapping of type variables tvs to some
  99 types tys, the value which is the required instance is
 100
 101         f tys (insts [tys/tvs])
 102
 103
 104 @instMethod@ is used if there is no instance for a method; then it is
 105 expressed in terms of the corresponding dictionary (or possibly, in a
 106 wired-in case only, dictionaries).
 107
 108 \begin{code}
 109 instMethod :: SplitUniqSupply
 110            -> InstOrigin
 111            -> Id -> [UniType]
 112            -> (TypecheckedExpr, [Inst])
 113
 114 instMethod uniqs orig id tys
 115   = (mkDictApp (mkTyApp (Var id) tys) dicts,
 116      insts)
 117   where
 118    (tyvars, theta, tau_ty) = splitType (getIdUniType id)
 119    tenv                    = tyvars `zipEqual` tys
 120    insts                   = mk_dict_insts uniqs theta
 121    dicts                   = map mkInstId insts
 122
 123    mk_dict_insts us [] = []
 124    mk_dict_insts us ((clas, ty) : rest)
 125       = case splitUniqSupply us of { (s1, s2) ->
 126         (Dict (getSUnique s1) clas (instantiateTauTy tenv ty) orig)
 127         : mk_dict_insts s2 rest
 128         }
 129 \end{code}
 130
 131 @instTemplate@ is used if there is an instance for a method or dictionary.
 132
 133 \begin{code}
 134 instTemplate :: SplitUniqSupply
 135              -> InstOrigin
 136              -> [(TyVarTemplate, UniType)]
 137              -> InstTemplate
 138              -> (TypecheckedExpr, [Inst])
 139
 140 instTemplate uniqs orig tenv (MkInstTemplate id ty_tmpls inst_tys)
 141   = (mkDictApp (mkTyApp (Var id) ty_args) ids,  -- ToDo: not strictly a dict app
 142                                                 -- for Method inst_tys
 143      insts)
 144   where
 145     ty_args         = map (instantiateTy tenv) ty_tmpls
 146     insts           = mk_insts uniqs inst_tys
 147     ids             = map mkInstId insts
 148
 149     mk_insts us [] = []
 150     mk_insts us (inst_ty : rest)
 151       = case splitUniqSupply us of { (s1, s2) ->
 152         let
 153             uniq = getSUnique s1
 154         in
 155         (case inst_ty of
 156            DictTy clas ty  -> Dict uniq clas (instantiateTy tenv ty) orig
 157            MethodTy id tys -> Method uniq id (map (instantiateTy tenv) tys) orig
 158         ) : mk_insts s2 rest
 159         }
 160 \end{code}
 161
 162
 163 %************************************************************************
 164 %*                                                                      *
 165 \subsection[InstEnv-adding]{Adding new class instances}
 166 %*                                                                      *
 167 %************************************************************************
 168
 169 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@ based on
 170 information from a single instance declaration.  It complains about
 171 any overlap with an existing instance.
 172
 173 Notice that we manufacture the @DictFunId@ and @ConstMethodId@s from
 174 scratch here, rather than passing them in.  This means a small amount
 175 of duplication (no big deal) and that we can't attach a single
 176 canonical unfolding; but they don't have a slot for unfoldings
 177 anyway...  This could be improved.  (We do, however, snaffle in the
 178 pragma info from the interface...)
 179
 180 {\em Random notes}
 181
 182 \begin{verbatim}
 183 class Foo a where
 184   fop :: Ord b => a -> b -> b -> a
 185
 186 instance Foo Int where
 187   fop x y z = if y<z then x else fop x z y
 188
 189 instance Foo a => Foo [a] where
 190   fop []     y z = []
 191   fop (x:xs) y z = [fop x y z]
 192 \end{verbatim}
 193
 194
 195 For the Int instance we add to the ??? envt
 196 \begin{verbatim}
 197   (ClassOpId Foo fop) |--> [Int,b] |--> InstTemplate (ConstMethodId Foo fop Int) [b] [Ord b]
 198 \end{verbatim}
 199
 200 If there are no type variables, @addClassInstance@ adds constant
 201 instances for those class ops not mentioned in the class-op details
 202 (possibly using the pragma info that was passed in).  This MUST
 203 be the same decision as that by @tcInstDecls2@ about whether to
 204 generate constant methods.  NB: A slightly more permissive version
 205 would base the decision on the context being empty, but there is
 206 slightly more admin associated and the benefits are very slight; the
 207 context is seldom empty unless there are no tyvars involved.
 208
 209 Note: the way of specifying class-op instance details is INADEQUATE
 210 for polymorphic class ops.  That just means you can't specify clever
 211 instances for them via this function.
 212
 213 \begin{code}
 214 addClassInst
 215     :: Class                    -- class in question (for err msg only)
 216     -> ClassInstEnv             -- Incoming envt
 217     -> UniType                  -- The instance type
 218     -> Id                       -- Dict fun id to apply
 219     -> [TyVarTemplate]          -- Types to which (after instantiation) to apply the dfun
 220     -> ThetaType                -- Dicts to which to apply the dfun
 221     -> SrcLoc                   -- associated SrcLoc (for err msg only)
 222     -> MaybeErr
 223           ClassInstEnv          -- Success
 224           (Class, (UniType, SrcLoc),  -- Failure: the overlapping pair
 225                   (UniType, SrcLoc))
 226
 227 addClassInst clas inst_env inst_ty dfun_id inst_tyvars dfun_theta locn
 228   = case (insertMEnv matchTy inst_env inst_ty dict_template) of
 229       Succeeded inst_env' -> Succeeded inst_env'
 230       Failed (ty', MkInstTemplate id' _ _)
 231         -> Failed (clas, (inst_ty, locn), (ty', getSrcLoc id'))
 232   where
 233     dict_template = MkInstTemplate dfun_id
 234                                    (map mkTyVarTemplateTy inst_tyvars)
 235                                    (unzipWith DictTy dfun_theta)
 236 \end{code}
 237
 238 ============ NOT USED =============
 239 @addConstMethInst@ panics on overlap, because @addClassInst@ has already found
 240 any overlap.
 241
 242 \begin{pseudocode}
 243 addConstMethInst :: IdInstEnv
 244                  -> UniType             -- The instance type
 245                  -> Id                  -- The constant method
 246                  -> [TyVarTemplate]     -- Apply method to these (as above)
 247                  -> IdInstEnv
 248
 249 addConstMethInst inst_env inst_ty meth_id inst_tyvars
 250   = case (insertMEnv matchTys inst_env [inst_ty] template) of
 251       Succeeded inst_env' -> inst_env'
 252       Failed (tys', MkInstTemplate id' _ _) ->
 253         pprPanic "addConstMethInst:"
 254                 (ppSep [ppr PprDebug meth_id,
 255                         ppr PprDebug inst_ty,
 256                         ppr PprDebug id'])
 257   where
 258      template = MkInstTemplate meth_id (map mkTyVarTemplateTy inst_tyvars) []
 259         -- Constant method just needs to be applied to tyvars
 260         -- (which are usually empty)
 261 \end{pseudocode}
 262
 263 @mkIdInstEnv@ is useful in the simple case where we've a list of
 264 @(types, id)@ pairs; the \tr{id} is the \tr{types} specialisation of
 265 some other Id (in which the resulting IdInstEnv will doubtless be
 266 embedded.  There's no messing about with type variables or
 267 dictionaries here.
 268
 269 \begin{code}
 270 {- OLD:
 271 mkIdInstEnv :: [([TauType],Id)] -> IdInstEnv
 272
 273 mkIdInstEnv [] = nullMEnv
 274 mkIdInstEnv ((tys,id) : rest)
 275   = let
 276         inst_env = mkIdInstEnv rest
 277     in
 278     case (insertMEnv matchTys inst_env tys template) of
 279       Succeeded inst_env' -> inst_env'
 280       Failed _ -> panic "Failed in mkIdInstEnv"
 281   where
 282     template = MkInstTemplate id [] []
 283 -}
 284 \end{code}
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 \subsection[InstEnv-lookup]{Performing lookup}
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 lookupInst :: SplitUniqSupply
 294            -> Inst
 295            -> Maybe (TypecheckedExpr,
 296                      [Inst])
 297
 298 lookupInst uniqs (Dict _ clas ty orig)
 299   = if isTyVarTy ty then
 300         Nothing -- No instances of a class at a type variable
 301     else
 302       case (lookupMEnv matchTy inst_env ty) of
 303         Nothing             -> Nothing
 304         Just (_,tenv,templ) -> Just (instTemplate uniqs orig tenv templ)
 305   where
 306     inst_env
 307       = case orig of
 308
 309           -- During deriving and instance specialisation operations
 310           -- we can't get the instances of the class from inside the
 311           -- class, because the latter ain't ready yet.  Instead we
 312           -- find a mapping from classes to envts inside the dict origin.
 313           -- (A Simon hack [WDP])
 314
 315           DerivingOrigin inst_mapper _ _ _ _ -> fst (inst_mapper clas)
 316
 317           InstanceSpecOrigin inst_mapper _ _ _ -> fst (inst_mapper clas)
 318
 319           -- Usually we just get the instances of the class from
 320           -- inside the class itself.
 321
 322           other -> getClassInstEnv clas
 323
 324 lookupInst uniqs (Method _ id tys orig)
 325   = if (all isTyVarTy tys) then
 326         general_case    -- Instance types are all type variables, so there can't be
 327                         -- a special instance for this method
 328
 329     else        -- Get the inst env from the Id, and look up in it
 330       case (lookupSpecEnv (getIdSpecialisation id) tys) of
 331         Nothing             -> general_case
 332         Just (spec_id, types_left, num_dicts_to_toss)
 333           -> Just (instMethod uniqs orig spec_id types_left)
 334   where
 335     general_case = Just (instMethod uniqs orig id tys)
 336 \end{code}
 337
 338 Now "overloaded" literals: the plain truth is that the compiler
 339 is intimately familiar w/ the types Int, Integer, Float, and Double;
 340 for everything else, we actually conjure up an appropriately-applied
 341 fromInteger/fromRational, as the Haskell report suggests.
 342
 343 \begin{code}
 344 lookupInst uniqs (LitInst u (OverloadedIntegral i from_int from_integer) ty orig)
 345   = Just (
 346     case (getUniDataTyCon_maybe ty) of  -- this way is *unflummoxed* by synonyms
 347       Just (tycon, [], _)
 348         | tycon == intPrimTyCon         -> (intprim_lit,    [])
 349         | tycon == doublePrimTyCon      -> (doubleprim_lit, [])
 350         | tycon == intTyCon             -> (int_lit,        [])
 351         | tycon == doubleTyCon          -> (double_lit,     [])
 352         | tycon == floatTyCon           -> (float_lit,      [])
 353 --      | tycon == wordTyCon            -> (word_lit,       [])
 354 --      | tycon == addrTyCon            -> (addr_lit,       [])
 355
 356       _{-otherwise-} ->
 357
 358         if (i >= toInteger minInt && i <= toInteger maxInt) then
 359             -- It's overloaded but small enough to fit into an Int
 360
 361             let u2              = getSUnique uniqs
 362                 method  = Method u2 from_int [ty] orig
 363             in
 364             (App (Var (mkInstId method)) int_lit, [method])
 365
 366         else
 367             -- Alas, it is overloaded and a big literal!
 368
 369             let u2         = getSUnique uniqs
 370                 method = Method u2 from_integer [ty] orig
 371             in
 372             (App (Var (mkInstId method)) (Lit (IntLit i)), [method])
 373     )
 374   where
 375 #if __GLASGOW_HASKELL__ <= 22
 376     iD = ((fromInteger i) :: Double)
 377 #else
 378     iD = ((fromInteger i) :: Rational)
 379 #endif
 380     intprim_lit    = Lit (IntPrimLit i)
 381     doubleprim_lit = Lit (DoublePrimLit iD)
 382     int_lit        = App (Var intDataCon)    intprim_lit
 383     double_lit     = App (Var doubleDataCon) doubleprim_lit
 384     float_lit      = App (Var floatDataCon)  (Lit (FloatPrimLit iD))
 385 --  word_lit       = App (Var wordDataCon)   intprim_lit
 386 --  addr_lit       = App (Var addrDataCon)   intprim_lit
 387
 388 lookupInst uniqs (LitInst u (OverloadedFractional f from_rational) ty orig)
 389   = Just (
 390     case (getUniDataTyCon_maybe ty) of  -- this way is *unflummoxed* by synonyms
 391       Just (tycon, [], _)
 392         | tycon == doublePrimTyCon -> (doubleprim_lit, [])
 393         | tycon == doubleTyCon     -> (double_lit, [])
 394         | tycon == floatTyCon      -> (float_lit,  [])
 395
 396       _ {-otherwise-} ->    -- gotta fromRational it...
 397         --pprTrace "lookupInst:fractional lit ty?:" (ppr PprDebug ty) (
 398         let
 399             u2     = getSUnique uniqs
 400             method = Method u2 from_rational [ty] orig
 401         in
 402         (App (Var (mkInstId method)) (Lit (FracLit f)), [method])
 403         --)
 404     )
 405   where
 406 #if __GLASGOW_HASKELL__ <= 22
 407     fD = ((fromRational f) :: Double)
 408 #else
 409     fD = f
 410 #endif
 411     doubleprim_lit = Lit (DoublePrimLit fD)
 412     double_lit     = App (Var doubleDataCon) doubleprim_lit
 413     float_lit      = App (Var floatDataCon)  (Lit (FloatPrimLit  fD))
 414 \end{code}
 415
 416 There is a second, simpler interface, when you want an instance of a
 417 class at a given nullary type constructor.  It just returns the
 418 appropriate dictionary if it exists.  It is used only when resolving
 419 ambiguous dictionaries.
 420
 421 \begin{code}
 422 lookupClassInstAtSimpleType :: Class -> UniType -> Maybe Id
 423
 424 lookupClassInstAtSimpleType clas ty
 425   = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
 426       Nothing                              -> Nothing
 427       Just (_,_,MkInstTemplate dict [] []) -> Just dict
 428 \end{code}
 429
 430 Notice in the above that the type constructors in the default list
 431 should all have arity zero, so there should be no type variables
 432 or thetas in the instance declaration.
 433
 434 There's yet a third interface for Insts which need no binding.
 435 They are used to record constraints on type variables, notably
 436 for CCall arguments and results.
 437
 438 \begin{code}
 439 lookupNoBindInst :: SplitUniqSupply
 440                  -> Inst
 441                  -> Maybe [Inst]
 442
 443 lookupNoBindInst uniqs (Dict _ clas ty orig)
 444   = if isTyVarTy ty then
 445         Nothing -- No instances of a class at a type variable
 446     else
 447       case (lookupMEnv matchTy inst_env ty) of
 448         Nothing             -> Nothing
 449         Just (_,tenv,templ) ->
 450           case (instTemplate uniqs orig tenv templ) of
 451             (bottom_rhs, insts)
 452               -> Just insts
 453                 -- The idea here is that the expression built by
 454                 -- instTemplate isn't relevant; indeed, it might well
 455                 -- be a place-holder bottom value.
 456   where
 457     inst_env = getClassInstEnv clas
 458 \end{code}
 459
 460 \begin{code}
 461 mkInstSpecEnv :: Class                  -- class
 462               -> UniType                -- instance type
 463               -> [TyVarTemplate]        -- instance tyvars
 464               -> ThetaType              -- superclasses dicts
 465               -> SpecEnv                -- specenv for dfun of instance
 466
 467 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
 468   = mkSpecEnv (catMaybes (map maybe_spec_info matches))
 469   where
 470     matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
 471
 472     maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
 473       = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
 474     maybe_spec_info (_, match_info, _)
 475       = Nothing
 476
 477 \end{code}
 478
 479 %************************************************************************
 480 %*                                                                      *
 481 \subsection[MatchEnv]{Matching environments}
 482 %*                                                                      *
 483 %************************************************************************
 484
 485 ``Matching'' environments allow you to bind a template to a value;
 486 when you look up in it, you supply a value which is matched against
 487 the template.
 488
 489 \begin{code}
 490 type MatchEnv key value = [(key, value)]
 491 \end{code}
 492
 493 For now we just use association lists.  The list is maintained sorted
 494 in order of {\em decreasing specificness} of @key@, so that the first
 495 match will be the most specific.
 496
 497 \begin{code}
 498 nullMEnv :: MatchEnv a b
 499 nullMEnv = []
 500
 501 mkMEnv :: [(key, value)] -> MatchEnv key value
 502 mkMEnv stuff = stuff
 503 \end{code}
 504
 505 @lookupMEnv@ looks up in a @MatchEnv@.
 506 It simply takes the first match, should be the most specific.
 507
 508 \begin{code}
 509 lookupMEnv :: (key {- template -} ->    -- Matching function
 510                key {- instance -} ->
 511                Maybe match_info)
 512            -> MatchEnv key value        -- The envt
 513            -> key                       -- Key
 514            -> Maybe (key,               -- Template
 515                      match_info,        -- Match info returned by matching fn
 516                      value)             -- Value
 517
 518 lookupMEnv key_match alist key
 519   = find alist
 520   where
 521     find [] = Nothing
 522     find ((tpl, val) : rest)
 523       = case key_match tpl key of
 524           Nothing         -> find rest
 525           Just match_info -> Just (tpl, match_info, val)
 526 \end{code}
 527
 528 @matchEnv@ returns all more specidfic matches in a @MatchEnv@,
 529 most specific first.
 530
 531 \begin{code}
 532 matchMEnv :: (key {- template -} ->     -- Matching function
 533               key {- instance -} ->
 534               Maybe match_info)
 535           -> MatchEnv key value         -- The envt
 536           -> key                        -- Key
 537           -> [(key,
 538                match_info,              -- Match info returned by matching fn
 539                value)]                  -- Value
 540
 541 matchMEnv key_match alist key
 542   = match alist
 543   where
 544     match [] = []
 545     match ((tpl, val) : rest)
 546       = case key_match tpl key of
 547           Nothing -> case key_match key tpl of
 548                        Nothing         -> match rest
 549                        Just match_info -> (tpl, match_info, val) : match rest
 550           Just _  -> []
 551 \end{code}
 552
 553 @insertMEnv@ extends a match environment, checking for overlaps.
 554
 555 \begin{code}
 556 insertMEnv :: (key {- template -} ->            -- Matching function
 557                key {- instance -} ->
 558                Maybe match_info)
 559            -> MatchEnv key value                -- Envt
 560            -> key -> value                      -- New item
 561            -> MaybeErr (MatchEnv key value)     -- Success...
 562                        (key, value)             -- Failure: Offending overlap
 563
 564 insertMEnv match_fn alist key value
 565   = insert alist
 566   where
 567     -- insert has to put the new item in BEFORE any keys which are
 568     -- LESS SPECIFIC than the new key, and AFTER any keys which are
 569     -- MORE SPECIFIC The list is maintained in specific-ness order, so
 570     -- we just stick it in either last, or just before the first key
 571     -- of which the new key is an instance.  We check for overlap at
 572     -- that point.
 573
 574     insert [] = returnMaB [(key, value)]
 575     insert ((t,v) : rest)
 576       = case (match_fn t key) of
 577           Nothing ->
 578             -- New key is not an instance of this existing one, so
 579             -- continue down the list.
 580             insert rest                 `thenMaB` (\ rest' ->
 581             returnMaB ((t,v):rest') )
 582
 583           Just match_info ->
 584             -- New key *is* an instance of the old one, so check the
 585             -- other way round in case of identity.
 586
 587             case (match_fn key t) of
 588               Just _  -> failMaB (t,v)
 589                          -- Oops; overlap
 590
 591               Nothing -> returnMaB ((key,value):(t,v):rest)
 592                          -- All ok; insert here
 593 \end{code}