Inst.hs 31.5 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,
16
       newWanted, newWanteds,
17

18
       tcInstBinders, tcInstBinder,
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
import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
36
import {-# SOURCE #-}   TcUnify( unifyType, unifyKind )
37

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

69
import Control.Monad( unless )
70

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

79
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId)
80 81 82
-- Used when Name is the wired-in name for a wired-in class method,
-- so the caller knows its type for sure, which should be of form
--    forall a. C a => <blah>
83
-- newMethodFromName is supposed to instantiate just the outer
84 85 86 87
-- type variable and constraint

newMethodFromName origin name inst_ty
  = do { id <- tcLookupId name
88 89 90 91
              -- 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.
92

93 94 95 96
       ; let ty = piResultTy (idType id) inst_ty
             (theta, _caller_knows_this) = tcSplitPhiTy ty
       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
                 instCall origin [inst_ty] theta
97

98
       ; return (mkHsWrap wrap (HsVar (noLoc id))) }
99

Austin Seipp's avatar
Austin Seipp committed
100 101 102
{-
************************************************************************
*                                                                      *
103
        Deep instantiation and skolemisation
Austin Seipp's avatar
Austin Seipp committed
104 105
*                                                                      *
************************************************************************
106

107 108 109 110
Note [Deep skolemisation]
~~~~~~~~~~~~~~~~~~~~~~~~~
deeplySkolemise decomposes and skolemises a type, returning a type
with all its arrows visible (ie not buried under foralls)
111

112
Examples:
113

114
  deeplySkolemise (Int -> forall a. Ord a => blah)
115 116
    =  ( wp, [a], [d:Ord a], Int -> blah )
    where wp = \x:Int. /\a. \(d:Ord a). <hole> x
117

118
  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
119 120
    =  ( 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
121

122 123 124 125 126
In general,
  if      deeplySkolemise ty = (wrap, tvs, evs, rho)
    and   e :: rho
  then    wrap e :: ty
    and   'wrap' binds tvs, evs
127

128 129 130
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
131
-}
132

133 134 135 136 137
deeplySkolemise :: TcSigmaType
                -> TcM ( HsWrapper
                       , [(Name,TyVar)]     -- All skolemised variables
                       , [EvVar]            -- All "given"s
                       , TcRhoType )
138

139
deeplySkolemise ty
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
  = 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
                    , mkFunTys arg_tys' rho ) }

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

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
165 166 167 168 169
-- | 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
170
-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
171 172
topInstantiate = top_instantiate True

173
-- | Instantiate all outer 'Inferred' binders
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
174 175 176 177 178 179 180 181 182
-- 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

183
top_instantiate :: Bool   -- True  <=> instantiate *all* variables
184
                          -- False <=> instantiate only the inferred ones
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
185 186 187 188 189 190 191
                -> 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)
192 193
             in_scope    = mkInScopeSet (tyCoVarsOfType ty)
             empty_subst = mkEmptyTCvSubst in_scope
Simon Peyton Jones's avatar
Simon Peyton Jones committed
194
             inst_tvs    = binderVars inst_bndrs
195 196 197 198
       ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
       ; let inst_theta' = substTheta subst inst_theta
             sigma'      = substTy subst (mkForAllTys leave_bndrs $
                                          mkFunTys leave_theta rho)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
