\section[TcBinds]{TcBinds}
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcMonoBinds,
TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
import TcMType
import TcType
import {- Kind parts of -} Type
+import Coercion
import VarEnv
import TysPrim
import Id
-- Extend the envt right away with all
-- the Ids declared with type signatures
- ; gla_exts <- doptM Opt_GlasgowExts
+ ; poly_rec <- doptM Opt_RelaxedPolyRec
; (binds', thing) <- tcExtendIdEnv poly_ids $
- tc_val_binds gla_exts top_lvl sig_fn prag_fn
+ tc_val_binds poly_rec top_lvl sig_fn prag_fn
binds thing_inside
; return (ValBindsOut binds' sigs, thing) }
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-tc_val_binds gla_exts top_lvl sig_fn prag_fn [] thing_inside
+tc_val_binds poly_rec top_lvl sig_fn prag_fn [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
-tc_val_binds gla_exts top_lvl sig_fn prag_fn (group : groups) thing_inside
+tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
- <- tc_group gla_exts top_lvl sig_fn prag_fn group $
- tc_val_binds gla_exts top_lvl sig_fn prag_fn groups thing_inside
+ <- tc_group poly_rec top_lvl sig_fn prag_fn group $
+ tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
------------------------
-- We get a list of groups back, because there may
-- be specialisations etc as well
-tc_group gla_exts top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
+tc_group poly_rec top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
-- A single non-recursive binding
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
= do { (binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn NonRecursive binds thing_inside
; return ([(NonRecursive, b) | b <- binds], thing) }
-tc_group gla_exts top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
- | not gla_exts -- Recursive group, normal Haskell 98 route
+tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+ | not poly_rec -- Recursive group, normal Haskell 98 route
= do { (binds1, thing) <- tc_haskell98 top_lvl sig_fn prag_fn Recursive binds thing_inside
; return ([(Recursive, unionManyBags binds1)], thing) }
bindLocalInsts :: TopLevelFlag -> TcM ([LHsBinds TcId], [TcId], a) -> TcM ([LHsBinds TcId], a)
bindLocalInsts top_lvl thing_inside
| isTopLevel top_lvl = do { (binds, ids, thing) <- thing_inside; return (binds, thing) }
- -- For the top level don't bother will all this bindInstsOfLocalFuns stuff.
+ -- For the top level don't bother with all this bindInstsOfLocalFuns stuff.
-- All the top level things are rec'd together anyway, so it's fine to
-- leave them to the tcSimplifyTop, and quite a bit faster too
-- BUILD THE POLYMORPHIC RESULT IDs
; let dict_ids = map instToId dicts
- ; exports <- mapM (mkExport prag_fn tyvars_to_gen (map idType dict_ids))
+ ; 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]
--------------
-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)
-- e.g. f = \(x::forall a. a->a) -> <body>
-- We want to infer a higher-rank type for f
setSrcSpan b_loc $
- do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches)
+ do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
-- Check for an unboxed tuple type
-- f = (# True, False #)
| (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
- tcMatchesFun mono_name matches mono_ty
+ tcMatchesFun mono_name inf matches mono_ty
; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
fun_infix = inf, fun_matches = matches',
-------------------
tcRhs :: TcMonoBind -> TcM (HsBind TcId)
tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
- = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches
- (idType mono_id)
+ = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
+ matches (idType mono_id)
; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
bind_fvs = placeHolderNames, fun_co_fn = co_fn,
fun_tick = Nothing }) }
unify_ctxt sig@(TcSigInfo { sig_theta = theta })
= setSrcSpan (instLocSpan (sig_loc sig)) $
addErrCtxt (sigContextsCtxt sig1 sig) $
- unifyTheta theta1 theta
+ do { cois <- unifyTheta theta1 theta
+ ; -- Check whether all coercions are identity coercions
+ -- That can happen if we have, say
+ -- f :: C [a] => ...
+ -- g :: C (F a) => ...
+ -- where F is a type function and (F a ~ [a])
+ -- Then unification might succeed with a coercion. But it's much
+ -- much simpler to require that such signatures have identical contexts
+ checkTc (all isIdentityCoercion cois)
+ (ptext SLIT("Mutually dependent functions have syntactically distinct contexts"))
+ }
checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
checkSigsTyVars qtvs sigs
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}