Commit 27310213 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Major refactoring of the type inference engine

This patch embodies many, many changes to the contraint solver, which
make it simpler, more robust, and more beautiful.  But it has taken
me ages to get right. The forcing issue was some obscure programs
involving recursive dictionaries, but these eventually led to a
massive refactoring sweep.

Main changes are:
 * No more "frozen errors" in the monad.  Instead "insoluble
   constraints" are now part of the WantedConstraints type.

 * The WantedConstraint type is a product of bags, instead of (as
   before) a bag of sums.  This eliminates a good deal of tagging and
   untagging.

 * This same WantedConstraints data type is used
     - As the way that constraints are gathered
     - As a field of an implication constraint
     - As both argument and result of solveWanted
     - As the argument to reportUnsolved

 * We do not generate any evidence for Derived constraints. They are
   purely there to allow "impovement" by unifying unification
   variables.

 * In consequence, nothing is ever *rewritten* by a Derived
   constraint.  This removes, by construction, all the horrible
   potential recursive-dictionary loops that were making us tear our
   hair out.  No more isGoodRecEv search either. Hurrah!

 * We add the superclass Derived constraints during canonicalisation,
   after checking for duplicates.  So fewer superclass constraints
   are generated than before.

 * Skolem tc-tyvars no longer carry SkolemInfo.  Instead, the
   SkolemInfo lives in the GivenLoc of the Implication, where it
   can be tidied, zonked, and substituted nicely.  This alone is
   a major improvement.

 * Tidying is improved, so that we tend to get t1, t2, t3, rather
   than t1, t11, t111, etc

   Moreover, unification variables are always printed with a digit
   (thus a0, a1, etc), so that plain 'a' is available for a skolem
   arising from a type signature etc. In this way,
     (a) We quietly say which variables are unification variables,
         for those who know and care
     (b) Types tend to get printed as the user expects.  If he writes
             f :: a -> a
             f = ...blah...
         then types involving 'a' get printed with 'a', rather than
         some tidied variant.

 * There are significant improvements in error messages, notably
   in the "Cannot deduce X from Y" messages.
