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