-\subsection{tcMonoBind}
-%* *
-%************************************************************************
-
-@tcMonoBinds@ deals with a single @MonoBind@.
-The signatures have been dealt with already.
-
-\begin{code}
-tcMonoBinds :: LHsBinds Name
- -> [TcSigInfo] -> RecFlag
- -> TcM (LHsBinds TcId,
- Bag (Name, -- Bound names
- TcId)) -- Corresponding monomorphic bound things
-
-tcMonoBinds mbinds tc_ty_sigs is_rec
- -- Three stages:
- -- 1. Check the patterns, building up an environment binding
- -- the variables in this group (in the recursive case)
- -- 2. Extend the environment
- -- 3. Check the RHSs
- = mapBagM tc_lbind_pats mbinds `thenM` \ bag_of_pairs ->
- let
- (complete_it, xve)
- = foldrBag combine
- (returnM (emptyBag, emptyBag), emptyBag)
- bag_of_pairs
- combine (complete_it1, xve1) (complete_it2, xve2)
- = (complete_it, xve1 `unionBags` xve2)
- where
- complete_it = complete_it1 `thenM` \ (b1, bs1) ->
- complete_it2 `thenM` \ (b2, bs2) ->
- returnM (b1 `consBag` b2, bs1 `unionBags` bs2)
- in
- tcExtendLocalValEnv2 (bagToList xve) complete_it
- where
- tc_lbind_pats :: LHsBind Name
- -> TcM (TcM (LHsBind TcId, Bag (Name,TcId)), -- Completer
- Bag (Name,TcId))
- -- wrapper for tc_bind_pats to deal with the location stuff
- tc_lbind_pats (L loc bind)
- = addSrcSpan loc $ do
- (tc, bag) <- tc_bind_pats bind
- return (wrap tc, bag)
- where
- wrap tc = addSrcSpan loc $ do
- (bind, stuff) <- tc
- return (L loc bind, stuff)
-
-
- tc_bind_pats :: HsBind Name
- -> TcM (TcM (HsBind TcId, Bag (Name,TcId)), -- Completer
- Bag (Name,TcId))
- tc_bind_pats (FunBind (L nm_loc name) inf matches)
- -- Three cases:
- -- a) Type sig supplied
- -- b) No type sig and recursive
- -- c) No type sig and non-recursive
-
- | Just sig <- maybeSig tc_ty_sigs name
- = let -- (a) There is a type signature
- -- Use it for the environment extension, and check
- -- the RHS has the appropriate type (with outer for-alls stripped off)
- mono_id = sig_mono_id sig
- mono_ty = idType mono_id
- complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
- returnM (FunBind (L nm_loc mono_id) inf matches',
- unitBag (name, mono_id))
- in
- returnM (complete_it, if isRec is_rec then unitBag (name, sig_poly_id sig)
- else emptyBag)
-
- | isRec is_rec
- = -- (b) No type signature, and recursive
- -- So we must use an ordinary H-M type variable
- -- which means the variable gets an inferred tau-type
- newLocalName name `thenM` \ mono_name ->
- newTyVarTy argTypeKind `thenM` \ mono_ty ->
- let
- mono_id = mkLocalId mono_name mono_ty
- complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
- returnM (FunBind (L nm_loc mono_id) inf matches',
- unitBag (name, mono_id))
- in
- returnM (complete_it, unitBag (name, mono_id))
-
- | otherwise -- (c) No type signature, and non-recursive
- = let -- So we can use a 'hole' type to infer a higher-rank type
- complete_it
- = newHole `thenM` \ hole ->
- tcMatchesFun name matches (Infer hole) `thenM` \ matches' ->
- readMutVar hole `thenM` \ fun_ty ->
- newLocalName name `thenM` \ mono_name ->
- let
- mono_id = mkLocalId mono_name fun_ty
- in
- returnM (FunBind (L nm_loc mono_id) inf matches',
- unitBag (name, mono_id))
- in
- returnM (complete_it, emptyBag)
-
- tc_bind_pats bind@(PatBind pat grhss)
- = -- Now typecheck the pattern
- -- We do now support binding fresh (not-already-in-scope) scoped
- -- type variables in the pattern of a pattern binding.
- -- For example, this is now legal:
- -- (x::a, y::b) = e
- -- The type variables are brought into scope in tc_binds_and_then,
- -- so we don't have to do anything here.
- newHole `thenM` \ hole ->
- tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) ->
- readMutVar hole `thenM` \ pat_ty ->
-
- -- Don't know how to deal with pattern-bound existentials yet
- checkTc (isEmptyBag tvs && null lie_avail)
- (existentialExplode bind) `thenM_`
-
- let
- complete_it = addErrCtxt (patMonoBindsCtxt bind) $
- tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' ->
- returnM (PatBind pat' grhss', ids)
- in
- returnM (complete_it, if isRec is_rec then ids else emptyBag)
-
- -- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
- -- If there was a type sig for that Id, we want to make it much
- -- as if that type signature had been on the binder as a SigPatIn.
- -- We check for a type signature; if there is one, we use the mono_id
- -- from the signature. This is how we make sure the tau part of the
- -- signature actually matches the type of the LHS; then tc_bind_pats
- -- ensures the LHS and RHS have the same type
-
- tc_pat_bndr name pat_ty
- = case maybeSig tc_ty_sigs name of
- Nothing -> newLocalName name `thenM` \ bndr_name ->
- tcMonoPatBndr bndr_name pat_ty
-
- Just sig -> addSrcSpan (srcLocSpan (getSrcLoc name)) $
- -- TODO: location wrong
- tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
- returnM (co_fn, mono_id)
- where
- mono_id = sig_mono_id sig
-\end{code}
-
-
-%************************************************************************
-%* *