\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
- LSig, Match(..), HsBindGroup(..), IPBind(..),
+ LSig, Match(..), HsBindGroup(..), IPBind(..),
+ HsType(..), hsLTyVarNames, isVanillaLSig,
LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
collectHsBindBinders, collectPatBinders, pprPatBind
)
import TcRnMonad
import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
-import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, newLocalName, tcLookupLocalIds )
+import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, newLocalName, tcLookupLocalIds )
import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs )
import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
- TcSigInfo(..), TcSigFun, mkTcSig, lookupSig
+ TcSigInfo(..), TcSigFun, lookupSig
)
import TcPat ( tcPat, PatCtxt(..) )
import TcSimplify ( bindInstsOfLocalFuns )
mkForAllTy, isUnLiftedType, tcGetTyVar_maybe,
mkTyVarTys )
import Unify ( tcMatchPreds )
-import Kind ( argTypeKind, isUnliftedTypeKind )
+import Kind ( argTypeKind )
import VarEnv ( lookupVarEnv )
import TysPrim ( alphaTyVar )
import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
import Var ( idType, idName )
import Name ( Name )
import NameSet
-import Var ( tyVarKind )
import VarSet
import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
import Bag
-- want. The bit we care about is the local bindings
-- and the free type variables thereof
tcTopBinds binds
- = tc_binds_and_then TopLevel glue binds $
- getLclEnv `thenM` \ env ->
- returnM (emptyLHsBinds, env)
+ = tc_binds_and_then TopLevel glue binds $
+ do { env <- getLclEnv
+ ; return (emptyLHsBinds, env) }
where
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive MonoBinds
glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
+ glue (HsIPBinds _) _ = panic "Top-level HsIpBinds"
-- Can't have a HsIPBinds at top level
+tcHsBootSigs :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
+-- A hs-boot file has only one BindGroup, and it only has type
+-- signatures in it. The renamer checked all this
+tcHsBootSigs [HsBindGroup _ sigs _]
+ = do { ids <- mapM (addLocM tc_sig) (filter isVanillaLSig sigs)
+ ; tcExtendIdEnv ids $ do
+ { env <- getLclEnv
+ ; return (emptyLHsBinds, env) }}
+ where
+ tc_sig (Sig (L _ name) ty)
+ = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+ ; return (mkLocalId name sigma_ty) }
tcBindsAndThen
:: (HsBindGroup TcId -> thing -> thing) -- Combinator
tcBindWithSigs top_lvl mbind sigs is_rec = do
{ -- TYPECHECK THE SIGNATURES
tc_ty_sigs <- recoverM (returnM []) $
- tcTySigs [sig | sig@(L _(Sig name _)) <- sigs]
+ tcTySigs (filter isVanillaLSig sigs)
; let lookup_sig = lookupSig tc_ty_sigs
-- SET UP THE MAIN RECOVERY; take advantage of any type sigs
-> TcSigFun -> RecFlag
-> TcM (LHsBinds TcId, [MonoBindInfo])
-type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
- -- Type signature (if any), and
- -- the monomorphic bound things
-
-bndrNames :: [MonoBindInfo] -> [Name]
-bndrNames mbi = [n | (n,_,_) <- mbi]
-
-getMonoType :: MonoBindInfo -> TcTauType
-getMonoType (_,_,mono_id) = idType mono_id
-
tcMonoBinds binds lookup_sig is_rec
= do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
- ; let mono_info = getMonoBindInfo tc_binds
- ; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $
+
+ -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
+ -- For (a) it's ok to bring them all into scope at once, even
+ -- though each type sig should scope only over its own RHS,
+ -- because the renamer has sorted all that out.
+ ; let mono_info = getMonoBindInfo tc_binds
+ rhs_tvs = [ (name, mkTyVarTy tv)
+ | (_, Just sig, _) <- mono_info,
+ (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
+ rhs_id_env = map mk mono_info -- A binding for each term variable
+
+ ; binds' <- tcExtendTyVarEnv2 rhs_tvs $
+ tcExtendIdEnv2 rhs_id_env $
mapBagM (wrapLocM tcRhs) tc_binds
; return (binds', mono_info) }
+ where
+ mk (name, Just sig, _) = (name, sig_id sig) -- Use the type sig if there is one
+ mk (name, Nothing, mono_id) = (name, mono_id) -- otherwise use a monomorphic version
------------------------
-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
= TcFunBind MonoBindInfo (Located TcId) Bool (MatchGroup Name)
| TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
+type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
+ -- Type signature (if any), and
+ -- the monomorphic bound things
+
+bndrNames :: [MonoBindInfo] -> [Name]
+bndrNames mbi = [n | (n,_,_) <- mbi]
+
+getMonoType :: MonoBindInfo -> TcTauType
+getMonoType (_,_,mono_id) = idType mono_id
+
tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
tcLhs lookup_sig (FunBind (L nm_loc name) inf matches)
= do { let mb_sig = lookup_sig name
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
-tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches)
+tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
= do { matches' <- tcMatchesFun (idName mono_id) matches
(Check (idType mono_id))
; return (FunBind fun' inf matches') }
where
get_info (TcFunBind info _ _ _) rest = info : rest
get_info (TcPatBind infos _ _ _) rest = infos ++ rest
-
----------------------
-rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)]
--- Environment for RHS of definitions: use type sig if there is one
-rhsEnvExtension mono_info
- = map mk mono_info
- where
- mk (name, Just sig, _) = (name, sig_id sig)
- mk (name, Nothing, mono_id) = (name, mono_id)
\end{code}
-- all the right hand sides agree a common vocabulary for their type
-- constraints
tcTySigs [] = return []
-tcTySigs (L span (Sig (L _ name) ty) : sigs)
- = do { -- Typecheck the first signature
- ; sigma1 <- setSrcSpan span $
- tcHsSigType (FunSigCtxt name) ty
- ; let id1 = mkLocalId name sigma1
- ; tc_sig1 <- mkTcSig id1
- ; tc_sigs <- mapM (tcTySig tc_sig1) sigs
- ; return (tc_sig1 : tc_sigs) }
+tcTySigs sigs
+ = do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs
+ ; tc_sigs' <- mapM (checkSigCtxt tc_sig1) tc_sigs
+ ; return (tc_sig1 : tc_sigs') }
-tcTySig sig1 (L span (Sig (L _ name) ty))
+tcTySig :: LSig Name -> TcM TcSigInfo
+tcTySig (L span (Sig (L _ name) ty))
= setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+ ; let rigid_info = SigSkol name
+ poly_id = mkLocalId name sigma_ty
+
+ -- 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.)
+ scoped_names = case ty of
+ L _ (HsForAllTy _ tvs _ _) -> hsLTyVarNames tvs
+ other -> []
+
; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
- ; let poly_id = mkLocalId name sigma_ty
- bale_out = failWithTc $
- sigContextsErr (sig_id sig1) name sigma_ty
+ ; loc <- getInstLoc (SigOrigin rigid_info)
+ ; return (TcSigInfo { sig_id = poly_id, sig_scoped = scoped_names,
+ sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
+ sig_loc = loc }) }
- -- Try to match the context of this signature with
+checkSigCtxt :: TcSigInfo -> TcSigInfo -> TcM TcSigInfo
+checkSigCtxt sig1 sig@(TcSigInfo { sig_tvs = tvs, sig_theta = theta, sig_tau = tau })
+ = -- Try to match the context of this signature with
-- that of the first signature
- ; case tcMatchPreds tvs theta (sig_theta sig1) of {
- Nothing -> bale_out
- ; Just tenv -> do
- ; case check_tvs tenv tvs of
- Nothing -> bale_out
- Just tvs' -> do {
-
- let subst = mkTvSubst tenv
- theta' = substTheta subst theta
- tau' = substTy subst tau
- ; loc <- getInstLoc (SigOrigin rigid_info)
- ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs',
- sig_theta = theta', sig_tau = tau',
- sig_loc = loc }) }}}
+ case tcMatchPreds (sig_tvs sig) (sig_theta sig) (sig_theta sig1) of {
+ Nothing -> bale_out ;
+ Just tenv ->
+
+ case check_tvs tenv tvs of {
+ Nothing -> bale_out ;
+ Just tvs' ->
+
+ let
+ subst = mkTvSubst tenv
+ in
+ return (sig { sig_tvs = tvs',
+ sig_theta = substTheta subst theta,
+ sig_tau = substTy subst tau }) }}
+
where
- rigid_info = SigSkol name
+ bale_out = setSrcSpan (instLocSrcSpan (sig_loc sig)) $
+ failWithTc $
+ sigContextsErr (sig_id sig1) (sig_id sig)
-- Rather tedious check that the type variables
-- have been matched only with another type variable,
nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
-sigContextsErr id1 name ty
+sigContextsErr id1 id2
= vcat [ptext SLIT("Mis-match between the contexts of the signatures for"),
nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
- ppr name <+> dcolon <+> ppr ty]),
+ ppr id2 <+> dcolon <+> ppr (idType id2)]),
ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]