Commit 6d2b0ae3 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Overhaul of the rewrite rules

- Cleaned up and simplified rules
- Added many missing cases
- The rules OccursCheck and swap have been eliminated and integrate with
  the other rules; ie, Subst and Unify perform the occurs check themselves
  and they can deal with left-to-right and right-to-left oriented rewrites.
  This makes the code simpler and more efficient.
- Also added comments.
parent bbd67a5f
...@@ -42,7 +42,8 @@ module Inst ( ...@@ -42,7 +42,8 @@ module Inst (
isTyVarDict, isMethodFor, isTyVarDict, isMethodFor,
zonkInst, zonkInsts, zonkInst, zonkInsts,
instToId, instToVar, instType, instName, instToId, instToVar, instType, instName, instToDictBind,
addInstToDictBind,
InstOrigin(..), InstLoc, pprInstLoc, InstOrigin(..), InstLoc, pprInstLoc,
...@@ -91,6 +92,7 @@ import PrelNames ...@@ -91,6 +92,7 @@ import PrelNames
import BasicTypes import BasicTypes
import SrcLoc import SrcLoc
import DynFlags import DynFlags
import Bag
import Maybes import Maybes
import Util import Util
import Outputable import Outputable
...@@ -205,6 +207,15 @@ tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unio ...@@ -205,6 +207,15 @@ tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unio
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie) tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
--------------------------
instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
instToDictBind inst rhs
= unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
\end{code} \end{code}
Predicates Predicates
...@@ -1005,7 +1016,7 @@ mkEqInst (EqPred ty1 ty2) co ...@@ -1005,7 +1016,7 @@ mkEqInst (EqPred ty1 ty2) co
mkWantedEqInst :: PredType -> TcM Inst mkWantedEqInst :: PredType -> TcM Inst
mkWantedEqInst pred@(EqPred ty1 ty2) mkWantedEqInst pred@(EqPred ty1 ty2)
= do { cotv <- newMetaTyVar TauTv (mkCoKind ty1 ty2) = do { cotv <- newMetaCoVar ty1 ty2
; mkEqInst pred (Left cotv) ; mkEqInst pred (Left cotv)
} }
......
...@@ -688,23 +688,16 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) ...@@ -688,23 +688,16 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
returnM (unitBag main_bind) returnM (unitBag main_bind)
mkCoVars :: [PredType] -> TcM [TyVar] mkCoVars :: [PredType] -> TcM [TyVar]
mkCoVars [] = return [] mkCoVars = newCoVars . map unEqPred
mkCoVars (pred:preds) = where
do { uniq <- newUnique unEqPred (EqPred ty1 ty2) = (ty1, ty2)
; let name = mkSysTvName uniq FSLIT("mkCoVars") unEqPred _ = panic "TcInstDcls.mkCoVars"
; let tv = mkCoVar name (PredTy pred)
; tvs <- mkCoVars preds
; return (tv:tvs)
}
mkMetaCoVars :: [PredType] -> TcM [TyVar] mkMetaCoVars :: [PredType] -> TcM [TyVar]
mkMetaCoVars [] = return [] mkMetaCoVars = mappM eqPredToCoVar
mkMetaCoVars (EqPred ty1 ty2:preds) = where
do { tv <- newMetaTyVar TauTv (mkCoKind ty1 ty2) eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
; tvs <- mkMetaCoVars preds eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
; return (tv:tvs)
}
tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
avail_insts op_items monobinds uprags avail_insts op_items monobinds uprags
......
...@@ -34,14 +34,14 @@ module TcMType ( ...@@ -34,14 +34,14 @@ module TcMType (
-------------------------------- --------------------------------
-- Creating new coercion variables -- Creating new coercion variables
newCoVars, newCoVars, newMetaCoVar,
-------------------------------- --------------------------------
-- Instantiation -- Instantiation
tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar, tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
tcInstSigTyVars, zonkSigTyVar, tcInstSigTyVars, zonkSigTyVar,
tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType, tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType,
tcSkolSigType, tcSkolSigTyVars, tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
-------------------------------- --------------------------------
-- Checking type validity -- Checking type validity
...@@ -49,7 +49,8 @@ module TcMType ( ...@@ -49,7 +49,8 @@ module TcMType (
SourceTyCtxt(..), checkValidTheta, checkFreeness, SourceTyCtxt(..), checkValidTheta, checkFreeness,
checkValidInstHead, checkValidInstance, checkValidInstHead, checkValidInstance,
checkInstTermination, checkValidTypeInst, checkTyFamFreeness, checkInstTermination, checkValidTypeInst, checkTyFamFreeness,
validDerivPred, arityErr, checkUpdateMeta, updateMeta, checkTauTvUpdate, fillBoxWithTau, unifyKindCtxt,
unifyKindMisMatch, validDerivPred, arityErr, notMonoType, notMonoArgs,
-------------------------------- --------------------------------
-- Zonking -- Zonking
...@@ -122,6 +123,186 @@ tcInstType inst_tyvars ty ...@@ -122,6 +123,186 @@ tcInstType inst_tyvars ty
\end{code} \end{code}
%************************************************************************
%* *
Updating tau types
%* *
%************************************************************************
Can't be in TcUnify, as we also need it in TcTyFuns.
\begin{code}
type SwapFlag = Bool
-- False <=> the two args are (actual, expected) respectively
-- True <=> the two args are (expected, actual) respectively
checkUpdateMeta :: SwapFlag
-> TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
-- Update tv1, which is flexi; occurs check is alrady done
-- The 'check' version does a kind check too
-- We do a sub-kind check here: we might unify (a b) with (c d)
-- where b::*->* and d::*; this should fail
checkUpdateMeta swapped tv1 ref1 ty2
= do { checkKinds swapped tv1 ty2
; updateMeta tv1 ref1 ty2 }
updateMeta :: TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
updateMeta tv1 ref1 ty2
= ASSERT( isMetaTyVar tv1 )
ASSERT( isBoxyTyVar tv1 || isTauTy ty2 )
do { ASSERTM2( do { details <- readMetaTyVar tv1; return (isFlexi details) }, ppr tv1 )
; traceTc (text "updateMeta" <+> ppr tv1 <+> text ":=" <+> ppr ty2)
; writeMutVar ref1 (Indirect ty2)
}
----------------
checkKinds swapped tv1 ty2
-- We're about to unify a type variable tv1 with a non-tyvar-type ty2.
-- ty2 has been zonked at this stage, which ensures that
-- its kind has as much boxity information visible as possible.
| tk2 `isSubKind` tk1 = returnM ()
| otherwise
-- Either the kinds aren't compatible
-- (can happen if we unify (a b) with (c d))
-- or we are unifying a lifted type variable with an
-- unlifted type: e.g. (id 3#) is illegal
= addErrCtxtM (unifyKindCtxt swapped tv1 ty2) $
unifyKindMisMatch k1 k2
where
(k1,k2) | swapped = (tk2,tk1)
| otherwise = (tk1,tk2)
tk1 = tyVarKind tv1
tk2 = typeKind ty2
----------------
checkTauTvUpdate :: TcTyVar -> TcType -> TcM TcType
-- (checkTauTvUpdate tv ty)
-- We are about to update the TauTv tv with ty.
-- Check (a) that tv doesn't occur in ty (occurs check)
-- (b) that ty is a monotype
-- Furthermore, in the interest of (b), if you find an
-- empty box (BoxTv that is Flexi), fill it in with a TauTv
--
-- Returns the (non-boxy) type to update the type variable with, or fails
checkTauTvUpdate orig_tv orig_ty
= go orig_ty
where
go (TyConApp tc tys)
| isSynTyCon tc = go_syn tc tys
| otherwise = do { tys' <- mappM go tys; return (TyConApp tc tys') }
go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
go (PredTy p) = do { p' <- go_pred p; return (PredTy p') }
go (FunTy arg res) = do { arg' <- go arg; res' <- go res; return (FunTy arg' res') }
go (AppTy fun arg) = do { fun' <- go fun; arg' <- go arg; return (mkAppTy fun' arg') }
-- NB the mkAppTy; we might have instantiated a
-- type variable to a type constructor, so we need
-- to pull the TyConApp to the top.
go (ForAllTy tv ty) = notMonoType orig_ty -- (b)
go (TyVarTy tv)
| orig_tv == tv = occurCheck tv -- (a)
| isTcTyVar tv = go_tyvar tv (tcTyVarDetails tv)
| otherwise = return (TyVarTy tv)
-- Ordinary (non Tc) tyvars
-- occur inside quantified types
go_pred (ClassP c tys) = do { tys' <- mapM go tys; return (ClassP c tys') }
go_pred (IParam n ty) = do { ty' <- go ty; return (IParam n ty') }
go_pred (EqPred t1 t2) = do { t1' <- go t1; t2' <- go t2; return (EqPred t1' t2') }
go_tyvar tv (SkolemTv _) = return (TyVarTy tv)
go_tyvar tv (MetaTv box ref)
= do { cts <- readMutVar ref
; case cts of
Indirect ty -> go ty
Flexi -> case box of
BoxTv -> fillBoxWithTau tv ref
other -> return (TyVarTy tv)
}
-- go_syn is called for synonyms only
-- See Note [Type synonyms and the occur check]
go_syn tc tys
| not (isTauTyCon tc)
= notMonoType orig_ty -- (b) again
| otherwise
= do { (msgs, mb_tys') <- tryTc (mapM go tys)
; case mb_tys' of
Just tys' -> return (TyConApp tc tys')
-- Retain the synonym (the common case)
Nothing | isOpenTyCon tc
-> notMonoArgs (TyConApp tc tys)
-- Synonym families must have monotype args
| otherwise
-> go (expectJust "checkTauTvUpdate"
(tcView (TyConApp tc tys)))
-- Try again, expanding the synonym
}
occurCheck tv = occurCheckErr (mkTyVarTy tv) orig_ty
fillBoxWithTau :: BoxyTyVar -> IORef MetaDetails -> TcM TcType
-- (fillBoxWithTau tv ref) fills ref with a freshly allocated
-- tau-type meta-variable, whose print-name is the same as tv
-- Choosing the same name is good: when we instantiate a function
-- we allocate boxy tyvars with the same print-name as the quantified
-- tyvar; and then we often fill the box with a tau-tyvar, and again
-- we want to choose the same name.
fillBoxWithTau tv ref
= do { tv' <- tcInstTyVar tv -- Do not gratuitously forget
; let tau = mkTyVarTy tv' -- name of the type variable
; writeMutVar ref (Indirect tau)
; return tau }
\end{code}
Error mesages in case of kind mismatch.
\begin{code}
unifyKindMisMatch ty1 ty2
= zonkTcKind ty1 `thenM` \ ty1' ->
zonkTcKind ty2 `thenM` \ ty2' ->
let
msg = hang (ptext SLIT("Couldn't match kind"))
2 (sep [quotes (ppr ty1'),
ptext SLIT("against"),
quotes (ppr ty2')])
in
failWithTc msg
unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred
-- tv1 and ty2 are zonked already
= returnM msg
where
msg = (env2, ptext SLIT("When matching the kinds of") <+>
sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual])
(pp_expected, pp_actual) | swapped = (pp2, pp1)
| otherwise = (pp1, pp2)
(env1, tv1') = tidyOpenTyVar tidy_env tv1
(env2, ty2') = tidyOpenType env1 ty2
pp1 = ppr tv1' <+> dcolon <+> ppr (tyVarKind tv1)
pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2)
\end{code}
Error message for failure due to an occurs check.
\begin{code}
occurCheckErr :: TcType -> TcType -> TcM a
occurCheckErr ty containingTy
= do { env0 <- tcInitTidyEnv
; ty' <- zonkTcType ty
; containingTy' <- zonkTcType containingTy
; let (env1, tidy_ty1) = tidyOpenType env0 ty'
(env2, tidy_ty2) = tidyOpenType env1 containingTy'
extra = sep [ppr tidy_ty1, char '=', ppr tidy_ty2]
; failWithTcM (env2, hang msg 2 extra) }
where
msg = ptext SLIT("Occurs check: cannot construct the infinite type:")
\end{code}
%************************************************************************ %************************************************************************
%* * %* *
Kind variables Kind variables
...@@ -136,6 +317,9 @@ newCoVars spec ...@@ -136,6 +317,9 @@ newCoVars spec
(mkCoKind ty1 ty2) (mkCoKind ty1 ty2)
| ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] } | ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] }
newMetaCoVar :: TcType -> TcType -> TcM TcTyVar
newMetaCoVar ty1 ty2 = newMetaTyVar TauTv (mkCoKind ty1 ty2)
newKindVar :: TcM TcKind newKindVar :: TcM TcKind
newKindVar = do { uniq <- newUnique newKindVar = do { uniq <- newUnique
; ref <- newMutVar Flexi ; ref <- newMutVar Flexi
...@@ -886,7 +1070,6 @@ kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of ...@@ -886,7 +1070,6 @@ kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of
\end{code} \end{code}
%************************************************************************ %************************************************************************
%* * %* *
\subsection{Checking a theta or source type} \subsection{Checking a theta or source type}
...@@ -1097,6 +1280,21 @@ arityErr kind name n m ...@@ -1097,6 +1280,21 @@ arityErr kind name n m
n_arguments | n == 0 = ptext SLIT("no arguments") n_arguments | n == 0 = ptext SLIT("no arguments")
| n == 1 = ptext SLIT("1 argument") | n == 1 = ptext SLIT("1 argument")
| True = hsep [int n, ptext SLIT("arguments")] | True = hsep [int n, ptext SLIT("arguments")]
-----------------
notMonoType ty
= do { ty' <- zonkTcType ty
; env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 ty'
msg = ptext SLIT("Cannot match a monotype with") <+> quotes (ppr tidy_ty)
; failWithTcM (env1, msg) }
notMonoArgs ty
= do { ty' <- zonkTcType ty
; env0 <- tcInitTidyEnv
; let (env1, tidy_ty) = tidyOpenType env0 ty'
msg = ptext SLIT("Arguments of type synonym families must be monotypes") <+> quotes (ppr tidy_ty)
; failWithTcM (env1, msg) }
\end{code} \end{code}
......
...@@ -715,23 +715,22 @@ data Inst ...@@ -715,23 +715,22 @@ data Inst
| EqInst { -- delayed unification of the form | EqInst { -- delayed unification of the form
-- co :: ty1 ~ ty2 -- co :: ty1 ~ ty2
tci_left :: TcType, -- ty1 tci_left :: TcType, -- ty1 -- both types are...
tci_right :: TcType, -- ty2 tci_right :: TcType, -- ty2 -- ...free of boxes
tci_co :: Either -- co tci_co :: Either -- co
TcTyVar -- a wanted equation, with a hole, to be TcTyVar -- - a wanted equation, with a hole, to be
-- filled with a witness for the equality -- filled with a witness for the equality;
-- for equation generated by the -- for equation arising from deferring
-- unifier, 'ty1' is the actual and -- unification, 'ty1' is the actual and
-- 'ty2' the expected type -- 'ty2' the expected type
Coercion, -- a given equation, with a coercion Coercion, -- - a given equation, with a coercion
-- witnessing the equality -- witnessing the equality;
-- a coercion that originates from a -- a coercion that originates from a
-- signature or a GADT is a CoVar, but -- signature or a GADT is a CoVar, but
-- after normalisation of coercions, -- after normalisation of coercions, they
-- they can be arbitrary Coercions -- can be arbitrary Coercions involving
-- involving constructors and -- constructors and pseudo-constructors
-- pseudo-constructors like sym and -- like sym and trans.
-- trans.
tci_loc :: InstLoc, tci_loc :: InstLoc,
tci_name :: Name -- Debugging help only: this makes it easier to tci_name :: Name -- Debugging help only: this makes it easier to
......
...@@ -1455,7 +1455,8 @@ tcSimplifyRuleLhs wanteds ...@@ -1455,7 +1455,8 @@ tcSimplifyRuleLhs wanteds
-- to fromInteger; this looks fragile to me -- to fromInteger; this looks fragile to me
; lookup_result <- lookupSimpleInst w' ; lookup_result <- lookupSimpleInst w'
; case lookup_result of ; case lookup_result of
GenInst ws' rhs -> go dicts (addBind binds w rhs) (ws' ++ ws) GenInst ws' rhs ->
go dicts (addInstToDictBind binds w rhs) (ws' ++ ws)
NoInstance -> pprPanic "tcSimplifyRuleLhs" (ppr w) NoInstance -> pprPanic "tcSimplifyRuleLhs" (ppr w)
} }
\end{code} \end{code}
...@@ -1705,7 +1706,7 @@ reduceContext env wanteds ...@@ -1705,7 +1706,7 @@ reduceContext env wanteds
; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs ; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
-- 1. Normalise the *given* *equality* constraints -- 1. Normalise the *given* *equality* constraints
; (given_eqs, eliminate_skolems) <- normaliseGivens given_eqs0 ; (given_eqs, eliminate_skolems) <- normaliseGivenEqs given_eqs0
-- 2. Normalise the *given* *dictionary* constraints -- 2. Normalise the *given* *dictionary* constraints
-- wrt. the toplevel and given equations -- wrt. the toplevel and given equations
...@@ -1713,11 +1714,11 @@ reduceContext env wanteds ...@@ -1713,11 +1714,11 @@ reduceContext env wanteds
given_dicts0 given_dicts0
-- 3. Solve the *wanted* *equation* constraints -- 3. Solve the *wanted* *equation* constraints
; eq_irreds0 <- solveWanteds given_eqs wanted_eqs ; eq_irreds0 <- solveWantedEqs given_eqs wanted_eqs
-- 4. Normalise the *wanted* equality constraints with respect to -- 4. Normalise the *wanted* equality constraints with respect to
-- each other -- each other
; eq_irreds <- normaliseWanteds eq_irreds0 ; eq_irreds <- normaliseWantedEqs eq_irreds0
-- 5. Build the Avail mapping from "given_dicts" -- 5. Build the Avail mapping from "given_dicts"
; init_state <- foldlM addGiven emptyAvails given_dicts ; init_state <- foldlM addGiven emptyAvails given_dicts
...@@ -2299,7 +2300,9 @@ extractResults (Avails _ avails) wanteds ...@@ -2299,7 +2300,9 @@ extractResults (Avails _ avails) wanteds
Just (Given id) Just (Given id)
| id == w_id -> go avails binds irreds (w:givens) ws | id == w_id -> go avails binds irreds (w:givens) ws
| otherwise -> go avails (addBind binds w (nlHsVar id)) irreds (update_id w id:givens) ws | otherwise ->
go avails (addInstToDictBind binds w (nlHsVar id)) irreds
(update_id w id:givens) ws
-- The sought Id can be one of the givens, via a superclass chain -- The sought Id can be one of the givens, via a superclass chain
-- and then we definitely don't want to generate an x=x binding! -- and then we definitely don't want to generate an x=x binding!
...@@ -2311,7 +2314,7 @@ extractResults (Avails _ avails) wanteds ...@@ -2311,7 +2314,7 @@ extractResults (Avails _ avails) wanteds
Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds givens (ws' ++ ws) Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds givens (ws' ++ ws)
where where
new_binds = addBind binds w rhs new_binds = addInstToDictBind binds w rhs
where where
w_id = instToId w w_id = instToId w
update_id m@(Method{}) id = m {tci_id = id} update_id m@(Method{}) id = m {tci_id = id}
...@@ -2348,7 +2351,7 @@ extractLocalResults (Avails _ avails) wanteds ...@@ -2348,7 +2351,7 @@ extractLocalResults (Avails _ avails) wanteds
Just (Rhs rhs ws') -> go (add_given avails w) new_binds givens (ws' ++ ws) Just (Rhs rhs ws') -> go (add_given avails w) new_binds givens (ws' ++ ws)
where where
new_binds = addBind binds w rhs new_binds = addInstToDictBind binds w rhs
where where
w_id = instToId w w_id = instToId w
...@@ -2449,6 +2452,7 @@ addAvailAndSCs want_scs avails inst avail ...@@ -2449,6 +2452,7 @@ addAvailAndSCs want_scs avails inst avail
find_all :: IdSet -> Inst -> IdSet find_all :: IdSet -> Inst -> IdSet
find_all so_far kid find_all so_far kid
| isEqInst kid = so_far
| kid_id `elemVarSet` so_far = so_far | kid_id `elemVarSet` so_far = so_far
| Just avail <- findAvail avails kid = findAllDeps so_far' avail | Just avail <- findAvail avails kid = findAllDeps so_far' avail
| otherwise = so_far' | otherwise = so_far'
...@@ -2915,7 +2919,7 @@ report_no_instances tidy_env mb_what insts ...@@ -2915,7 +2919,7 @@ report_no_instances tidy_env mb_what insts
; mapM_ complain_implic implics ; mapM_ complain_implic implics
; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
; groupErrs complain_no_inst insts3 ; groupErrs complain_no_inst insts3
; mapM_ complain_eq eqInsts ; mapM_ eqInstMisMatch eqInsts
} }
where where
complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts) complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
...@@ -2925,13 +2929,6 @@ report_no_instances tidy_env mb_what insts ...@@ -2925,13 +2929,6 @@ report_no_instances tidy_env mb_what insts
(Just (tci_loc inst, tci_given inst)) (Just (tci_loc inst, tci_given inst))
(tci_wanted inst) (tci_wanted inst)
complain_eq EqInst {tci_left = lty, tci_right = rty,
tci_loc = InstLoc _ _ ctxt}
= do { (env, msg) <- misMatchMsg lty rty
; setErrCtxt ctxt $
failWithTcM (env, msg)
}
check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc
-- Right msg => overlap message -- Right msg => overlap message
-- Left inst => no instance -- Left inst => no instance
...@@ -3084,36 +3081,4 @@ reduceDepthErr n stack ...@@ -3084,36 +3081,4 @@ reduceDepthErr n stack
nest 4 (pprStack stack)] nest 4 (pprStack stack)]
pprStack stack = vcat (map pprInstInFull stack) pprStack stack = vcat (map pprInstInFull stack)
-----------------------
misMatchMsg :: TcType -> TcType -> TcM (TidyEnv, SDoc)
-- Generate the message when two types fail to match,
-- going to some trouble to make it helpful.
-- The argument order is: actual type, expected type
misMatchMsg ty_act ty_exp
= do { env0 <- tcInitTidyEnv
; ty_exp <- zonkTcType ty_exp
; ty_act <- zonkTcType ty_act
; (env1, pp_exp, extra_exp) <- ppr_ty env0 ty_exp
; (env2, pp_act, extra_act) <- ppr_ty env1 ty_act
; return (env2,
sep [sep [ptext SLIT("Couldn't match expected type") <+> pp_exp,
nest 7 $
ptext SLIT("against inferred type") <+> pp_act],
nest 2 (extra_exp $$ extra_act)]) }
ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc)
ppr_ty env ty
= do { let (env1, tidy_ty) = tidyOpenType env ty
; (env2, extra) <- ppr_extra env1 tidy_ty
; return (env2, quotes (ppr tidy_ty), extra) }
-- (ppr_extra env ty) shows extra info about 'ty'
ppr_extra env (TyVarTy tv)
| isSkolemTyVar tv || isSigTyVar tv
= return (env1, pprSkolTvBinding tv1)
where
(env1, tv1) = tidySkolemTyVar env tv
ppr_extra env ty = return (env, empty) -- Normal case
\end{code} \end{code}
This diff is collapsed.
...@@ -22,7 +22,7 @@ module TcUnify ( ...@@ -22,7 +22,7 @@ module TcUnify (
unifyType, unifyTypeList, unifyTheta, unifyType, unifyTypeList, unifyTheta,
unifyKind, unifyKinds, unifyFunKind, unifyKind, unifyKinds, unifyFunKind,
checkExpectedKind, checkExpectedKind,
preSubType, boxyMatchTypes, preSubType, boxyMatchTypes,
-------------------------------- --------------------------------
-- Holes -- Holes
...@@ -1126,9 +1126,9 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 ...@@ -1126,9 +1126,9 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2
-- need to defer unification by generating a wanted equality constraint. -- need to defer unification by generating a wanted equality constraint.
go1 outer ty1 ty2 go1 outer ty1 ty2
| ty1_is_fun || ty2_is_fun | ty1_is_fun || ty2_is_fun
= do { (coi1, ty1') <- if ty1_is_fun then tcNormalizeFamInst ty1 = do { (coi1, ty1') <- if ty1_is_fun then tcNormaliseFamInst ty1
else return (IdCo, ty1) else return (IdCo, ty1)
; (coi2, ty2') <- if ty2_is_fun then tcNormalizeFamInst ty2 ; (coi2, ty2') <- if ty2_is_fun then tcNormaliseFamInst ty2
else return (IdCo, ty2) else return (IdCo, ty2)
; coi <- if isOpenSynTyConApp ty1' || isOpenSynTyConApp ty2' ; coi <- if isOpenSynTyConApp ty1' || isOpenSynTyConApp ty2'
then do { -- One type family app can't be reduced yet then do { -- One type family app can't be reduced yet
...@@ -1329,7 +1329,7 @@ uUnfilledVar outer swapped tv1 details1 ps_ty2 non_var_ty2 ...@@ -1329,7 +1329,7 @@ uUnfilledVar outer swapped tv1 details1 ps_ty2 non_var_ty2
| isOpenSynTyConApp non_var_ty2 | isOpenSynTyConApp non_var_ty2
= -- 'non_var_ty2's outermost constructor is a type family, = -- 'non_var_ty2's outermost constructor is a type family,
-- which we may may be able to normalise -- which we may may be able to normalise
do { (coi2, ty2') <- tcNormalizeFamInst non_var_ty2 do { (coi2, ty2') <- tcNormaliseFamInst non_var_ty2
; case coi2 of ; case coi2 of
IdCo -> -- no progress, but maybe after other instantiations IdCo -> -- no progress, but maybe after other instantiations
defer_unification outer swapped (TyVarTy tv1) ps_ty2 defer_unification outer swapped (TyVarTy tv1) ps_ty2
...@@ -1390,7 +1390,7 @@ defer_unification outer False ty1 ty2 ...@@ -1390,7 +1390,7 @@ defer_unification outer False ty1 ty2
= do { ty1' <- unBox ty1 >>= zonkTcType -- unbox *and* zonk.. = do { ty1' <- unBox ty1 >>= zonkTcType -- unbox *and* zonk..