-- signatures in it. The renamer checked all this
tcHsBootSigs (ValBindsOut binds sigs)
= do { checkTc (null binds) badBootDeclErr
- ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
+ ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
tc_boot_sig (TypeSig (L _ name) ty)
= do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
= do { -- Typecheck the signature
; let { prag_fn = mkPragFun sigs
- ; ty_sigs = filter isVanillaLSig sigs
+ ; ty_sigs = filter isTypeLSig sigs
; sig_fn = mkTcSigFun ty_sigs }
; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
-- BUILD THE POLYMORPHIC RESULT IDs
; let dict_vars = map instToVar dicts -- May include equality constraints
- ; exports <- mapM (mkExport top_lvl rec_group prag_fn tyvars_to_gen (map varType dict_vars))
+ ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars))
mono_bind_infos
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
--------------
-mkExport :: TopLevelFlag -> RecFlag -> TcPragFun -> [TyVar] -> [TcType]
+mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
-> MonoBindInfo
-> TcM ([TyVar], Id, Id, [LPrag])
-- mkExport generates exports with
-- Pre-condition: the inferred_tvs are already zonked
-mkExport top_lvl rec_group prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+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 has a zonked type
- ; prags <- tcPrags rec_group poly_id (prag_fn poly_name)
+ ; prags <- tcPrags poly_id (prag_fn poly_name)
-- tcPrags requires a zonked poly_id
; return (tvs, poly_id, mono_id, prags) }
env = foldl add emptyNameEnv prs
add env (n,p) = extendNameEnv_Acc (:) singleton env n p
-tcPrags :: RecFlag -> Id -> [LSig Name] -> TcM [LPrag]
--- Pre-condition: the poly_id is zonked
--- Reason: required by tcSubExp
-tcPrags rec_group poly_id prags = mapM tc_lprag prags
+tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
+tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
where
- tc_lprag :: LSig Name -> TcM LPrag
- tc_lprag (L loc prag) = setSrcSpan loc $
- addErrCtxt (pragSigCtxt prag) $
- do { prag' <- tc_prag prag
- ; return (L loc prag') }
-
- tc_prag (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
- tc_prag (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec
- tc_prag (InlineSig _ inl) = do { warnIfRecInline rec_group inl poly_id
- ; return (InlinePrag inl) }
- tc_prag (FixSig {}) = panic "tcPrag FixSig"
- tc_prag (TypeSig {}) = panic "tcPrag TypeSig"
+ tc_prag prag = addErrCtxt (pragSigCtxt prag) $
+ tcPrag poly_id prag
pragSigCtxt :: Sig Name -> SDoc
pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag)
-warnIfRecInline :: RecFlag -> InlineSpec -> TcId -> TcM ()
-warnIfRecInline rec_group (Inline _ is_inline) poly_id
- | is_inline && isRec rec_group = addWarnTc warn
- | otherwise = return ()
- where
- warn = ptext (sLit "INLINE pragma for recursive binder") <+> quotes (ppr poly_id)
- <+> ptext (sLit "may be discarded")
+tcPrag :: TcId -> Sig Name -> TcM Prag
+-- Pre-condition: the poly_id is zonked
+-- Reason: required by tcSubExp
+tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
+tcPrag poly_id (SpecInstSig hs_ty) = tcSpecPrag poly_id hs_ty defaultInlineSpec
+tcPrag _ (InlineSig _ inl) = return (InlinePrag inl)
+tcPrag _ sig = pprPanic "tcPrag" (ppr sig)
+
tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
tcSpecPrag poly_id hs_ty inl
(strictBindErr "Recursive" unlifted mbind)
; checkTc (isSingletonBag mbind)
(strictBindErr "Multiple" unlifted mbind)
+ -- This should be a checkTc, not a warnTc, but as of GHC 6.11
+ -- the versions of alex and happy available have non-conforming
+ -- templates, so the GHC build fails if it's an error:
+ ; warnTc (not bang_pat)
+ (unliftedMustBeBang mbind)
; mapM_ check_sig infos
; return True }
| otherwise
(badStrictSig unlifted sig)
check_sig _ = return ()
+unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc
+unliftedMustBeBang mbind
+ = hang (text "Bindings containing unlifted types must use an outermost bang pattern:")
+ 4 (pprLHsBinds mbind)
+
strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
strictBindErr flavour unlifted mbind
= hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
-- 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)
+ checkTc (all isIdentityCoI cois)
(ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
}
-- Precondition: no duplicates
mkTcSigFun sigs = lookupNameEnv env
where
- env = mkNameEnv [(name, hsExplicitTvs lhs_ty)
- | L _ (TypeSig (L _ name) lhs_ty) <- sigs]
+ env = mkNameEnv (mapCatMaybes mk_pair sigs)
+ mk_pair (L _ (TypeSig (L _ name) lhs_ty)) = Just (name, hsExplicitTvs lhs_ty)
+ mk_pair (L _ (IdSig id)) = Just (idName id, [])
+ mk_pair _ = Nothing
-- The scoped names are the ones explicitly mentioned
-- in the HsForAll. (There may be more in sigma_ty, because
-- of nested type synonyms. See Note [More instantiated than scoped].)
= setSrcSpan span $
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; return (mkLocalId name sigma_ty) }
+tcTySig (L _ (IdSig id))
+ = return id
tcTySig s = pprPanic "tcTySig" (ppr s)
-------------------