- sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
- sig_ids = [id | (TySigInfo _ id _ _ _ _) <- tc_ty_sigs]
-
- tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
-
- tc_mono_binds (AndMonoBinds mb1 mb2)
- = tc_mono_binds mb1 `thenTc` \ (mb1a, lie1) ->
- tc_mono_binds mb2 `thenTc` \ (mb2a, lie2) ->
- returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
-
- tc_mono_binds (FunMonoBind name inf matches locn)
- = tcAddSrcLoc locn $
- tcLookupLocalValueOK "tc_mono_binds" name `thenNF_Tc` \ id ->
-
- -- Before checking the RHS, extend the envt with
- -- bindings for the *polymorphic* Ids from any type signatures
- tcExtendLocalValEnv sig_names sig_ids $
- tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
-
- returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
-
- tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
- = tcAddSrcLoc locn $
- tcAddErrCtxt (patMonoBindsCtxt bind) $
- tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
-
- -- Before checking the RHS, but after the pattern, extend the envt with
- -- bindings for the *polymorphic* Ids from any type signatures
- tcExtendLocalValEnv sig_names sig_ids $
- tcGRHSsAndBinds pat_ty grhss_and_binds `thenTc` \ (grhss_and_binds2, lie) ->
- returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
- plusLIE lie_pat lie)
+ sig_fn name = case maybeSig tc_ty_sigs name of
+ Nothing -> Nothing
+ Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id
+
+ mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
+ Nothing -> (name, mono_id)
+ Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
+
+ tc_mb_pats EmptyMonoBinds
+ = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+ tc_mb_pats (AndMonoBinds mb1 mb2)
+ = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
+ tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
+ let
+ complete_it xve = complete_it1 xve `thenTc` \ (mb1', lie1) ->
+ complete_it2 xve `thenTc` \ (mb2', lie2) ->
+ returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
+ in
+ returnTc (complete_it,
+ lie_req1 `plusLIE` lie_req2,
+ tvs1 `unionBags` tvs2,
+ ids1 `unionBags` ids2,
+ lie_avail1 `plusLIE` lie_avail2)
+
+ tc_mb_pats (FunMonoBind name inf matches locn)
+ = newTyVarTy boxedTypeKind `thenNF_Tc` \ bndr_ty ->
+ tcVarPat sig_fn name bndr_ty `thenTc` \ bndr_id ->
+ let
+ complete_it xve = tcAddSrcLoc locn $
+ 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)
+
+ tc_mb_pats bind@(PatMonoBind pat grhss locn)
+ = tcAddSrcLoc locn $
+
+ -- Figure out the appropriate kind for the pattern,
+ -- and generate a suitable type variable
+ (case is_rec of
+ Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types
+ NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types
+ ) `thenNF_Tc` \ pat_ty ->
+
+ -- Now typecheck the pattern
+ -- We don't support binding fresh type variables in the
+ -- pattern of a pattern binding. For example, this is illegal:
+ -- (x::a, y::b) = e
+ -- whereas this is ok
+ -- (x::Int, y::Bool) = e
+ --
+ -- We don't check explicitly for this problem. Instead, we simply
+ -- type check the pattern with tcPat. If the pattern mentions any
+ -- fresh tyvars we simply get an out-of-scope type variable error
+ tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
+ let
+ complete_it xve = tcAddSrcLoc locn $
+ tcAddErrCtxt (patMonoBindsCtxt bind) $
+ tcExtendLocalValEnv xve $
+ tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
+ returnTc (PatMonoBind pat' grhss' locn, lie)
+ in
+ returnTc (complete_it, lie_req, tvs, ids, lie_avail)