parent fd6de028
......@@ -280,7 +280,7 @@ mkSystemVarName :: Unique -> FastString -> Name
mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)
mkSysTvName :: Unique -> FastString -> Name
mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs)
mkSysTvName uniq fs = mkSystemName uniq (mkOccNameFS tvName fs)
-- | Make a name for a foreign call
mkFCallName :: Unique -> String -> Name
......
......@@ -42,7 +42,7 @@ module OccName (
mkTyVarOcc, mkTyVarOccFS,
mkTcOcc, mkTcOccFS,
mkClsOcc, mkClsOccFS,
mkDFunOcc,
mkDFunOcc,
mkTupleOcc,
setOccNameSpace,
......@@ -720,7 +720,9 @@ tidyOccName in_scope occ@(OccName occ_sp fs)
Just n -> -- Already used: make a new guess,
-- change the guess base, and try again
tidyOccName (extendOccEnv in_scope occ (n+1))
(mkOccName occ_sp (unpackFS fs ++ show n))
(mkOccName occ_sp (base_occ ++ show n))
where
base_occ = reverse (dropWhile isDigit (reverse (unpackFS fs)))
\end{code}
%************************************************************************
......
......@@ -50,7 +50,7 @@ module Var (
mkTyVar, mkTcTyVar, mkWildCoVar,
-- ** Taking 'TyVar's apart
tyVarName, tyVarKind, tcTyVarDetails,
tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
setTyVarName, setTyVarUnique, setTyVarKind,
......@@ -283,6 +283,9 @@ mkTcTyVar name kind details
tcTyVarDetails :: TyVar -> TcTyVarDetails
tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
\end{code}
%************************************************************************
......
......@@ -576,13 +576,10 @@ type RttiInstantiation = [(TcTyVar, TyVar)]
-- | Returns the instantiated type scheme ty', and the
-- mapping from new (instantiated) -to- old (skolem) type variables
-- We want this mapping just for old RuntimeUnkSkols, to avoid
-- gratuitously changing their unique on every trip
instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme (tvs, ty)
= liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs
, isRuntimeUnkSkol tv]
; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
; return (substTy subst ty, rtti_inst) }
applyRevSubst :: RttiInstantiation -> TR ()
......@@ -1132,7 +1129,7 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
where
zonk_unbound_meta tv
= ASSERT( isTcTyVar tv )
do { tv' <- skolemiseUnboundMetaTyVar RuntimeUnkSkol tv
do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
-- This is where RuntimeUnkSkols are born:
-- otherwise-unconstrained unification variables are
-- turned into RuntimeUnkSkols as they leave the
......
......@@ -860,17 +860,21 @@ emptyModIface mod
-- | Interactive context, recording information relevant to GHCi
data InteractiveContext
= InteractiveContext {
ic_toplev_scope :: [Module], -- ^ The context includes the "top-level" scope of
ic_toplev_scope :: [Module] -- ^ The context includes the "top-level" scope of
-- these modules
ic_exports :: [(Module, Maybe (ImportDecl RdrName))], -- ^ The context includes just the exported parts of these
, ic_exports :: [(Module, Maybe (ImportDecl RdrName))] -- ^ The context includes just the exported parts of these
-- modules
ic_rn_gbl_env :: GlobalRdrEnv, -- ^ The contexts' cached 'GlobalRdrEnv', built from
, ic_rn_gbl_env :: GlobalRdrEnv -- ^ The contexts' cached 'GlobalRdrEnv', built from
-- 'ic_toplev_scope' and 'ic_exports'
ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user.
-- Later Ids shadow earlier ones with the same OccName.
, ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user.
-- Later Ids shadow earlier ones with the same OccName
-- Expressions are typed with these Ids in the envt
-- For runtime-debugging, these Ids may have free
-- TcTyVars of RuntimUnkSkol flavour, but no free TyVars
-- (because the typechecker doesn't expect that)
#ifdef GHCI
, ic_resume :: [Resume] -- ^ The stack of breakpoint contexts
......
......@@ -546,7 +546,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
e_tyvar = mkTcTyVar e_name liftedTypeKind (SkolemTv RuntimeUnkSkol)
e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
ictxt0 = hsc_IC hsc_env
......@@ -572,12 +572,16 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
occs = modBreaks_vars breaks ! index
span = modBreaks_locs breaks ! index
-- filter out any unboxed ids; we can't bind these at the prompt
let pointers = filter (\(id,_) -> isPointer id) vars
-- Filter out any unboxed ids;
-- we can't bind these at the prompt
pointers = filter (\(id,_) -> isPointer id) vars
isPointer id | PtrRep <- idPrimRep id = True
| otherwise = False
let (ids, offsets) = unzip pointers
(ids, offsets) = unzip pointers
free_tvs = foldr (unionVarSet . tyVarsOfType . idType)
(tyVarsOfType result_ty) ids
-- It might be that getIdValFromApStack fails, because the AP_STACK
-- has been accidentally evaluated, or something else has gone wrong.
......@@ -589,15 +593,18 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost"
new_ids <- zipWithM mkNewId occs filtered_ids
let names = map idName new_ids
us <- mkSplitUniqSupply 'I'
let (us1, us2) = splitUniqSupply us
tv_subst = newTyVars us1 free_tvs
new_ids = zipWith3 (mkNewId tv_subst) occs filtered_ids (uniqsFromSupply us2)
names = map idName new_ids
-- make an Id for _result. We use the Unique of the FastString "_result";
-- we don't care about uniqueness here, because there will only be one
-- _result in scope at any time.
let result_name = mkInternalName (getUnique result_fs)
(mkVarOccFS result_fs) span
result_id = Id.mkVanillaGlobal result_name result_ty
result_id = Id.mkVanillaGlobal result_name (substTy tv_subst result_ty)
-- for each Id we're about to bind in the local envt:
-- - tidy the type variables
......@@ -619,20 +626,25 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span)
where
mkNewId :: OccName -> Id -> IO Id
mkNewId occ id = do
us <- mkSplitUniqSupply 'I'
-- we need a fresh Unique for each Id we bind, because the linker
-- We need a fresh Unique for each Id we bind, because the linker
-- state is single-threaded and otherwise we'd spam old bindings
-- whenever we stop at a breakpoint. The InteractveContext is properly
-- saved/restored, but not the linker state. See #1743, test break026.
let
uniq = uniqFromSupply us
loc = nameSrcSpan (idName id)
name = mkInternalName uniq occ loc
ty = idType id
new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
return new_id
mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id
mkNewId tv_subst occ id uniq
= Id.mkVanillaGlobalWithInfo name ty (idInfo id)
where
loc = nameSrcSpan (idName id)
name = mkInternalName uniq occ loc
ty = substTy tv_subst (idType id)
newTyVars :: UniqSupply -> TcTyVarSet -> TvSubst
-- Similarly, clone the type variables mentioned in the types
-- we have here, *and* make them all RuntimeUnk tyars
newTyVars us tvs
= mkTopTvSubst [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
| (tv, uniq) <- varSetElems tvs `zip` uniqsFromSupply us
, let name = setNameUnique (tyVarName tv) uniq ]
rttiEnvironment :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
......@@ -979,5 +991,7 @@ reconstructType hsc_env bound id = do
hv <- Linker.getHValue hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
#endif /* GHCI */
......@@ -178,8 +178,7 @@ checkForConflicts inst_envs famInst
-- We use tcInstSkolType because we don't want to allocate
-- fresh *meta* type variables.
; skol_tvs <- tcInstSkolTyVars FamInstSkol
(tyConTyVars (famInstTyCon famInst))
; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
; unless (null conflicts) $
conflictInstErr famInst (fst (head conflicts))
......
......@@ -18,13 +18,16 @@ module Inst (
tcSyntaxName,
-- Simple functions over evidence variables
hasEqualities,
hasEqualities, unitImplication,
tyVarsOfWanteds, tyVarsOfWanted, tyVarsOfWantedEvVar, tyVarsOfWantedEvVars,
tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX,
tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
tidyWanteds, tidyWanted, tidyWantedEvVar, tidyWantedEvVars,
tidyEvVar, tidyImplication
tidyWantedEvVar, tidyWantedEvVars, tidyWC,
tidyEvVar, tidyImplication, tidyFlavoredEvVar,
substWantedEvVar, substWantedEvVars, substFlavoredEvVar,
substEvVar, substImplication
) where
#include "HsVersions.h"
......@@ -47,7 +50,7 @@ import Coercion
import HscTypes
import Id
import Name
import Var ( Var, TyVar, EvVar, varType, setVarType )
import Var
import VarEnv
import VarSet
import PrelNames
......@@ -57,7 +60,7 @@ import Bag
import Maybes
import Util
import Outputable
import Data.List
import Data.List( mapAccumL )
\end{code}
......@@ -75,7 +78,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta
emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred = do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred
; emitConstraint (WcEvVar (WantedEvVar ev loc))
; emitFlat (mkEvVarX ev loc)
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
......@@ -136,17 +139,16 @@ ToDo: this eta-abstraction plays fast and loose with termination,
\begin{code}
deeplySkolemise
:: SkolemInfo
-> TcSigmaType
:: TcSigmaType
-> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
deeplySkolemise skol_info ty
deeplySkolemise ty
| Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
= do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
; tvs1 <- mapM (tcInstSkolTyVar skol_info) tvs
; tvs1 <- tcInstSkolTyVars tvs
; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1)
; ev_vars1 <- newEvVars (substTheta subst theta)
; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise skol_info (substTy subst ty')
; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
; return ( mkWpLams ids1
<.> mkWpTyLams tvs1
<.> mkWpLams ev_vars1
......@@ -415,7 +417,7 @@ addLocalInst home_ie ispec
-- This is absurdly delicate.
let dfun = instanceDFunId ispec
; (tvs', theta', tau') <- tcInstSkolType UnkSkol (idType dfun)
; (tvs', theta', tau') <- tcInstSkolType (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun'
......@@ -477,6 +479,11 @@ addDictLoc ispec thing_inside
%************************************************************************
\begin{code}
unitImplication :: Implication -> Bag Implication
unitImplication implic
| isEmptyWC (ic_wanted implic) = emptyBag
| otherwise = unitBag implic
hasEqualities :: [EvVar] -> Bool
-- Has a bunch of canonical constraints (all givens) got any equalities in it?
hasEqualities givens = any (has_eq . evVarPred) givens
......@@ -485,23 +492,22 @@ hasEqualities givens = any (has_eq . evVarPred) givens
has_eq (IParam {}) = False
has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls)
----------------
tyVarsOfWanteds :: WantedConstraints -> TyVarSet
tyVarsOfWanteds = foldrBag (unionVarSet . tyVarsOfWanted) emptyVarSet
tyVarsOfWanted :: WantedConstraint -> TyVarSet
tyVarsOfWanted (WcEvVar wev) = tyVarsOfWantedEvVar wev
tyVarsOfWanted (WcImplic impl) = tyVarsOfImplication impl
---------------- Getting free tyvars -------------------------
tyVarsOfWC :: WantedConstraints -> TyVarSet
tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= tyVarsOfEvVarXs flat `unionVarSet`
tyVarsOfBag tyVarsOfImplication implic `unionVarSet`
tyVarsOfEvVarXs insol
tyVarsOfImplication :: Implication -> TyVarSet
tyVarsOfImplication implic = tyVarsOfWanteds (ic_wanted implic)
`minusVarSet` (ic_skols implic)
tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted })
= tyVarsOfWC wanted `minusVarSet` skols
tyVarsOfWantedEvVar :: WantedEvVar -> TyVarSet
tyVarsOfWantedEvVar (WantedEvVar ev _) = tyVarsOfEvVar ev
tyVarsOfEvVarX :: EvVarX a -> TyVarSet
tyVarsOfEvVarX (EvVarX ev _) = tyVarsOfEvVar ev
tyVarsOfWantedEvVars :: Bag WantedEvVar -> TyVarSet
tyVarsOfWantedEvVars = foldrBag (unionVarSet . tyVarsOfWantedEvVar) emptyVarSet
tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet
tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX
tyVarsOfEvVar :: EvVar -> TyVarSet
tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
......@@ -509,29 +515,94 @@ tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
tyVarsOfEvVars :: [EvVar] -> TyVarSet
tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
---------------
tidyWanteds :: TidyEnv -> WantedConstraints -> WantedConstraints
tidyWanteds env = mapBag (tidyWanted env)
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
---------------- Tidying -------------------------
tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints
tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= WC { wc_flat = tidyWantedEvVars env flat
, wc_impl = mapBag (tidyImplication env) implic
, wc_insol = mapBag (tidyFlavoredEvVar env) insol }
tidyWanted :: TidyEnv -> WantedConstraint -> WantedConstraint
tidyWanted env (WcEvVar wev) = WcEvVar (tidyWantedEvVar env wev)
tidyWanted env (WcImplic implic) = WcImplic (tidyImplication env implic)
tidyImplication :: TidyEnv -> Implication -> Implication
tidyImplication env implic@(Implic { ic_skols = tvs
, ic_given = given
, ic_wanted = wanted
, ic_loc = loc })
= implic { ic_skols = mkVarSet tvs'
, ic_given = map (tidyEvVar env1) given
, ic_wanted = tidyWC env1 wanted
, ic_loc = tidyGivenLoc env1 loc }
where
(env1, tvs') = mapAccumL tidyTyVarBndr env (varSetElems tvs)
tidyEvVar :: TidyEnv -> EvVar -> EvVar
tidyEvVar env var = setVarType var (tidyType env (varType var))
tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar
tidyWantedEvVar env (WantedEvVar ev loc) = WantedEvVar (tidyEvVar env ev) loc
tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l
tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
tidyEvVar :: TidyEnv -> EvVar -> EvVar
tidyEvVar env v = setVarType v (tidyType env (varType v))
tidyImplication :: TidyEnv -> Implication -> Implication
tidyImplication env implic@(Implic { ic_skols = skols, ic_given = given
, ic_wanted = wanted })
= implic { ic_skols = mkVarSet skols'
, ic_given = map (tidyEvVar env') given
, ic_wanted = tidyWanteds env' wanted }
tidyFlavoredEvVar :: TidyEnv -> FlavoredEvVar -> FlavoredEvVar
tidyFlavoredEvVar env (EvVarX v fl)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
tidyFlavor _ fl = fl
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span ctxt
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
tidySkolemInfo _ info = info
---------------- Substitution -------------------------
substWC :: TvSubst -> WantedConstraints -> WantedConstraints
substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= WC { wc_flat = substWantedEvVars subst flat
, wc_impl = mapBag (substImplication subst) implic
, wc_insol = mapBag (substFlavoredEvVar subst) insol }
substImplication :: TvSubst -> Implication -> Implication
substImplication subst implic@(Implic { ic_skols = tvs
, ic_given = given
, ic_wanted = wanted
, ic_loc = loc })
= implic { ic_skols = mkVarSet tvs'
, ic_given = map (substEvVar subst1) given
, ic_wanted = substWC subst1 wanted
, ic_loc = substGivenLoc subst1 loc }
where
(env', skols') = mapAccumL tidyTyVarBndr env (varSetElems skols)
(subst1, tvs') = mapAccumL substTyVarBndr subst (varSetElems tvs)
substEvVar :: TvSubst -> EvVar -> EvVar
substEvVar subst var = setVarType var (substTy subst (varType var))
substWantedEvVars :: TvSubst -> Bag WantedEvVar -> Bag WantedEvVar
substWantedEvVars subst = mapBag (substWantedEvVar subst)
substWantedEvVar :: TvSubst -> WantedEvVar -> WantedEvVar
substWantedEvVar subst (EvVarX v l) = EvVarX (substEvVar subst v) l
substFlavoredEvVar :: TvSubst -> FlavoredEvVar -> FlavoredEvVar
substFlavoredEvVar subst (EvVarX v fl)
= EvVarX (substEvVar subst v) (substFlavor subst fl)
substFlavor :: TvSubst -> CtFlavor -> CtFlavor
substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
substFlavor _ fl = fl
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids)
substSkolemInfo _ info = info
\end{code}
\ No newline at end of file
......@@ -237,7 +237,7 @@ tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty)
tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
; [w_tv] <- tcInstSkolTyVars ArrowSkol [alphaTyVar]
; [w_tv] <- tcInstSkolTyVars [alphaTyVar]
; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point
-- a ((w,t1) .. tn) t
......
......@@ -33,7 +33,6 @@ import Var
import Name
import NameSet
import NameEnv
import VarSet
import SrcLoc
import Bag
import ErrUtils
......@@ -388,11 +387,10 @@ tcPolyCheck :: TcSigInfo -> PragFun
-- it binds a single variable,
-- it has a signature,
tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
, sig_theta = theta, sig_loc = loc })
, sig_theta = theta, sig_tau = tau, sig_loc = loc })
prag_fn rec_tc bind_list
= do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName id))
; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau)
; (ev_binds, (binds', [mono_info]))
<- checkConstraints skol_info tvs ev_vars $
tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
......@@ -423,12 +421,8 @@ tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
; let get_tvs | isTopLevel top_lvl = tyVarsOfType
| otherwise = exactTyVarsOfType
-- See Note [Silly type synonym] in TcType
tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos
; (qtvs, givens, ev_binds) <- simplifyInfer mono tau_tvs wanted
; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
; (qtvs, givens, ev_binds) <- simplifyInfer top_lvl mono name_taus wanted
; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens))
mono_infos
......@@ -545,14 +539,13 @@ tcSpec poly_id prag@(SpecSig _ hs_ty inl)
; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
(ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id))
-- Note [SPECIALISE pragmas]
; wrap <- tcSubType origin skol_info (idType poly_id) spec_ty
; wrap <- tcSubType origin sig_ctxt (idType poly_id) spec_ty
; return (SpecPrag poly_id wrap inl) }
where
name = idName poly_id
poly_ty = idType poly_id
origin = SpecPragOrigin name
sig_ctxt = FunSigCtxt name
skol_info = SigSkol sig_ctxt
spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
tcSpec _ prag = pprPanic "tcSpec" (ppr prag)
......@@ -700,9 +693,6 @@ type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
-- Type signature (if any), and
-- the monomorphic bound things
getMonoType :: MonoBindInfo -> TcTauType
getMonoType (_,_,mono_id) = idType mono_id
tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
| Just sig <- sig_fn name
......@@ -1049,7 +1039,10 @@ tcInstSig sig_fn use_skols name
| Just (scoped_tvs, loc) <- sig_fn name
= do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
-- scope when starting the binding group
; (tvs, theta, tau) <- tcInstSigType use_skols name (idType poly_id)
; let poly_ty = idType poly_id
; (tvs, theta, tau) <- if use_skols
then tcInstType tcInstSkolTyVars poly_ty
else tcInstType tcInstSigTyVars poly_ty
; let sig = TcSigInfo { sig_id = poly_id
, sig_scoped = scoped_tvs
, sig_tvs = tvs, sig_theta = theta, sig_tau = tau
......
This diff is collapsed.
......@@ -168,10 +168,9 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
-- default methods. Better to make separate AbsBinds for each
; let
(tyvars, _, _, op_items) = classBigSig clas
rigid_info = ClsSkol clas
prag_fn = mkPragFun sigs default_binds
prag_fn = mkPragFun sigs default_binds
sig_fn = mkSigFun sigs
clas_tyvars = tcSkolSigTyVars rigid_info tyvars
clas_tyvars = tcSuperSkolTyVars tyvars
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
......
......@@ -203,6 +203,7 @@ tcLookupFamInst tycon tys
= do { env <- getGblEnv
; eps <- getEps
; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv)
; case lookupFamInstEnv instEnv tycon tys of
[] -> return Nothing
((fam_inst, rep_tys):_)
......
This diff is collapsed.
......@@ -82,7 +82,7 @@ tcPolyExpr expr res_ty
tcPolyExprNC expr res_ty
= do { traceTc "tcPolyExprNC" (ppr res_ty)
; (gen_fn, expr') <- tcGen (GenSkol res_ty) res_ty $ \ _ rho ->
; (gen_fn, expr') <- tcGen GenSigCtxt res_ty $ \ _ rho ->
tcMonoExprNC expr rho
; return (mkLHsWrap gen_fn expr') }
......@@ -191,7 +191,7 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty
-- Remember to extend the lexical type-variable environment
; (gen_fn, expr')
<- tcGen (SigSkol ExprSigCtxt) sig_tc_ty $ \ skol_tvs res_ty ->
<- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
-- See Note [More instantiated than scoped] in TcBinds
tcMonoExprNC expr res_ty
......@@ -819,7 +819,8 @@ tcApp fun args res_ty
-- Typecheck the result, thereby propagating
-- info (if any) from result into the argument types
-- Both actual_res_ty and res_ty are deeply skolemised
; co_res <- unifyType actual_res_ty res_ty
; co_res <- addErrCtxt (funResCtxt fun) $
unifyType actual_res_ty res_ty
-- Typecheck the arguments
; args1 <- tcArgs fun args expected_arg_tys
......@@ -1384,6 +1385,10 @@ funAppCtxt fun arg arg_no
quotes (ppr fun) <> text ", namely"])
2 (quotes (ppr arg))
funResCtxt :: LHsExpr Name -> SDoc
funResCtxt fun
= ptext (sLit "In the return type of a call of") <+> quotes (ppr fun)
badFieldTypes :: [(Name,TcType)] -> SDoc
badFieldTypes prs
= hang (ptext (sLit "Record update for insufficiently polymorphic field")
......
......@@ -1075,7 +1075,7 @@ zonkTypeCollecting unbound_tv_set
= zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
where
zonk_unbound_tyvar tv
= do { tv' <- zonkQuantifiedTyVar tv
= do { tv' <- zonkQuantifiedTyVar tv
; tv_set <- readMutVar unbound_tv_set
; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
; return (mkTyVarTy tv') }
......
......@@ -867,7 +867,7 @@ tcPatSig ctxt sig res_ty
; if null sig_tvs then do {
-- The type signature binds no type variables,
-- and hence is rigid, so use it to zap the res_ty
wrap <- tcSubType PatSigOrigin (SigSkol ctxt) res_ty sig_ty
wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty
; return (sig_ty, [], wrap)
} else do {
......@@ -896,7 +896,7 @@ tcPatSig ctxt sig res_ty
; sig_tvs' <- tcInstSigTyVars sig_tvs
; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty
sig_tv_tys' = mkTyVarTys sig_tvs'
; wrap <- tcSubType PatSigOrigin (SigSkol ctxt) res_ty sig_ty'
; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
-- Check that each is bound to a distinct type variable,
-- and one that is not already in scope
......
......@@ -13,7 +13,6 @@ import TcBinds
import TcTyClsDecls
import TcClassDcl
import TcPat( addInlinePrags )
import TcSimplify( simplifyTop )
import TcRnMonad
import TcMType
import TcType
......@@ -621,7 +620,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
do { -- Instantiate the instance decl with skolem constants
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id)
; let (clas, inst_tys) = tcSplitDFunHead inst_head
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
......@@ -633,16 +632,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
; orig_ev_vars <- newEvVars orig_theta
; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
; (sc_binds, sc_dicts, sc_args)
<- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
; (sc_dicts, sc_args)
<- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
-- Check that any superclasses gotten from a silent arguemnt
-- can be deduced from the originally-specified dfun arguments
; ct_loc <- getCtLoc ScOrigin
; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
emitConstraints $ listToBag $
[ WcEvVar (WantedEvVar sc ct_loc)
| sc <- sc_dicts, isSilentEvVar sc ]
emitFlats $ listToBag $
[ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ]
-- Deal with 'SPECIALISE instance' pragmas
-- See Note [SPECIALISE instance pragmas]
......@@ -698,7 +696,6 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
, abs_binds = unitBag dict_bind }
; return (unitBag (L loc main_bind) `unionBags`
unionManyBags sc_binds `unionBags`
listToBag meth_binds)
}
where
......@@ -708,23 +705,17 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
loc = getSrcSpan dfun_id
------------------------------
tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr)
-- All superclasses should be either
-- (a) be one of the arguments to the dfun, of
-- (b) be a constant, soluble at top level
tcSuperClass n_ty_args ev_vars pred
| Just (ev, i) <- find n_ty_args ev_vars
= return (emptyBag, ev, DFunLamArg i)
= return (ev, DFunLamArg i)
| otherwise
= ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
do { sc_dict <- newWantedEvVar pred
; loc <- getCtLoc ScOrigin
; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
; let ev_wrap = WpLet (EvBinds ev_binds)
sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
-- It's very important to solve the superclass constraint *in isolation*
-- so that it isn't generated by superclass selection from something else
-- We then generate the (also rather degenerate) top-level binding:
-- sc_dict = let sc_dict = <blah> in sc_dict
-- where <blah> is generated by solving the implication constraint
= ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) -- Constant!
do { sc_dict <- emitWanted ScOrigin pred
; return (sc_dict, DFunConstArg (Var sc_dict)) }
where
find _ [] = Nothing
find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
......@@ -863,7 +854,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt
(idType dfun_id) spec_dfun_ty
; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
where
......
This diff is collapsed.
This diff is collapsed.
......@@ -73,7 +73,7 @@ tcMatchesFun fun_name inf matches exp_ty
; checkArgs fun_name matches
; (wrap_gen, (wrap_fun, group))
<- tcGen (SigSkol (FunSigCtxt fun_name)) exp_ty $ \ _ exp_rho ->
<- tcGen (FunSigCtxt fun_name) exp_ty $ \ _ exp_rho ->
-- Note [Polymorphic expected type for tcMatchesFun]
matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
......
......@@ -669,10 +669,7 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
; checkExistentials ex_tvs penv
; let skol_info = case pe_ctxt penv of
LamPat mc -> PatSkol data_con mc
LetPat {} -> UnkSkol -- Doesn't matter
; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs
; ex_tvs' <- tcInstSuperSkolTyVars ex_tvs
-- Get location from monad, not from ex_tvs
; let pat_ty' = mkTyConApp tycon ctxt_res_tys
......@@ -704,14 +701,17 @@ tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
-- order is *important* as we generate the list of
-- dictionary binders from theta'
no_equalities = not (any isEqPred theta')
skol_info = case pe_ctxt penv of
LamPat mc -> PatSkol data_con mc