\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
+module TcBinds ( tcBindsAndThen, tcTopBinds,
tcSpecSigs, tcBindWithSigs ) where
#include "HsVersions.h"
import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcExpr )
-import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
- Match(..), collectMonoBinders, andMonoBindList, andMonoBinds
+import CmdLineOpts ( opt_NoMonomorphismRestriction )
+import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..),
+ Match(..), collectMonoBinders, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
-import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
+import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
-import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
+import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
newDicts, tyVarsOfInst, instToId,
getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
- tcLookupTyConByKey,
+ tcLookupTyCon,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
)
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( TcType, TcThetaType,
- TcTyVar,
- newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
- zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
+import TcType ( TcThetaType, newTyVarTy, newTyVar,
+ zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
)
import TcUnify ( unifyTauTy, unifyTauTyLists )
-import Id ( Id, mkVanillaId, setInlinePragma, idFreeTyVars )
+import CoreFVs ( idFreeTyVars )
+import Id ( mkVanillaId, setInlinePragma )
import Var ( idType, idName )
-import IdInfo ( setInlinePragInfo, InlinePragInfo(..) )
-import Name ( Name, getName, getOccName, getSrcLoc )
+import IdInfo ( InlinePragInfo(..) )
+import Name ( Name, getOccName, getSrcLoc )
import NameSet
import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
- splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
- mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType,
- isUnboxedType, unboxedTypeKind, boxedTypeKind
+ mkForAllTys, mkFunTys,
+ mkPredTy, mkForAllTy, isUnLiftedType,
+ unliftedTypeKind, liftedTypeKind, openTypeKind
)
-import FunDeps ( tyVarFunDep, oclose )
-import Var ( TyVar, tyVarKind )
+import FunDeps ( oclose )
+import Var ( tyVarKind )
import VarSet
import Bag
import Util ( isIn )
import Maybes ( maybeToBool )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
import FiniteMap ( listToFM, lookupFM )
-import Unique ( ioTyConKey, mainKey, hasKey, Uniquable(..) )
-import SrcLoc ( SrcLoc )
+import PrelNames ( ioTyConName, mainKey, hasKey )
import Outputable
\end{code}
dictionaries, which we resolve at the module level.
\begin{code}
-tcTopBindsAndThen, tcBindsAndThen
+tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE)
+tcTopBinds binds
+ = tc_binds_and_then TopLevel glue binds $
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc ((EmptyMonoBinds, env), emptyLIE)
+ where
+ glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)
+
+
+tcBindsAndThen
:: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
-> RenamedHsBinds
- -> TcM s (thing, LIE)
- -> TcM s (thing, LIE)
+ -> TcM (thing, LIE)
+ -> TcM (thing, LIE)
-tcTopBindsAndThen = tc_binds_and_then TopLevel
-tcBindsAndThen = tc_binds_and_then NotTopLevel
+tcBindsAndThen = tc_binds_and_then NotTopLevel
tc_binds_and_then top_lvl combiner EmptyBinds do_next
= do_next
-- Create specialisations of functions bound here
-- We want to keep non-recursive things non-recursive
- -- so that we desugar unboxed bindings correctly
+ -- so that we desugar unlifted bindings correctly
case (top_lvl, is_rec) of
-- For the top level don't bother will all this bindInstsOfLocalFuns stuff
\begin{pseudocode}
% tcBindsAndThen
% :: RenamedHsBinds
-% -> TcM s (thing, LIE, thing_ty))
-% -> TcM s ((TcHsBinds, thing), LIE, thing_ty)
+% -> TcM (thing, LIE, thing_ty))
+% -> TcM ((TcHsBinds, thing), LIE, thing_ty)
%
% tcBindsAndThen EmptyBinds do_next
% = do_next `thenTc` \ (thing, lie, thing_ty) ->
-> [TcSigInfo]
-> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
-> RecFlag
- -> TcM s (TcMonoBinds, LIE, [TcId])
+ -> TcM (TcMonoBinds, LIE, [TcId])
tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
= recoverTc (
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise subsequent
-- error messages
- newTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
+ newTyVar liftedTypeKind `thenNF_Tc` \ alpha_tv ->
let
forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
- binder_names = map fst (bagToList (collectMonoBinders mbind))
+ binder_names = collectMonoBinders mbind
poly_ids = map mk_dummy binder_names
mk_dummy name = case maybeSig tc_ty_sigs name of
Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-- Finally, zonk the generalised type variables to real TyVars
- -- This commits any unbound kind variables to boxed kind
+ -- This commits any unbound kind variables to lifted kind
-- I'm a little worried that such a kind variable might be
-- free in the environment, but I don't think it's possible for
-- this to happen when the type variable is not free in the envt
returnTc ()
) `thenTc_`
- ASSERT( not (any ((== unboxedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
+ ASSERT( not (any ((== unliftedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
-- The instCantBeGeneralised stuff in tcSimplify should have
-- already raised an error if we're trying to generalise an
- -- unboxed tyvar (NB: unboxed tyvars are always introduced
+ -- unlifted tyvar (NB: unlifted tyvars are always introduced
-- along with a class constraint) and it's better done there
-- because we have more precise origin information.
-- That's why we just use an ASSERT here.
-- at all.
pat_binders :: [Name]
- pat_binders = map fst $ bagToList $ collectMonoBinders $
- (justPatBindings mbind EmptyMonoBinds)
+ pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
in
- -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
+ -- CHECK FOR UNLIFTED BINDERS IN PATTERN BINDINGS
mapTc (\id -> checkTc (not (idName id `elem` pat_binders
- && isUnboxedType (idType id)))
- (unboxedPatBindErr id)) zonked_mono_ids
+ && isUnLiftedType (idType id)))
+ (unliftedPatBindErr id)) zonked_mono_ids
`thenTc_`
-- BUILD RESULTS
)
where
tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
- is_unrestricted = isUnRestrictedGroup tysig_names mbind
+ is_unrestricted | opt_NoMonomorphismRestriction = True
+ | otherwise = isUnRestrictedGroup tysig_names mbind
justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
justPatBindings (AndMonoBinds b1 b2) binds =
-- Then we should generalise over b too; otherwise it will be
-- reported as ambiguous.
zonkFunDeps fds `thenNF_Tc` \ fds' ->
- let tvFundep = tyVarFunDep fds'
- extended_tyvars = oclose tvFundep body_tyvars
+ let
+ extended_tyvars = oclose fds' body_tyvars
in
returnNF_Tc (emptyVarSet, extended_tyvars)
else
tcMonoBinds :: RenamedMonoBinds
-> [TcSigInfo]
-> RecFlag
- -> TcM s (TcMonoBinds,
+ -> TcM (TcMonoBinds,
LIE, -- LIE required
[Name], -- Bound names
[TcId]) -- Corresponding monomorphic bound things
tcMonoBinds mbinds tc_ty_sigs is_rec
= tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
let
- tv_list = bagToList tvs
id_list = bagToList ids
(names, mono_ids) = unzip id_list
lie_avail1 `plusLIE` lie_avail2)
tc_mb_pats (FunMonoBind name inf matches locn)
- = new_lhs_ty `thenNF_Tc` \ bndr_ty ->
+ = newTyVarTy kind `thenNF_Tc` \ bndr_ty ->
tc_pat_bndr name bndr_ty `thenTc` \ bndr_id ->
let
complete_it xve = tcAddSrcLoc locn $
tc_mb_pats bind@(PatMonoBind pat grhss locn)
= tcAddSrcLoc locn $
- new_lhs_ty `thenNF_Tc` \ pat_ty ->
+ newTyVarTy kind `thenNF_Tc` \ pat_ty ->
-- Now typecheck the pattern
-- We don't support binding fresh type variables in the
-- Figure out the appropriate kind for the pattern,
-- and generate a suitable type variable
- new_lhs_ty = case is_rec of
- Recursive -> newTyVarTy boxedTypeKind -- Recursive, so no unboxed types
- NonRecursive -> newTyVarTy_OpenKind -- Non-recursive, so we permit unboxed types
+ kind = case is_rec of
+ Recursive -> liftedTypeKind -- Recursive, so no unlifted types
+ NonRecursive -> openTypeKind -- Non-recursive, so we permit unlifted types
\end{code}
%************************************************************************
now (ToDo).
\begin{code}
-checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM s (Maybe (TcThetaType, LIE))
+checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM (Maybe (TcThetaType, LIE))
checkSigMatch top_lvl binder_names mono_ids sigs
| main_bound_here
= -- First unify the main_id with IO t, for any old t
tcSetErrCtxt mainTyCheckCtxt (
- tcLookupTyConByKey ioTyConKey `thenTc` \ ioTyCon ->
- newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
+ tcLookupTyCon ioTyConName `thenTc` \ ioTyCon ->
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ t_tv ->
unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
(idType main_mono_id)
) `thenTc_`
-- which is just waht check_one_sig looks for
mapTc check_one_sig sigs `thenTc_`
mapTc check_main_ctxt sigs `thenTc_`
-
- returnTc (Just ([], emptyLIE))
+ returnTc (Just ([], emptyLIE))
| not (null sigs)
= mapTc check_one_sig sigs `thenTc_`
{-# SPECIALISE (f::<type) = g #-}
\begin{code}
-tcSpecSigs :: [RenamedSig] -> TcM s (TcMonoBinds, LIE)
+tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE)
tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
= -- SPECIALISE f :: forall b. theta => tau = g
tcAddSrcLoc src_loc $
nest 4 (ppr v <+> dcolon <+> ppr ty)]
-----------------------------------------------
-notAsPolyAsSigErr sig_tau mono_tyvars
- = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
- 4 (vcat [text "Can't for-all the type variable(s)" <+>
- pprQuotedList mono_tyvars,
- text "in the type" <+> quotes (ppr sig_tau)
- ])
-
------------------------------------------------
-badMatchErr sig_ty inferred_ty
- = hang (ptext SLIT("Type signature doesn't match inferred type"))
- 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
- hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
- ])
-
------------------------------------------------
-unboxedPatBindErr id
- = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
+unliftedPatBindErr id
+ = ptext SLIT("variable in a lazy pattern binding has unlifted type: ")
<+> quotes (ppr id)
-----------------------------------------------
-----------------------------------------------
unliftedBindErr flavour mbind
- = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))
+ = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
4 (ppr mbind)
existentialExplode mbinds
projects / ghc-hetmet.git / blobdiff