199 200 201 202 203 204

       ; wrap1 <- instCall orig (mkTyVarTys inst_tvs') inst_theta'
       ; traceTc "Instantiating"
                 (vcat [ text "all tyvars?" <+> ppr inst_all
                       , text "origin" <+> pprCtOrigin orig
                       , text "type" <+> ppr ty
205 206
                       , text "theta" <+> ppr theta
                       , text "leave_bndrs" <+> ppr leave_bndrs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
                       , text "with" <+> ppr inst_tvs'
                       , 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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
223
    (binders, phi) = tcSplitForAllTyVarBndrs ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
224 225 226 227
    (theta, rho)   = tcSplitPhiTy phi

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

230 231 232 233 234 235
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
236
-- That is, wrap :: ty ~> rho
237 238 239 240
--
-- 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.
241

242 243 244 245 246 247 248 249 250 251 252 253 254
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
255
  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
256 257 258
  = do { (subst', tvs') <- newMetaTyVarsX subst tvs
       ; ids1  <- newSysLocalIds (fsLit "di") (substTys subst' arg_tys)
       ; let theta' = substTheta subst' theta
259
       ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
260 261 262 263
       ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
                                                , text "type" <+> ppr ty
                                                , text "with" <+> ppr tvs'
                                                , text "args:" <+> ppr ids1
264
                                                , text "theta:" <+>  ppr theta'
265 266
                                                , text "subst:" <+> ppr subst'])
       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
267
       ; return (mkWpLams ids1
268
                    <.> wrap2
269
                    <.> wrap1
270 271
                    <.> mkWpEvVarApps ids1,
                 mkFunTys arg_tys rho2) }
272

273 274 275 276 277 278 279 280
  | 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
281

Austin Seipp's avatar
Austin Seipp committed
282 283 284
{-
************************************************************************
*                                                                      *
285
            Instantiating a call
Austin Seipp's avatar
Austin Seipp committed
286 287
*                                                                      *
************************************************************************
288 289 290 291 292 293 294 295 296 297

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
298
-}
299

300
----------------
301
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
302
-- Instantiate the constraints of a call
303
--      (instCall o tys theta)
304 305
-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
-- (b) Throws these dictionaries into the LIE
306
-- (c) Returns an HsWrapper ([.] tys dicts)
307

308 309 310
instCall orig tys theta
  = do  { dict_app <- instCallConstraints orig theta
        ; return (dict_app <.> mkWpTyApps tys) }
311 312

----------------
313
instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
314 315
-- Instantiates the TcTheta, puts all constraints thereby generated
-- into the LIE, and returns a HsWrapper to enclose the call site.
316

317
instCallConstraints orig preds
318
  | null preds
319
  = return idHsWrapper
batterseapower's avatar
batterseapower committed
320
  | otherwise
Simon Peyton Jones's avatar
Simon Peyton Jones committed
321 322
  = do { evs <- mapM go preds
       ; traceTc "instCallConstraints" (ppr evs)
323 324
       ; return (mkWpEvApps evs) }
  where
325
    go pred
326
     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
327
     = do  { co <- unifyType Nothing ty1 ty2
328
           ; return (EvCoercion co) }
329 330 331 332

       -- Try short-cut #2
     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
     , tc `hasKey` heqTyConKey
333
     = do { co <- unifyType Nothing ty1 ty2
334 335
          ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) }

336
     | otherwise
337
     = emitWanted orig pred
338

339 340 341
instDFunType :: DFunId -> [DFunInstType]
             -> TcM ( [TcType]      -- instantiated argument types
                    , TcThetaType ) -- instantiated constraint
342 343
-- See Note [DFunInstType: instantiating types] in InstEnv
instDFunType dfun_id dfun_inst_tys
344
  = do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys
345
       ; return (inst_tys, substTheta subst dfun_theta) }
346 347 348
  where
    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)

349
    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
350 351
    go subst [] [] = return (subst, [])
    go subst (tv:tvs) (Just ty : mb_tys)
352 353 354
      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
                                 tvs
                                 mb_tys
355 356
           ; return (subst', ty : tys) }
    go subst (tv:tvs) (Nothing : mb_tys)
357
      = do { (subst', tv') <- newMetaTyVarX subst tv
358 359 360 361
           ; (subst'', tys) <- go subst' tvs mb_tys
           ; return (subst'', mkTyVarTy tv' : tys) }
    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)

362 363 364 365 366
----------------
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
367 368
  = do  { _co <- instCallConstraints orig theta -- Discard the coercion
        ; return () }
369

370 371 372 373 374 375 376 377 378 379 380 381 382
{-
************************************************************************
*                                                                      *
         Instantiating Kinds
*                                                                      *
************************************************************************

-}

---------------------------
-- | This is used to instantiate binders when type-checking *types* only.
-- The @VarEnv Kind@ gives some known instantiations.
-- See also Note [Bidirectional type checking]
383
tcInstBinders :: TCvSubst -> Maybe (VarEnv Kind)
384
               -> [TyBinder] -> TcM (TCvSubst, [TcType])
385 386
tcInstBinders subst mb_kind_info bndrs
  = do { (subst, args) <- mapAccumLM (tcInstBinder mb_kind_info) subst bndrs
387 388 389 390 391 392
       ; traceTc "instantiating tybinders:"
           (vcat $ zipWith (\bndr arg -> ppr bndr <+> text ":=" <+> ppr arg)
                           bndrs args)
       ; return (subst, args) }

-- | Used only in *types*
393
tcInstBinder :: Maybe (VarEnv Kind)
394
              -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
395
tcInstBinder mb_kind_info subst (Named (TvBndr tv _))
396 397 398 399
  = case lookup_tv tv of
      Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)
      Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
                    ; return (subst', mkTyVarTy tv') }
Simon Peyton Jones's avatar
Simon Peyton Jones committed
400 401 402 403
  where
    lookup_tv tv = do { env <- mb_kind_info   -- `Maybe` monad
                      ; lookupVarEnv env tv }

404

405
tcInstBinder _ subst (Anon ty)
406 407 408
     -- This is the *only* constraint currently handled in types.
  | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty
  = do { let origin = TypeEqOrigin { uo_actual   = k1
409
                                   , uo_expected = k2
410 411
                                   , uo_thing    = Nothing }
       ; co <- case role of
412
                 Nominal          -> unifyKind Nothing k1 k2
413
                 Representational -> emitWantedEq origin KindLevel role k1 k2
414
                 Phantom          -> pprPanic "tcInstBinder Phantom" (ppr ty)
415 416 417 418 419 420 421 422 423 424 425 426 427 428
       ; arg' <- mk co k1 k2
       ; return (subst, arg') }

  | isPredTy substed_ty
  = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty
       ; addErrTcM (env, text "Illegal constraint in a type:" <+> ppr tidy_ty)

         -- just invent a new variable so that we can continue
       ; u <- newUnique
       ; let name = mkSysTvName u (fsLit "dict")
       ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) }


  | otherwise
Simon Peyton Jones's avatar
Simon Peyton Jones committed
429 430
  = do { tv_ty <- newFlexiTyVarTy substed_ty
       ; return (subst, tv_ty) }
431 432

  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
433
    substed_ty = substTy subst ty
434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481

      -- handle boxed equality constraints, because it's so easy
    get_pred_tys_maybe ty
      | Just (r, k1, k2) <- getEqPredTys_maybe ty
      = Just (\co _ _ -> return $ mkCoercionTy co, r, k1, k2)
      | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
      = if | tc `hasKey` heqTyConKey
             -> Just (mkHEqBoxTy, Nominal, k1, k2)
           | otherwise
             -> Nothing
      | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
      = if | tc `hasKey` eqTyConKey
             -> Just (mkEqBoxTy, Nominal, k1, k2)
           | tc `hasKey` coercibleTyConKey
             -> Just (mkCoercibleBoxTy, Representational, k1, k2)
           | otherwise
             -> Nothing
      | otherwise
      = Nothing

-------------------------------
-- | 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]
  where k1 = typeKind ty1
        k2 = typeKind ty2

