collectMonoBinders, andMonoBinds,
collectSigTysFromMonoBinds
)
-import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
+import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds,
+ RenamedTyClDecl )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
import TcPat ( tcPat, tcSubPat, tcMonoPatBndr )
import TcSimplify ( bindInstsOfLocalFuns )
import TcMType ( newTyVar, newTyVarTy, newHoleTyVarTy,
- zonkTcTyVarToTyVar
+ zonkTcTyVarToTyVar, readHoleResult
)
-import TcType ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
+import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
mkPredTy, mkForAllTy, isUnLiftedType,
unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind
)
tcSimplifyRestricted doc tau_tvs lie_req `thenTc` \ (qtvs, lie_free, binds) ->
-- Check that signature type variables are OK
- checkSigsTyVars sigs `thenTc_`
+ checkSigsTyVars qtvs sigs `thenTc` \ final_qtvs ->
- returnTc (qtvs, lie_free, binds, [])
+ returnTc (final_qtvs, lie_free, binds, [])
else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
tcSimplifyInfer doc tau_tvs lie_req
else -- UNRESTRICTED CASE, WITH TYPE SIGS
-- CHECKING CASE: Unrestricted group, there are type signatures
- -- Check signature contexts are empty
+ -- Check signature contexts are identical
checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) ->
-- Check that the needed dicts can be
tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
-- Check that signature type variables are OK
- checkSigsTyVars sigs `thenTc_`
+ checkSigsTyVars forall_tvs sigs `thenTc` \ final_qtvs ->
- returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
+ returnTc (final_qtvs, lie_free, dict_binds, sig_dicts)
where
tysig_names = map (idName . tcSigPolyId) sigs
checkTc (equalLength theta theta1) sigContextsErr `thenTc_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
-checkSigsTyVars sigs = mapTc_ check_one sigs
+checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
+checkSigsTyVars qtvs sigs
+ = mapTc check_one sigs `thenTc` \ sig_tvs_s ->
+ let
+ -- Sigh. Make sure that all the tyvars in the type sigs
+ -- appear in the returned ty var list, which is what we are
+ -- going to generalise over. Reason: we occasionally get
+ -- silly types like
+ -- type T a = () -> ()
+ -- f :: T a
+ -- f () = ()
+ -- Here, 'a' won't appear in qtvs, so we have to add it
+
+ sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s
+ all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs
+ in
+ returnTc (varSetElems all_tvs)
where
check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
= tcAddSrcLoc src_loc $
let
bndr_ty = idType bndr_id
complete_it xve = tcAddSrcLoc locn $
- tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
+ tcMatchesFun xve name bndr_ty matches `thenTc` \ (matches', lie) ->
returnTc (FunMonoBind bndr_id inf matches' locn, lie)
in
returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
-- so we don't have to do anything here.
tcPat tc_pat_bndr pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+ readHoleResult pat_ty `thenTc` \ pat_ty' ->
let
complete_it xve = tcAddSrcLoc locn $
tcAddErrCtxt (patMonoBindsCtxt bind) $
tcExtendLocalValEnv2 xve $
- tcGRHSs PatBindRhs grhss pat_ty `thenTc` \ (grhss', lie) ->
+ tcGRHSs PatBindRhs grhss pat_ty' `thenTc` \ (grhss', lie) ->
returnTc (PatMonoBind pat' grhss' locn, lie)
in
returnTc (complete_it, lie_req, tvs, ids, lie_avail)
tcMonoPatBndr bndr_name pat_ty
Just sig -> tcAddSrcLoc (getSrcLoc name) $
- tcSubPat pat_ty (idType mono_id) `thenTc` \ (co_fn, lie) ->
+ tcSubPat (idType mono_id) pat_ty `thenTc` \ (co_fn, lie) ->
returnTc (co_fn, lie, mono_id)
where
mono_id = tcSigMonoId sig