A clean-up pass on fundeps and implicit params. Haven't yet incorporated
changes from Hugs/GHC meeting yet, tho.
- Fixed up several places in Type.lhs where IPNotes were probably being
incorrectly handled. Strongly suggests a better solution should be
implemented for marking implicit params than piggybacking on NoteTys.
- tcSimplifyAndCheck was handling implicit params incorrectly
(holding on to them when it should have been booting them out to frees).
- Improved improvement WRT type signatures (the signature is now taken
into account when improving).
- Added improvement when matching against local polymorphic types.
+instance Outputable name => Outputable (BangType name) where
+ ppr = ppr_bang
+
ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
ppr_bang (Banged ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
-- come before:
-- - computing vars over which to quantify
-- - zonking the generalized type vars
-- come before:
-- - computing vars over which to quantify
-- - zonking the generalized type vars
- tcImprove lie_req `thenTc_`
+ let lie_avail = case maybe_sig_theta of
+ Nothing -> emptyLIE
+ Just (_, la) -> la in
+ tcImprove (lie_avail `plusLIE` lie_req) `thenTc_`
-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-- The tyvars_not_to_gen are free in the environment, and hence
-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-- The tyvars_not_to_gen are free in the environment, and hence
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
+import TcImprove ( tcImprove )
import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
import TcType ( TcType, TcTauType,
tcInstTyVars,
tcInstTcType, tcSplitRhoTy,
mkTyConApp, splitSigmaTy,
splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
mkTyConApp, splitSigmaTy,
splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
- isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
+ isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
boxedTypeKind, mkArrowKind,
tidyOpenType
)
boxedTypeKind, mkArrowKind,
tidyOpenType
)
-> TcType -- Expected type (could be a polytpye)
-> TcM s (TcExpr, LIE)
-> TcType -- Expected type (could be a polytpye)
-> TcM s (TcExpr, LIE)
-tcExpr expr ty | isForAllTy ty = -- Polymorphic case
- tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
+tcExpr expr ty | isSigmaTy ty = -- Polymorphic case
+ tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
- | otherwise = -- Monomorphic case
- tcMonoExpr expr ty
+ | otherwise = -- Monomorphic case
+ tcMonoExpr expr ty
checkSigTyVars sig_tyvars free_tyvars `thenTc` \ zonked_sig_tyvars ->
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
checkSigTyVars sig_tyvars free_tyvars `thenTc` \ zonked_sig_tyvars ->
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
+ tcImprove (sig_dicts `plusLIE` lie_arg) `thenTc_`
-- ToDo: better origin
tcSimplifyAndCheck
(text "the type signature of an expression")
-- ToDo: better origin
tcSimplifyAndCheck
(text "the type signature of an expression")
= tcSetErrCtxt (exprSigCtxt in_expr) $
tcHsSigType poly_ty `thenTc` \ sig_tc_ty ->
= tcSetErrCtxt (exprSigCtxt in_expr) $
tcHsSigType poly_ty `thenTc` \ sig_tc_ty ->
- if not (isForAllTy sig_tc_ty) then
+ if not (isSigmaTy sig_tc_ty) then
-- Easy case
unifyTauTy sig_tc_ty res_ty `thenTc_`
tcMonoExpr expr sig_tc_ty
-- Easy case
unifyTauTy sig_tc_ty res_ty `thenTc_`
tcMonoExpr expr sig_tc_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) ->
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
tcIPBinds binds `thenTc` \ (binds', types, lie2) ->
partitionPredsOfLIE isBound lie `thenTc` \ (ips, lie', dict_binds) ->
- pprTrace "tcMonoExpr With" (ppr (ips, lie', dict_binds)) $
let expr'' = if nullMonoBinds dict_binds
then expr'
else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
let expr'' = if nullMonoBinds dict_binds
then expr'
else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
- , splitRhoTy
- , isForAllTy
- , mkForAllTys
)
import PprType ( {- instance Outputable Type -} )
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
)
import PprType ( {- instance Outputable Type -} )
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
-- We're infering (not checking) the type, and
-- the inst constrains a local type variable
-- We're infering (not checking) the type, and
-- the inst constrains a local type variable
- | isDict inst = DontReduceUnlessConstant -- Dicts
- | otherwise = ReduceMe AddToIrreds -- Lits and Methods
+ | isClassDict inst = DontReduceUnlessConstant -- Dicts
+ | otherwise = ReduceMe AddToIrreds -- Lits and Methods
\end{code}
@tcSimplifyAndCheck@ is similar to the above, except that it checks
\end{code}
@tcSimplifyAndCheck@ is similar to the above, except that it checks
where
givens = lieToList given_lie
-- see comment on wanteds in tcSimplify
where
givens = lieToList given_lie
-- see comment on wanteds in tcSimplify
- wanteds = filter notFunDep (lieToList wanted_lie)
+ -- JRL nope - it's too early to throw away fundeps here...
+ wanteds = {- filter notFunDep -} (lieToList wanted_lie)
given_dicts = filter isClassDict givens
try_me inst
-- Does not constrain a local tyvar
| isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
given_dicts = filter isClassDict givens
try_me inst
-- Does not constrain a local tyvar
| isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
- && (isDict inst || null (getIPs inst))
= Free
-- When checking against a given signature we always reduce
= Free
-- When checking against a given signature we always reduce
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
import Outputable
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( Name, NamedThing(..), getSrcLoc, isTvOcc, nameOccName )
import Outputable
-import Maybes ( mapMaybe, expectJust )
+import Maybes ( mapMaybe, catMaybes, expectJust )
import UniqSet ( UniqSet, emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import UniqSet ( UniqSet, emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
- = Just (decl, getUnique name, map (getUnique . get_clas) ctxt)
+ = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
mk_cls_edges other_decl
= Nothing
mk_cls_edges other_decl
= Nothing
mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _)
mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _)
- = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
- get_cons condecls `unionUniqSets`
+ = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
+ get_cons condecls `unionUniqSets`
get_deriv derivs))
mk_edges decl@(TySynonym name _ rhs _)
get_deriv derivs))
mk_edges decl@(TySynonym name _ rhs _)
----------------------------------------------------
----------------------------------------------------
-get_ctxt ctxt = unionManyUniqSets (map (set_name . get_clas) ctxt)
-get_clas (HsPClass clas _) = clas
+get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt)))
+get_clas (HsPClass clas _) = Just clas
+get_clas _ = Nothing
----------------------------------------------------
get_deriv Nothing = emptyUniqSet
----------------------------------------------------
get_deriv Nothing = emptyUniqSet
)
import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
)
import Type ( getTyVar, tyVarsOfTypes, splitFunTy, applyTys,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
- mkTyVarTy, splitForAllTys, isForAllTy, splitAlgTyConApp_maybe,
+ mkTyVarTy, splitAlgTyConApp_maybe,
mkArrowKind, mkArrowKinds, boxedTypeKind,
isUnboxedType, Type, ThetaType, classesOfPreds
)
mkArrowKind, mkArrowKinds, boxedTypeKind,
isUnboxedType, Type, ThetaType, classesOfPreds
)
mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys,
+ applyTy, applyTys, mkPiType, hoistForAllTys,
TauType, RhoType, SigmaType, PredType(..), ThetaType,
ClassPred, ClassContext, mkClassPred,
getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
isTauTy, mkRhoTy, splitRhoTy,
TauType, RhoType, SigmaType, PredType(..), ThetaType,
ClassPred, ClassContext, mkClassPred,
getClassTys_maybe, ipName_maybe, classesToPreds, classesOfPreds,
isTauTy, mkRhoTy, splitRhoTy,
- mkSigmaTy, splitSigmaTy,
+ mkSigmaTy, isSigmaTy, splitSigmaTy,
-- Lifting and boxity
isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
-- Lifting and boxity
isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, isNewType,
splitFunTy (NoteTy _ ty) = splitFunTy ty
splitFunTy_maybe :: Type -> Maybe (Type, Type)
splitFunTy (NoteTy _ ty) = splitFunTy ty
splitFunTy_maybe :: Type -> Maybe (Type, Type)
-splitFunTy_maybe (FunTy arg res) = Just (arg, res)
-splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
-splitFunTy_maybe other = Nothing
+splitFunTy_maybe (FunTy arg res) = Just (arg, res)
+splitFunTy_maybe (NoteTy (IPNote _) ty) = Nothing
+splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty
+splitFunTy_maybe other = Nothing
splitFunTys :: Type -> ([Type], Type)
splitFunTys ty = split [] ty ty
where
split args orig_ty (FunTy arg res) = split (arg:args) res res
splitFunTys :: Type -> ([Type], Type)
splitFunTys ty = split [] ty ty
where
split args orig_ty (FunTy arg res) = split (arg:args) res res
+ split args orig_ty (NoteTy (IPNote _) ty)
+ = (reverse args, orig_ty)
split args orig_ty (NoteTy _ ty) = split args orig_ty ty
split args orig_ty ty = (reverse args, orig_ty)
split args orig_ty (NoteTy _ ty) = split args orig_ty ty
split args orig_ty ty = (reverse args, orig_ty)
-- including functions are returned as Just ..
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-- including functions are returned as Just ..
splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
-splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
-splitTyConApp_maybe other = Nothing
+splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
+splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
+splitTyConApp_maybe (NoteTy (IPNote _) ty) = Nothing
+splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty
+splitTyConApp_maybe other = Nothing
-- splitAlgTyConApp_maybe looks for
-- *saturated* applications of *algebraic* data types
-- splitAlgTyConApp_maybe looks for
-- *saturated* applications of *algebraic* data types
splitAlgTyConApp_maybe (TyConApp tc tys)
| isAlgTyCon tc &&
tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
splitAlgTyConApp_maybe (TyConApp tc tys)
| isAlgTyCon tc &&
tyConArity tc == length tys = Just (tc, tys, tyConDataCons tc)
+splitAlgTyConApp_maybe (NoteTy (IPNote _) ty)
+ = Nothing
splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
splitAlgTyConApp_maybe other = Nothing
splitAlgTyConApp_maybe (NoteTy _ ty) = splitAlgTyConApp_maybe ty
splitAlgTyConApp_maybe other = Nothing
splitNewType_maybe :: Type -> Maybe Type
-- Find the representation of a newtype, if it is one
-- Looks through multiple levels of newtype, but does not look through for-alls
splitNewType_maybe :: Type -> Maybe Type
-- Find the representation of a newtype, if it is one
-- Looks through multiple levels of newtype, but does not look through for-alls
+splitNewType_maybe (NoteTy (IPNote _) ty)
+ = Nothing
splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
Just rep_ty -> ASSERT( length tys == tyConArity tc )
splitNewType_maybe (NoteTy _ ty) = splitNewType_maybe ty
splitNewType_maybe (TyConApp tc tys) = case newTyConRep tc of
Just rep_ty -> ASSERT( length tys == tyConArity tc )
return (tyvar, NoteTy (UsgNote usg) ty'')
Nothing -> splitFAT_m ty
where
return (tyvar, NoteTy (UsgNote usg) ty'')
Nothing -> splitFAT_m ty
where
- splitFAT_m (NoteTy _ ty) = splitFAT_m ty
- splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
- splitFAT_m _ = Nothing
-
-isForAllTy :: Type -> Bool
-isForAllTy (NoteTy _ ty) = isForAllTy ty
-isForAllTy (ForAllTy tyvar ty) = True
-isForAllTy _ = False
+ splitFAT_m (NoteTy (IPNote _) ty) = Nothing
+ splitFAT_m (NoteTy _ ty) = splitFAT_m ty
+ splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty)
+ splitFAT_m _ = Nothing
splitForAllTys :: Type -> ([TyVar], Type)
splitForAllTys ty = case splitUsgTy_maybe ty of
splitForAllTys :: Type -> ([TyVar], Type)
splitForAllTys ty = case splitUsgTy_maybe ty of
in (tvs, NoteTy (UsgNote usg) ty'')
Nothing -> split ty ty []
where
in (tvs, NoteTy (UsgNote usg) ty'')
Nothing -> split ty ty []
where
- split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
- split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
- split orig_ty t tvs = (reverse tvs, orig_ty)
+ split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+ split orig_ty (NoteTy (IPNote _) ty) tvs = (reverse tvs, orig_ty)
+ split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs
+ split orig_ty t tvs = (reverse tvs, orig_ty)
\end{code}
@mkPiType@ makes a (->) type or a forall type, depending on whether
\end{code}
@mkPiType@ makes a (->) type or a forall type, depending on whether
\begin{code}
isTauTy :: Type -> Bool
\begin{code}
isTauTy :: Type -> Bool
-isTauTy (TyVarTy v) = True
-isTauTy (TyConApp _ tys) = all isTauTy tys
-isTauTy (AppTy a b) = isTauTy a && isTauTy b
-isTauTy (FunTy a b) = isTauTy a && isTauTy b
-isTauTy (NoteTy _ ty) = isTauTy ty
-isTauTy other = False
+isTauTy (TyVarTy v) = True
+isTauTy (TyConApp _ tys) = all isTauTy tys
+isTauTy (AppTy a b) = isTauTy a && isTauTy b
+isTauTy (FunTy a b) = isTauTy a && isTauTy b
+isTauTy (NoteTy (IPNote _) ty) = False
+isTauTy (NoteTy _ ty) = isTauTy ty
+isTauTy other = False
split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
Just p -> split res res (p:ts)
Nothing -> (reverse ts, orig_ty)
split orig_ty (FunTy arg res) ts = case splitPredTy_maybe arg of
Just p -> split res res (p:ts)
Nothing -> (reverse ts, orig_ty)
- split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
- split orig_ty ty ts = (reverse ts, orig_ty)
+ split orig_ty (NoteTy (IPNote _) ty) ts = (reverse ts, orig_ty)
+ split orig_ty (NoteTy _ ty) ts = split orig_ty ty ts
+ split orig_ty ty ts = (reverse ts, orig_ty)
\begin{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
\begin{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
+isSigmaTy :: Type -> Bool
+isSigmaTy (FunTy a b) = isPredTy a
+ where isPredTy (NoteTy (IPNote _) _) = True
+ -- JRL could be a dict ty, but that would be polymorphic,
+ -- and thus there would have been an outer ForAllTy
+ isPredTy _ = False
+isSigmaTy (NoteTy (IPNote _) _) = False
+isSigmaTy (NoteTy _ ty) = isSigmaTy ty
+isSigmaTy (ForAllTy tyvar ty) = True
+isSigmaTy _ = False
+
splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
splitSigmaTy ty =
(tyvars, theta, tau)
splitSigmaTy :: Type -> ([TyVar], [PredType], Type)
splitSigmaTy ty =
(tyvars, theta, tau)
seqNote (SynNote ty) = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqNote (UsgNote usg) = usg `seq` ()
seqNote (SynNote ty) = seqType ty
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqNote (UsgNote usg) = usg `seq` ()
-seqNote (IPNote nm) = nm `seq` ()
+seqNote (IPNote nm) = nm `seq` ()