import CmdLineOpts ( opt_NoMonomorphismRestriction )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
Match(..), HsMatchContext(..),
- collectMonoBinders, andMonoBinds
+ collectMonoBinders, andMonoBinds,
+ collectSigTysFromMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
)
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars,
- TcSigInfo(..), tcTySig, maybeSig, sigCtxt
+ TcSigInfo(..), tcTySig, maybeSig, sigCtxt, tcAddScopedTyVars
)
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
import CoreFVs ( idFreeTyVars )
import Id ( mkLocalId, setInlinePragma )
import Var ( idType, idName )
-import IdInfo ( InlinePragInfo(..) )
import Name ( Name, getOccName, getSrcLoc )
import NameSet
import Var ( tyVarKind )
import VarSet
import Bag
-import Util ( isIn )
-import Maybes ( maybeToBool )
-import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel )
+import Util ( isIn, equalLength )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel,
+ isAlwaysActive )
import FiniteMap ( listToFM, lookupFM )
import Outputable
\end{code}
do_next
tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
- = -- TYPECHECK THE SIGNATURES
+ = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
+ -- Notice that they scope over
+ -- a) the type signatures in the binding group
+ -- b) the bindings in the group
+ -- c) the scope of the binding group (the "in" part)
+ tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $
+
+ -- TYPECHECK THE SIGNATURES
mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
tcBindWithSigs top_lvl bind tc_ty_sigs
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,
returnTc (sig_avails, map instToId sig_dicts)
where
sig1_dict_tys = map mkPredTy theta1
- n_sig1_theta = length theta1
sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
= tcAddErrCtxt (sigContextsCtxt id1 id) $
- checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
+ checkTc (equalLength theta theta1) sigContextsErr `thenTc_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
checkSigsTyVars sigs = mapTc_ check_one sigs
isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
+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 _ [] Nothing _) = False -- No args, no signature
-isUnRestrictedMatch other = True -- Some args or a signature
+isUnRestrictedMatch (Match [] _ _ : _) = False -- No args => like a pattern binding
+isUnRestrictedMatch other = True -- Some args => a function binding
\end{code}
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
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
projects / ghc-hetmet.git / blobdiff