-- | This takes @a ~# b@ and returns @a ~ b@.
mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkEqBoxTy co ty1 ty2
  = do { eq_tc <- tcLookupTyCon eqTyConName
       ; let [datacon] = tyConDataCons eq_tc
       ; hetero <- mkHEqBoxTy co ty1 ty2
       ; return $ mkTyConApp (promoteDataCon datacon) [k, ty1, ty2, hetero] }
  where k = typeKind ty1

-- | This takes @a ~R# b@ and returns @Coercible a b@.
mkCoercibleBoxTy :: TcCoercion -> Type -> Type -> TcM Type
-- monadic just for convenience with mkEqBoxTy
mkCoercibleBoxTy co ty1 ty2
  = do { return $
         mkTyConApp (promoteDataCon coercibleDataCon)
                    [k, ty1, ty2, mkCoercionTy co] }
  where k = typeKind ty1

Austin Seipp's avatar
Austin Seipp committed
482 483 484
{-
************************************************************************
*                                                                      *
485
                Literals
Austin Seipp's avatar
Austin Seipp committed
486 487
*                                                                      *
************************************************************************
488

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
489 490 491
-}

{-
492 493 494 495
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).
496

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
497
-}
498

499
newOverloadedLit :: HsOverLit GhcRn
500
                 -> ExpRhoType
501
                 -> TcM (HsOverLit GhcTcId)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
502
newOverloadedLit
503
  lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty
504
  | not rebindable
505 506 507
    -- 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
508
       ; dflags <- getDynFlags
509
       ; case shortCutLit dflags val res_ty of
510 511 512 513
        -- 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
514 515 516 517
           Just expr -> return (lit { ol_witness = expr, ol_type = res_ty
                                    , ol_rebindable = False })
           Nothing   -> newNonTrivialOverloadedLit orig lit
                                                   (mkCheckExpType res_ty) }
