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(..),
import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
TcIdOcc(..), TcIdBndr(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
-import TcLoop ( tcGRHSsAndBinds )
+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 Outputable ( pprNonOp )
+import Name ( pprNonSym )
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}
+
+===========
+\begin{code}
+{-
+
+data SigInfo
+ = SigInfo RnName
+ (TcIdBndr s) -- Polymorpic version
+ (TcIdBndr s) -- Monomorphic verstion
+ [TcType s] [TcIdOcc s] -- Instance information for the monomorphic version
+
+
+
+ -- Deal with type signatures
+ tcTySigs sigs `thenTc` \ sig_infos ->
+ let
+ sig_binders = [binder | SigInfo binder _ _ _ _ <- sig_infos]
+ poly_sigs = [(name,poly) | SigInfo name poly _ _ _ <- sig_infos]
+ mono_sigs = [(name,mono) | SigInfo name _ mono _ _ <- sig_infos]
+ nosig_binders = binders `minusList` sig_binders
+ in
+
+
+ -- Typecheck the binding group
+ tcExtendLocalEnv poly_sigs (
+ newMonoIds nosig_binders kind (\ nosig_local_ids ->
+ tcMonoBinds mono_sigs mono_binds `thenTc` \ binds_w_lies ->
+ returnTc (nosig_local_ids, binds_w_lies)
+ )) `thenTc` \ (nosig_local_ids, binds_w_lies) ->
+
+
+ -- Decide what to generalise over
+ getImplicitStuffToGen sig_ids binds_w_lies
+ `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
+
+ mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo
+ where
+ ty = mkForAllTys tyvars_to_gen $
+ mkFunTys dict_tys $
+ tcIdType local_id
+
+ more_sig_infos = [ SigInfo binder (mk_poly binder local_id)
+ local_id tys_to_gen dicts_to_gen lie_to_gen
+ | (binder, local_id) <- zipEqual "???" nosig_binders nosig_local_ids
+ ]
+
+ all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder
+ in
+
+
+ -- Now generalise the bindings
+ let
+ -- 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'
+ ]
+
+ 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
+ (zipEqual "gen_bind" local_ids poly_ids)
+ (dict_binds ++ local_binds)
+ bind,
+ lie_free)
+ where
+ local_ids = bindersOf bind
+ local_sigs = [sig | sig@(SigInfo _ _ local_id _ _) <- all_sig_infos,
+ local_id `elem` local_ids
+ ]
+
+ (tyvars_to_gen_here, dicts, avail)
+ = case (local_ids, sigs) of
+
+ ([local_id], [SigInfo _ _ _ tyvars_to_gen dicts lie])
+ -> (tyvars_to_gen, dicts, lie)
+
+ other -> (tyvars_to_gen, dicts, avail)
+\end{code}
+
+@getImplicitStuffToGen@ decides what type variables
+and LIE to generalise over.
+
+For a "restricted group" -- see the monomorphism restriction
+for a definition -- we bind no dictionaries, and
+remove from tyvars_to_gen any constrained type variables
+
+*Don't* simplify dicts at this point, because we aren't going
+to generalise over these dicts. By the time we do simplify them
+we may well know more. For example (this actually came up)
+ f :: Array Int Int
+ f x = array ... xs where xs = [1,2,3,4,5]
+We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
+stuff. If we simplify only at the f-binding (not the xs-binding)
+we'll know that the literals are all Ints, and we can just produce
+Int literals!
+
+Find all the type variables involved in overloading, the "constrained_tyvars"
+These are the ones we *aren't* going to generalise.
+We must be careful about doing this:
+ (a) If we fail to generalise a tyvar which is not actually
+ constrained, then it will never, ever get bound, and lands
+ up printed out in interface files! Notorious example:
+ instance Eq a => Eq (Foo a b) where ..
+ Here, b is not constrained, even though it looks as if it is.
+ Another, more common, example is when there's a Method inst in
+ the LIE, whose type might very well involve non-overloaded
+ type variables.
+ (b) On the other hand, we mustn't generalise tyvars which are constrained,
+ because we are going to pass on out the unmodified LIE, with those
+ tyvars in it. They won't be in scope if we've generalised them.
+
+So we are careful, and do a complete simplification just to find the
+constrained tyvars. We don't use any of the results, except to
+find which tyvars are constrained.
+
+\begin{code}
+getImplicitStuffToGen is_restricted sig_ids binds_w_lies
+ | isUnRestrictedGroup tysig_vars bind
+ = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, dicts_to_gen) ->
+ returnNF_Tc (emptyTyVarSet, tyvars_to_gen, dicts_to_gen)
+
+ | otherwise
+ = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
+ let
+ -- ASSERT: dicts_sig is already zonked!
+ constrained_tyvars = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet constrained_dicts
+ reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
+ in
+ returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE)
+
+ where
+ sig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs]
+
+ (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2,
+ lie1 `plusLIE` lie2))
+ get
+ (emptyTyVarSet, emptyLIE)
+ binds_w_lies
+ get (bind, lie)
+ = case bindersOf bind of
+ [local_id] | local_id `in` sig_ids -> -- A simple binding with
+ -- a type signature
+ (emptyTyVarSet, emptyLIE)
+
+ local_ids -> -- Complex binding or no type sig
+ (foldr (unionTyVarSets . tcIdType) emptyTyVarSet local_ids,
+ lie)
+-}
+\end{code}
+
+
+
\begin{code}
tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
plusLIE lie_pat lie)
-tcMonoBinds (FunMonoBind name matches locn)
+tcMonoBinds (FunMonoBind name inf matches locn)
= tcAddSrcLoc locn $
tcLookupLocalValueOK "tcMonoBinds" name `thenNF_Tc` \ id ->
tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
- returnTc (FunMonoBind (TcId id) matches' locn, lie)
+ returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
\end{code}
%************************************************************************
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