import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcExpr )
+import CmdLineOpts ( opt_NoMonomorphismRestriction )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..),
Match(..), collectMonoBinders, andMonoBinds
)
import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
mkForAllTys, mkFunTys,
mkPredTy, mkForAllTy, isUnLiftedType,
- isUnboxedType, unboxedTypeKind, boxedTypeKind, openTypeKind
+ unliftedTypeKind, liftedTypeKind, openTypeKind
)
-import FunDeps ( tyVarFunDep, oclose )
+import FunDeps ( oclose )
import Var ( tyVarKind )
import VarSet
import Bag
-- 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
-- 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 = collectMonoBinders mbind
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.
pat_binders :: [Name]
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
-- Figure out the appropriate kind for the pattern,
-- and generate a suitable type variable
kind = case is_rec of
- Recursive -> boxedTypeKind -- Recursive, so no unboxed types
- NonRecursive -> openTypeKind -- Non-recursive, so we permit unboxed types
+ Recursive -> liftedTypeKind -- Recursive, so no unlifted types
+ NonRecursive -> openTypeKind -- Non-recursive, so we permit unlifted types
\end{code}
%************************************************************************
= -- First unify the main_id with IO t, for any old t
tcSetErrCtxt mainTyCheckCtxt (
tcLookupTyCon ioTyConName `thenTc` \ ioTyCon ->
- newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv ->
+ newTyVarTy liftedTypeKind `thenNF_Tc` \ t_tv ->
unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
(idType main_mono_id)
) `thenTc_`
nest 4 (ppr v <+> dcolon <+> ppr 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