module Hint.Unsafe(unsafeHint) where
import Hint.Type(DeclHint',ModuleEx(..),Severity(..),rawIdea',toSS')
import Data.Char
import Refact.Types hiding(Match)
import Data.Generics.Uniplate.Operations
import HsSyn
import OccName
import RdrName
import FastString
import BasicTypes
import SrcLoc
import GHC.Util
unsafeHint :: DeclHint'
unsafeHint _ (ModuleEx _ _ (L _ m) _) = \(L loc d) ->
[rawIdea' Hint.Type.Warning "Missing NOINLINE pragma" loc
(unsafePrettyPrint d)
(Just $ dropWhile isSpace (unsafePrettyPrint $ gen x) ++ "\n" ++ unsafePrettyPrint d)
[] [InsertComment (toSS' (L loc d)) (unsafePrettyPrint $ gen x)]
| d@(ValD _
FunBind {fun_id=L _ (Unqual x)
, fun_matches=MG{mg_origin=FromSource,mg_alts=L _ [L _ Match {m_pats=[]}]}}) <- [d]
, isUnsafeDecl d
, x `notElem` noinline]
where
gen :: OccName -> LHsDecl GhcPs
gen x = noLoc $
SigD noExt (InlineSig noExt (noLoc (mkRdrUnqual x))
(InlinePragma (SourceText "{-# NOINLINE") NoInline Nothing NeverActive FunLike))
noinline :: [OccName]
noinline = [q | LL _(SigD _ (InlineSig _ (L _ (Unqual q))
(InlinePragma _ NoInline Nothing NeverActive FunLike))
) <- hsmodDecls m]
isUnsafeDecl :: HsDecl GhcPs -> Bool
isUnsafeDecl (ValD _ FunBind {fun_matches=MG {mg_origin=FromSource,mg_alts=LL _ alts}}) =
any isUnsafeApp (childrenBi alts) || any isUnsafeDecl (childrenBi alts)
isUnsafeDecl _ = False
isUnsafeApp :: HsExpr GhcPs -> Bool
isUnsafeApp (OpApp _ (LL _ l) op _ ) | isDol' op = isUnsafeFun l
isUnsafeApp (HsApp _ (LL _ x) _) = isUnsafeFun x
isUnsafeApp _ = False
isUnsafeFun :: HsExpr GhcPs -> Bool
isUnsafeFun (HsVar _ (LL _ x)) | x == mkVarUnqual (fsLit "unsafePerformIO") = True
isUnsafeFun (OpApp _ (LL _ l) op _) | isDot' op = isUnsafeFun l
isUnsafeFun _ = False