- 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"
-
-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 ()
+ (inl_sigs, other_sigs) = partition isInlineLSig prag_sigs
+ (spec_sigs, bad_sigs) = partition isSpecLSig other_sigs
+
+-- warn_discarded_spec = warnPrags poly_id spec_sigs $
+-- ptext (sLit "SPECIALISE pragmas for non-overloaded function")
+ warn_dup_inline = warnPrags poly_id inl_sigs $
+ ptext (sLit "Duplicate INLINE pragmas for")
+ warn_discarded_sigs = warnPrags poly_id bad_sigs $
+ ptext (sLit "Discarding unexpected pragmas for")
+
+ -----------
+ tc_inl [] = return poly_id
+ tc_inl (L loc (InlineSig _ prag) : other_inls)
+ = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
+ ; return (poly_id `setInlinePragma` prag) }
+ tc_inl _ = panic "tc_inl"
+
+{- Earlier we tried to warn about
+ (a) INLINE for recursive function
+ (b) INLINE for function that is part of a multi-binder group
+ Code fragments below. But we want to allow
+ {-# INLINE f #-}
+ f x = x : g y
+ g y = ....f...f....
+ even though they are mutually recursive.
+ So I'm just omitting the warnings for now
+
+ | multi_bind && isInlinePragma prag
+ = do { setSrcSpan loc $ addWarnTc multi_bind_warn
+ ; return poly_id }
+ | otherwise
+ ; when (isInlinePragma prag && isRec rec_group)
+ (setSrcSpan loc (addWarnTc rec_inline_warn))
+
+ rec_inline_warn = ptext (sLit "INLINE pragma for recursive binder")
+ <+> quotes (ppr poly_id) <+> ptext (sLit "may be discarded")
+
+ multi_bind_warn = hang (ptext (sLit "Discarding INLINE pragma for") <+> quotes (ppr poly_id))
+ 2 (ptext (sLit "because it is bound by a pattern, or mutual recursion") )
+-}
+
+
+warnPrags :: Id -> [LSig Name] -> SDoc -> TcM ()
+warnPrags id bad_sigs herald
+ = addWarnTc (hang (herald <+> quotes (ppr id))
+ 2 (ppr_sigs bad_sigs))