import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
-import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) )
+import DynFlags ( dopt, DynFlags,
+ DynFlag(Opt_MonomorphismRestriction, Opt_MonoPatBinds, Opt_GlasgowExts) )
import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
HsLocalBinds(..), HsValBinds(..), HsIPBinds(..),
LSig, Match(..), IPBind(..), Prag(..),
[poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
else do -- The normal lifted case: GENERALISE
- { is_unres <- isUnRestrictedGroup bind_list sig_fn
+ { dflags <- getDOpts
; (tyvars_to_gen, dict_binds, dict_ids)
<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
- generalise top_lvl is_unres mono_bind_infos lie_req
+ generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
-- FINALISE THE QUANTIFIED TYPE VARIABLES
-- The quantified type variables often include meta type variables
; extendLIEs lie
; let const_dicts = map instToId lie
; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
+ -- Most of the work of specialisation is done by
+ -- the desugarer, guided by the SpecPrag
--------------
-- If typechecking the binds fails, then return with each
check_sig other = return ()
strictBindErr flavour unlifted mbind
- = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) 4 (ppr mbind)
+ = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:"))
+ 4 (pprLHsBinds mbind)
where
msg | unlifted = ptext SLIT("bindings for unlifted types")
| otherwise = ptext SLIT("bang-pattern bindings")
tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss })
= do { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names
+ ; mono_pat_binds <- doptM Opt_MonoPatBinds
+ -- With -fmono-pat-binds, we do no generalisation of pattern bindings
+ -- But the signature can still be polymoprhic!
+ -- data T = MkT (forall a. a->a)
+ -- x :: forall a. a->a
+ -- MkT x = <rhs>
+ -- The function get_sig_ty decides whether the pattern-bound variables
+ -- should have exactly the type in the type signature (-fmono-pat-binds),
+ -- or the instantiated version (-fmono-pat-binds)
; let nm_sig_prs = names `zip` mb_sigs
- tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs]
+ get_sig_ty | mono_pat_binds = idType . sig_id
+ | otherwise = sig_tau
+ tau_sig_env = mkNameEnv [ (name, get_sig_ty sig)
+ | (name, Just sig) <- nm_sig_prs]
sig_tau_fn = lookupNameEnv tau_sig_env
tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ ->
%************************************************************************
\begin{code}
-generalise :: TopLevelFlag -> Bool
+generalise :: DynFlags -> TopLevelFlag
+ -> [LHsBind Name] -> TcSigFun
-> [MonoBindInfo] -> [Inst]
-> TcM ([TcTyVar], TcDictBinds, [TcId])
-generalise top_lvl is_unrestricted mono_infos lie_req
- | not is_unrestricted -- RESTRICTED CASE
+generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
+ | isMonoGroup dflags bind_list
+ = do { extendLIEs lie_req; return ([], emptyBag, []) }
+
+ | isRestrictedGroup dflags bind_list sig_fn -- RESTRICTED CASE
= -- Check signature contexts are empty
do { checkTc (all is_mono_sig sigs)
(restrictedBindCtxtErr bndrs)
| otherwise = []
-------------------
-isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
-isUnRestrictedGroup binds sig_fn
- = do { mono_restriction <- doptM Opt_MonomorphismRestriction
- ; return (not mono_restriction || all_unrestricted) }
+isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
+-- No generalisation at all
+isMonoGroup dflags binds
+ = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
+ where
+ is_pat_bind (L _ (PatBind {})) = True
+ is_pat_bind other = False
+
+-------------------
+isRestrictedGroup :: DynFlags -> [LHsBind Name] -> TcSigFun -> Bool
+isRestrictedGroup dflags binds sig_fn
+ = mono_restriction && not all_unrestricted
where
+ mono_restriction = dopt Opt_MonomorphismRestriction dflags
all_unrestricted = all (unrestricted . unLoc) binds
has_sig n = isJust (sig_fn n)