module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
- HsExpr, Match, PolyType, InPat, OutPat,
+ HsExpr, Match, PolyType, InPat, OutPat(..),
GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
collectBinders )
-import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
- RenamedMonoBinds(..), RnName(..)
+import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..),
+ SYN_IE(RenamedMonoBinds), RnName(..)
)
-import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
- TcIdOcc(..), TcIdBndr(..) )
+import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds),
+ TcIdOcc(..), SYN_IE(TcIdBndr) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
-import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
+import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
-import TcLoop ( tcGRHSsAndBinds )
+import SpecEnv ( SpecEnv )
+IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcMatches ( tcMatchesFun )
import TcMonoType ( tcPolyType )
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( newTcTyVar, tcInstType )
+import TcType ( newTcTyVar, tcInstSigType )
import Unify ( unifyTauTy )
import Kind ( mkBoxedTypeKind, mkTypeKind )
import Id ( GenId, idType, mkUserId )
import IdInfo ( noIdInfo )
-import Maybes ( assocMaybe, catMaybes, Maybe(..) )
-import Name ( pprNonOp )
+import Maybes ( assocMaybe, catMaybes )
+import Name ( pprNonSym, Name )
import PragmaInfo ( PragmaInfo(..) )
import Pretty
-import RnHsSyn ( RnName ) -- instances
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy,
mkSigmaTy, splitSigmaTy,
splitRhoTy, mkForAllTy, splitForAllTy )
-import Util ( panic )
+import Util ( isIn, zipEqual, panic )
\end{code}
%************************************************************************
genBinds binder_names mono_ids bind' lie sig_info prag_info_fn
where
kind = case bind of
- NonRecBind _ -> mkBoxedTypeKind -- Recursive, so no unboxed types
- RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types
+ NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types
+ RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types
\end{code}
`thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) ->
+ *** CHECK FOR UNBOXED TYVARS HERE! ***
+
+
+
-- Make poly_ids for all the binders that don't have type signatures
let
+ tys_to_gen = mkTyVarTys tyvars_to_gen
dicts_to_gen = map instToId (bagToList lie_to_gen)
- dict_tys = map tcIdType dicts_to_gen
+ dict_tys = map tcIdType dicts_to_gen
mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo
where
mkFunTys dict_tys $
tcIdType local_id
- tys_to_gen = mkTyVarTys tyvars_to_gen
more_sig_infos = [ SigInfo binder (mk_poly binder local_id)
local_id tys_to_gen dicts_to_gen lie_to_gen
- | (binder, local_id) <- nosig_binders `zipEqual` nosig_local_ids
+ | (binder, local_id) <- zipEqual "???" nosig_binders nosig_local_ids
]
- local_binds = [ (local_id, DictApp (mkHsTyApp (HsVar local_id) inst_tys) dicts)
- | SigInfo _ _ local_id inst_tys dicts <- more_sig_infos
- ]
-
all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder
in
-- Now generalise the bindings
let
- find_sig lid = head [ (pid, tvs, ds, lie)
+ -- local_binds is a bunch of bindings of the form
+ -- f_mono = f_poly tyvars dicts
+ -- one for each binder, f, that lacks a type signature.
+ -- This bunch of bindings is put at the top of the RHS of every
+ -- binding in the group, so as to bind all the f_monos.
+
+ local_binds = [ (local_id, mkHsDictApp (mkHsTyApp (HsVar local_id) tys_to_gen) dicts_to_gen)
+ | local_id <- nosig_local_ids
+ ]
+
+ find_sig lid = head [ (pid, tvs, ds, lie)
| SigInfo _ pid lid' tvs ds lie,
lid==lid'
]
- -- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen:
- -- We still need to do this simplification, because some dictionaries
- -- may gratuitously constrain some tyvars over which we *are* going
- -- to generalise.
- -- For example d::Eq (Foo a b), where Foo is instanced as above.
+
gen_bind (bind, lie)
= tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie
`thenTc` \ (lie_free, dict_binds) ->
returnTc (AbsBind tyvars_to_gen_here
dicts
- (local_ids `zipEqual` poly_ids)
+ (zipEqual "gen_bind" local_ids poly_ids)
(dict_binds ++ local_binds)
bind,
lie_free)
returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE)
where
- sig_ids = [sig_var | (TySigInfo sig_id _ _ _ _) <- ty_sigs]
+ sig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs]
(tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2,
lie1 `plusLIE` lie2))
tcTySigs (Sig v ty _ src_loc : other_sigs)
= tcAddSrcLoc src_loc (
tcPolyType ty `thenTc` \ sigma_ty ->
- tcInstType [] sigma_ty `thenNF_Tc` \ sigma_ty' ->
+ tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
let
(tyvars', theta', tau') = splitSigmaTy sigma_ty'
in
-- Get and instantiate its alleged specialised type
tcPolyType poly_ty `thenTc` \ sig_sigma ->
- tcInstType [] sig_sigma `thenNF_Tc` \ sig_ty ->
+ tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
let
(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
origin = ValSpecOrigin name
-- Get and instantiate the type of the id mentioned
tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
- tcInstType [] (idType main_id) `thenNF_Tc` \ main_ty ->
+ tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
let
(main_tyvars, main_rho) = splitForAllTy main_ty
(main_theta,main_tau) = splitRhoTy main_rho
\end{code}
-Error contexts and messages
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection[TcBinds-monomorphism]{The monomorphism restriction}
+%* *
+%************************************************************************
+
+Not exported:
+
+\begin{code}
+isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these
+ -> TcBind s
+ -> Bool
+
+isUnRestrictedGroup sigs EmptyBind = True
+isUnRestrictedGroup sigs (NonRecBind monobinds) = isUnResMono sigs monobinds
+isUnRestrictedGroup sigs (RecBind monobinds) = isUnResMono sigs monobinds
+
+is_elem v vs = isIn "isUnResMono" v vs
+
+isUnResMono sigs (PatMonoBind (VarPat (TcId v)) _ _) = v `is_elem` sigs
+isUnResMono sigs (PatMonoBind other _ _) = False
+isUnResMono sigs (VarMonoBind (TcId v) _) = v `is_elem` sigs
+isUnResMono sigs (FunMonoBind _ _ _ _) = True
+isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 &&
+ isUnResMono sigs mb2
+isUnResMono sigs EmptyMonoBinds = True
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[TcBinds-errors]{Error contexts and messages}
+%* *
+%************************************************************************
+
+
\begin{code}
patMonoBindsCtxt bind sty
= ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
valSpecSigCtxt v ty sty
= ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
- 4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")),
+ 4 (ppSep [ppBeside (pprNonSym sty v) (ppPStr SLIT(" ::")),
ppr sty ty])
\end{code}
projects / ghc-hetmet.git / blobdiff