import ErrUtils
import Digraph
import Maybes
+import List
import Util
import BasicTypes
import Outputable
-- TYPECHECK THE BINDINGS
; ((binds', mono_bind_infos), lie_req)
<- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
+ ; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req))
-- CHECK FOR UNLIFTED BINDINGS
-- These must be non-recursive etc, and are not generalised
else do -- The normal lifted case: GENERALISE
{ dflags <- getDOpts
- ; (tyvars_to_gen, dict_binds, dict_ids)
+ ; (tyvars_to_gen, dicts, dict_binds)
<- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
- -- FINALISE THE QUANTIFIED TYPE VARIABLES
- -- The quantified type variables often include meta type variables
- -- we want to freeze them into ordinary type variables, and
- -- default their kind (e.g. from OpenTypeKind to TypeKind)
- ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
-
-- BUILD THE POLYMORPHIC RESULT IDs
- ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
+ ; let dict_ids = map instToId dicts
+ ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map idType dict_ids))
mono_bind_infos
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids))
- ; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
+ ; let abs_bind = L loc $ AbsBinds tyvars_to_gen
dict_ids exports
(dict_binds `unionBags` binds')
--------------
-mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
- -> TcM ([TyVar], Id, Id, [Prag])
+mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
+ -> MonoBindInfo
+ -> TcM ([TyVar], Id, Id, [LPrag])
-- mkExport generates exports with
-- zonked type variables,
-- zonked poly_ids
-- Pre-condition: the inferred_tvs are already zonked
-mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
- = do { (tvs, poly_id) <- mk_poly_id mb_sig
+mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+ = do { warn_missing_sigs <- doptM Opt_WarnMissingSigs
+ ; let warn = isTopLevel top_lvl && warn_missing_sigs
+ ; (tvs, poly_id) <- mk_poly_id warn mb_sig
; poly_id' <- zonkId poly_id
; prags <- tcPrags poly_id' (prag_fn poly_name)
where
poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
- mk_poly_id Nothing = return (inferred_tvs, mkLocalId poly_name poly_ty)
- mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
- ; return (tvs, sig_id sig) }
+ mk_poly_id warn Nothing = do { missingSigWarn warn poly_name poly_ty
+ ; return (inferred_tvs, mkLocalId poly_name poly_ty) }
+ mk_poly_id warn (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
+ ; return (tvs, sig_id sig) }
zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
env = foldl add emptyNameEnv prs
add env (n,p) = extendNameEnv_Acc (:) singleton env n p
-tcPrags :: Id -> [LSig Name] -> TcM [Prag]
-tcPrags poly_id prags = mapM tc_prag prags
+tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
+tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
where
- tc_prag (L loc prag) = setSrcSpan loc $
- addErrCtxt (pragSigCtxt prag) $
- tcPrag poly_id prag
+ tc_prag prag = addErrCtxt (pragSigCtxt prag) $
+ tcPrag poly_id prag
pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
generalise :: DynFlags -> TopLevelFlag
-> [LHsBind Name] -> TcSigFun
-> [MonoBindInfo] -> [Inst]
- -> TcM ([TcTyVar], TcDictBinds, [TcId])
+ -> TcM ([TyVar], [Inst], TcDictBinds)
+-- The returned [TyVar] are all ready to quantify
+
generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
| isMonoGroup dflags bind_list
- = do { extendLIEs lie_req; return ([], emptyBag, []) }
+ = do { extendLIEs lie_req
+ ; return ([], [], emptyBag) }
| isRestrictedGroup dflags bind_list sig_fn -- RESTRICTED CASE
= -- Check signature contexts are empty
-- Check that signature type variables are OK
; final_qtvs <- checkSigsTyVars qtvs sigs
- ; return (final_qtvs, binds, []) }
+ ; return (final_qtvs, [], binds) }
| null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
= tcSimplifyInfer doc tau_tvs lie_req
-- Check that the needed dicts can be
-- expressed in terms of the signature ones
- ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
+ ; (qtvs, binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
-- Check that signature type variables are OK
- ; final_qtvs <- checkSigsTyVars forall_tvs sigs
+ ; final_qtvs <- checkSigsTyVars qtvs sigs
- ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
+ ; returnM (final_qtvs, sig_lie, binds) }
where
bndrs = bndrNames mono_infos
sigs = [sig | (_, Just sig, _) <- mono_infos]
<+> quotes (ppr tidy_tv2)
; failWithTcM (env2, msg) }
where
-\end{code}
+\end{code}
@getTyVarsToGen@ decides what type variables to generalise over.
genCtxt binder_names
= ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
+
+missingSigWarn False name ty = return ()
+missingSigWarn True name ty
+ = do { env0 <- tcInitTidyEnv
+ ; let (env1, tidy_ty) = tidyOpenType env0 ty
+ ; addWarnTcM (env1, mk_msg tidy_ty) }
+ where
+ mk_msg ty = vcat [ptext SLIT("Definition but no type signature for") <+> quotes (ppr name),
+ sep [ptext SLIT("Inferred type:") <+> ppr name <+> dcolon <+> ppr ty]]
\end{code}
projects / ghc-hetmet.git / blobdiff