-- Copyright (c) 2019 The DAML Authors. All rights reserved.

-- SPDX-License-Identifier: Apache-2.0


module Development.IDE.GHC.Warnings(withWarnings) where

import ErrUtils
import GhcPlugins as GHC hiding (Var)

import           Control.Concurrent.Extra
import qualified           Data.Text as T

import           Development.IDE.Types.Diagnostics
import           Development.IDE.GHC.Error


-- | Take a GHC monadic action (e.g. @typecheckModule pm@ for some

-- parsed module 'pm@') and produce a "decorated" action that will

-- harvest any warnings encountered executing the action. The 'phase'

-- argument classifies the context (e.g. "Parser", "Typechecker").

--

--   The ModSummary function is required because of

--   https://github.com/ghc/ghc/blob/5f1d949ab9e09b8d95319633854b7959df06eb58/compiler/main/GHC.hs#L623-L640

--   which basically says that log_action is taken from the ModSummary when GHC feels like it.

--   The given argument lets you refresh a ModSummary log_action

withWarnings :: T.Text -> ((ModSummary -> ModSummary) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings :: Text
-> ((ModSummary -> ModSummary) -> IO a)
-> IO ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
diagSource (ModSummary -> ModSummary) -> IO a
action = do
  Var [[(WarnReason, FileDiagnostic)]]
warnings <- [[(WarnReason, FileDiagnostic)]]
-> IO (Var [[(WarnReason, FileDiagnostic)]])
forall a. a -> IO (Var a)
newVar []
  let newAction :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
      newAction :: DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
newAction DynFlags
dynFlags WarnReason
wr Severity
_ SrcSpan
loc PprStyle
style SDoc
msg = do
        let wr_d :: [(WarnReason, FileDiagnostic)]
wr_d = (FileDiagnostic -> (WarnReason, FileDiagnostic))
-> [FileDiagnostic] -> [(WarnReason, FileDiagnostic)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (WarnReason
wr,) ([FileDiagnostic] -> [(WarnReason, FileDiagnostic)])
-> [FileDiagnostic] -> [(WarnReason, FileDiagnostic)]
forall a b. (a -> b) -> a -> b
$ Text -> DynFlags -> ErrMsg -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dynFlags (ErrMsg -> [FileDiagnostic]) -> ErrMsg -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ DynFlags -> SrcSpan -> PrintUnqualified -> SDoc -> ErrMsg
mkWarnMsg DynFlags
dynFlags SrcSpan
loc (PprStyle -> PrintUnqualified
queryQual PprStyle
style) SDoc
msg
        Var [[(WarnReason, FileDiagnostic)]]
-> ([[(WarnReason, FileDiagnostic)]]
    -> IO [[(WarnReason, FileDiagnostic)]])
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var [[(WarnReason, FileDiagnostic)]]
warnings (([[(WarnReason, FileDiagnostic)]]
  -> IO [[(WarnReason, FileDiagnostic)]])
 -> IO ())
-> ([[(WarnReason, FileDiagnostic)]]
    -> IO [[(WarnReason, FileDiagnostic)]])
-> IO ()
forall a b. (a -> b) -> a -> b
$ [[(WarnReason, FileDiagnostic)]]
-> IO [[(WarnReason, FileDiagnostic)]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(WarnReason, FileDiagnostic)]]
 -> IO [[(WarnReason, FileDiagnostic)]])
-> ([[(WarnReason, FileDiagnostic)]]
    -> [[(WarnReason, FileDiagnostic)]])
-> [[(WarnReason, FileDiagnostic)]]
-> IO [[(WarnReason, FileDiagnostic)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(WarnReason, FileDiagnostic)]
wr_d[(WarnReason, FileDiagnostic)]
-> [[(WarnReason, FileDiagnostic)]]
-> [[(WarnReason, FileDiagnostic)]]
forall a. a -> [a] -> [a]
:)
  a
res <- (ModSummary -> ModSummary) -> IO a
action ((ModSummary -> ModSummary) -> IO a)
-> (ModSummary -> ModSummary) -> IO a
forall a b. (a -> b) -> a -> b
$ \ModSummary
x -> ModSummary
x{ms_hspp_opts :: DynFlags
ms_hspp_opts = (ModSummary -> DynFlags
ms_hspp_opts ModSummary
x){log_action :: DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
log_action = DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
newAction}}
  [[(WarnReason, FileDiagnostic)]]
warns <- Var [[(WarnReason, FileDiagnostic)]]
-> IO [[(WarnReason, FileDiagnostic)]]
forall a. Var a -> IO a
readVar Var [[(WarnReason, FileDiagnostic)]]
warnings
  ([(WarnReason, FileDiagnostic)], a)
-> IO ([(WarnReason, FileDiagnostic)], a)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(WarnReason, FileDiagnostic)] -> [(WarnReason, FileDiagnostic)]
forall a. [a] -> [a]
reverse ([(WarnReason, FileDiagnostic)] -> [(WarnReason, FileDiagnostic)])
-> [(WarnReason, FileDiagnostic)] -> [(WarnReason, FileDiagnostic)]
forall a b. (a -> b) -> a -> b
$ [[(WarnReason, FileDiagnostic)]] -> [(WarnReason, FileDiagnostic)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(WarnReason, FileDiagnostic)]]
warns, a
res)