import {-# SOURCE #-} TcExpr ( tcExpr )
import CmdLineOpts ( opt_NoMonomorphismRestriction )
-import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..),
- Match(..), collectMonoBinders, andMonoBinds
+import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
+ Match(..), HsMatchContext(..),
+ collectMonoBinders, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
-import Inst ( LIE, emptyLIE, mkLIE, plusLIE, lieToList, InstOrigin(..),
- newDicts, tyVarsOfInsts, instToId
+import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
+ newDicts, instToId
)
import TcEnv ( tcExtendLocalValEnv,
- newSpecPragmaId, newLocalId,
- tcGetGlobalTyVars
+ newSpecPragmaId, newLocalId
)
-import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyToDicts )
-import TcMonoType ( tcHsSigType, checkSigTyVars,
+import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( newTyVarTy, newTyVar, zonkTcTyVarsAndFV,
- zonkTcTyVarToTyVar
+import TcMType ( newTyVarTy, newTyVar,
+ zonkTcTyVarToTyVar,
+ unifyTauTy, unifyTauTyLists
+ )
+import TcType ( mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
+ mkPredTy, mkForAllTy, isUnLiftedType,
+ unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind
)
-import TcUnify ( unifyTauTy, unifyTauTyLists )
import CoreFVs ( idFreeTyVars )
-import Id ( mkVanillaId, setInlinePragma )
+import Id ( mkLocalId, setInlinePragma )
import Var ( idType, idName )
-import IdInfo ( InlinePragInfo(..) )
import Name ( Name, getOccName, getSrcLoc )
import NameSet
-import Type ( mkTyVarTy,
- mkForAllTys, mkFunTys, tyVarsOfType,
- mkPredTy, mkForAllTy, isUnLiftedType,
- unliftedTypeKind, liftedTypeKind, openTypeKind
- )
import Var ( tyVarKind )
import VarSet
import Bag
import Util ( isIn )
-import Maybes ( maybeToBool )
-import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel,
+ isAlwaysActive )
import FiniteMap ( listToFM, lookupFM )
import Outputable
\end{code}
poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
- Nothing -> mkVanillaId name forall_a_a -- No signature
+ Nothing -> mkLocalId name forall_a_a -- No signature
in
returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
) $
-- TYPECHECK THE BINDINGS
tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
let
- tau_tvs = varSetElems (foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids)
+ tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
in
-- GENERALISE
+ tcAddSrcLoc (minimum (map getSrcLoc binder_names)) $
+ tcAddErrCtxt (genCtxt binder_names) $
generalise binder_names mbind tau_tvs lie_req tc_ty_sigs
`thenTc` \ (tc_tyvars_to_gen, lie_free, dict_binds, dict_ids) ->
exports = zipWith mk_export binder_names zonked_mono_ids
dict_tys = map idType zonked_dict_ids
- inlines = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
- no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
- [(name, IMustNotBeINLINEd True phase) | InlineSig name phase loc <- inline_sigs, maybeToBool phase])
- -- "INLINE n foo" means inline foo, but not until at least phase n
- -- "NOINLINE n foo" means don't inline foo until at least phase n, and even
- -- then only if it is small enough etc.
- -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
- -- See comments in CoreUnfold.blackListed for the Authorised Version
+ inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
+ no_inlines = listToFM [(name, phase) | InlineSig _ name phase _ <- inline_sigs,
+ not (isAlwaysActive phase)]
+ -- AlwaysActive is the default, so don't bother with them
mk_export binder_name zonked_mono_id
= (tyvars,
(sig_tyvars, sig_poly_id)
Nothing -> (real_tyvars_to_gen, new_poly_id)
- new_poly_id = mkVanillaId binder_name poly_ty
+ new_poly_id = mkLocalId binder_name poly_ty
poly_ty = mkForAllTys real_tyvars_to_gen
$ mkFunTys dict_tys
$ idType zonked_mono_id
-- at all.
in
+ traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
+ exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_`
+
-- BUILD RESULTS
returnTc (
- -- pprTrace "binding.." (ppr ((zonked_dict_ids, dict_binds),
- -- exports, [idType poly_id | (_, poly_id, _) <- exports])) $
AbsBinds real_tyvars_to_gen
zonked_dict_ids
exports
Nothing -> bndr
checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids
- = ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
+ = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
-- The instCantBeGeneralised stuff in tcSimplify should have
-- already raised an error if we're trying to generalise an
-- unboxed tyvar (NB: unboxed tyvars are always introduced
\begin{code}
generalise binder_names mbind tau_tvs lie_req sigs
+ | not is_unrestricted -- RESTRICTED CASE
+ = -- Check signature contexts are empty
+ checkTc (all is_mono_sig sigs)
+ (restrictedBindCtxtErr binder_names) `thenTc_`
------------------------
- | is_unrestricted && null sigs
- = -- INFERENCE CASE: Unrestricted group, no type signatures
- tcSimplifyInfer (ptext SLIT("bindings for") <+> pprBinders binder_names)
- tau_tvs lie_req
+ -- Now simplify with exactly that set of tyvars
+ -- We have to squash those Methods
+ tcSimplifyRestricted doc tau_tvs lie_req `thenTc` \ (qtvs, lie_free, binds) ->
------------------------
- | is_unrestricted
+ -- Check that signature type variables are OK
+ checkSigsTyVars sigs `thenTc_`
+
+ returnTc (qtvs, lie_free, binds, [])
+
+ | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
+ = tcSimplifyInfer doc tau_tvs lie_req
+
+ | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS
= -- CHECKING CASE: Unrestricted group, there are type signatures
-- Check signature contexts are empty
checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) ->
-
+
-- Check that the needed dicts can be
-- expressed in terms of the signature ones
- tcSimplifyInferCheck check_doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
+ tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
-- Check that signature type variables are OK
checkSigsTyVars sigs `thenTc_`
returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
------------------------
- | otherwise -- RESTRICTED CASE: Restricted group
- = -- Check signature contexts are empty
- (if null sigs then
- returnTc ()
- else
- checkSigsCtxts sigs `thenTc` \ (_, sig_dicts) ->
- checkTc (null sig_dicts)
- (restrictedBindCtxtErr binder_names)
- ) `thenTc_`
-
- -- Identify constrained tyvars
- tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
- zonkTcTyVarsAndFV tau_tvs `thenNF_Tc` \ tau_tvs' ->
- zonkTcTyVarsAndFV lie_tvs `thenNF_Tc` \ lie_tvs' ->
- let
- forall_tvs = tau_tvs' `minusVarSet` (lie_tvs' `unionVarSet` gbl_tvs)
- -- Don't bother to oclose the gbl_tvs; this is a rare case
- in
- returnTc (varSetElems forall_tvs, lie_req, EmptyMonoBinds, [])
-
where
- tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
is_unrestricted | opt_NoMonomorphismRestriction = True
| otherwise = isUnRestrictedGroup tysig_names mbind
- lie_tvs = varSetElems (tyVarsOfInsts (lieToList lie_req))
- check_doc = case tysig_names of
- [n] -> ptext SLIT("type signature for") <+> quotes (ppr n)
- other -> ptext SLIT("type signature(s) for") <+> pprBinders tysig_names
+ tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
+ is_mono_sig (TySigInfo _ _ _ theta _ _ _ _) = null theta
+
+ doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
+-----------------------
-- 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
- --
- -- We return a representative
-checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs)
- = mapTc_ check_one other_sigs `thenTc_`
+checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
+ = tcAddSrcLoc src_loc $
+ mapTc_ check_one other_sigs `thenTc_`
if null theta1 then
returnTc ([], []) -- Non-overloaded type signatures
else
sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (sigContextsCtxt id1 id) $
+ = tcAddErrCtxt (sigContextsCtxt id1 id) $
checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
newTyVarTy kind `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:
+ -- We don't support binding fresh (not-already-in-scope) scoped
+ -- 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
complete_it xve = tcAddSrcLoc locn $
tcAddErrCtxt (patMonoBindsCtxt bind) $
tcExtendLocalValEnv xve $
- tcGRHSs grhss pat_ty PatBindRhs `thenTc` \ (grhss', lie) ->
+ tcGRHSs PatBindRhs grhss pat_ty `thenTc` \ (grhss', lie) ->
returnTc (PatMonoBind pat' grhss' locn, lie)
in
returnTc (complete_it, lie_req, tvs, ids, lie_avail)
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsSigType poly_ty `thenTc` \ sig_ty ->
+ tcHsSigType (FunSigCtxt name) 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
sigContextsErr = ptext SLIT("Mismatched contexts")
sigContextsCtxt s1 s2
- = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
- quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
- 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
+ = vcat [ptext SLIT("When matching the contexts of the signatures for"),
+ nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
+ ppr s2 <+> dcolon <+> ppr (idType s2)]),
+ ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
-----------------------------------------------
unliftedBindErr flavour mbind
4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
ptext SLIT("that falls under the monomorphism restriction")])
+genCtxt binder_names
+ = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
+
-- Used in error messages
-pprBinders bndrs = braces (pprWithCommas ppr bndrs)
+pprBinders bndrs = pprWithCommas ppr bndrs
\end{code}
projects / ghc-hetmet.git / blobdiff