-
-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,
- 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
- = tc_mb_pats mbinds `thenM` \ (complete_it, xve) ->
- tcExtendLocalValEnv2 (bagToList xve) complete_it
- where
- tc_mb_pats EmptyMonoBinds
- = returnM (returnM (EmptyMonoBinds, emptyBag), emptyBag)
-
- tc_mb_pats (AndMonoBinds mb1 mb2)
- = tc_mb_pats mb1 `thenM` \ (complete_it1, xve1) ->
- tc_mb_pats mb2 `thenM` \ (complete_it2, xve2) ->
- let
- complete_it = complete_it1 `thenM` \ (mb1', bs1) ->
- complete_it2 `thenM` \ (mb2', bs2) ->
- returnM (AndMonoBinds mb1' mb2', bs1 `unionBags` bs2)
- in
- returnM (complete_it, xve1 `unionBags` xve2)
-
- tc_mb_pats (FunMonoBind name inf matches locn)
- -- 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 = tcSigMonoId sig
- mono_ty = idType mono_id
- complete_it = addSrcLoc locn $
- tcMatchesFun name mono_ty matches `thenM` \ matches' ->
- returnM (FunMonoBind mono_id inf matches' locn,
- unitBag (name, mono_id))
- in
- returnM (complete_it, if isRec is_rec then unitBag (name,tcSigPolyId 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 openTypeKind `thenM` \ mono_ty ->
- let
- mono_id = mkLocalId mono_name mono_ty
- complete_it = addSrcLoc locn $
- tcMatchesFun name mono_ty matches `thenM` \ matches' ->
- returnM (FunMonoBind mono_id inf matches' locn,
- 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
- = addSrcLoc locn $
- newHoleTyVarTy `thenM` \ fun_ty ->
- tcMatchesFun name fun_ty matches `thenM` \ matches' ->
- readHoleResult fun_ty `thenM` \ fun_ty' ->
- newLocalName name `thenM` \ mono_name ->
- let
- mono_id = mkLocalId mono_name fun_ty'
- in
- returnM (FunMonoBind mono_id inf matches' locn,
- unitBag (name, mono_id))
- in
- returnM (complete_it, emptyBag)
-
- tc_mb_pats bind@(PatMonoBind pat grhss locn)
- = addSrcLoc locn $
-
- -- 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.
-
- newHoleTyVarTy `thenM` \ pat_ty ->
- tcPat tc_pat_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) ->
- readHoleResult pat_ty `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 = addSrcLoc locn $
- addErrCtxt (patMonoBindsCtxt bind) $
- tcGRHSs PatBindRhs grhss pat_ty' `thenM` \ grhss' ->
- returnM (PatMonoBind pat' grhss' locn, 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_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