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 ...@@ -280,7 +280,7 @@ mkSystemVarName :: Unique -> FastString -> Name
mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs)
mkSysTvName :: Unique -> FastString -> Name 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 -- | Make a name for a foreign call
mkFCallName :: Unique -> String -> Name mkFCallName :: Unique -> String -> Name
......
...@@ -42,7 +42,7 @@ module OccName ( ...@@ -42,7 +42,7 @@ module OccName (
mkTyVarOcc, mkTyVarOccFS, mkTyVarOcc, mkTyVarOccFS,
mkTcOcc, mkTcOccFS, mkTcOcc, mkTcOccFS,
mkClsOcc, mkClsOccFS, mkClsOcc, mkClsOccFS,
mkDFunOcc, mkDFunOcc,
mkTupleOcc, mkTupleOcc,
setOccNameSpace, setOccNameSpace,
...@@ -720,7 +720,9 @@ tidyOccName in_scope occ@(OccName occ_sp fs) ...@@ -720,7 +720,9 @@ tidyOccName in_scope occ@(OccName occ_sp fs)
Just n -> -- Already used: make a new guess, Just n -> -- Already used: make a new guess,
-- change the guess base, and try again -- change the guess base, and try again
tidyOccName (extendOccEnv in_scope occ (n+1)) 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} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -50,7 +50,7 @@ module Var ( ...@@ -50,7 +50,7 @@ module Var (
mkTyVar, mkTcTyVar, mkWildCoVar, mkTyVar, mkTcTyVar, mkWildCoVar,
-- ** Taking 'TyVar's apart -- ** Taking 'TyVar's apart
tyVarName, tyVarKind, tcTyVarDetails, tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's -- ** Modifying 'TyVar's
setTyVarName, setTyVarUnique, setTyVarKind, setTyVarName, setTyVarUnique, setTyVarKind,
...@@ -283,6 +283,9 @@ mkTcTyVar name kind details ...@@ -283,6 +283,9 @@ mkTcTyVar name kind details
tcTyVarDetails :: TyVar -> TcTyVarDetails tcTyVarDetails :: TyVar -> TcTyVarDetails
tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var) tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -576,13 +576,10 @@ type RttiInstantiation = [(TcTyVar, TyVar)] ...@@ -576,13 +576,10 @@ type RttiInstantiation = [(TcTyVar, TyVar)]
-- | Returns the instantiated type scheme ty', and the -- | Returns the instantiated type scheme ty', and the
-- mapping from new (instantiated) -to- old (skolem) type variables -- 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 :: QuantifiedType -> TR (TcType, RttiInstantiation)
instScheme (tvs, ty) instScheme (tvs, ty)
= liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs = liftTcM $ do { (tvs', _, subst) <- tcInstTyVars tvs
; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
, isRuntimeUnkSkol tv]
; return (substTy subst ty, rtti_inst) } ; return (substTy subst ty, rtti_inst) }
applyRevSubst :: RttiInstantiation -> TR () applyRevSubst :: RttiInstantiation -> TR ()
...@@ -1132,7 +1129,7 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta) ...@@ -1132,7 +1129,7 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
where where
zonk_unbound_meta tv zonk_unbound_meta tv
= ASSERT( isTcTyVar tv ) = ASSERT( isTcTyVar tv )
do { tv' <- skolemiseUnboundMetaTyVar RuntimeUnkSkol tv do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
-- This is where RuntimeUnkSkols are born: -- This is where RuntimeUnkSkols are born:
-- otherwise-unconstrained unification variables are -- otherwise-unconstrained unification variables are
-- turned into RuntimeUnkSkols as they leave the -- turned into RuntimeUnkSkols as they leave the
......
...@@ -860,17 +860,21 @@ emptyModIface mod ...@@ -860,17 +860,21 @@ emptyModIface mod
-- | Interactive context, recording information relevant to GHCi -- | Interactive context, recording information relevant to GHCi
data InteractiveContext data InteractiveContext
= 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 -- 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 -- 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_toplev_scope' and 'ic_exports'
ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user. , ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user.
-- Later Ids shadow earlier ones with the same OccName. -- 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 #ifdef GHCI
, ic_resume :: [Resume] -- ^ The stack of breakpoint contexts , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts
......
...@@ -546,7 +546,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do ...@@ -546,7 +546,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do
exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span exn_name = mkInternalName (getUnique exn_fs) (mkVarOccFS exn_fs) span
e_fs = fsLit "e" e_fs = fsLit "e"
e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span 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) exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
ictxt0 = hsc_IC hsc_env ictxt0 = hsc_IC hsc_env
...@@ -572,12 +572,16 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do ...@@ -572,12 +572,16 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
occs = modBreaks_vars breaks ! index occs = modBreaks_vars breaks ! index
span = modBreaks_locs breaks ! index span = modBreaks_locs breaks ! index
-- filter out any unboxed ids; we can't bind these at the prompt -- Filter out any unboxed ids;
let pointers = filter (\(id,_) -> isPointer id) vars -- we can't bind these at the prompt
pointers = filter (\(id,_) -> isPointer id) vars
isPointer id | PtrRep <- idPrimRep id = True isPointer id | PtrRep <- idPrimRep id = True
| otherwise = False | 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 -- It might be that getIdValFromApStack fails, because the AP_STACK
-- has been accidentally evaluated, or something else has gone wrong. -- has been accidentally evaluated, or something else has gone wrong.
...@@ -589,15 +593,18 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do ...@@ -589,15 +593,18 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
debugTraceMsg (hsc_dflags hsc_env) 1 $ debugTraceMsg (hsc_dflags hsc_env) 1 $
text "Warning: _result has been evaluated, some bindings have been lost" text "Warning: _result has been evaluated, some bindings have been lost"
new_ids <- zipWithM mkNewId occs filtered_ids us <- mkSplitUniqSupply 'I'
let names = map idName new_ids 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"; -- 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 -- we don't care about uniqueness here, because there will only be one
-- _result in scope at any time. -- _result in scope at any time.
let result_name = mkInternalName (getUnique result_fs) let result_name = mkInternalName (getUnique result_fs)
(mkVarOccFS result_fs) span (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: -- for each Id we're about to bind in the local envt:
-- - tidy the type variables -- - tidy the type variables
...@@ -619,20 +626,25 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do ...@@ -619,20 +626,25 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do
hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
return (hsc_env1, if result_ok then result_name:names else names, span) return (hsc_env1, if result_ok then result_name:names else names, span)
where where
mkNewId :: OccName -> Id -> IO Id -- We need a fresh Unique for each Id we bind, because the linker
mkNewId occ id = do
us <- mkSplitUniqSupply 'I'
-- we need a fresh Unique for each Id we bind, because the linker
-- state is single-threaded and otherwise we'd spam old bindings -- state is single-threaded and otherwise we'd spam old bindings
-- whenever we stop at a breakpoint. The InteractveContext is properly -- whenever we stop at a breakpoint. The InteractveContext is properly
-- saved/restored, but not the linker state. See #1743, test break026. -- saved/restored, but not the linker state. See #1743, test break026.
let mkNewId :: TvSubst -> OccName -> Id -> Unique -> Id
uniq = uniqFromSupply us mkNewId tv_subst occ id uniq
loc = nameSrcSpan (idName id) = Id.mkVanillaGlobalWithInfo name ty (idInfo id)
name = mkInternalName uniq occ loc where
ty = idType id loc = nameSrcSpan (idName id)
new_id = Id.mkVanillaGlobalWithInfo name ty (idInfo id) name = mkInternalName uniq occ loc
return new_id 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 :: HscEnv -> IO HscEnv
rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
...@@ -979,5 +991,7 @@ reconstructType hsc_env bound id = do ...@@ -979,5 +991,7 @@ reconstructType hsc_env bound id = do
hv <- Linker.getHValue hsc_env (varName id) hv <- Linker.getHValue hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv cvReconstructType hsc_env bound (idType id) hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
#endif /* GHCI */ #endif /* GHCI */
...@@ -178,8 +178,7 @@ checkForConflicts inst_envs famInst ...@@ -178,8 +178,7 @@ checkForConflicts inst_envs famInst
-- We use tcInstSkolType because we don't want to allocate -- We use tcInstSkolType because we don't want to allocate
-- fresh *meta* type variables. -- fresh *meta* type variables.
; skol_tvs <- tcInstSkolTyVars FamInstSkol ; skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst))
(tyConTyVars (famInstTyCon famInst))
; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs ; let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs
; unless (null conflicts) $ ; unless (null conflicts) $
conflictInstErr famInst (fst (head conflicts)) conflictInstErr famInst (fst (head conflicts))
......
...@@ -18,13 +18,16 @@ module Inst ( ...@@ -18,13 +18,16 @@ module Inst (
tcSyntaxName, tcSyntaxName,
-- Simple functions over evidence variables -- Simple functions over evidence variables
hasEqualities, hasEqualities, unitImplication,
tyVarsOfWanteds, tyVarsOfWanted, tyVarsOfWantedEvVar, tyVarsOfWantedEvVars, tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX,
tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication, tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
tidyWanteds, tidyWanted, tidyWantedEvVar, tidyWantedEvVars,
tidyEvVar, tidyImplication
tidyWantedEvVar, tidyWantedEvVars, tidyWC,
tidyEvVar, tidyImplication, tidyFlavoredEvVar,
substWantedEvVar, substWantedEvVars, substFlavoredEvVar,
substEvVar, substImplication
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -47,7 +50,7 @@ import Coercion ...@@ -47,7 +50,7 @@ import Coercion
import HscTypes import HscTypes
import Id import Id
import Name import Name
import Var ( Var, TyVar, EvVar, varType, setVarType ) import Var
import VarEnv import VarEnv
import VarSet import VarSet
import PrelNames import PrelNames
...@@ -57,7 +60,7 @@ import Bag ...@@ -57,7 +60,7 @@ import Bag
import Maybes import Maybes
import Util import Util
import Outputable import Outputable
import Data.List import Data.List( mapAccumL )
\end{code} \end{code}
...@@ -75,7 +78,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta ...@@ -75,7 +78,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta
emitWanted :: CtOrigin -> TcPredType -> TcM EvVar emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred = do { loc <- getCtLoc origin emitWanted origin pred = do { loc <- getCtLoc origin
; ev <- newWantedEvVar pred ; ev <- newWantedEvVar pred
; emitConstraint (WcEvVar (WantedEvVar ev loc)) ; emitFlat (mkEvVarX ev loc)
; return ev } ; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
...@@ -136,17 +139,16 @@ ToDo: this eta-abstraction plays fast and loose with termination, ...@@ -136,17 +139,16 @@ ToDo: this eta-abstraction plays fast and loose with termination,
\begin{code} \begin{code}
deeplySkolemise deeplySkolemise
:: SkolemInfo :: TcSigmaType
-> TcSigmaType
-> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType) -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
deeplySkolemise skol_info ty deeplySkolemise ty
| Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
= do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
; tvs1 <- mapM (tcInstSkolTyVar skol_info) tvs ; tvs1 <- tcInstSkolTyVars tvs
; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1) ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1)
; ev_vars1 <- newEvVars (substTheta subst theta) ; 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 ; return ( mkWpLams ids1
<.> mkWpTyLams tvs1 <.> mkWpTyLams tvs1
<.> mkWpLams ev_vars1 <.> mkWpLams ev_vars1
...@@ -415,7 +417,7 @@ addLocalInst home_ie ispec ...@@ -415,7 +417,7 @@ addLocalInst home_ie ispec
-- This is absurdly delicate. -- This is absurdly delicate.
let dfun = instanceDFunId ispec let dfun = instanceDFunId ispec
; (tvs', theta', tau') <- tcInstSkolType UnkSkol (idType dfun) ; (tvs', theta', tau') <- tcInstSkolType (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau' ; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau') dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun' ispec' = setInstanceDFunId ispec dfun'
...@@ -477,6 +479,11 @@ addDictLoc ispec thing_inside ...@@ -477,6 +479,11 @@ addDictLoc ispec thing_inside
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
unitImplication :: Implication -> Bag Implication
unitImplication implic
| isEmptyWC (ic_wanted implic) = emptyBag
| otherwise = unitBag implic
hasEqualities :: [EvVar] -> Bool hasEqualities :: [EvVar] -> Bool
-- Has a bunch of canonical constraints (all givens) got any equalities in it? -- Has a bunch of canonical constraints (all givens) got any equalities in it?
hasEqualities givens = any (has_eq . evVarPred) givens hasEqualities givens = any (has_eq . evVarPred) givens
...@@ -485,23 +492,22 @@ hasEqualities givens = any (has_eq . evVarPred) givens ...@@ -485,23 +492,22 @@ hasEqualities givens = any (has_eq . evVarPred) givens
has_eq (IParam {}) = False has_eq (IParam {}) = False
has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls) has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls)
---------------- ---------------- Getting free tyvars -------------------------
tyVarsOfWanteds :: WantedConstraints -> TyVarSet tyVarsOfWC :: WantedConstraints -> TyVarSet
tyVarsOfWanteds = foldrBag (unionVarSet . tyVarsOfWanted) emptyVarSet tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= tyVarsOfEvVarXs flat `unionVarSet`
tyVarsOfWanted :: WantedConstraint -> TyVarSet tyVarsOfBag tyVarsOfImplication implic `unionVarSet`
tyVarsOfWanted (WcEvVar wev) = tyVarsOfWantedEvVar wev tyVarsOfEvVarXs insol
tyVarsOfWanted (WcImplic impl) = tyVarsOfImplication impl
tyVarsOfImplication :: Implication -> TyVarSet tyVarsOfImplication :: Implication -> TyVarSet
tyVarsOfImplication implic = tyVarsOfWanteds (ic_wanted implic) tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted })
`minusVarSet` (ic_skols implic) = tyVarsOfWC wanted `minusVarSet` skols
tyVarsOfWantedEvVar :: WantedEvVar -> TyVarSet tyVarsOfEvVarX :: EvVarX a -> TyVarSet
tyVarsOfWantedEvVar (WantedEvVar ev _) = tyVarsOfEvVar ev tyVarsOfEvVarX (EvVarX ev _) = tyVarsOfEvVar ev
tyVarsOfWantedEvVars :: Bag WantedEvVar -> TyVarSet tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet
tyVarsOfWantedEvVars = foldrBag (unionVarSet . tyVarsOfWantedEvVar) emptyVarSet tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX
tyVarsOfEvVar :: EvVar -> TyVarSet tyVarsOfEvVar :: EvVar -> TyVarSet
tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
...@@ -509,29 +515,94 @@ tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev ...@@ -509,29 +515,94 @@ tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
tyVarsOfEvVars :: [EvVar] -> TyVarSet tyVarsOfEvVars :: [EvVar] -> TyVarSet
tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
--------------- tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tidyWanteds :: TidyEnv -> WantedConstraints -> WantedConstraints tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
tidyWanteds env = mapBag (tidyWanted env)
---------------- 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 tidyImplication :: TidyEnv -> Implication -> Implication
tidyWanted env (WcEvVar wev) = WcEvVar (tidyWantedEvVar env wev) tidyImplication env implic@(Implic { ic_skols = tvs
tidyWanted env (WcImplic implic) = WcImplic (tidyImplication env implic) , 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 :: 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 :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
tidyWantedEvVars env = mapBag (tidyWantedEvVar env) tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyFlavoredEvVar :: TidyEnv -> FlavoredEvVar -> FlavoredEvVar
tidyEvVar env v = setVarType v (tidyType env (varType v)) tidyFlavoredEvVar env (EvVarX v fl)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyImplication :: TidyEnv -> Implication -> Implication
tidyImplication env implic@(Implic { ic_skols = skols, ic_given = given tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
, ic_wanted = wanted }) tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
= implic { ic_skols = mkVarSet skols' tidyFlavor _ fl = fl
, ic_given = map (tidyEvVar env') given
, ic_wanted = tidyWanteds env' wanted } 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 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} \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) ...@@ -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) tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $ = addErrCtxt (cmdCtxt cmd) $
do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] 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 ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point
-- a ((w,t1) .. tn) t -- a ((w,t1) .. tn) t
......
...@@ -33,7 +33,6 @@ import Var ...@@ -33,7 +33,6 @@ import Var
import Name import Name
import NameSet import NameSet
import NameEnv import NameEnv
import VarSet
import SrcLoc import SrcLoc
import Bag import Bag
import ErrUtils import ErrUtils
...@@ -388,11 +387,10 @@ tcPolyCheck :: TcSigInfo -> PragFun ...@@ -388,11 +387,10 @@ tcPolyCheck :: TcSigInfo -> PragFun
-- it binds a single variable, -- it binds a single variable,
-- it has a signature, -- it has a signature,
tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped 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 prag_fn rec_tc bind_list
= do { ev_vars <- newEvVars theta = do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau)
; let skol_info = SigSkol (FunSigCtxt (idName id))
; (ev_binds, (binds', [mono_info])) ; (ev_binds, (binds', [mono_info]))
<- checkConstraints skol_info tvs ev_vars $ <- checkConstraints skol_info tvs ev_vars $
tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $ tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
...@@ -423,12 +421,8 @@ tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list ...@@ -423,12 +421,8 @@ tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
; let get_tvs | isTopLevel top_lvl = tyVarsOfType ; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
| otherwise = exactTyVarsOfType ; (qtvs, givens, ev_binds) <- simplifyInfer top_lvl mono name_taus wanted
-- 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
; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens)) ; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens))
mono_infos mono_infos
...@@ -545,14 +539,13 @@ tcSpec poly_id prag@(SpecSig _ hs_ty inl) ...@@ -545,14 +539,13 @@ tcSpec poly_id prag@(SpecSig _ hs_ty inl)
; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) ; warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
(ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id)) (ptext (sLit "SPECIALISE pragma for non-overloaded function") <+> quotes (ppr poly_id))
-- Note [SPECIALISE pragmas] -- Note [SPECIALISE pragmas]