+
+===========
+\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) <- nosig_binders `zipEqual` 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
+ (local_ids `zipEqual` 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}
+
+
+