518

519
  | otherwise
520
  = newNonTrivialOverloadedLit orig lit res_ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
521 522 523 524 525 526
  where
    orig = LiteralOrigin lit

-- Does not handle things that 'shortCutLit' can handle. See also
-- newOverloadedLit in TcUnify
newNonTrivialOverloadedLit :: CtOrigin
527
                           -> HsOverLit GhcRn
528
                           -> ExpRhoType
529
                           -> TcM (HsOverLit GhcTcId)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
530
newNonTrivialOverloadedLit orig
531
  lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ meth_name)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
532
               , ol_rebindable = rebindable }) res_ty
533 534
  = do  { hs_lit <- mkOverLit val
        ; let lit_ty = hsLitType hs_lit
535 536 537 538 539 540 541 542 543 544
        ; (_, 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
                      , ol_type = res_ty
                      , ol_rebindable = rebindable }) }
newNonTrivialOverloadedLit _ lit _
  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
545 546

------------
547
mkOverLit ::(HasDefaultX p, SourceTextX p) => OverLitVal -> TcM (HsLit p)
548
mkOverLit (HsIntegral i)
549
  = do  { integer_ty <- tcMetaTy integerTyConName
550 551
        ; return (HsInteger (setSourceText $ il_text i)
                            (il_value i) integer_ty) }
552 553

mkOverLit (HsFractional r)
554
  = do  { rat_ty <- tcMetaTy rationalTyConName
555
        ; return (HsRat def r rat_ty) }
Ian Lynagh's avatar
Ian Lynagh committed
556

557
mkOverLit (HsIsString src s) = return (HsString (setSourceText src) s)
558

Austin Seipp's avatar
Austin Seipp committed
559 560 561
{-
************************************************************************
*                                                                      *
562 563
                Re-mappable syntax

564
     Used only for arrow syntax -- find a way to nuke this
Austin Seipp's avatar
Austin Seipp committed
565 566
*                                                                      *
************************************************************************
567

568
Suppose we are doing the -XRebindableSyntax thing, and we encounter
569 570 571 572
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:
573

574
  (>>) :: HB m n mn => m a -> n b -> mn b
575

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

578 579 580 581
        let then72 :: forall a b. m a -> m b -> m b
            then72 = ...something involving the user's (>>)...
        in
        ...the do-expression...
582 583 584

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

586
In fact tcSyntaxName just generates the RHS for then72, because we only
587
want an actual binding in the do-expression case. For literals, we can
588
just use the expression inline.
Austin Seipp's avatar
Austin Seipp committed
589
-}
590

591
tcSyntaxName :: CtOrigin
592 593 594 595
             -> TcType                 -- ^ Type to instantiate it at
             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)
             -> TcM (Name, HsExpr GhcTcId)
                                       -- ^ (Standard name, suitable expression)
596 597
-- USED ONLY FOR CmdTop (sigh) ***
-- See Note [CmdSyntaxTable] in HsExpr
598

599
tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))
600 601 602
  | std_nm == user_nm
  = do rhs <- newMethodFromName orig std_nm ty
       return (std_nm, rhs)
603

604 605
tcSyntaxName orig ty (std_nm, user_nm_expr) = do
    std_id <- tcLookupId std_nm
606 607
    let
        -- C.f. newMethodAtLoc
608 609
        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
        sigma1         = substTyWith [tv] [ty] tau
610 611
        -- Actually, the "tau-type" might be a sigma-type in the
        -- case of locally-polymorphic methods.
612 613 614

    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do

615 616 617
        -- Check that the user-supplied thing has the
        -- same type as the standard one.
        -- Tiresome jiggling because tcCheckSigma takes a located expression
618 619 620
     span <- getSrcSpanM
     expr <- tcPolyExpr (L span user_nm_expr) sigma1
     return (std_nm, unLoc expr)
621

622
syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
623
               -> TcRn (TidyEnv, SDoc)
624
syntaxNameCtxt name orig ty tidy_env
625
  = do { inst_loc <- getCtLocM orig (Just TypeLevel)
626 627 628
       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
                          <+> text "(needed by a syntactic construct)"
                        , nest 2 (text "has the required type:"
629
                                  <+> ppr (tidyType tidy_env ty))
630
                        , nest 2 (pprCtLoc inst_loc) ]
631
       ; return (tidy_env, msg) }
632

