Inst.hs 31.8 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1 2 3 4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5 6

The @Inst@ type: dictionaries or method instances
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
9
{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}
10
{-# LANGUAGE FlexibleContexts #-}
11 12

module Inst (
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
13 14
       deeplySkolemise,
       topInstantiate, topInstantiateInferred, deeplyInstantiate,
15
       instCall, instDFunType, instStupidTheta, instTyVarsWith,
16
       newWanted, newWanteds,
17

Simon Peyton Jones's avatar
Simon Peyton Jones committed
18
       tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
19

20
       newOverloadedLit, mkOverLit,
21

22
       newClsInst,
23
       tcGetInsts, tcGetInstEnvs, getOverlapFlag,
Adam Gundry's avatar
Adam Gundry committed
24 25
       tcExtendLocalInstEnv,
       instCallConstraints, newMethodFromName,
26 27 28
       tcSyntaxName,

       -- Simple functions over evidence variables
29 30
       tyCoVarsOfWC,
       tyCoVarsOfCt, tyCoVarsOfCts,
31 32
    ) where

33
#include "HsVersions.h"
34

35 36
import GhcPrelude

37
import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
38
import {-# SOURCE #-}   TcUnify( unifyType, unifyKind )
39

40
import BasicTypes ( IntegralLit(..), SourceText(..) )
41
import FastString
Simon Marlow's avatar
Simon Marlow committed
42 43
import HsSyn
import TcHsSyn
44
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
45
import TcEnv
46
import TcEvidence
Simon Marlow's avatar
Simon Marlow committed
47
import InstEnv
48
import TysWiredIn  ( heqDataCon, eqDataCon )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
49
import CoreSyn     ( isOrphan )
Simon Marlow's avatar
Simon Marlow committed
50 51
import FunDeps
import TcMType
batterseapower's avatar
batterseapower committed
52
import Type
53
import TyCoRep
Simon Marlow's avatar
Simon Marlow committed
54 55
import TcType
import HscTypes
56 57
import Class( Class )
import MkId( mkDictFunId )
58
import CoreSyn( Expr(..) )  -- For the Coercion constructor
Simon Marlow's avatar
Simon Marlow committed
59 60
import Id
import Name
Simon Peyton Jones's avatar
Simon Peyton Jones committed
61
import Var      ( EvVar, tyVarName, VarBndr(..) )
62
import DataCon
Simon Marlow's avatar
Simon Marlow committed
63 64 65 66
import VarEnv
import PrelNames
import SrcLoc
import DynFlags
67
import Util
68
import Outputable
69 70
import qualified GHC.LanguageExtensions as LangExt

71
import Control.Monad( unless )
72

Austin Seipp's avatar
Austin Seipp committed
73 74 75
{-
************************************************************************
*                                                                      *
76
                Creating and emittind constraints
Austin Seipp's avatar
Austin Seipp committed
77 78 79
*                                                                      *
************************************************************************
-}
80

81 82 83 84 85 86
newMethodFromName
  :: CtOrigin              -- ^ why do we need this?
  -> Name                  -- ^ name of the method
  -> [TcRhoType]           -- ^ types with which to instantiate the class
  -> TcM (HsExpr GhcTcId)
-- ^ Used when 'Name' is the wired-in name for a wired-in class method,
87
-- so the caller knows its type for sure, which should be of form
88 89 90 91
--
-- > forall a. C a => <blah>
--
-- 'newMethodFromName' is supposed to instantiate just the outer
92 93
-- type variable and constraint

94
newMethodFromName origin name ty_args
95
  = do { id <- tcLookupId name
96 97 98 99
              -- Use tcLookupId not tcLookupGlobalId; the method is almost
              -- always a class op, but with -XRebindableSyntax GHC is
              -- meant to find whatever thing is in scope, and that may
              -- be an ordinary function.
100

101
       ; let ty = piResultTys (idType id) ty_args
102 103
             (theta, _caller_knows_this) = tcSplitPhiTy ty
       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
104
                 instCall origin ty_args theta
105

106
       ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
107

Austin Seipp's avatar
Austin Seipp committed
108 109 110
{-
************************************************************************
*                                                                      *
111
        Deep instantiation and skolemisation
Austin Seipp's avatar
Austin Seipp committed
112 113
*                                                                      *
************************************************************************
114

115 116 117 118
Note [Deep skolemisation]
~~~~~~~~~~~~~~~~~~~~~~~~~
deeplySkolemise decomposes and skolemises a type, returning a type
with all its arrows visible (ie not buried under foralls)
119

120
Examples:
121

122
  deeplySkolemise (Int -> forall a. Ord a => blah)
123 124
    =  ( wp, [a], [d:Ord a], Int -> blah )
    where wp = \x:Int. /\a. \(d:Ord a). <hole> x
125

126
  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
127 128
    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
129

130 131 132 133 134
In general,
  if      deeplySkolemise ty = (wrap, tvs, evs, rho)
    and   e :: rho
  then    wrap e :: ty
    and   'wrap' binds tvs, evs
135

136 137 138
ToDo: this eta-abstraction plays fast and loose with termination,
      because it can introduce extra lambdas.  Maybe add a `seq` to
      fix this
Austin Seipp's avatar
Austin Seipp committed
139
-}
140

141 142 143 144 145
deeplySkolemise :: TcSigmaType
                -> TcM ( HsWrapper
                       , [(Name,TyVar)]     -- All skolemised variables
                       , [EvVar]            -- All "given"s
                       , TcRhoType )
146

147
deeplySkolemise ty
148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
  = go init_subst ty
  where
    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))

    go subst ty
      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
      = do { let arg_tys' = substTys subst arg_tys
           ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'
           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs
           ; ev_vars1       <- newEvVars (substTheta subst' theta)
           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
           ; let tv_prs1 = map tyVarName tvs `zip` tvs1
           ; return ( mkWpLams ids1
                      <.> mkWpTyLams tvs1
                      <.> mkWpLams ev_vars1
                      <.> wrap
                      <.> mkWpEvVarApps ids1
                    , tv_prs1  ++ tvs_prs2
                    , ev_vars1 ++ ev_vars2
Simon Peyton Jones's avatar
Simon Peyton Jones committed
167
                    , mkVisFunTys arg_tys' rho ) }
168 169 170 171

      | otherwise
      = return (idHsWrapper, [], [], substTy subst ty)
        -- substTy is a quick no-op on an empty substitution
172

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
173 174 175 176 177
-- | Instantiate all outer type variables
-- and any context. Never looks through arrows.
topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- if    topInstantiate ty = (wrap, rho)
-- and   e :: ty
178
-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
179 180
topInstantiate = top_instantiate True

181
-- | Instantiate all outer 'Inferred' binders
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
182 183 184 185 186 187 188 189 190
-- and any context. Never looks through arrows or specified type variables.
-- Used for visible type application.
topInstantiateInferred :: CtOrigin -> TcSigmaType
                       -> TcM (HsWrapper, TcSigmaType)
-- if    topInstantiate ty = (wrap, rho)
-- and   e :: ty
-- then  wrap e :: rho
topInstantiateInferred = top_instantiate False

191
top_instantiate :: Bool   -- True  <=> instantiate *all* variables
192
                          -- False <=> instantiate only the inferred ones
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
193 194 195 196 197 198 199
                -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
top_instantiate inst_all orig ty
  | not (null binders && null theta)
  = do { let (inst_bndrs, leave_bndrs) = span should_inst binders
             (inst_theta, leave_theta)
               | null leave_bndrs = (theta, [])
               | otherwise        = ([], theta)
200 201
             in_scope    = mkInScopeSet (tyCoVarsOfType ty)
             empty_subst = mkEmptyTCvSubst in_scope
Simon Peyton Jones's avatar
Simon Peyton Jones committed
202
             inst_tvs    = binderVars inst_bndrs
203 204 205
       ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
       ; let inst_theta' = substTheta subst inst_theta
             sigma'      = substTy subst (mkForAllTys leave_bndrs $
Simon Peyton Jones's avatar
Simon Peyton Jones committed
206
                                          mkPhiTy leave_theta rho)
207
             inst_tv_tys' = mkTyVarTys inst_tvs'
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
208

209
       ; wrap1 <- instCall orig inst_tv_tys' inst_theta'
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
210 211 212
       ; traceTc "Instantiating"
                 (vcat [ text "all tyvars?" <+> ppr inst_all
                       , text "origin" <+> pprCtOrigin orig
213
                       , text "type" <+> debugPprType ty
214 215
                       , text "theta" <+> ppr theta
                       , text "leave_bndrs" <+> ppr leave_bndrs
216
                       , text "with" <+> vcat (map debugPprType inst_tv_tys')
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
217 218 219 220 221 222 223 224 225 226 227 228 229 230 231
                       , text "theta:" <+>  ppr inst_theta' ])

       ; (wrap2, rho2) <-
           if null leave_bndrs

         -- account for types like forall a. Num a => forall b. Ord b => ...
           then top_instantiate inst_all orig sigma'

         -- but don't loop if there were any un-inst'able tyvars
           else return (idHsWrapper, sigma')

       ; return (wrap2 <.> wrap1, rho2) }

  | otherwise = return (idHsWrapper, ty)
  where
Ningning Xie's avatar
Ningning Xie committed
232
    (binders, phi) = tcSplitForAllVarBndrs ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
233 234 235 236
    (theta, rho)   = tcSplitPhiTy phi

    should_inst bndr
      | inst_all  = True
237
      | otherwise = binderArgFlag bndr == Inferred
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
238

239 240 241 242 243 244
deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
--   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha
-- In general if
-- if    deeplyInstantiate ty = (wrap, rho)
-- and   e :: ty
-- then  wrap e :: rho
245
-- That is, wrap :: ty ~> rho
246 247 248 249
--
-- If you don't need the HsWrapper returned from this function, consider
-- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that
-- only computes the returned TcRhoType.
250

251 252 253 254 255 256 257 258 259 260 261 262 263
deeplyInstantiate orig ty =
  deeply_instantiate orig
                     (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))
                     ty

deeply_instantiate :: CtOrigin
                   -> TCvSubst
                   -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
-- Internal function to deeply instantiate that builds on an existing subst.
-- It extends the input substitution and applies the final subtitution to
-- the types on return.  See #12549.

deeply_instantiate orig subst ty
264
  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
265
  = do { (subst', tvs') <- newMetaTyVarsX subst tvs
266 267 268
       ; let arg_tys' = substTys   subst' arg_tys
             theta'   = substTheta subst' theta
       ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'
269
       ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
270 271 272 273
       ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
                                                , text "type" <+> ppr ty
                                                , text "with" <+> ppr tvs'
                                                , text "args:" <+> ppr ids1
274
                                                , text "theta:" <+>  ppr theta'
275 276
                                                , text "subst:" <+> ppr subst'])
       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
277
       ; return (mkWpLams ids1
278
                    <.> wrap2
279
                    <.> wrap1
280
                    <.> mkWpEvVarApps ids1,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
281
                 mkVisFunTys arg_tys' rho2) }
282

283 284 285 286 287 288 289 290
  | otherwise
  = do { let ty' = substTy subst ty
       ; traceTc "deeply_instantiate final subst"
                 (vcat [ text "origin:"   <+> pprCtOrigin orig
                       , text "type:"     <+> ppr ty
                       , text "new type:" <+> ppr ty'
                       , text "subst:"    <+> ppr subst ])
      ; return (idHsWrapper, ty') }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
291

292 293 294 295

instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
-- Use this when you want to instantiate (forall a b c. ty) with
-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
296
-- not yet match (perhaps because there are unsolved constraints; #14154)
297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313
-- If they don't match, emit a kind-equality to promise that they will
-- eventually do so, and thus make a kind-homongeneous substitution.
instTyVarsWith orig tvs tys
  = go empty_subst tvs tys
  where
    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))

    go subst [] []
      = return subst
    go subst (tv:tvs) (ty:tys)
      | tv_kind `tcEqType` ty_kind
      = go (extendTCvSubst subst tv ty) tvs tys
      | otherwise
      = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
           ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }
      where
        tv_kind = substTy subst (tyVarKind tv)
314
        ty_kind = tcTypeKind ty
315 316 317

    go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)

Austin Seipp's avatar
Austin Seipp committed
318 319 320
{-
************************************************************************
*                                                                      *
321
            Instantiating a call
Austin Seipp's avatar
Austin Seipp committed
322 323
*                                                                      *
************************************************************************
324 325 326 327 328 329 330 331 332 333

Note [Handling boxed equality]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The solver deals entirely in terms of unboxed (primitive) equality.
There should never be a boxed Wanted equality. Ever. But, what if
we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
is boxed, so naive treatment here would emit a boxed Wanted equality.

So we simply check for this case and make the right boxing of evidence.

Austin Seipp's avatar
Austin Seipp committed
334
-}
335

336
----------------
337
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
338
-- Instantiate the constraints of a call
339
--      (instCall o tys theta)
340 341
-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
-- (b) Throws these dictionaries into the LIE
342
-- (c) Returns an HsWrapper ([.] tys dicts)
343

344 345 346
instCall orig tys theta
  = do  { dict_app <- instCallConstraints orig theta
        ; return (dict_app <.> mkWpTyApps tys) }
347 348

----------------
349
instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
350 351
-- Instantiates the TcTheta, puts all constraints thereby generated
-- into the LIE, and returns a HsWrapper to enclose the call site.
352

353
instCallConstraints orig preds
354
  | null preds
355
  = return idHsWrapper
batterseapower's avatar
batterseapower committed
356
  | otherwise
Simon Peyton Jones's avatar
Simon Peyton Jones committed
357 358
  = do { evs <- mapM go preds
       ; traceTc "instCallConstraints" (ppr evs)
359 360
       ; return (mkWpEvApps evs) }
  where
361
    go :: TcPredType -> TcM EvTerm
362
    go pred
363
     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
364
     = do  { co <- unifyType Nothing ty1 ty2
365
           ; return (evCoercion co) }
366 367 368 369

       -- Try short-cut #2
     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
     , tc `hasKey` heqTyConKey
370
     = do { co <- unifyType Nothing ty1 ty2
371
          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
372

373
     | otherwise
374
     = emitWanted orig pred
375

376 377 378
instDFunType :: DFunId -> [DFunInstType]
             -> TcM ( [TcType]      -- instantiated argument types
                    , TcThetaType ) -- instantiated constraint
379 380
-- See Note [DFunInstType: instantiating types] in InstEnv
instDFunType dfun_id dfun_inst_tys
381
  = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
382
       ; return (inst_tys, substTheta subst dfun_theta) }
383
  where
384 385 386 387 388
    dfun_ty = idType dfun_id
    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
                  -- With quantified constraints, the
                  -- type of a dfun may not be closed
389

390
    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
391 392
    go subst [] [] = return (subst, [])
    go subst (tv:tvs) (Just ty : mb_tys)
393 394 395
      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
                                 tvs
                                 mb_tys
396 397
           ; return (subst', ty : tys) }
    go subst (tv:tvs) (Nothing : mb_tys)
398
      = do { (subst', tv') <- newMetaTyVarX subst tv
399 400 401 402
           ; (subst'', tys) <- go subst' tvs mb_tys
           ; return (subst'', mkTyVarTy tv' : tys) }
    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)

403 404 405 406 407
----------------
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
-- Similar to instCall, but only emit the constraints in the LIE
-- Used exclusively for the 'stupid theta' of a data constructor
instStupidTheta orig theta
408 409
  = do  { _co <- instCallConstraints orig theta -- Discard the coercion
        ; return () }
410

Simon Peyton Jones's avatar
Simon Peyton Jones committed
411 412

{- *********************************************************************
413 414 415
*                                                                      *
         Instantiating Kinds
*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
416
********************************************************************* -}
417

Simon Peyton Jones's avatar
Simon Peyton Jones committed
418 419 420 421 422 423 424 425
-- | Instantiates up to n invisible binders
-- Returns the instantiating types, and body kind
tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)

tcInstInvisibleTyBinders 0 kind
  = return ([], kind)
tcInstInvisibleTyBinders n ty
  = go n empty_subst ty
426
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
427 428 429 430 431 432 433 434 435 436 437
    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))

    go n subst kind
      | n > 0
      , Just (bndr, body) <- tcSplitPiTy_maybe kind
      , isInvisibleBinder bndr
      = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
           ; (args, inner_ty) <- go (n-1) subst' body
           ; return (arg:args, inner_ty) }
      | otherwise
      = return ([], substTy subst kind)
438 439

-- | Used only in *types*
Simon Peyton Jones's avatar
Simon Peyton Jones committed
440 441 442 443
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
tcInstInvisibleTyBinder subst (Named (Bndr tv _))
  = do { (subst', tv') <- newMetaTyVarX subst tv
       ; return (subst', mkTyVarTy tv') }
444

Simon Peyton Jones's avatar
Simon Peyton Jones committed
445 446 447 448 449 450
tcInstInvisibleTyBinder subst (Anon af ty)
  | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)
    -- Equality is the *only* constraint currently handled in types.
    -- See Note [Constraints in kinds] in TyCoRep
  = ASSERT( af == InvisArg )
    do { co <- unifyKind Nothing k1 k2
451
       ; arg' <- mk co
452 453
       ; return (subst, arg') }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
454 455 456
  | otherwise  -- This should never happen
               -- See TyCoRep Note [Constraints in kinds]
  = pprPanic "tcInvisibleTyBinder" (ppr ty)
457

Simon Peyton Jones's avatar
Simon Peyton Jones committed
458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476
-------------------------------
get_eq_tys_maybe :: Type
                 -> Maybe ( Coercion -> TcM Type
                             -- given a coercion proving t1 ~# t2, produce the
                             -- right instantiation for the TyBinder at hand
                          , Type  -- t1
                          , Type  -- t2
                          )
-- See Note [Constraints in kinds] in TyCoRep
get_eq_tys_maybe ty
  -- Lifted heterogeneous equality (~~)
  | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
  , tc `hasKey` heqTyConKey
  = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)

  -- Lifted homogeneous equality (~)
  | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
  , tc `hasKey` eqTyConKey
  = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
477 478

  | otherwise
Simon Peyton Jones's avatar
Simon Peyton Jones committed
479
  = Nothing
480 481 482 483 484 485 486

-- | This takes @a ~# b@ and returns @a ~~ b@.
mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
-- monadic just for convenience with mkEqBoxTy
mkHEqBoxTy co ty1 ty2
  = return $
    mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
487 488
  where k1 = tcTypeKind ty1
        k2 = tcTypeKind ty2
489 490 491 492

-- | This takes @a ~# b@ and returns @a ~ b@.
mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkEqBoxTy co ty1 ty2
493 494
  = return $
    mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
495
  where k = tcTypeKind ty1
496

Austin Seipp's avatar
Austin Seipp committed
497 498 499
{-
************************************************************************
*                                                                      *
500
                Literals
Austin Seipp's avatar
Austin Seipp committed
501 502
*                                                                      *
************************************************************************
503

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
504 505 506
-}

{-
507 508 509 510
In newOverloadedLit we convert directly to an Int or Integer if we
know that's what we want.  This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).
511

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
512
-}
513

514
newOverloadedLit :: HsOverLit GhcRn
515
                 -> ExpRhoType
516
                 -> TcM (HsOverLit GhcTcId)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
517
newOverloadedLit
518
  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
519
  | not rebindable
520 521 522
    -- all built-in overloaded lits are tau-types, so we can just
    -- tauify the ExpType
  = do { res_ty <- expTypeToType res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
523
       ; dflags <- getDynFlags
524
       ; case shortCutLit dflags val res_ty of
525 526 527 528
        -- Do not generate a LitInst for rebindable syntax.
        -- Reason: If we do, tcSimplify will call lookupInst, which
        --         will call tcSyntaxName, which does unification,
        --         which tcSimplify doesn't like
529 530
           Just expr -> return (lit { ol_witness = expr
                                    , ol_ext = OverLitTc False res_ty })
531 532
           Nothing   -> newNonTrivialOverloadedLit orig lit
                                                   (mkCheckExpType res_ty) }
533

534
  | otherwise
535
  = newNonTrivialOverloadedLit orig lit res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
536 537
  where
    orig = LiteralOrigin lit
538
newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
539 540 541 542

-- Does not handle things that 'shortCutLit' can handle. See also
-- newOverloadedLit in TcUnify
newNonTrivialOverloadedLit :: CtOrigin
543
                           -> HsOverLit GhcRn
544
                           -> ExpRhoType
545
                           -> TcM (HsOverLit GhcTcId)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
546
newNonTrivialOverloadedLit orig
547 548
  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
               , ol_ext = rebindable }) res_ty
549 550
  = do  { hs_lit <- mkOverLit val
        ; let lit_ty = hsLitType hs_lit
551 552 553 554 555 556
        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
                                      [synKnownType lit_ty] res_ty $
                      \_ -> return ()
        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
        ; res_ty <- readExpType res_ty
        ; return (lit { ol_witness = witness
557
                      , ol_ext = OverLitTc rebindable res_ty }) }
558 559
newNonTrivialOverloadedLit _ lit _
  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
560 561

------------
562
mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
563
mkOverLit (HsIntegral i)
564
  = do  { integer_ty <- tcMetaTy integerTyConName
565
        ; return (HsInteger (il_text i)
566
                            (il_value i) integer_ty) }
567 568

mkOverLit (HsFractional r)
569
  = do  { rat_ty <- tcMetaTy rationalTyConName
570
        ; return (HsRat noExt r rat_ty) }
Ian Lynagh's avatar
Ian Lynagh committed
571

572
mkOverLit (HsIsString src s) = return (HsString src s)
573

Austin Seipp's avatar
Austin Seipp committed
574 575 576
{-
************************************************************************
*                                                                      *
577 578
                Re-mappable syntax

579
     Used only for arrow syntax -- find a way to nuke this
Austin Seipp's avatar
Austin Seipp committed
580 581
*                                                                      *
************************************************************************
582

583
Suppose we are doing the -XRebindableSyntax thing, and we encounter
584 585 586 587
a do-expression.  We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
this:
588

589
  (>>) :: HB m n mn => m a -> n b -> mn b
590

591
So the idea is to generate a local binding for (>>), thus:
592

593 594 595 596
        let then72 :: forall a b. m a -> m b -> m b
            then72 = ...something involving the user's (>>)...
        in
        ...the do-expression...
597 598 599

Now the do-expression can proceed using then72, which has exactly
the expected type.
600

601
In fact tcSyntaxName just generates the RHS for then72, because we only
602
want an actual binding in the do-expression case. For literals, we can
603
just use the expression inline.
Austin Seipp's avatar
Austin Seipp committed
604
-}
605

606
tcSyntaxName :: CtOrigin
607 608 609 610
             -> TcType                 -- ^ Type to instantiate it at
             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)
             -> TcM (Name, HsExpr GhcTcId)
                                       -- ^ (Standard name, suitable expression)
611 612
-- USED ONLY FOR CmdTop (sigh) ***
-- See Note [CmdSyntaxTable] in HsExpr
613

614
tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
615
  | std_nm == user_nm
616
  = do rhs <- newMethodFromName orig std_nm [ty]
617
       return (std_nm, rhs)
618

619 620
tcSyntaxName orig ty (std_nm, user_nm_expr) = do
    std_id <- tcLookupId std_nm
621 622
    let
        -- C.f. newMethodAtLoc
623 624
        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
        sigma1         = substTyWith [tv] [ty] tau
625 626
        -- Actually, the "tau-type" might be a sigma-type in the
        -- case of locally-polymorphic methods.
627 628 629

    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do

630 631 632
        -- Check that the user-supplied thing has the
        -- same type as the standard one.
        -- Tiresome jiggling because tcCheckSigma takes a located expression
633 634 635
     span <- getSrcSpanM
     expr <- tcPolyExpr (L span user_nm_expr) sigma1
     return (std_nm, unLoc expr)
636

637
syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
638
               -> TcRn (TidyEnv, SDoc)
639
syntaxNameCtxt name orig ty tidy_env
640
  = do { inst_loc <- getCtLocM orig (Just TypeLevel)
641 642 643
       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
                          <+> text "(needed by a syntactic construct)"
                        , nest 2 (text "has the required type:"
644
                                  <+> ppr (tidyType tidy_env ty))
645
                        , nest 2 (pprCtLoc inst_loc) ]
646
       ; return (tidy_env, msg) }
647

Austin Seipp's avatar
Austin Seipp committed
648 649 650
{-
************************************************************************
*                                                                      *
651
                Instances
Austin Seipp's avatar
Austin Seipp committed
652 653 654
*                                                                      *
************************************************************************
-}
655

656
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
Simon Peyton Jones's avatar
Simon Peyton Jones committed
657 658 659
-- Construct the OverlapFlag from the global module flags,
-- but if the overlap_mode argument is (Just m),
--     set the OverlapMode to 'm'
660
getOverlapFlag overlap_mode
661
  = do  { dflags <- getDynFlags
662 663
        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags
              incoherent_ok = xopt LangExt.IncoherentInstances  dflags
664 665
              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
                                  , overlapMode   = x }
Alan Zimmerman's avatar
Alan Zimmerman committed
666 667 668
              default_oflag | incoherent_ok = use (Incoherent NoSourceText)
                            | overlap_ok    = use (Overlaps NoSourceText)
                            | otherwise     = use (NoOverlap NoSourceText)
669

670 671
              final_oflag = setOverlapModeMaybe default_oflag overlap_mode
        ; return final_oflag }
