{-
    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,toSSA)
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.SourceText
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 GhcPs
m)) = \ld :: LHsDecl GhcPs
ld@(L SrcSpanAnnA
loc HsDecl GhcPs
d) ->
  [Severity
-> String
-> SrcSpan
-> String
-> Maybe String
-> [Note]
-> [Refactoring SrcSpan]
-> Idea
rawIdea Severity
Hint.Type.Warning String
"Missing NOINLINE pragma" (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc)
         (forall a. Outputable a => a -> String
unsafePrettyPrint HsDecl GhcPs
d)
         (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> String
trimStart (forall a. Outputable a => a -> String
unsafePrettyPrint forall a b. (a -> b) -> a -> b
$ OccName -> LHsDecl GhcPs
gen OccName
x) forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Outputable a => a -> String
unsafePrettyPrint HsDecl GhcPs
d)
         [] [forall a. a -> String -> Refactoring a
InsertComment (forall a e. GenLocated (SrcSpanAnn' a) e -> SrcSpan
toSSA LHsDecl GhcPs
ld) (forall a. Outputable a => a -> String
unsafePrettyPrint 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 -> LIdP idL
fun_id=L SrcSpanAnnN
_ (Unqual OccName
x)
                      , fun_matches :: forall idL idR. HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)
fun_matches=MG{mg_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext=Origin
XMG GhcPs (LHsExpr GhcPs)
FromSource,mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts=L SrcSpanAnnL
_ [L SrcSpanAnnA
_ Match {m_pats :: forall p body. Match p body -> [LPat p]
m_pats=[]}]}}) <- [HsDecl GhcPs
d]
     -- 'x' is a synonym for an application involving 'unsafePerformIO'
     , HsDecl GhcPs -> Bool
isUnsafeDecl HsDecl GhcPs
d
     -- 'x' is not marked 'NOINLINE'.
     , OccName
x 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 = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$
      forall p. XSigD p -> Sig p -> HsDecl p
SigD NoExtField
noExtField (forall pass.
XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
InlineSig forall ann. EpAnn ann
EpAnnNotUsed (forall a an. a -> LocatedAn an a
noLocA (OccName -> RdrName
mkRdrUnqual OccName
x))
                      (SourceText
-> InlineSpec
-> Maybe Arity
-> Activation
-> RuleMatchInfo
-> InlinePragma
InlinePragma (String -> SourceText
SourceText String
"{-# NOINLINE") (SourceText -> InlineSpec
NoInline (String -> SourceText
SourceText String
"{-# NOINLINE")) forall a. Maybe a
Nothing Activation
NeverActive RuleMatchInfo
FunLike))
    noinline :: [OccName]
    noinline :: [OccName]
noinline = [OccName
q | L SrcSpanAnnA
_(SigD XSigD GhcPs
_ (InlineSig XInlineSig GhcPs
_ (L SrcSpanAnnN
_ (Unqual OccName
q))
                                                (InlinePragma SourceText
_ (NoInline (SourceText String
"{-# NOINLINE")) Maybe Arity
Nothing Activation
NeverActive RuleMatchInfo
FunLike))
        ) <- forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
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_ext :: forall p body. MatchGroup p body -> XMG p body
mg_ext=Origin
XMG GhcPs (LHsExpr GhcPs)
FromSource,mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
mg_alts=L SrcSpanAnnL
_ [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts}}) =
  forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsExpr GhcPs -> Bool
isUnsafeApp (forall from to. Biplate from to => from -> [to]
childrenBi [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
alts) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any HsDecl GhcPs -> Bool
isUnsafeDecl (forall from to. Biplate from to => from -> [to]
childrenBi [GenLocated
   SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 SrcSpanAnnA
_ 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 SrcSpanAnnA
_ 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 SrcSpanAnnN
_ RdrName
x)) | RdrName
x forall a. Eq a => a -> a -> Bool
== FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"unsafePerformIO") = Bool
True
isUnsafeFun (OpApp XOpApp GhcPs
_ (L SrcSpanAnnA
_ 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