import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcCheckRho )
-import DynFlags ( DynFlag(Opt_MonomorphismRestriction) )
+import DynFlags ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) )
import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
HsLocalBinds(..), HsValBinds(..), HsIPBinds(..),
LSig, Match(..), IPBind(..), Prag(..),
HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames,
isVanillaLSig, sigName, placeHolderNames, isPragLSig,
- LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds,
+ LPat, GRHSs, MatchGroup(..), pprLHsBinds,
collectHsBindBinders, collectPatBinders, pprPatBind
)
import TcHsSyn ( zonkId, (<$>) )
import TcRnMonad
import Inst ( newDictsAtLoc, newIPDict, instToId )
import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2,
- newLocalName, tcLookupLocalIds, pprBinders,
+ tcLookupLocalIds, pprBinders,
tcGetGlobalTyVars )
import TcUnify ( Expected(..), tcInfer, unifyTheta, tcSub,
bleatEscapedTvs, sigCtxt )
import SrcLoc ( Located(..), unLoc, getLoc )
import Bag
import ErrUtils ( Message )
-import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
-import Maybes ( fromJust, isJust, orElse )
+import Digraph ( SCC(..), stronglyConnComp )
+import Maybes ( fromJust, isJust, isNothing, orElse, catMaybes )
import Util ( singleton )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
- RecFlag(..), isNonRec )
+ RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec )
import Outputable
\end{code}
-- want. The bit we care about is the local bindings
-- and the free type variables thereof
tcTopBinds binds
- = do { (ValBindsOut prs, env) <- tcValBinds TopLevel binds getLclEnv
+ = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv
; return (foldr (unionBags . snd) emptyBag prs, env) }
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive LHsBinds
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it. The renamer checked all this
-tcHsBootSigs (ValBindsIn binds sigs)
- = do { checkTc (isEmptyLHsBinds binds) badBootDeclErr
+tcHsBootSigs (ValBindsOut binds sigs)
+ = do { checkTc (null binds) badBootDeclErr
; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
where
- tc_boot_sig (Sig (L _ name) ty)
+ tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
-- Notice that we make GlobalIds, not LocalIds
returnM (ip_inst, (IPBind ip' expr'))
------------------------
-mkEdges :: (Name -> Bool) -> [LHsBind Name]
- -> [(LHsBind Name, BKey, [BKey])]
-
-type BKey = Int -- Just number off the bindings
-
-mkEdges exclude_fn binds
- = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
- let mb_key = lookupNameEnv key_map n,
- isJust mb_key,
- not (exclude_fn n) ])
- | (bind, key) <- keyd_binds
- ]
- where
- keyd_binds = binds `zip` [0::BKey ..]
-
- bind_fvs (FunBind _ _ _ fvs) = fvs
- bind_fvs (PatBind _ _ _ fvs) = fvs
- bind_fvs bind = pprPanic "mkEdges" (ppr bind)
-
- key_map :: NameEnv BKey -- Which binding it comes from
- key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
- , bndr <- bindersOfHsBind bind ]
-
-bindersOfHsBind :: HsBind Name -> [Name]
-bindersOfHsBind (PatBind pat _ _ _) = collectPatBinders pat
-bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]
-
-------------------------
tcValBinds :: TopLevelFlag
-> HsValBinds Name -> TcM thing
-> TcM (HsValBinds TcId, thing)
tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
+ = pprPanic "tcValBinds" (ppr binds)
+
+tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= tcAddLetBoundTyVars binds $
-- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
-- Notice that they scope over
do { -- Typecheck the signature
tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs)
-
- -- Do the basic strongly-connected component thing
- ; let { sccs :: [SCC (LHsBind Name)]
- ; sccs = stronglyConnComp (mkEdges (\n -> False) (bagToList binds))
- ; prag_fn = mkPragFun sigs
+ ; let { prag_fn = mkPragFun sigs
; sig_fn = lookupSig tc_ty_sigs
; sig_ids = map sig_id tc_ty_sigs }
-- the Ids declared with type signatures
; (binds', thing) <- tcExtendIdEnv sig_ids $
tc_val_binds top_lvl sig_fn prag_fn
- sccs thing_inside
+ binds thing_inside
- ; return (ValBindsOut binds', thing) }
+ ; return (ValBindsOut binds' sigs, thing) }
------------------------
tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun
- -> [SCC (LHsBind Name)] -> TcM thing
+ -> [(RecFlag, LHsBinds Name)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
= do { thing <- thing_inside
; return ([], thing) }
-tc_val_binds top_lvl sig_fn prag_fn (scc : sccs) thing_inside
+tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
- <- tc_group top_lvl sig_fn prag_fn scc $
- tc_val_binds top_lvl sig_fn prag_fn sccs thing_inside
+ <- tc_group top_lvl sig_fn prag_fn group $
+ tc_val_binds top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
------------------------
tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun
- -> SCC (LHsBind Name) -> TcM thing
+ -> (RecFlag, LHsBinds Name) -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck one strongly-connected component of the original program.
-- We get a list of groups back, because there may
-- be specialisations etc as well
-tc_group top_lvl sig_fn prag_fn scc@(AcyclicSCC bind) thing_inside
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
= -- A single non-recursive binding
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
- do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive
- sig_fn prag_fn scc thing_inside
+ do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive
+ sig_fn prag_fn binds thing_inside
; return ([(NonRecursive, b) | b <- binds], thing) }
-tc_group top_lvl sig_fn prag_fn (CyclicSCC binds) thing_inside
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
= -- A recursive strongly-connected component
- -- To maximise polymorphism, we do a new strongly-connected
- -- component analysis, this time omitting any references to
- -- variables with type signatures.
+ -- To maximise polymorphism (with -fglasgow-exts), we do a new
+ -- strongly-connected component analysis, this time omitting
+ -- any references to variables with type signatures.
--
-- Then we bring into scope all the variables with type signatures
- do { traceTc (text "tc_group rec" <+> vcat [ppr b $$ text "--and--" | b <- binds])
- ; let { sccs :: [SCC (LHsBind Name)]
- ; sccs = stronglyConnComp (mkEdges has_sig binds) }
- ; (binds, thing) <- go sccs
+ do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
+ ; gla_exts <- doptM Opt_GlasgowExts
+ ; (binds,thing) <- if gla_exts
+ then go new_sccs
+ else tc_binds Recursive binds thing_inside
; return ([(Recursive, unionManyBags binds)], thing) }
-- Rec them all together
where
+ new_sccs :: [SCC (LHsBind Name)]
+ new_sccs = stronglyConnComp (mkEdges sig_fn binds)
+
-- go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing)
go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs)
; return (binds1 ++ binds2, thing) }
go [] = do { thing <- thing_inside; return ([], thing) }
- go1 scc thing_inside = tcPolyBinds top_lvl Recursive
- sig_fn prag_fn scc thing_inside
+ go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind)
+ go1 (CyclicSCC binds) = tc_binds Recursive (listToBag binds)
- has_sig :: Name -> Bool
- has_sig n = isJust (sig_fn n)
+ tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds
------------------------
-tcPolyBinds :: TopLevelFlag -> RecFlag
+mkEdges :: TcSigFun -> LHsBinds Name
+ -> [(LHsBind Name, BKey, [BKey])]
+
+type BKey = Int -- Just number off the bindings
+
+mkEdges sig_fn binds
+ = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
+ let mb_key = lookupNameEnv key_map n,
+ isJust mb_key,
+ no_sig n ])
+ | (bind, key) <- keyd_binds
+ ]
+ where
+ no_sig :: Name -> Bool
+ no_sig n = isNothing (sig_fn n)
+
+ keyd_binds = bagToList binds `zip` [0::BKey ..]
+
+ bind_fvs (FunBind _ _ _ fvs) = fvs
+ bind_fvs (PatBind _ _ _ fvs) = fvs
+ bind_fvs bind = pprPanic "mkEdges" (ppr bind)
+
+ key_map :: NameEnv BKey -- Which binding it comes from
+ key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
+ , bndr <- bindersOfHsBind bind ]
+
+bindersOfHsBind :: HsBind Name -> [Name]
+bindersOfHsBind (PatBind pat _ _ _) = collectPatBinders pat
+bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]
+
+------------------------
+tcPolyBinds :: TopLevelFlag
+ -> RecFlag -- Whether the group is really recursive
+ -> RecFlag -- Whether it's recursive for typechecking purposes
-> TcSigFun -> TcPragFun
- -> SCC (LHsBind Name)
+ -> LHsBinds Name
-> TcM thing
-> TcM ([LHsBinds TcId], thing)
-- group, because we use type signatures to maximise polymorphism
--
-- Deals with the bindInstsOfLocalFuns thing too
+--
+-- Returns a list because the input may be a single non-recursive binding,
+-- in which case the dependency order of the resulting bindings is
+-- important.
-tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside
+tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside
= -- NB: polymorphic recursion means that a function
-- may use an instance of itself, we must look at the LIE arising
-- from the function's own right hand side. Hence the getLIE
- -- encloses the tc_poly_binds.
- do { traceTc (text "tcPolyBinds" <+> ppr scc)
+ -- encloses the tc_poly_binds.
+ do { traceTc (text "tcPolyBinds" <+> ppr scc)
; ((binds1, poly_ids, thing), lie) <- getLIE $
- do { (binds1, poly_ids) <- tc_poly_binds top_lvl is_rec
+ do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc
sig_fn prag_fn scc
; thing <- tcExtendIdEnv poly_ids thing_inside
; return (binds1, poly_ids, thing) }
; return (binds1 ++ [lie_binds], thing) }}
------------------------
-tc_poly_binds :: TopLevelFlag -> RecFlag
+tc_poly_binds :: TopLevelFlag -- See comments on tcPolyBinds
+ -> RecFlag -> RecFlag
-> TcSigFun -> TcPragFun
- -> SCC (LHsBind Name)
+ -> LHsBinds Name
-> TcM ([LHsBinds TcId], [TcId])
-- Typechecks the bindings themselves
-- Knows nothing about the scope of the bindings
-tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
+tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds
= let
- non_rec = case bind_scc of { AcyclicSCC _ -> True; CyclicSCC _ -> False }
- binds = flattenSCC bind_scc
- binder_names = collectHsBindBinders (listToBag binds)
+ binder_names = collectHsBindBinders binds
+ bind_list = bagToList binds
- loc = getLoc (head binds)
+ loc = getLoc (head bind_list)
-- TODO: location a bit awkward, but the mbinds have been
-- dependency analysed and may no longer be adjacent
in
-- TYPECHECK THE BINDINGS
; ((binds', mono_bind_infos), lie_req)
- <- getLIE (tcMonoBinds binds sig_fn non_rec)
+ <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
-- CHECK FOR UNLIFTED BINDINGS
-- These must be non-recursive etc, and are not generalised
; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
; if any isUnLiftedType zonked_mono_tys then
do { -- Unlifted bindings
- checkUnliftedBinds top_lvl is_rec binds' mono_bind_infos
+ checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos
; extendLIEs lie_req
; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
mk_export (name, Nothing, mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
[poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
else do -- The normal lifted case: GENERALISE
- { is_unres <- isUnRestrictedGroup binds sig_fn
+ { is_unres <- isUnRestrictedGroup bind_list sig_fn
; (tyvars_to_gen, dict_binds, dict_ids)
<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
generalise top_lvl is_unres mono_bind_infos lie_req
pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
tcPrag :: TcId -> Sig Name -> TcM Prag
-tcPrag poly_id (SpecSig orig_name hs_ty) = tcSpecPrag poly_id hs_ty
-tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty
-tcPrag poly_id (InlineSig inl _ act) = return (InlinePrag inl act)
+tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl
+tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec
+tcPrag poly_id (InlineSig v inl) = return (InlinePrag inl)
-tcSpecPrag :: TcId -> LHsType Name -> TcM Prag
-tcSpecPrag poly_id hs_ty
+tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
+tcSpecPrag poly_id hs_ty inl
= do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
; (co_fn, lie) <- getLIE (tcSub spec_ty (idType poly_id))
; extendLIEs lie
; let const_dicts = map instToId lie
- ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts) }
+ ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts inl) }
--------------
-- If typechecking the binds fails, then return with each
checkUnliftedBinds :: TopLevelFlag -> RecFlag
-> LHsBinds TcId -> [MonoBindInfo] -> TcM ()
-checkUnliftedBinds top_lvl is_rec mbind infos
+checkUnliftedBinds top_lvl rec_group mbind infos
= do { checkTc (isNotTopLevel top_lvl)
(unliftedBindErr "Top-level" mbind)
- ; checkTc (isNonRec is_rec)
+ ; checkTc (isNonRec rec_group)
(unliftedBindErr "Recursive" mbind)
; checkTc (isSingletonBag mbind)
(unliftedBindErr "Multiple" mbind)
\begin{code}
tcMonoBinds :: [LHsBind Name]
-> TcSigFun
- -> Bool -- True <=> either the binders are not mentioned
- -- in their RHSs or they have type sigs
+ -> RecFlag -- True <=> the binding is recursive for typechecking purposes
+ -- i.e. the binders are mentioned in their RHSs, and
+ -- we are not resuced by a type signature
-> TcM (LHsBinds TcId, [MonoBindInfo])
tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)]
sig_fn -- Single function binding,
- True -- binder isn't mentioned in RHS,
+ NonRecursive -- binder isn't mentioned in RHS,
| Nothing <- sig_fn name -- ...with no type signature
= -- In this very special case we infer the type of the
-- right hand side first (it may have a higher-rank type)
\begin{code}
tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
-tcTySigs sigs = mappM tcTySig (filter isVanillaLSig sigs)
+tcTySigs sigs = do { mb_sigs <- mappM tcTySig (filter isVanillaLSig sigs)
+ ; return (catMaybes mb_sigs) }
-tcTySig :: LSig Name -> TcM TcSigInfo
-tcTySig (L span (Sig (L _ name) ty))
- = setSrcSpan span $
+tcTySig :: LSig Name -> TcM (Maybe TcSigInfo)
+tcTySig (L span (TypeSig (L _ name) ty))
+ = recoverM (return Nothing) $
+ setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty
; loc <- getInstLoc (SigOrigin (SigSkol name))
- ; return (TcSigInfo { sig_id = mkLocalId name sigma_ty,
- sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
- sig_scoped = scoped_names, sig_loc = loc }) }
+ ; return (Just (TcSigInfo { sig_id = mkLocalId name sigma_ty,
+ sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
+ sig_scoped = scoped_names, sig_loc = loc })) }
where
-- The scoped names are the ones explicitly mentioned
-- in the HsForAll. (There may be more in sigma_ty, because
projects / ghc-hetmet.git / blobdiff