Commit 4716851a authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Merge branch 'master' of http://darcs.haskell.org/ghc

parents cfcddaae 541781f2
......@@ -683,7 +683,9 @@ dsEvTerm (EvId v) = Var v
dsEvTerm (EvCast v co)
= dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvKindCast v co)
= dsTcCoercion co $ (\_ -> Var v)
dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
......
......@@ -84,9 +84,9 @@ module GHC (
-- * Interactive evaluation
getBindings, getInsts, getPrintUnqual,
findModule,
lookupModule,
findModule, lookupModule,
#ifdef GHCI
isModuleTrusted,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
......@@ -1247,26 +1247,32 @@ lookupModule mod_name Nothing = withSession $ \hsc_env -> do
Found _ m -> return m
err -> noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
case lookupUFM (hsc_HPT hsc_env) mod_name of
Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
_not_a_home_module -> return Nothing
#ifdef GHCI
-- | Check that a module is safe to import (according to Safe Haskell).
--
-- We return True to indicate the import is safe and False otherwise
-- although in the False case an error may be thrown first.
isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
return$ InteractiveEval.getHistorySpan hsc_env h
return $ InteractiveEval.getHistorySpan hsc_env h
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
obtainTermFromVal bound force ty a =
withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId bound force id =
withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
obtainTermFromId bound force id = withSession $ \hsc_env ->
liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
#endif
......
......@@ -206,6 +206,9 @@ instance Monad Hsc where
instance MonadIO Hsc where
liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
instance Functor Hsc where
fmap f m = m >>= \a -> return $ f a
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w) <- hsc hsc_env emptyBag
......@@ -911,20 +914,18 @@ hscCheckSafeImports tcg_env = do
text "Rule \"" <> ftext n <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
-- | Validate that safe imported modules are actually safe.
-- For modules in the HomePackage (the package the module we
-- are compiling in resides) this just involves checking its
-- trust type is 'Safe' or 'Trustworthy'. For modules that
-- reside in another package we also must check that the
-- external pacakge is trusted. See the Note [Safe Haskell
-- Trust Check] above for more information.
-- | Validate that safe imported modules are actually safe. For modules in the
-- HomePackage (the package the module we are compiling in resides) this just
-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
-- that reside in another package we also must check that the external pacakge
-- is trusted. See the Note [Safe Haskell Trust Check] above for more
-- information.
--
-- The code for this is quite tricky as the whole algorithm
-- is done in a few distinct phases in different parts of the
-- code base. See RnNames.rnImportDecl for where package trust
-- dependencies for a module are collected and unioned.
-- Specifically see the Note [RnNames . Tracking Trust Transitively]
-- and the Note [RnNames . Trust Own Package].
-- The code for this is quite tricky as the whole algorithm is done in a few
-- distinct phases in different parts of the code base. See
-- RnNames.rnImportDecl for where package trust dependencies for a module are
-- collected and unioned. Specifically see the Note [RnNames . Tracking Trust
-- Transitively] and the Note [RnNames . Trust Own Package].
checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkSafeImports dflags tcg_env
= do
......@@ -941,7 +942,7 @@ checkSafeImports dflags tcg_env
clearWarnings
logWarnings oldErrs
-- See the Note [ Safe Haskell Inference]
-- See the Note [Safe Haskell Inference]
case (not $ isEmptyBag errs) of
-- We have errors!
......@@ -953,7 +954,7 @@ checkSafeImports dflags tcg_env
-- All good matey!
False -> do
when (packageTrustOn dflags) $ checkPkgTrust pkg_reqs
when (packageTrustOn dflags) $ checkPkgTrust dflags pkg_reqs
-- add in trusted package requirements for this module
let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs }
return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust }
......@@ -984,46 +985,33 @@ checkSafeImports dflags tcg_env
-- easier interface to work with
checkSafe (_, _, False) = return Nothing
checkSafe (m, l, True ) = hscCheckSafe' dflags m l
-- Here we check the transitive package trust requirements are OK still.
checkPkgTrust :: [PackageId] -> Hsc ()
checkPkgTrust pkgs =
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
where
errors = catMaybes $ map go pkgs
go pkg
| trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing
| otherwise
= Just $ mkPlainErrMsg noSrcSpan
$ text "The package (" <> ppr pkg <> text ") is required"
<> text " to be trusted but it isn't!"
checkSafe (m, l, True ) = fst `fmap` hscCheckSafe' dflags m l
-- | Check that a module is safe to import.
--
-- We return a package id if the safe import is OK and a Nothing otherwise
-- with the reason for the failure printed out.
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO (Maybe PackageId)
-- We return True to indicate the import is safe and False otherwise
-- although in the False case an exception may be thrown first.
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
hscCheckSafe' dflags m l
pkgs <- snd `fmap` hscCheckSafe' dflags m l
when (packageTrustOn dflags) $ checkPkgTrust dflags pkgs
errs <- getWarnings
return $ isEmptyBag errs
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId)
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
hscCheckSafe' dflags m l = do
tw <- isModSafe m l
(tw, pkgs) <- isModSafe m l
case tw of
False -> return Nothing
True | isHomePkg m -> return Nothing
| otherwise -> return $ Just $ modulePackageId m
False -> return (Nothing, pkgs)
True | isHomePkg m -> return (Nothing, pkgs)
| otherwise -> return (Just $ modulePackageId m, pkgs)
where
-- Is a module trusted? Return Nothing if True, or a String if it isn't,
-- containing the reason it isn't. Also return if the module trustworthy
-- (true) or safe (false) so we know if we should check if the package
-- itself is trusted in the future.
isModSafe :: Module -> SrcSpan -> Hsc (Bool)
-- Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the
-- modules own package be trusted and a list of other packages required to
-- be trusted (these later ones haven't been checked)
isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
isModSafe m l = do
iface <- lookup' m
case iface of
......@@ -1040,11 +1028,14 @@ hscCheckSafe' dflags m l = do
safeM = trust `elem` [Sf_SafeInfered, Sf_Safe, Sf_Trustworthy]
-- check package is trusted
safeP = packageTrusted trust trust_own_pkg m
-- pkg trust reqs
pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
case (safeM, safeP) of
-- General errors we throw but Safe errors we log
(True, True ) -> return $ trust == Sf_Trustworthy
(True, True ) -> return (trust == Sf_Trustworthy, pkgRs)
(True, False) -> liftIO . throwIO $ pkgTrustErr
(False, _ ) -> logWarnings modTrustErr >> return (trust == Sf_Trustworthy)
(False, _ ) -> logWarnings modTrustErr >>
return (trust == Sf_Trustworthy, pkgRs)
where
pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m
......@@ -1055,11 +1046,10 @@ hscCheckSafe' dflags m l = do
<+> text "can't be safely imported!"
<+> text "The module itself isn't safe."
-- | Check the package a module resides in is trusted.
-- Safe compiled modules are trusted without requiring
-- that their package is trusted. For trustworthy modules,
-- modules in the home package are trusted but otherwise
-- we check the package trust flag.
-- | Check the package a module resides in is trusted. Safe compiled
-- modules are trusted without requiring that their package is trusted. For
-- trustworthy modules, modules in the home package are trusted but
-- otherwise we check the package trust flag.
packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted _ _ _
| not (packageTrustOn dflags) = True
......@@ -1077,13 +1067,40 @@ hscCheckSafe' dflags m l = do
let pkgIfaceT = eps_PIT hsc_eps
homePkgT = hsc_HPT hsc_env
iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
#ifdef GHCI
-- the 'lookupIfaceByModule' method will always fail when calling from GHCi
-- as the compiler hasn't filled in the various module tables
-- so we need to call 'getModuleInterface' to load from disk
iface' <- case iface of
Just _ -> return iface
Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
return iface'
#else
return iface
#endif
isHomePkg :: Module -> Bool
isHomePkg m
| thisPackage dflags == modulePackageId m = True
| otherwise = False
-- | Check the list of packages are trusted.
checkPkgTrust :: DynFlags -> [PackageId] -> Hsc ()
checkPkgTrust dflags pkgs =
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
where
errors = catMaybes $ map go pkgs
go pkg
| trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing
| otherwise
= Just $ mkPlainErrMsg noSrcSpan
$ text "The package (" <> ppr pkg <> text ") is required"
<> text " to be trusted but it isn't!"
-- | Set module to unsafe and wipe trust information.
--
-- Make sure to call this method to set a module to infered unsafe,
......
......@@ -60,12 +60,14 @@ and packages. Doing this without caching any trust information would be very
slow as we would need to touch all packages and interface files a module depends
on. To avoid this we make use of the property that if a modules Safe Haskell
mode changes, this triggers a recompilation from that module in the dependcy
graph. So we can just worry mostly about direct imports. There is one trust
property that can change for a package though without recompliation being
triggered, package trust. So we must check that all packages a module
tranitively depends on to be trusted are still trusted when we are compiling
this module (as due to recompilation avoidance some modules below may not be
considered trusted any more without recompilation being triggered).
graph. So we can just worry mostly about direct imports.
There is one trust property that can change for a package though without
recompliation being triggered: package trust. So we must check that all
packages a module tranitively depends on to be trusted are still trusted when
we are compiling this module (as due to recompilation avoidance some modules
below may not be considered trusted any more without recompilation being
triggered).
We handle this by augmenting the existing transitive list of packages a module M
depends on with a bool for each package that says if it must be trusted when the
......@@ -110,7 +112,7 @@ haskell at all and simply imports B, should A inherit all the the trust
requirements from B? Should A now also require that a package p is trusted since
B required it?
We currently say no but I saying yes also makes sense. The difference is, if a
We currently say no but saying yes also makes sense. The difference is, if a
module M that doesn't use Safe Haskell imports a module N that does, should all
the trusted package requirements be dropped since M didn't declare that it cares
about Safe Haskell (so -XSafe is more strongly associated with the module doing
......
......@@ -8,9 +8,6 @@
module TcCanonical(
canonicalize,
canOccursCheck, canEq, canEvVar,
rewriteWithFunDeps,
emitFDWorkAsWanted, emitFDWorkAsDerived,
StopOrContinue (..)
) where
......@@ -19,8 +16,6 @@ module TcCanonical(
import BasicTypes ( IPName )
import TcErrors
import TcRnTypes
import FunDeps
import qualified TcMType as TcM
import TcType
import Type
import Kind
......@@ -32,7 +27,7 @@ import Name ( Name )
import Var
import VarEnv
import Outputable
import Control.Monad ( when, unless, zipWithM, foldM )
import Control.Monad ( when, unless, zipWithM )
import MonadUtils
import Control.Applicative ( (<|>) )
......@@ -42,7 +37,6 @@ import TcSMonad
import FastString
import Data.Maybe ( isNothing )
import Pair ( pSnd )
\end{code}
......@@ -204,11 +198,13 @@ canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl
canEvVar :: EvVar -> PredTree
-> SubGoalDepth -> CtFlavor -> TcS StopOrContinue
-- Called only for non-canonical EvVars
canEvVar ev pred_classifier d fl
= case pred_classifier of
ClassPred cls tys -> canClass d fl ev cls tys
`andWhenContinue` emit_superclasses
EqPred ty1 ty2 -> canEq d fl ev ty1 ty2
EqPred ty1 ty2 -> canEq d fl ev ty1 ty2
`andWhenContinue` emit_kind_constraint
IPPred nm ty -> canIP d fl ev nm ty
IrredPred ev_ty -> canIrred d fl ev ev_ty
TuplePred tys -> canTuple d fl ev tys
......@@ -219,9 +215,58 @@ canEvVar ev pred_classifier d fl
= do { sctxt <- getTcSContext
; unless (simplEqsOnly sctxt) $
newSCWorkFromFlavored d v_new fl cls xis_new
-- Arguably we should "seq" the coercions if they are derived,
-- as we do below for emit_kind_constraint, to allow errors in
-- superclasses to be executed if deferred to runtime!
; continueWith ct }
emit_superclasses _ = panic "emit_superclasses of non-class!"
emit_kind_constraint ct@(CTyEqCan { cc_id = ev, cc_depth = d
, cc_flavor = fl, cc_tyvar = tv
, cc_rhs = ty })
= do_emit_kind_constraint ct ev d fl (mkTyVarTy tv) ty
emit_kind_constraint ct@(CFunEqCan { cc_id = ev, cc_depth = d
, cc_flavor = fl
, cc_fun = fn, cc_tyargs = xis1
, cc_rhs = xi2 })
= do_emit_kind_constraint ct ev d fl (mkTyConApp fn xis1) xi2
emit_kind_constraint ct = continueWith ct
do_emit_kind_constraint ct eqv d fl ty1 ty2
| compatKind k1 k2 = continueWith ct
| otherwise
= do { keqv <- forceNewEvVar kind_co_fl (mkEqPred (k1,k2))
; eqv' <- forceNewEvVar fl (mkEqPred (ty1,ty2))
; _fl <- case fl of
Wanted {}-> setEvBind eqv
(mkEvKindCast eqv' (mkTcCoVarCo keqv)) fl
Given {} -> setEvBind eqv'
(mkEvKindCast eqv (mkTcCoVarCo keqv)) fl
Derived {} -> return fl
; canEq_ d kind_co_fl keqv k1 k2 -- Emit kind equality
; continueWith (ct { cc_id = eqv' }) }
where k1 = typeKind ty1
k2 = typeKind ty2
ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2
-- Always create a Wanted kind equality even if
-- you are decomposing a given constraint.
-- NB: DV finds this reasonable for now. Maybe we
-- have to revisit.
kind_co_fl
| Given (CtLoc _sk_info src_span err_ctxt) _ <- fl
= let orig = TypeEqOrigin (UnifyOrigin ty1 ty2)
ctloc = pushErrCtxtSameOrigin ctxt $
CtLoc orig src_span err_ctxt
in Wanted ctloc
| Wanted ctloc <- fl
= Wanted (pushErrCtxtSameOrigin ctxt ctloc)
| Derived ctloc <- fl
= Derived (pushErrCtxtSameOrigin ctxt ctloc)
| otherwise
= panic "do_emit_kind_constraint: non-CtLoc inside!"
-- Tuple canonicalisation
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -555,26 +600,28 @@ flatten :: SubGoalDepth -- Depth
flatten d ctxt ty
| Just ty' <- tcView ty
= do { (xi, co) <- flatten d ctxt ty'
; return (xi,co) }
-- DV: The following is tedious to do but maybe we should return to this
-- Preserve type synonyms if possible
-- ; if no_flattening
-- then return (xi, mkTcReflCo xi,no_flattening) -- Importantly, not xi!
-- else return (xi,co,no_flattening)
-- }
flatten d ctxt v@(TyVarTy _)
; return (xi,co) }
flatten d ctxt (TyVarTy tv)
= do { ieqs <- getInertEqs
; let co = liftInertEqsTy ieqs ctxt v -- co : v ~ ty
ty = pSnd (tcCoercionKind co)
; if v `eqType` ty then
return (ty,mkTcReflCo ty)
else -- NB recursive call. Why? See Note [Non-idempotent inert substitution]
-- Actually I believe that applying the substition only *twice* will suffice
do { (ty_final,co') <- flatten d ctxt ty -- co' : ty_final ~ ty
; return (ty_final,co' `mkTcTransCo` mkTcSymCo co) } }
; let mco = tv_eq_subst (fst ieqs) tv -- co : v ~ ty
; case mco of -- Done, but make sure the kind is zonked
Nothing ->
do { let knd = tyVarKind tv
; (new_knd,_kind_co) <- flatten d ctxt knd
; let ty = mkTyVarTy (setVarType tv new_knd)
; return (ty, mkTcReflCo ty) }
-- NB recursive call.
-- Why? See Note [Non-idempotent inert substitution]
-- Actually, I think applying the substition just twice will suffice
Just (co,ty) ->
do { (ty_final,co') <- flatten d ctxt ty
; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } }
where tv_eq_subst subst tv
| Just (ct,co) <- lookupVarEnv subst tv
, cc_flavor ct `canRewrite` ctxt
= Just (co,cc_rhs ct)
| otherwise = Nothing
\end{code}
......@@ -1106,28 +1153,17 @@ canEqLeafOriented :: SubGoalDepth -- Depth
-> TcType -> TcType -> TcS StopOrContinue
-- By now s1 will either be a variable or a type family application
canEqLeafOriented d fl eqv s1 s2
| let k1 = typeKind s1
, let k2 = typeKind s2
-- Establish kind invariants for CFunEqCan and CTyEqCan
= do { are_compat <- compatKindTcS k1 k2
; can_unify <- if not are_compat
then unifyKindTcS s1 s2 k1 k2
else return False
-- If the kinds cannot be unified or are not compatible, don't fail
-- right away; instead, emit a frozen error
; if (not are_compat && not can_unify) then
canEqFailure d fl eqv
else can_eq_kinds_ok d fl eqv s1 s2 }
where can_eq_kinds_ok d fl eqv s1 s2
= can_eq_split_lhs d fl eqv s1 s2
where can_eq_split_lhs d fl eqv s1 s2
| Just (fn,tys1) <- splitTyConApp_maybe s1
= canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2
| Just tv <- getTyVar_maybe s1
= canEqLeafTyVarLeftRec d fl eqv tv s2
| otherwise
= pprPanic "canEqLeafOriented" $
text "Non-variable or non-family equality LHS" <+> ppr eqv <+>
dcolon <+> ppr (evVarPred eqv)
text "Non-variable or non-family equality LHS" <+>
ppr eqv <+> dcolon <+> ppr (evVarPred eqv)
canEqLeafFunEqLeftRec :: SubGoalDepth
-> CtFlavor
-> EqVar
......@@ -1471,117 +1507,3 @@ we first try expanding each of the ti to types which no longer contain
a. If this turns out to be impossible, we next try expanding F
itself, and so on.
%************************************************************************
%* *
%* Functional dependencies, instantiation of equations
%* *
%************************************************************************
When we spot an equality arising from a functional dependency,
we now use that equality (a "wanted") to rewrite the work-item
constraint right away. This avoids two dangers
Danger 1: If we send the original constraint on down the pipeline
it may react with an instance declaration, and in delicate
situations (when a Given overlaps with an instance) that
may produce new insoluble goals: see Trac #4952
Danger 2: If we don't rewrite the constraint, it may re-react
with the same thing later, and produce the same equality
again --> termination worries.
To achieve this required some refactoring of FunDeps.lhs (nicer
now!).
\begin{code}
rewriteWithFunDeps :: [Equation]
-> [Xi]
-> WantedLoc
-> TcS (Maybe ([Xi], [TcCoercion], [(EvVar,WantedLoc)]))
-- Not quite a WantedEvVar unfortunately
-- Because our intention could be to make
-- it derived at the end of the day
-- NB: The flavor of the returned EvVars will be decided by the caller
-- Post: returns no trivial equalities (identities) and all EvVars returned are fresh
rewriteWithFunDeps eqn_pred_locs xis wloc
= do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs
; let fd_ev_pos :: [(Int,(EqVar,WantedLoc))]
fd_ev_pos = concat fd_ev_poss
(rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis)
; if null fd_ev_pos then return Nothing
else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) }
instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))]
-- Post: Returns the position index as well as the corresponding FunDep equality
instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs
, fd_pred1 = d1, fd_pred2 = d2 })
= do { let tvs = varSetElems qtvs
; tvs' <- mapM instFlexiTcS tvs -- IA0_TODO: we might need to do kind substitution
; let subst = zipTopTvSubst tvs (mkTyVarTys tvs')
; foldM (do_one subst) [] eqs }
where
do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 })
= let sty1 = Type.substTy subst ty1
sty2 = Type.substTy subst ty2
in if eqType sty1 sty2 then return ievs -- Return no trivial equalities
else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds
; let wl' = push_ctx wl
; if isNewEvVar eqv then
return $ (i,(evc_the_evvar eqv,wl')):ievs
else -- We are eventually going to emit FD work back in the work list so
-- it is important that we only return the /freshly created/ and not
-- some existing equality!
return ievs }
push_ctx :: WantedLoc -> WantedLoc
push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc
mkEqnMsg :: (TcPredType, SDoc)
-> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc)
mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
= do { zpred1 <- TcM.zonkTcPredType pred1
; zpred2 <- TcM.zonkTcPredType pred2
; let { tpred1 = tidyType tidy_env zpred1
; tpred2 = tidyType tidy_env zpred2 }
; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]),
nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])]
; return (tidy_env, msg) }
rewriteDictParams :: [(Int,(EqVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty)
-> [Type] -- A sequence of types: tys
-> [(Type, TcCoercion)] -- Returns: [(ty', co : ty' ~ ty)]
rewriteDictParams param_eqs tys
= zipWith do_one tys [0..]
where
do_one :: Type -> Int -> (Type, TcCoercion)
do_one ty n = case lookup n param_eqs of
Just wev -> (get_fst_ty wev, mkTcCoVarCo (fst wev))
Nothing -> (ty, mkTcReflCo ty) -- Identity
get_fst_ty (wev,_wloc)
| Just (ty1, _) <- getEqPredTys_maybe (evVarPred wev )
= ty1
| otherwise
= panic "rewriteDictParams: non equality fundep!?"
emitFDWork :: Bool
-> [(EvVar,WantedLoc)]
-> SubGoalDepth -> TcS ()
emitFDWork as_wanted evlocs d
= updWorkListTcS $ appendWorkListEqs fd_cts
where fd_cts = map mk_fd_ct evlocs
mk_fl wl = if as_wanted then (Wanted wl) else (Derived wl)
mk_fd_ct (v,wl) = CNonCanonical { cc_id = v
, cc_flavor = mk_fl wl
, cc_depth = d }
emitFDWorkAsDerived, emitFDWorkAsWanted :: [(EvVar,WantedLoc)]
-> SubGoalDepth
-> TcS ()
emitFDWorkAsDerived = emitFDWork False
emitFDWorkAsWanted = emitFDWork True
\end{code}
\ No newline at end of file
......@@ -23,6 +23,7 @@ import TcSMonad
import TcType
import TypeRep
import Type
import Kind ( isKind )
import Class
import Unify ( tcMatchTys )
import Inst
......@@ -465,8 +466,12 @@ addExtraInfo ctxt ty1 ty2
extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2
misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy
misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
, nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
misMatchMsg ty1 ty2
= sep [ ptext cm_ty_or_knd <+> quotes (ppr ty1)
, nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
where cm_ty_or_knd
| isKind ty1 = sLit "Couldn't match kind"
| otherwise = sLit "Couldn't match type"
kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy
kindErrorMsg ty1 ty2
......
......@@ -16,7 +16,7 @@ module TcEvidence (