import {-# SOURCE #-} TcExpr ( tcExpr )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
- collectMonoBinders, andMonoBindList, andMonoBinds
+ Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
import TcImprove ( tcImprove )
-import TcMonoType ( tcHsType, checkSigTyVars,
+import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
import PrelInfo ( main_NAME, ioTyCon_NAME )
-import Id ( Id, mkVanillaId, setInlinePragma )
+import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
import Var ( idType, idName )
import IdInfo ( setInlinePragInfo, InlinePragInfo(..) )
import Name ( Name, getName, getOccName, getSrcLoc )
-- come before:
-- - computing vars over which to quantify
-- - zonking the generalized type vars
- tcImprove lie_req `thenTc_`
+ let lie_avail = case maybe_sig_theta of
+ Nothing -> emptyLIE
+ Just (_, la) -> la in
+ tcImprove (lie_avail `plusLIE` lie_req) `thenTc_`
-- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-- The tyvars_not_to_gen are free in the environment, and hence
-- SIMPLIFY THE LIE
tcExtendGlobalTyVars tyvars_not_to_gen (
let ips = getIPsOfLIE lie_req in
- if null real_tyvars_to_gen_list && null ips then
+ if null real_tyvars_to_gen_list && (null ips || not is_unrestricted) then
-- No polymorphism, and no IPs, so no need to simplify context
returnTc (lie_req, EmptyMonoBinds, [])
else
is_elem v vs = isIn "isUnResMono" v vs
-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 (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
+ v `is_elem` sigs
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
isUnRestrictedGroup sigs mb2
isUnRestrictedGroup sigs EmptyMonoBinds = True
+
+isUnRestrictedMatch (Match _ [] Nothing _) = False -- No args, no signature
+isUnRestrictedMatch other = True -- Some args or a signature
\end{code}
-- 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)
+ check_one_sig (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
= tcAddSrcLoc src_loc $
- tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $
- checkSigTyVars sig_tyvars
+ tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
+ checkSigTyVars sig_tyvars (idFreeTyVars id)
-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
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)]
+ sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
-- Search for Main.main in the binder_names, return corresponding mono_id
find_main NotTopLevel binder_names mono_ids = Nothing
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsType poly_ty `thenTc` \ sig_ty ->
+ tcHsSigType poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time