672

673 674 675 676
tcGetInsts :: TcM [ClsInst]
-- Gets the local class instances.
tcGetInsts = fmap tcg_insts getGblEnv

677 678 679 680 681 682
newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
           -> Class -> [Type] -> TcM ClsInst
newClsInst overlap_mode dfun_name tvs theta clas tys
  = do { (subst, tvs') <- freshenTyVarBndrs tvs
             -- Be sure to freshen those type variables,
             -- so they are sure not to appear in any lookup
683 684 685 686 687 688 689 690 691
       ; let tys' = substTys subst tys

             dfun = mkDictFunId dfun_name tvs theta clas tys
             -- The dfun uses the original 'tvs' because
             -- (a) they don't need to be fresh
             -- (b) they may be mentioned in the ib_binds field of
             --     an InstInfo, and in TcEnv.pprInstInfoDetails it's
             --     helpful to use the same names

692
       ; oflag <- getOverlapFlag overlap_mode
693
       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
694 695 696
       ; warnIfFlag Opt_WarnOrphans
                    (isOrphan (is_orphan inst))
                    (instOrphWarn inst)
697 698 699 700
       ; return inst }

instOrphWarn :: ClsInst -> SDoc
instOrphWarn inst
701
  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
702 703 704 705 706 707 708
    $$ text "To avoid this"
    $$ nest 4 (vcat possibilities)
  where
    possibilities =
      text "move the instance declaration to the module of the class or of the type, or" :
      text "wrap the type with a newtype and declare the instance on the new type." :
      []
709

710
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
711 712 713 714
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
715 716 717 718
      ; (inst_env', cls_insts') <- foldlM addLocalInst
                                          (tcg_inst_env env, tcg_insts env)
                                          dfuns
      ; let env' = env { tcg_insts    = cls_insts'
719
                       , tcg_inst_env = inst_env' }
720
      ; setGblEnv env' thing_inside }
721

722 723
addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
-- Check that the proposed new instance is OK,
724
-- and then add it to the home inst env
725
-- If overwrite_inst, then we can overwrite a direct match
726
addLocalInst (home_ie, my_insts) ispec
727 728 729
   = do {
             -- Load imported instances, so that we report
             -- duplicates correctly
730 731 732 733 734 735

             -- 'matches'  are existing instance declarations that are less
             --            specific than the new one
             -- 'dups'     are those 'matches' that are equal to the new one
         ; isGHCi <- getIsGHCi
         ; eps    <- getEps
736
         ; tcg_env <- getGblEnv
737 738 739 740 741 742 743

           -- In GHCi, we *override* any identical instances
           -- that are also defined in the interactive context
           -- See Note [Override identical instances in GHCi]
         ; let home_ie'
                 | isGHCi    = deleteFromInstEnv home_ie ispec
                 | otherwise = home_ie
744

Edward Z. Yang's avatar
Edward Z. Yang committed
745
               global_ie = eps_inst_env eps
746 747 748 749 750 751 752 753
               inst_envs = InstEnvs { ie_global  = global_ie
                                    , ie_local   = home_ie'
                                    , ie_visible = tcVisibleOrphanMods tcg_env }

             -- Check for inconsistent functional dependencies
         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
         ; unless (null inconsistent_ispecs) $
           funDepErr ispec inconsistent_ispecs
754

755
             -- Check for duplicate instance decls.
756 757 758
         ; let (_tvs, cls, tys) = instanceHead ispec
               (matches, _, _)  = lookupInstEnv False inst_envs cls tys
               dups             = filter (identicalClsInstHead ispec) (map fst matches)
759 760 761
         ; unless (null dups) $
           dupInstErr ispec (head dups)

762
         ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
763

Austin Seipp's avatar
Austin Seipp committed
764
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796
Note [Signature files and type class instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Instances in signature files do not have an effect when compiling:
when you compile a signature against an implementation, you will
see the instances WHETHER OR NOT the instance is declared in
the file (this is because the signatures go in the EPS and we
can't filter them out easily.)  This is also why we cannot
place the instance in the hi file: it would show up as a duplicate,
and we don't have instance reexports anyway.

However, you might find them useful when typechecking against
a signature: the instance is a way of indicating to GHC that
some instance exists, in case downstream code uses it.

Implementing this is a little tricky.  Consider the following
situation (sigof03):

 module A where
     instance C T where ...

 module ASig where
     instance C T

When compiling ASig, A.hi is loaded, which brings its instances
into the EPS.  When we process the instance declaration in ASig,
we should ignore it for the purpose of doing a duplicate check,
since it's not actually a duplicate. But don't skip the check
entirely, we still want this to fail (tcfail221):

 module ASig where
     instance C T
     instance C T
797

Simon Peyton Jones's avatar
Simon Peyton Jones committed
798 799 800 801
Note that in some situations, the interface containing the type
class instances may not have been loaded yet at all.  The usual
situation when A imports another module which provides the
instances (sigof02m):
802

Simon Peyton Jones's avatar
Simon Peyton Jones committed
803 804 805 806 807 808 809
 module A(module B) where
     import B

See also Note [Signature lazy interface loading].  We can't
rely on this, however, since sometimes we'll have spurious
type class instances in the EPS, see #9422 (sigof02dm)

Austin Seipp's avatar
Austin Seipp committed
810 811
************************************************************************
*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
812
        Errors and tracing
Austin Seipp's avatar
Austin Seipp committed
813 814 815
*                                                                      *
************************************************************************
-}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
816

817
traceDFuns :: [ClsInst] -> TcRn ()
818
traceDFuns ispecs
819
  = traceTc "Adding instances:" (vcat (map pp ispecs))
820
  where
821 822
    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
                  2 (ppr ispec)
823
        -- Print the dfun name itself too
824

825
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
826
funDepErr ispec ispecs
827
  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
828 829
                    (ispec : ispecs)

830
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
831
dupInstErr ispec dup_ispec
832
  = addClsInstsErr (text "Duplicate instance declarations:")
833
                    [ispec, dup_ispec]
834 835 836 837 838 839 840 841 842 843

addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr herald ispecs
  = setSrcSpan (getSrcSpan (head sorted)) $
    addErr (hang herald 2 (pprInstances sorted))
 where
   sorted = sortWith getSrcLoc ispecs
   -- The sortWith just arranges that instances are dislayed in order
   -- of source location, which reduced wobbling in error messages,
   -- and is better for users