+\begin{code}
+generalise binder_names mbind tau_tvs lie_req sigs =
+
+ -- check for -fno-monomorphism-restriction
+ doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR ->
+ let is_unrestricted | no_MR = True
+ | otherwise = isUnRestrictedGroup tysig_names mbind
+ in
+
+ if not is_unrestricted then -- RESTRICTED CASE
+ -- Check signature contexts are empty
+ checkTc (all is_mono_sig sigs)
+ (restrictedBindCtxtErr binder_names) `thenM_`
+
+ -- Now simplify with exactly that set of tyvars
+ -- We have to squash those Methods
+ tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) ->
+
+ -- Check that signature type variables are OK
+ checkSigsTyVars qtvs sigs `thenM` \ final_qtvs ->
+
+ returnM (final_qtvs, binds, [])
+
+ else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
+ tcSimplifyInfer doc tau_tvs lie_req
+
+ else -- UNRESTRICTED CASE, WITH TYPE SIGS
+ -- CHECKING CASE: Unrestricted group, there are type signatures
+ -- Check signature contexts are identical
+ checkSigsCtxts sigs `thenM` \ (sig_avails, sig_dicts) ->
+
+ -- Check that the needed dicts can be
+ -- expressed in terms of the signature ones
+ tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenM` \ (forall_tvs, dict_binds) ->
+
+ -- Check that signature type variables are OK
+ checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs ->
+
+ returnM (final_qtvs, dict_binds, sig_dicts)
+
+ where
+ tysig_names = map (idName . sig_poly_id) sigs
+ is_mono_sig sig = null (sig_theta sig)
+
+ doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
+
+-----------------------
+ -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
+ -- The type signatures on a mutually-recursive group of definitions
+ -- must all have the same context (or none).
+ --
+ -- We unify them because, with polymorphic recursion, their types
+ -- might not otherwise be related. This is a rather subtle issue.
+ -- ToDo: amplify
+checkSigsCtxts sigs@(TySigInfo { sig_poly_id = id1, sig_tvs = sig_tvs, sig_theta = theta1, sig_loc = span}
+ : other_sigs)
+ = addSrcSpan span $
+ mappM_ check_one other_sigs `thenM_`
+ if null theta1 then
+ returnM ([], []) -- Non-overloaded type signatures
+ else
+ newDicts SignatureOrigin theta1 `thenM` \ sig_dicts ->
+ let
+ -- The "sig_avails" is the stuff available. We get that from
+ -- the context of the type signature, BUT ALSO the lie_avail
+ -- so that polymorphic recursion works right (see comments at end of fn)
+ sig_avails = sig_dicts ++ sig_meths
+ in
+ returnM (sig_avails, map instToId sig_dicts)
+ where
+ sig1_dict_tys = map mkPredTy theta1
+ sig_meths = concatMap sig_insts sigs
+
+ check_one (TySigInfo {sig_poly_id = id, sig_theta = theta})
+ = addErrCtxt (sigContextsCtxt id1 id) $
+ checkTc (equalLength theta theta1) sigContextsErr `thenM_`
+ unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
+
+checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
+checkSigsTyVars qtvs sigs
+ = mappM check_one sigs `thenM` \ sig_tvs_s ->
+ let
+ -- Sigh. Make sure that all the tyvars in the type sigs
+ -- appear in the returned ty var list, which is what we are
+ -- going to generalise over. Reason: we occasionally get
+ -- silly types like
+ -- type T a = () -> ()
+ -- f :: T a
+ -- f () = ()
+ -- Here, 'a' won't appear in qtvs, so we have to add it
+
+ sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
+ all_tvs = extendVarSetList sig_tvs qtvs
+ in
+ returnM (varSetElems all_tvs)
+ where
+ check_one (TySigInfo {sig_poly_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau})
+ = addErrCtxt (ptext SLIT("In the type signature for")
+ <+> quotes (ppr id)) $
+ addErrCtxtM (sigCtxt id tvs theta tau) $
+ checkSigTyVarsWrt (idFreeTyVars id) tvs
+\end{code}
+
projects / ghc-hetmet.git / blobdiff