-
-isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
-isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
-isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
- isUnRestrictedGroup sigs mb2
-isUnRestrictedGroup sigs EmptyMonoBinds = True
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{tcMonoBind}
-%* *
-%************************************************************************
-
-@tcMonoBinds@ deals with a single @MonoBind@.
-The signatures have been dealt with already.
-
-\begin{code}
-tcMonoBinds :: RenamedMonoBinds
- -> [TcSigInfo]
- -> RecFlag
- -> TcM s (TcMonoBinds,
- LIE, -- LIE required
- [Name], -- Bound names
- [TcId]) -- Corresponding monomorphic bound things
-
-tcMonoBinds mbinds tc_ty_sigs is_rec
- = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
- let
- tv_list = bagToList tvs
- 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 && isEmptyBag lie_avail)
- (existentialExplode mbinds) `thenTc_`
-
- -- *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 `thenTc` \ (mbinds', lie_req_rhss) ->
-
- returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
- where
-
- -- This function is used when dealing with a LHS binder; we make a monomorphic
- -- version of the Id. We check for type signatures
- tc_pat_bndr name pat_ty
- = case maybeSig tc_ty_sigs name of
- Nothing
- -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
-
- Just (TySigInfo _ _ _ _ _ mono_id _ _)
- -> tcAddSrcLoc (getSrcLoc name) $
- unifyTauTy (idType mono_id) pat_ty `thenTc_`
- returnTc 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 ->
- tc_pat_bndr 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 tc_pat_bndr 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)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Signatures}
-%* *
-%************************************************************************
-
-@checkSigMatch@ does the next step in checking signature matching.
-The tau-type part has already been unified. What we do here is to
-check that this unification has not over-constrained the (polymorphic)
-type variables of the original signature type.
-
-The error message here is somewhat unsatisfactory, but it'll do for
-now (ToDo).
-
-\begin{code}
-checkSigMatch top_lvl binder_names mono_ids sigs
- | main_bound_here
- = -- First unify the main_id with IO t, for any old t
- tcSetErrCtxt mainTyCheckCtxt (
- tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon ->
- newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
- unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
- (idType main_mono_id)
- ) `thenTc_`
-
- -- Now check the signatures
- -- Must do this after the unification with IO t,
- -- in case of a silly signature like
- -- main :: forall a. a
- -- The unification to IO t will bind the type variable 'a',
- -- which is just waht check_one_sig looks for
- mapTc check_one_sig sigs `thenTc_`
- mapTc check_main_ctxt sigs `thenTc_`
-
- returnTc (Just ([], emptyLIE))
-
- | not (null sigs)
- = mapTc check_one_sig sigs `thenTc_`
- mapTc check_one_ctxt all_sigs_but_first `thenTc_`
- returnTc (Just (theta1, sig_lie))
-
- | otherwise
- = returnTc Nothing -- No constraints from type sigs
-
- where
- (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs
-
- sig1_dict_tys = mk_dict_tys theta1
- n_sig1_dict_tys = length sig1_dict_tys
- sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs]
-
- maybe_main = find_main top_lvl binder_names mono_ids
- main_bound_here = maybeToBool maybe_main
- Just main_mono_id = maybe_main
-
- -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
- -- Doesn't affect substitution
- check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
- checkSigTyVars sig_tyvars
-
-
- -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
- -- The type signatures on a mutually-recursive group of definitions
- -- must all have the same context (or none).
- --
- -- We unify them because, with polymorphic recursion, their types
- -- might not otherwise be related. This is a rather subtle issue.
- -- ToDo: amplify
- check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (sigContextsCtxt id1 id) $
- checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
- sigContextsErr `thenTc_`
- unifyTauTyLists sig1_dict_tys this_sig_dict_tys
- where
- this_sig_dict_tys = mk_dict_tys theta
-
- -- CHECK THAT FOR A GROUP INVOLVING Main.main, all
- -- the signature contexts are empty (what a bore)
- check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
- = tcAddSrcLoc src_loc $
- checkTc (null theta) (mainContextsErr id)
-
- mk_dict_tys theta = map mkPredTy theta
-
- sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
- nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
-
- -- Search for Main.main in the binder_names, return corresponding mono_id
- find_main NotTopLevel binder_names mono_ids = Nothing
- find_main TopLevel binder_names mono_ids = go binder_names mono_ids
- go [] [] = Nothing
- go (n:ns) (m:ms) | n == main_NAME = Just m
- | otherwise = go ns ms
projects / ghc-hetmet.git / blobdiff