compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The @Inst@ type: dictionaries or method instances
   7
   8 \begin{code}
   9 module Inst (
  10        deeplySkolemise,
  11        deeplyInstantiate, instCall, instStupidTheta,
  12        emitWanted, emitWanteds,
  13
  14        newOverloadedLit, mkOverLit,
  15
  16        tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv,
  17        instCallConstraints, newMethodFromName,
  18        tcSyntaxName,
  19
  20        -- Simple functions over evidence variables
  21        hasEqualities, unitImplication,
  22
  23        tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX,
  24        tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
  25
  26        tidyWantedEvVar, tidyWantedEvVars, tidyWC,
  27        tidyEvVar, tidyImplication, tidyFlavoredEvVar,
  28
  29        substWantedEvVar, substWantedEvVars, substFlavoredEvVar,
  30        substEvVar, substImplication
  31     ) where
  32
  33 #include "HsVersions.h"
  34
  35 import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
  36 import {-# SOURCE #-}   TcUnify( unifyType )
  37
  38 import FastString
  39 import HsSyn
  40 import TcHsSyn
  41 import TcRnMonad
  42 import TcEnv
  43 import InstEnv
  44 import FunDeps
  45 import TcMType
  46 import TcType
  47 import Class
  48 import Unify
  49 import HscTypes
  50 import Id
  51 import Name
  52 import Var      ( Var, TyVar, EvVar, varType, setVarType )
  53 import VarEnv
  54 import VarSet
  55 import PrelNames
  56 import SrcLoc
  57 import DynFlags
  58 import Bag
  59 import BasicTypes
  60 import Maybes
  61 import Util
  62 import Outputable
  63 import Data.List( mapAccumL )
  64 \end{code}
  65
  66
  67
  68 %************************************************************************
  69 %*                                                                      *
  70                 Emitting constraints
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 \begin{code}
  75 emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
  76 emitWanteds origin theta = mapM (emitWanted origin) theta
  77
  78 emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
  79 emitWanted origin pred = do { loc <- getCtLoc origin
  80                             ; ev  <- newWantedEvVar pred
  81                             ; emitFlat (mkEvVarX ev loc)
  82                             ; return ev }
  83
  84 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
  85 -- Used when Name is the wired-in name for a wired-in class method,
  86 -- so the caller knows its type for sure, which should be of form
  87 --    forall a. C a => <blah>
  88 -- newMethodFromName is supposed to instantiate just the outer
  89 -- type variable and constraint
  90
  91 newMethodFromName origin name inst_ty
  92   = do { id <- tcLookupId name
  93               -- Use tcLookupId not tcLookupGlobalId; the method is almost
  94               -- always a class op, but with -XRebindableSyntax GHC is
  95               -- meant to find whatever thing is in scope, and that may
  96               -- be an ordinary function.
  97
  98        ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id)
  99              (the_tv:rest) = tvs
 100              subst = zipOpenTvSubst [the_tv] [inst_ty]
 101
 102        ; wrap <- ASSERT( null rest && isSingleton theta )
 103                  instCall origin [inst_ty] (substTheta subst theta)
 104        ; return (mkHsWrap wrap (HsVar id)) }
 105 \end{code}
 106
 107
 108 %************************************************************************
 109 %*                                                                      *
 110         Deep instantiation and skolemisation
 111 %*                                                                      *
 112 %************************************************************************
 113
 114 Note [Deep skolemisation]
 115 ~~~~~~~~~~~~~~~~~~~~~~~~~
 116 deeplySkolemise decomposes and skolemises a type, returning a type
 117 with all its arrows visible (ie not buried under foralls)
 118
 119 Examples:
 120
 121   deeplySkolemise (Int -> forall a. Ord a => blah)
 122     =  ( wp, [a], [d:Ord a], Int -> blah )
 123     where wp = \x:Int. /\a. \(d:Ord a). <hole> x
 124
 125   deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
 126     =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
 127     where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
 128
 129 In general,
 130   if      deeplySkolemise ty = (wrap, tvs, evs, rho)
 131     and   e :: rho
 132   then    wrap e :: ty
 133     and   'wrap' binds tvs, evs
 134
 135 ToDo: this eta-abstraction plays fast and loose with termination,
 136       because it can introduce extra lambdas.  Maybe add a `seq` to
 137       fix this
 138
 139
 140 \begin{code}
 141 deeplySkolemise
 142   :: TcSigmaType
 143   -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
 144
 145 deeplySkolemise ty
 146   | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
 147   = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
 148        ; tvs1 <- tcInstSkolTyVars tvs
 149        ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1)
 150        ; ev_vars1 <- newEvVars (substTheta subst theta)
 151        ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
 152        ; return ( mkWpLams ids1
 153                    <.> mkWpTyLams tvs1
 154                    <.> mkWpLams ev_vars1
 155                    <.> wrap
 156                    <.> mkWpEvVarApps ids1
 157                 , tvs1     ++ tvs2
 158                 , ev_vars1 ++ ev_vars2
 159                 , mkFunTys arg_tys rho ) }
 160
 161   | otherwise
 162   = return (idHsWrapper, [], [], ty)
 163
 164 deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
 165 --   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha
 166 -- In general if
 167 -- if    deeplyInstantiate ty = (wrap, rho)
 168 -- and   e :: ty
 169 -- then  wrap e :: rho
 170
 171 deeplyInstantiate orig ty
 172   | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
 173   = do { (_, tys, subst) <- tcInstTyVars tvs
 174        ; ids1  <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
 175        ; wrap1 <- instCall orig tys (substTheta subst theta)
 176        ; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho)
 177        ; return (mkWpLams ids1
 178                     <.> wrap2
 179                     <.> wrap1
 180                     <.> mkWpEvVarApps ids1,
 181                  mkFunTys arg_tys rho2) }
 182
 183   | otherwise = return (idHsWrapper, ty)
 184 \end{code}
 185
 186
 187 %************************************************************************
 188 %*                                                                      *
 189             Instantiating a call
 190 %*                                                                      *
 191 %************************************************************************
 192
 193 \begin{code}
 194 ----------------
 195 instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 196 -- Instantiate the constraints of a call
 197 --      (instCall o tys theta)
 198 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
 199 -- (b) Throws these dictionaries into the LIE
 200 -- (c) Returns an HsWrapper ([.] tys dicts)
 201
 202 instCall orig tys theta
 203   = do  { dict_app <- instCallConstraints orig theta
 204         ; return (dict_app <.> mkWpTyApps tys) }
 205
 206 ----------------
 207 instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
 208 -- Instantiates the TcTheta, puts all constraints thereby generated
 209 -- into the LIE, and returns a HsWrapper to enclose the call site.
 210
 211 instCallConstraints _ [] = return idHsWrapper
 212
 213 instCallConstraints origin (EqPred ty1 ty2 : preds)     -- Try short-cut
 214   = do  { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
 215         ; co    <- unifyType ty1 ty2
 216         ; co_fn <- instCallConstraints origin preds
 217         ; return (co_fn <.> WpEvApp (EvCoercion co)) }
 218
 219 instCallConstraints origin (pred : preds)
 220   = do  { ev_var <- emitWanted origin pred
 221         ; co_fn <- instCallConstraints origin preds
 222         ; return (co_fn <.> WpEvApp (EvId ev_var)) }
 223
 224 ----------------
 225 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
 226 -- Similar to instCall, but only emit the constraints in the LIE
 227 -- Used exclusively for the 'stupid theta' of a data constructor
 228 instStupidTheta orig theta
 229   = do  { _co <- instCallConstraints orig theta -- Discard the coercion
 230         ; return () }
 231 \end{code}
 232
 233 %************************************************************************
 234 %*                                                                      *
 235                 Literals
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 In newOverloadedLit we convert directly to an Int or Integer if we
 240 know that's what we want.  This may save some time, by not
 241 temporarily generating overloaded literals, but it won't catch all
 242 cases (the rest are caught in lookupInst).
 243
 244 \begin{code}
 245 newOverloadedLit :: CtOrigin
 246                  -> HsOverLit Name
 247                  -> TcRhoType
 248                  -> TcM (HsOverLit TcId)
 249 newOverloadedLit orig
 250   lit@(OverLit { ol_val = val, ol_rebindable = rebindable
 251                , ol_witness = meth_name }) res_ty
 252
 253   | not rebindable
 254   , Just expr <- shortCutLit val res_ty
 255         -- Do not generate a LitInst for rebindable syntax.
 256         -- Reason: If we do, tcSimplify will call lookupInst, which
 257         --         will call tcSyntaxName, which does unification,
 258         --         which tcSimplify doesn't like
 259   = return (lit { ol_witness = expr, ol_type = res_ty })
 260
 261   | otherwise
 262   = do  { hs_lit <- mkOverLit val
 263         ; let lit_ty = hsLitType hs_lit
 264         ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
 265                 -- Overloaded literals must have liftedTypeKind, because
 266                 -- we're instantiating an overloaded function here,
 267                 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
 268                 -- However this'll be picked up by tcSyntaxOp if necessary
 269         ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
 270         ; return (lit { ol_witness = witness, ol_type = res_ty }) }
 271
 272 ------------
 273 mkOverLit :: OverLitVal -> TcM HsLit
 274 mkOverLit (HsIntegral i)
 275   = do  { integer_ty <- tcMetaTy integerTyConName
 276         ; return (HsInteger i integer_ty) }
 277
 278 mkOverLit (HsFractional r)
 279   = do  { rat_ty <- tcMetaTy rationalTyConName
 280         ; return (HsRat (fl_value r) rat_ty) }
 281
 282 mkOverLit (HsIsString s) = return (HsString s)
 283 \end{code}
 284
 285
 286
 287
 288 %************************************************************************
 289 %*                                                                      *
 290                 Re-mappable syntax
 291
 292      Used only for arrow syntax -- find a way to nuke this
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 Suppose we are doing the -XRebindableSyntax thing, and we encounter
 297 a do-expression.  We have to find (>>) in the current environment, which is
 298 done by the rename. Then we have to check that it has the same type as
 299 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 300 this:
 301
 302   (>>) :: HB m n mn => m a -> n b -> mn b
 303
 304 So the idea is to generate a local binding for (>>), thus:
 305
 306         let then72 :: forall a b. m a -> m b -> m b
 307             then72 = ...something involving the user's (>>)...
 308         in
 309         ...the do-expression...
 310
 311 Now the do-expression can proceed using then72, which has exactly
 312 the expected type.
 313
 314 In fact tcSyntaxName just generates the RHS for then72, because we only
 315 want an actual binding in the do-expression case. For literals, we can
 316 just use the expression inline.
 317
 318 \begin{code}
 319 tcSyntaxName :: CtOrigin
 320              -> TcType                  -- Type to instantiate it at
 321              -> (Name, HsExpr Name)     -- (Standard name, user name)
 322              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 323 --      *** NOW USED ONLY FOR CmdTop (sigh) ***
 324 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 325 -- So we do not call it from lookupInst, which is called from tcSimplify
 326
 327 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 328   | std_nm == user_nm
 329   = do rhs <- newMethodFromName orig std_nm ty
 330        return (std_nm, rhs)
 331
 332 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
 333     std_id <- tcLookupId std_nm
 334     let
 335         -- C.f. newMethodAtLoc
 336         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 337         sigma1          = substTyWith [tv] [ty] tau
 338         -- Actually, the "tau-type" might be a sigma-type in the
 339         -- case of locally-polymorphic methods.
 340
 341     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
 342
 343         -- Check that the user-supplied thing has the
 344         -- same type as the standard one.
 345         -- Tiresome jiggling because tcCheckSigma takes a located expression
 346      span <- getSrcSpanM
 347      expr <- tcPolyExpr (L span user_nm_expr) sigma1
 348      return (std_nm, unLoc expr)
 349
 350 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
 351                -> TcRn (TidyEnv, SDoc)
 352 syntaxNameCtxt name orig ty tidy_env = do
 353     inst_loc <- getCtLoc orig
 354     let
 355         msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
 356                                 ptext (sLit "(needed by a syntactic construct)"),
 357                     nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
 358                     nest 2 (pprArisingAt inst_loc)]
 359     return (tidy_env, msg)
 360 \end{code}
 361
 362
 363 %************************************************************************
 364 %*                                                                      *
 365                 Instances
 366 %*                                                                      *
 367 %************************************************************************
 368
 369 \begin{code}
 370 getOverlapFlag :: TcM OverlapFlag
 371 getOverlapFlag
 372   = do  { dflags <- getDOpts
 373         ; let overlap_ok    = xopt Opt_OverlappingInstances dflags
 374               incoherent_ok = xopt Opt_IncoherentInstances  dflags
 375               overlap_flag | incoherent_ok = Incoherent
 376                            | overlap_ok    = OverlapOk
 377                            | otherwise     = NoOverlap
 378
 379         ; return overlap_flag }
 380
 381 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 382 -- Gets both the external-package inst-env
 383 -- and the home-pkg inst env (includes module being compiled)
 384 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 385                      return (eps_inst_env eps, tcg_inst_env env) }
 386
 387 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
 388   -- Add new locally-defined instances
 389 tcExtendLocalInstEnv dfuns thing_inside
 390  = do { traceDFuns dfuns
 391       ; env <- getGblEnv
 392       ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
 393       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 394                          tcg_inst_env = inst_env' }
 395       ; setGblEnv env' thing_inside }
 396
 397 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
 398 -- Check that the proposed new instance is OK,
 399 -- and then add it to the home inst env
 400 addLocalInst home_ie ispec
 401   = do  {       -- Instantiate the dfun type so that we extend the instance
 402                 -- envt with completely fresh template variables
 403                 -- This is important because the template variables must
 404                 -- not overlap with anything in the things being looked up
 405                 -- (since we do unification).
 406                 --
 407                 -- We use tcInstSkolType because we don't want to allocate fresh
 408                 --  *meta* type variables.
 409                 --
 410                 -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
 411                 -- these variables must be bindable by tcUnifyTys.  See
 412                 -- the call to tcUnifyTys in InstEnv, and the special
 413                 -- treatment that instanceBindFun gives to isOverlappableTyVar
 414                 -- This is absurdly delicate.
 415
 416           let dfun = instanceDFunId ispec
 417         ; (tvs', theta', tau') <- tcInstSkolType (idType dfun)
 418         ; let   (cls, tys') = tcSplitDFunHead tau'
 419                 dfun'       = setIdType dfun (mkSigmaTy tvs' theta' tau')
 420                 ispec'      = setInstanceDFunId ispec dfun'
 421
 422                 -- Load imported instances, so that we report
 423                 -- duplicates correctly
 424         ; eps <- getEps
 425         ; let inst_envs = (eps_inst_env eps, home_ie)
 426
 427                 -- Check functional dependencies
 428         ; case checkFunDeps inst_envs ispec' of
 429                 Just specs -> funDepErr ispec' specs
 430                 Nothing    -> return ()
 431
 432                 -- Check for duplicate instance decls
 433         ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
 434               ; dup_ispecs = [ dup_ispec
 435                              | (dup_ispec, _) <- matches
 436                              , let (_,_,_,dup_tys) = instanceHead dup_ispec
 437                              , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 438                 -- Find memebers of the match list which ispec itself matches.
 439                 -- If the match is 2-way, it's a duplicate
 440         ; case dup_ispecs of
 441             dup_ispec : _ -> dupInstErr ispec' dup_ispec
 442             []            -> return ()
 443
 444                 -- OK, now extend the envt
 445         ; return (extendInstEnv home_ie ispec') }
 446
 447 traceDFuns :: [Instance] -> TcRn ()
 448 traceDFuns ispecs
 449   = traceTc "Adding instances:" (vcat (map pp ispecs))
 450   where
 451     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
 452         -- Print the dfun name itself too
 453
 454 funDepErr :: Instance -> [Instance] -> TcRn ()
 455 funDepErr ispec ispecs
 456   = addDictLoc ispec $
 457     addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
 458                2 (pprInstances (ispec:ispecs)))
 459 dupInstErr :: Instance -> Instance -> TcRn ()
 460 dupInstErr ispec dup_ispec
 461   = addDictLoc ispec $
 462     addErr (hang (ptext (sLit "Duplicate instance declarations:"))
 463                2 (pprInstances [ispec, dup_ispec]))
 464
 465 addDictLoc :: Instance -> TcRn a -> TcRn a
 466 addDictLoc ispec thing_inside
 467   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 468   where
 469    loc = getSrcLoc ispec
 470 \end{code}
 471
 472 %************************************************************************
 473 %*                                                                      *
 474         Simple functions over evidence variables
 475 %*                                                                      *
 476 %************************************************************************
 477
 478 \begin{code}
 479 unitImplication :: Implication -> Bag Implication
 480 unitImplication implic
 481   | isEmptyWC (ic_wanted implic) = emptyBag
 482   | otherwise                    = unitBag implic
 483
 484 hasEqualities :: [EvVar] -> Bool
 485 -- Has a bunch of canonical constraints (all givens) got any equalities in it?
 486 hasEqualities givens = any (has_eq . evVarPred) givens
 487   where
 488     has_eq (EqPred {})       = True
 489     has_eq (IParam {})       = False
 490     has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls)
 491
 492 ---------------- Getting free tyvars -------------------------
 493 tyVarsOfWC :: WantedConstraints -> TyVarSet
 494 tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
 495   = tyVarsOfEvVarXs flat `unionVarSet`
 496     tyVarsOfBag tyVarsOfImplication implic `unionVarSet`
 497     tyVarsOfEvVarXs insol
 498
 499 tyVarsOfImplication :: Implication -> TyVarSet
 500 tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted })
 501   = tyVarsOfWC wanted `minusVarSet` skols
 502
 503 tyVarsOfEvVarX :: EvVarX a -> TyVarSet
 504 tyVarsOfEvVarX (EvVarX ev _) = tyVarsOfEvVar ev
 505
 506 tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet
 507 tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX
 508
 509 tyVarsOfEvVar :: EvVar -> TyVarSet
 510 tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
 511
 512 tyVarsOfEvVars :: [EvVar] -> TyVarSet
 513 tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
 514
 515 tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
 516 tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
 517
 518 ---------------- Tidying -------------------------
 519 tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints
 520 tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
 521   = WC { wc_flat  = tidyWantedEvVars env flat
 522        , wc_impl  = mapBag (tidyImplication env) implic
 523        , wc_insol = mapBag (tidyFlavoredEvVar env) insol }
 524
 525 tidyImplication :: TidyEnv -> Implication -> Implication
 526 tidyImplication env implic@(Implic { ic_skols = tvs
 527                                    , ic_given = given
 528                                    , ic_wanted = wanted
 529                                    , ic_loc = loc })
 530   = implic { ic_skols = mkVarSet tvs'
 531            , ic_given = map (tidyEvVar env1) given
 532            , ic_wanted = tidyWC env1 wanted
 533            , ic_loc = tidyGivenLoc env1 loc }
 534   where
 535    (env1, tvs') = mapAccumL tidyTyVarBndr env (varSetElems tvs)
 536
 537 tidyEvVar :: TidyEnv -> EvVar -> EvVar
 538 tidyEvVar env var = setVarType var (tidyType env (varType var))
 539
 540 tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar
 541 tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l
 542
 543 tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
 544 tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
 545
 546 tidyFlavoredEvVar :: TidyEnv -> FlavoredEvVar -> FlavoredEvVar
 547 tidyFlavoredEvVar env (EvVarX v fl)
 548   = EvVarX (tidyEvVar env v) (tidyFlavor env fl)
 549
 550 tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
 551 tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
 552 tidyFlavor _   fl          = fl
 553
 554 tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
 555 tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span ctxt
 556
 557 tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
 558 tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
 559 tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
 560 tidySkolemInfo _   info            = info
 561
 562 ---------------- Substitution -------------------------
 563 substWC :: TvSubst -> WantedConstraints -> WantedConstraints
 564 substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
 565   = WC { wc_flat = substWantedEvVars subst flat
 566        , wc_impl = mapBag (substImplication subst) implic
 567        , wc_insol = mapBag (substFlavoredEvVar subst) insol }
 568
 569 substImplication :: TvSubst -> Implication -> Implication
 570 substImplication subst implic@(Implic { ic_skols = tvs
 571                                       , ic_given = given
 572                                       , ic_wanted = wanted
 573                                       , ic_loc = loc })
 574   = implic { ic_skols  = mkVarSet tvs'
 575            , ic_given  = map (substEvVar subst1) given
 576            , ic_wanted = substWC subst1 wanted
 577            , ic_loc    = substGivenLoc subst1 loc }
 578   where
 579    (subst1, tvs') = mapAccumL substTyVarBndr subst (varSetElems tvs)
 580
 581 substEvVar :: TvSubst -> EvVar -> EvVar
 582 substEvVar subst var = setVarType var (substTy subst (varType var))
 583
 584 substWantedEvVars :: TvSubst -> Bag WantedEvVar -> Bag WantedEvVar
 585 substWantedEvVars subst = mapBag (substWantedEvVar subst)
 586
 587 substWantedEvVar :: TvSubst -> WantedEvVar -> WantedEvVar
 588 substWantedEvVar subst (EvVarX v l) = EvVarX (substEvVar subst v) l
 589
 590 substFlavoredEvVar :: TvSubst -> FlavoredEvVar -> FlavoredEvVar
 591 substFlavoredEvVar subst (EvVarX v fl)
 592   = EvVarX (substEvVar subst v) (substFlavor subst fl)
 593
 594 substFlavor :: TvSubst -> CtFlavor -> CtFlavor
 595 substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
 596 substFlavor _     fl          = fl
 597
 598 substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
 599 substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
 600
 601 substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
 602 substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
 603 substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids)
 604 substSkolemInfo _     info            = info
 605 \end{code}