Austin Seipp's avatar
Austin Seipp committed
633 634 635
{-
************************************************************************
*                                                                      *
636
                Instances
Austin Seipp's avatar
Austin Seipp committed
637 638 639
*                                                                      *
************************************************************************
-}
640

641
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
Simon Peyton Jones's avatar
Simon Peyton Jones committed
642 643 644
-- Construct the OverlapFlag from the global module flags,
-- but if the overlap_mode argument is (Just m),
--     set the OverlapMode to 'm'
645
getOverlapFlag overlap_mode
646
  = do  { dflags <- getDynFlags
647 648
        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags
              incoherent_ok = xopt LangExt.IncoherentInstances  dflags
649 650
              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
                                  , overlapMode   = x }
Alan Zimmerman's avatar
Alan Zimmerman committed
651 652 653
              default_oflag | incoherent_ok = use (Incoherent NoSourceText)
                            | overlap_ok    = use (Overlaps NoSourceText)
                            | otherwise     = use (NoOverlap NoSourceText)
654

655 656
              final_oflag = setOverlapModeMaybe default_oflag overlap_mode
        ; return final_oflag }
657

658 659 660 661
tcGetInsts :: TcM [ClsInst]
-- Gets the local class instances.
tcGetInsts = fmap tcg_insts getGblEnv

662 663 664 665 666 667
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
668 669 670 671 672 673 674 675 676
       ; 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

677
       ; oflag <- getOverlapFlag overlap_mode
678
       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
679 680 681
       ; warnIfFlag Opt_WarnOrphans
                    (isOrphan (is_orphan inst))
                    (instOrphWarn inst)
682 683 684 685
       ; return inst }

instOrphWarn :: ClsInst -> SDoc
instOrphWarn inst
686
  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
687 688 689 690 691 692 693
    $$ 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." :
      []
694

695
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
696 697 698 699
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
700 701 702 703
      ; (inst_env', cls_insts') <- foldlM addLocalInst
                                          (tcg_inst_env env, tcg_insts env)
                                          dfuns
      ; let env' = env { tcg_insts    = cls_insts'
704
                       , tcg_inst_env = inst_env' }
705
      ; setGblEnv env' thing_inside }
706

707 708
addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
-- Check that the proposed new instance is OK,
709
-- and then add it to the home inst env
710
-- If overwrite_inst, then we can overwrite a direct match
711
addLocalInst (home_ie, my_insts) ispec
712 713 714
   = do {
             -- Load imported instances, so that we report
             -- duplicates correctly
715 716 717 718 719 720

             -- '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
721
         ; tcg_env <- getGblEnv
722 723 724 725 726 727 728

           -- 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
729

Edward Z. Yang's avatar
Edward Z. Yang committed
730
               global_ie = eps_inst_env eps
731 732 733 734 735 736 737 738
               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
739

740
             -- Check for duplicate instance decls.
741 742 743
         ; let (_tvs, cls, tys) = instanceHead ispec
               (matches, _, _)  = lookupInstEnv False inst_envs cls tys
               dups             = filter (identicalClsInstHead ispec) (map fst matches)
744 745 746
         ; unless (null dups) $
           dupInstErr ispec (head dups)

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

Austin Seipp's avatar
Austin Seipp committed
749
{-
Simon Peyton Jones's avatar
Simon Peyton Jones committed
750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781
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
782

Simon Peyton Jones's avatar
Simon Peyton Jones committed
783 784 785 786
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):
787

Simon Peyton Jones's avatar
Simon Peyton Jones committed
788 789 790 791 792 793 794
 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
795 796
************************************************************************
*                                                                      *
Simon Peyton Jones's avatar
Simon Peyton Jones committed
797
        Errors and tracing
Austin Seipp's avatar
Austin Seipp committed
798 799 800
*                                                                      *
************************************************************************
-}
Simon Peyton Jones's avatar
Simon Peyton Jones committed
801

802
traceDFuns :: [ClsInst] -> TcRn ()
803
traceDFuns ispecs
804
  = traceTc "Adding instances:" (vcat (map pp ispecs))
805
  where
806 807
    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
                  2 (ppr ispec)
808
        -- Print the dfun name itself too
809

810
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
811
funDepErr ispec ispecs
812
  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
813 814
                    (ispec : ispecs)

815
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
816
dupInstErr ispec dup_ispec
817
  = addClsInstsErr (text "Duplicate instance declarations:")
818
                    [ispec, dup_ispec]
819 820 821 822 823 824 825 826 827 828

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