-
-isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
-isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = isUnRestrictedMatch matches ||
- v `is_elem` sigs
-isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
- isUnRestrictedGroup sigs mb2
-isUnRestrictedGroup sigs EmptyMonoBinds = True
-
-isUnRestrictedMatch (Match [] _ _ : _) = False -- No args => like a pattern binding
-isUnRestrictedMatch other = True -- Some args => a function binding
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{tcMonoBind}
-%* *
-%************************************************************************
-
-@tcMonoBinds@ deals with a single @MonoBind@.
-The signatures have been dealt with already.
-
-\begin{code}
-tcMonoBinds :: RenamedMonoBinds
- -> [TcSigInfo]
- -> RecFlag
- -> TcM (TcMonoBinds,
- [Name], -- Bound names
- [TcId]) -- Corresponding monomorphic bound things
-
-tcMonoBinds mbinds tc_ty_sigs is_rec
- = tc_mb_pats mbinds `thenM` \ (complete_it, tvs, ids, lie_avail) ->
- let
- id_list = bagToList ids
- (names, mono_ids) = unzip id_list
-
- -- This last defn is the key one:
- -- extend the val envt with bindings for the
- -- things bound in this group, overriding the monomorphic
- -- ids with the polymorphic ones from the pattern
- extra_val_env = case is_rec of
- Recursive -> map mk_bind id_list
- NonRecursive -> []
- in
- -- Don't know how to deal with pattern-bound existentials yet
- checkTc (isEmptyBag tvs && null lie_avail)
- (existentialExplode mbinds) `thenM_`
-
- -- *Before* checking the RHSs, but *after* checking *all* the patterns,
- -- extend the envt with bindings for all the bound ids;
- -- and *then* override with the polymorphic Ids from the signatures
- -- That is the whole point of the "complete_it" stuff.
- --
- -- There's a further wrinkle: we have to delay extending the environment
- -- until after we've dealt with any pattern-bound signature type variables
- -- Consider f (x::a) = ...f...
- -- We're going to check that a isn't unified with anything in the envt,
- -- so f itself had better not be! So we pass the envt binding f into
- -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
- -- dealing with the signature tyvars
-
- complete_it extra_val_env `thenM` \ mbinds' ->
-
- returnM (mbinds', names, mono_ids)
- where
-
- mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
- Nothing -> (name, mono_id)
- Just sig -> (idName poly_id, poly_id)
- where
- poly_id = tcSigPolyId sig
-
- tc_mb_pats EmptyMonoBinds
- = returnM (\ xve -> returnM EmptyMonoBinds, emptyBag, emptyBag, [])
-
- tc_mb_pats (AndMonoBinds mb1 mb2)
- = tc_mb_pats mb1 `thenM` \ (complete_it1, tvs1, ids1, lie_avail1) ->
- tc_mb_pats mb2 `thenM` \ (complete_it2, tvs2, ids2, lie_avail2) ->
- let
- complete_it xve = complete_it1 xve `thenM` \ mb1' ->
- complete_it2 xve `thenM` \ mb2' ->
- returnM (AndMonoBinds mb1' mb2')
- in
- returnM (complete_it,
- tvs1 `unionBags` tvs2,
- ids1 `unionBags` ids2,
- lie_avail1 ++ lie_avail2)
-
- tc_mb_pats (FunMonoBind name inf matches locn)
- = (case maybeSig tc_ty_sigs name of
- Just sig -> returnM (tcSigMonoId sig)
- Nothing -> newLocalName name `thenM` \ bndr_name ->
- newTyVarTy openTypeKind `thenM` \ bndr_ty ->
- -- NB: not a 'hole' tyvar; since there is no type
- -- signature, we revert to ordinary H-M typechecking
- -- which means the variable gets an inferred tau-type
- returnM (mkLocalId bndr_name bndr_ty)
- ) `thenM` \ bndr_id ->
- let
- bndr_ty = idType bndr_id
- complete_it xve = addSrcLoc locn $
- tcMatchesFun xve name bndr_ty matches `thenM` \ matches' ->
- returnM (FunMonoBind bndr_id inf matches' locn)
- in
- returnM (complete_it, emptyBag, unitBag (name, bndr_id), [])
-
- tc_mb_pats bind@(PatMonoBind pat grhss locn)
- = addSrcLoc locn $
- newHoleTyVarTy `thenM` \ pat_ty ->
-
- -- 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.
-
- tcPat tc_pat_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
- readHoleResult pat_ty `thenM` \ pat_ty' ->
- let
- complete_it xve = addSrcLoc locn $
- addErrCtxt (patMonoBindsCtxt bind) $
- tcExtendLocalValEnv2 xve $
- tcGRHSs PatBindRhs grhss pat_ty' `thenM` \ grhss' ->
- returnM (PatMonoBind pat' grhss' locn)
- in
- returnM (complete_it, tvs, ids, lie_avail)
-
- -- 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_mb_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 -> addSrcLoc (getSrcLoc name) $
- tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
- returnM (co_fn, mono_id)
- where
- mono_id = tcSigMonoId sig