+mkPragFun :: [LSig Name] -> LHsBinds Name -> TcPragFun
+mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
+ where
+ prs = mapCatMaybes get_sig sigs
+
+ get_sig :: LSig Name -> Maybe (Located Name, LSig Name)
+ get_sig (L l (SpecSig nm ty inl)) = Just (nm, L l $ SpecSig nm ty (add_arity nm inl))
+ get_sig (L l (InlineSig nm inl)) = Just (nm, L l $ InlineSig nm (add_arity nm inl))
+ get_sig _ = Nothing
+
+ add_arity (L _ n) inl_prag -- Adjust inl_sat field to match visible arity of function
+ | Just ar <- lookupNameEnv ar_env n = inl_prag { inl_sat = Just ar }
+ | otherwise = inl_prag
+
+ prag_env :: NameEnv [LSig Name]
+ prag_env = foldl add emptyNameEnv prs
+ add env (L _ n,p) = extendNameEnv_Acc (:) singleton env n p
+
+ -- ar_env maps a local to the arity of its definition
+ ar_env :: NameEnv Arity
+ ar_env = foldrBag lhsBindArity emptyNameEnv binds
+
+lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
+ = extendNameEnv env (unLoc id) (matchGroupArity ms)
+lhsBindArity _ env = env -- PatBind/VarBind
+
+tcPrags :: RecFlag
+ -> Bool -- True <=> AbsBinds binds more than one variable
+ -> Bool -- True <=> function is overloaded
+ -> Id -> [LSig Name]
+ -> TcM (Id, [Located TcSpecPrag])
+-- Add INLINE and SPECIALSE pragmas
+-- INLINE prags are added to the (polymorphic) Id directly
+-- SPECIALISE prags are passed to the desugarer via TcSpecPrags
+-- Pre-condition: the poly_id is zonked
+-- Reason: required by tcSubExp
+tcPrags _rec_group _multi_bind is_overloaded_id poly_id prag_sigs
+ = do { poly_id' <- tc_inl inl_sigs
+
+ ; spec_prags <- mapM (wrapLocM (tcSpecPrag poly_id')) spec_sigs
+
+ ; unless (null spec_sigs || is_overloaded_id) warn_discarded_spec
+
+ ; unless (null bad_sigs) warn_discarded_sigs
+
+ ; return (poly_id', spec_prags) }
+ where
+ (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))
+ where
+ ppr_sigs sigs = vcat (map (ppr . getLoc) sigs)