    {-
        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" (SrcSpanAnnA -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA SrcSpanAnnA
    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 (GenLocated SrcSpanAnnA (HsDecl GhcPs) -> SrcSpan
    forall a e. GenLocated (EpAnn a) e -> SrcSpan
    toSSA LHsDecl GhcPs
    GenLocated SrcSpanAnnA (HsDecl GhcPs)
    ld) (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 -> 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=XMG GhcPs (LHsExpr GhcPs)
    Origin
    FromSource,mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
    mg_alts=L SrcSpanAnnLW
    _ [L SrcSpanAnnA
    _ Match {m_pats :: forall p body. Match p body -> XRec p [LPat p]
    m_pats=L EpaLocation
    _ []}]}}) <- [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 OccName -> [OccName] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem` [OccName]
    noinline]
      where
        noInline :: FastString
        noInline :: FastString
    noInline = String -> FastString
    fsLit (String -> FastString) -> String -> FastString
    forall a b. (a -> b) -> a -> b
    $ Char
    '{' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    '-' Char -> String -> String
    forall a. a -> [a] -> [a]
    : Char
    '#' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    " NOINLINE"

        gen :: OccName -> LHsDecl GhcPs
        gen :: OccName -> LHsDecl GhcPs
    gen OccName
    x = HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA (HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs))
    -> HsDecl GhcPs -> GenLocated SrcSpanAnnA (HsDecl GhcPs)
    forall a b. (a -> b) -> a -> b
    $
          XSigD GhcPs -> Sig GhcPs -> HsDecl GhcPs
    forall p. XSigD p -> Sig p -> HsDecl p
    SigD XSigD GhcPs
    NoExtField
    noExtField (XInlineSig GhcPs -> LIdP GhcPs -> InlinePragma -> Sig GhcPs
    forall pass.
    XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass
    InlineSig (EpaLocation, EpToken "#-}", ActivationAnn)
    XInlineSig GhcPs
    forall a. NoAnn a => a
    noAnn (RdrName -> GenLocated SrcSpanAnnN RdrName
    forall e a. HasAnnotation e => a -> GenLocated e a
    noLocA (OccName -> RdrName
    mkRdrUnqual OccName
    x))
                          (SourceText
    -> InlineSpec
    -> Maybe Arity
    -> Activation
    -> RuleMatchInfo
    -> InlinePragma
    InlinePragma (FastString -> SourceText
    SourceText FastString
    noInline) (SourceText -> InlineSpec
    NoInline (FastString -> SourceText
    SourceText FastString
    noInline)) Maybe Arity
    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 FastString
    noInline)) Maybe Arity
    Nothing Activation
    NeverActive RuleMatchInfo
    FunLike))
            ) <- HsModule GhcPs -> [LHsDecl GhcPs]
    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=XMG GhcPs (LHsExpr GhcPs)
    Origin
    FromSource,mg_alts :: forall p body. MatchGroup p body -> XRec p [LMatch p body]
    mg_alts=L SrcSpanAnnLW
    _ [GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
    alts}}) =
      (HsExpr GhcPs -> Bool) -> [HsExpr GhcPs] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any HsExpr GhcPs -> Bool
    isUnsafeApp ([GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
    -> [HsExpr GhcPs]
    forall from to. Biplate from to => from -> [to]
    childrenBi [GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr 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 ([GenLocated
       SrcSpanAnnA (Match GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))]
    -> [HsDecl GhcPs]
    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 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 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