{-
    Find things that are unsafe

<TEST>
{-# NOINLINE entries #-}; entries = unsafePerformIO newIO
entries = unsafePerformIO Multimap.newIO -- {-# NOINLINE entries #-} ; entries = unsafePerformIO Multimap.newIO
entries = unsafePerformIO $ f y where foo = 1 -- {-# NOINLINE entries #-} ; entries = unsafePerformIO $ f y where foo = 1
entries v = unsafePerformIO $ Multimap.newIO where foo = 1
entries v = x where x = unsafePerformIO $ Multimap.newIO
entries = x where x = unsafePerformIO $ Multimap.newIO -- {-# NOINLINE entries #-} ; entries = x where x = unsafePerformIO $ Multimap.newIO
entries = unsafePerformIO . bar
entries = unsafePerformIO . baz $ x -- {-# NOINLINE entries #-} ; entries = unsafePerformIO . baz $ x
entries = unsafePerformIO . baz $ x -- {-# NOINLINE entries #-} ; entries = unsafePerformIO . baz $ x
</TEST>
-}


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 GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC.Data.FastString
import GHC.Types.Basic
import GHC.Types.SrcLoc
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable

-- The conditions on which to fire this hint are subtle. We are
-- interested exclusively in application constants involving
-- 'unsafePerformIO'. For example,
-- @
--   f = \x -> unsafePerformIO x
-- @
-- is not such a declaration (the right hand side is a lambda, not an
-- application) whereas,
-- @
--   f = g where g = unsafePerformIO Multimap.newIO
-- @
-- is. We advise that such constants should have a @NOINLINE@ pragma.
unsafeHint :: DeclHint
unsafeHint :: DeclHint
unsafeHint Scope
_ (ModuleEx (L SrcSpan
_ HsModule
m) ApiAnns
_) = \(L SrcSpan
loc HsDecl GhcPs
d) ->
  [Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Hint.Type.Warning String
"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 (LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (LHsDecl GhcPs -> String) -> LHsDecl GhcPs -> String
forall a b. (a -> b) -> a -> b
$ OccName -> LHsDecl GhcPs
gen OccName
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\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 (LHsDecl GhcPs -> SrcSpan
forall a. Located a -> SrcSpan
toSS (SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsDecl GhcPs
d)) (LHsDecl GhcPs -> String
forall a. Outputable a => a -> String
unsafePrettyPrint (LHsDecl GhcPs -> String) -> LHsDecl GhcPs -> String
forall a b. (a -> b) -> a -> b
$ OccName -> LHsDecl GhcPs
gen OccName
x)]
     -- 'x' does not declare a new function.
     | d :: HsDecl GhcPs
d@(ValD XValD GhcPs
_
           FunBind {fun_id :: forall idL idR. HsBindLR idL idR -> Located (IdP idL)
fun_id=L SrcSpan
_ (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 SrcSpan
_ [L SrcSpan
_ Match {m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[]}]}}) <- [HsDecl GhcPs
d]
     -- 'x' is a synonym for an appliciation involing 'unsafePerformIO'
     , HsDecl GhcPs -> Bool
isUnsafeDecl HsDecl GhcPs
d
     -- 'x' is not marked 'NOINLINE'.
     , 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 -> LHsDecl GhcPs
gen OccName
x = HsDecl GhcPs -> LHsDecl GhcPs
forall e. e -> Located e
noLoc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl 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 (RdrName -> Located RdrName
forall e. e -> Located e
noLoc (OccName -> RdrName
mkRdrUnqual OccName
x))
                      (SourceText
-> InlineSpec
-> Maybe Arity
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma (String -> SourceText
SourceText String
"{-# NOINLINE") InlineSpec
NoInline Maybe Arity
forall a. Maybe a
Nothing Activation
NeverActive RuleMatchInfo
FunLike))
    noinline :: [OccName]
    noinline :: [OccName]
noinline = [OccName
q | L SrcSpan
_(SigD XSigD GhcPs
_ (InlineSig XInlineSig GhcPs
_ (L SrcSpan
_ (Unqual q))
                                                (InlinePragma SourceText
_ InlineSpec
NoInline Maybe Arity
Nothing Activation
NeverActive RuleMatchInfo
FunLike))
        ) <- HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
m]

isUnsafeDecl :: HsDecl GhcPs -> Bool
isUnsafeDecl :: HsDecl GhcPs -> Bool
isUnsafeDecl (ValD XValD GhcPs
_ 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 SrcSpan
_ [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 HsDecl GhcPs
_ = Bool
False

-- Am I equivalent to @unsafePerformIO x@?
isUnsafeApp :: HsExpr GhcPs -> Bool
isUnsafeApp :: HsExpr GhcPs -> Bool
isUnsafeApp (OpApp XOpApp GhcPs
_ (L SrcSpan
_ HsExpr GhcPs
l) LHsExpr GhcPs
op LHsExpr GhcPs
_ ) | LHsExpr GhcPs -> Bool
isDol LHsExpr GhcPs
op = HsExpr GhcPs -> Bool
isUnsafeFun HsExpr GhcPs
l
isUnsafeApp (HsApp XApp GhcPs
_ (L SrcSpan
_ HsExpr GhcPs
x) LHsExpr GhcPs
_) = HsExpr GhcPs -> Bool
isUnsafeFun HsExpr GhcPs
x
isUnsafeApp HsExpr GhcPs
_ = Bool
False

-- Am I equivalent to @unsafePerformIO . x@?
isUnsafeFun :: HsExpr GhcPs -> Bool
isUnsafeFun :: HsExpr GhcPs -> Bool
isUnsafeFun (HsVar XVar GhcPs
_ (L SrcSpan
_ IdP GhcPs
x)) | IdP GhcPs
RdrName
x RdrName -> RdrName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"unsafePerformIO") = Bool
True
isUnsafeFun (OpApp XOpApp GhcPs
_ (L SrcSpan
_ HsExpr GhcPs
l) LHsExpr GhcPs
op LHsExpr GhcPs
_) | LHsExpr GhcPs -> Bool
isDot LHsExpr GhcPs
op = HsExpr GhcPs -> Bool
isUnsafeFun HsExpr GhcPs
l
isUnsafeFun HsExpr GhcPs
_ = Bool
False