module Hint.Unsafe(unsafeHint) where
import Hint.Type(DeclHint,ModuleEx(..),Severity(..),rawIdea,toSS)
import Data.List.Extra
import Refact.Types hiding(Match)
import Data.Generics.Uniplate.DataOnly
import GHC.Hs
import OccName
import RdrName
import FastString
import BasicTypes
import SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
unsafeHint :: DeclHint
unsafeHint :: DeclHint
unsafeHint _ (ModuleEx (L _ m :: HsModule GhcPs
m) _) = \(L loc :: SrcSpan
loc d :: HsDecl GhcPs
d) ->
[Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Hint.Type.Warning "Missing NOINLINE pragma" SrcSpan
loc
(HsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsDecl GhcPs
d)
(String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> String
trimStart (GenLocated SrcSpan (HsDecl GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (GenLocated SrcSpan (HsDecl GhcPs) -> String)
-> GenLocated SrcSpan (HsDecl GhcPs) -> String
forall a b. (a -> b) -> a -> b
$ OccName -> GenLocated SrcSpan (HsDecl GhcPs)
gen OccName
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint HsDecl GhcPs
d)
[] [SrcSpan -> String -> Refactoring SrcSpan
forall a. a -> String -> Refactoring a
InsertComment (GenLocated SrcSpan (HsDecl GhcPs) -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
toSS (SrcSpan -> HsDecl GhcPs -> GenLocated SrcSpan (HsDecl GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsDecl GhcPs
d)) (GenLocated SrcSpan (HsDecl GhcPs) -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (GenLocated SrcSpan (HsDecl GhcPs) -> String)
-> GenLocated SrcSpan (HsDecl GhcPs) -> String
forall a b. (a -> b) -> a -> b
$ OccName -> GenLocated SrcSpan (HsDecl GhcPs)
gen OccName
x)]
| d :: HsDecl GhcPs
d@(ValD _
FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id=L _ (Unqual x)
, fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=MG{mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin=Origin
FromSource,mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=L _ [L _ Match {m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[]}]}}) <- [HsDecl GhcPs
d]
, HsDecl GhcPs -> Bool
isUnsafeDecl HsDecl GhcPs
d
, OccName
x OccName -> [OccName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [OccName]
noinline]
where
gen :: OccName -> LHsDecl GhcPs
gen :: OccName -> GenLocated SrcSpan (HsDecl GhcPs)
gen x :: OccName
x = SrcSpanLess (GenLocated SrcSpan (HsDecl GhcPs))
-> GenLocated SrcSpan (HsDecl GhcPs)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (SrcSpanLess (GenLocated SrcSpan (HsDecl GhcPs))
-> GenLocated SrcSpan (HsDecl GhcPs))
-> SrcSpanLess (GenLocated SrcSpan (HsDecl GhcPs))
-> GenLocated SrcSpan (HsDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
XSigD GhcPs
noExtField (XInlineSig GhcPs
-> GenLocated SrcSpan (IdP GhcPs) -> InlinePragma -> Sig GhcPs
forall pass.
XInlineSig pass -> Located (IdP pass) -> InlinePragma -> Sig pass
InlineSig NoExtField
XInlineSig GhcPs
noExtField (SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (OccName -> RdrName
mkRdrUnqual OccName
x))
(SourceText
-> InlineSpec
-> Maybe Arity
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma (String -> SourceText
SourceText "{-# NOINLINE") InlineSpec
NoInline Maybe Arity
forall a. Maybe a
Nothing Activation
NeverActive RuleMatchInfo
FunLike))
noinline :: [OccName]
noinline :: [OccName]
noinline = [OccName
q | L _(SigD _ (InlineSig _ (L _ (Unqual q))
(InlinePragma _ NoInline Nothing NeverActive FunLike))
) <- HsModule GhcPs -> [GenLocated SrcSpan (HsDecl GhcPs)]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule GhcPs
m]
isUnsafeDecl :: HsDecl GhcPs -> Bool
isUnsafeDecl :: HsDecl GhcPs -> Bool
isUnsafeDecl (ValD _ FunBind {fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=MG {mg_origin :: forall p body. MatchGroup p body -> Origin
mg_origin=Origin
FromSource,mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts=L _ alts :: [LMatch GhcPs (LHsExpr GhcPs)]
alts}}) =
(HsExpr GhcPs -> Bool) -> [HsExpr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsExpr GhcPs -> Bool
isUnsafeApp ([LMatch GhcPs (LHsExpr GhcPs)] -> [HsExpr GhcPs]
forall from to. Biplate from to => from -> [to]
childrenBi [LMatch GhcPs (LHsExpr GhcPs)]
alts) Bool -> Bool -> Bool
|| (HsDecl GhcPs -> Bool) -> [HsDecl GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsDecl GhcPs -> Bool
isUnsafeDecl ([LMatch GhcPs (LHsExpr GhcPs)] -> [HsDecl GhcPs]
forall from to. Biplate from to => from -> [to]
childrenBi [LMatch GhcPs (LHsExpr GhcPs)]
alts)
isUnsafeDecl _ = Bool
False
isUnsafeApp :: HsExpr GhcPs -> Bool
isUnsafeApp :: HsExpr GhcPs -> Bool
isUnsafeApp (OpApp _ (L _ l :: HsExpr GhcPs
l) op :: LHsExpr GhcPs
op _ ) | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op = HsExpr GhcPs -> Bool
isUnsafeFun HsExpr GhcPs
l
isUnsafeApp (HsApp _ (L _ x :: HsExpr GhcPs
x) _) = HsExpr GhcPs -> Bool
isUnsafeFun HsExpr GhcPs
x
isUnsafeApp _ = Bool
False
isUnsafeFun :: HsExpr GhcPs -> Bool
isUnsafeFun :: HsExpr GhcPs -> Bool
isUnsafeFun (HsVar _ (L _ x :: IdP GhcPs
x)) | IdP GhcPs
RdrName
x RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit "unsafePerformIO") = Bool
True
isUnsafeFun (OpApp _ (L _ l :: HsExpr GhcPs
l) op :: LHsExpr GhcPs
op _) | LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
op = HsExpr GhcPs -> Bool
isUnsafeFun HsExpr GhcPs
l
isUnsafeFun _ = Bool
False