\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcMonoBinds,
- TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
- TcSigInfo(..),
+ TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
+ TcSigInfo(..), TcSigFun, mkTcSigFun,
badBootDeclErr ) where
#include "HsVersions.h"
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(..),
= do { -- Typecheck the signature
; let { prag_fn = mkPragFun sigs
; ty_sigs = filter isVanillaLSig sigs
- ; sig_fn = mkSigFun ty_sigs }
+ ; sig_fn = mkTcSigFun ty_sigs }
; poly_ids <- mapM tcTySig ty_sigs
+ -- No recovery from bad signatures, because the type sigs
+ -- may bind type variables, so proceeding without them
+ -- can lead to a cascade of errors
+ -- ToDo: this means we fall over immediately if any type sig
+ -- is wrong, which is over-conservative, see Trac bug #745
-- Extend the envt right away with all
-- the Ids declared with type signatures
[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
fun_matches = matches, bind_fvs = fvs })]
sig_fn -- Single function binding
non_rec
- | Just sig <- sig_fn name -- ...with a type signature
+ | Just scoped_tvs <- sig_fn name -- ...with a type signature
= -- When we have a single function binding, with a type signature
-- we can (a) use genuine, rigid skolem constants for the type variables
-- (b) bring (rigid) scoped type variables into scope
setSrcSpan b_loc $
- do { tc_sig <- tcInstSig True sig
+ do { tc_sig <- tcInstSig True name scoped_tvs
; mono_name <- newLocalName name
; let mono_ty = sig_tau tc_sig
mono_id = mkLocalId mono_name mono_ty
tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
- = do { mb_sig <- tcInstSig_maybe (sig_fn name)
+ = do { mb_sig <- tcInstSig_maybe sig_fn name
; mono_name <- newLocalName name
; mono_ty <- mk_mono_ty mb_sig
; let mono_id = mkLocalId mono_name mono_ty
mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind
tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss })
- = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names
+ = do { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names
; let nm_sig_prs = names `zip` mb_sigs
tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs]
%************************************************************************
\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)
been instantiated.
\begin{code}
-type TcSigFun = Name -> Maybe (LSig Name)
+type TcSigFun = Name -> Maybe [Name] -- Maps a let-binder to the list of
+ -- type variables brought into scope
+ -- by its type signature.
+ -- Nothing => no type signature
-mkSigFun :: [LSig Name] -> TcSigFun
+mkTcSigFun :: [LSig Name] -> TcSigFun
-- Search for a particular type signature
-- Precondition: the sigs are all type sigs
-- Precondition: no duplicates
-mkSigFun sigs = lookupNameEnv env
+mkTcSigFun sigs = lookupNameEnv env
where
- env = mkNameEnv [(expectJust "mkSigFun" (sigName sig), sig) | sig <- sigs]
+ env = mkNameEnv [(name, scoped_tyvars hs_ty)
+ | L span (TypeSig (L _ name) (L _ hs_ty)) <- sigs]
+ scoped_tyvars (HsForAllTy Explicit tvs _ _) = hsLTyVarNames tvs
+ scoped_tyvars other = []
+ -- The scoped names are the ones explicitly mentioned
+ -- in the HsForAll. (There may be more in sigma_ty, because
+ -- of nested type synonyms. See Note [Scoped] with TcSigInfo.)
---------------
data TcSigInfo
; return (mkLocalId name sigma_ty) }
-------------------
-tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo)
+tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo)
-- Instantiate with *meta* type variables;
-- this signature is part of a multi-signature group
-tcInstSig_maybe Nothing = return Nothing
-tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig
- ; return (Just tc_sig) }
+tcInstSig_maybe sig_fn name
+ = case sig_fn name of
+ Nothing -> return Nothing
+ Just tvs -> do { tc_sig <- tcInstSig False name tvs
+ ; return (Just tc_sig) }
-tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo
+tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo
-- Instantiate the signature, with either skolems or meta-type variables
-- depending on the use_skols boolean
--
--
-- We must not use the same 'a' from the defn of T at both places!!
-tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty))
- = setSrcSpan loc $
- do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
+tcInstSig use_skols name scoped_names
+ = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
-- scope when starting the binding group
; let skol_info = SigSkol (FunSigCtxt name)
inst_tyvars | use_skols = tcInstSkolTyVars skol_info
; loc <- getInstLoc (SigOrigin skol_info)
; return (TcSigInfo { sig_id = poly_id,
sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
- sig_scoped = scoped_names, sig_loc = loc }) }
+ sig_scoped = final_scoped_names, sig_loc = loc }) }
-- Note that the scoped_names and the sig_tvs will have
-- different Names. That's quite ok; when we bring the
-- scoped_names into scope, we just bind them to the sig_tvs
where
- -- The scoped names are the ones explicitly mentioned
- -- in the HsForAll. (There may be more in sigma_ty, because
- -- of nested type synonyms. See Note [Scoped] with TcSigInfo.)
-- We also only have scoped type variables when we are instantiating
-- with true skolems
- scoped_names = case (use_skols, hs_ty) of
- (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs
- other -> []
+ final_scoped_names | use_skols = scoped_names
+ | otherwise = []
+
+-------------------
+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
-------------------
-isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
-isUnRestrictedGroup binds sig_fn
- = do { mono_restriction <- doptM Opt_MonomorphismRestriction
- ; return (not mono_restriction || all_unrestricted) }
+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)
projects / ghc-hetmet.git / blobdiff