-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE ExplicitNamespaces #-}

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

import           Data.List
import           ErrUtils
import           GhcPlugins                        as GHC hiding (Var, (<>))

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

import           Development.IDE.GHC.Error
import           Development.IDE.Types.Diagnostics
import           Language.LSP.Types                (type (|?) (..))


-- | 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 a b. (a -> b) -> [a] -> [b]
map ((WarnReason
wr,) (FileDiagnostic -> (WarnReason, FileDiagnostic))
-> (FileDiagnostic -> FileDiagnostic)
-> FileDiagnostic
-> (WarnReason, FileDiagnostic)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic
forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d)
third3 (WarnReason -> Diagnostic -> Diagnostic
attachReason 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
  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)

attachReason :: WarnReason -> Diagnostic -> Diagnostic
attachReason :: WarnReason -> Diagnostic -> Diagnostic
attachReason WarnReason
wr Diagnostic
d = Diagnostic
d{$sel:_code:Diagnostic :: Maybe (Int |? Text)
_code = Text -> Int |? Text
forall a b. b -> a |? b
InR (Text -> Int |? Text) -> Maybe Text -> Maybe (Int |? Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WarnReason -> Maybe Text
showReason WarnReason
wr}
 where
  showReason :: WarnReason -> Maybe Text
showReason = \case
    WarnReason
NoReason       -> Maybe Text
forall a. Maybe a
Nothing
    Reason WarningFlag
flag    -> WarningFlag -> Maybe Text
showFlag WarningFlag
flag
    ErrReason Maybe WarningFlag
flag -> WarningFlag -> Maybe Text
showFlag (WarningFlag -> Maybe Text) -> Maybe WarningFlag -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe WarningFlag
flag

showFlag :: WarningFlag -> Maybe T.Text
showFlag :: WarningFlag -> Maybe Text
showFlag WarningFlag
flag = (Text
"-W" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> (FlagSpec WarningFlag -> Text) -> FlagSpec WarningFlag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (FlagSpec WarningFlag -> String) -> FlagSpec WarningFlag -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagSpec WarningFlag -> String
forall flag. FlagSpec flag -> String
flagSpecName (FlagSpec WarningFlag -> Text)
-> Maybe (FlagSpec WarningFlag) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FlagSpec WarningFlag -> Bool)
-> [FlagSpec WarningFlag] -> Maybe (FlagSpec WarningFlag)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((WarningFlag -> WarningFlag -> Bool
forall a. Eq a => a -> a -> Bool
== WarningFlag
flag) (WarningFlag -> Bool)
-> (FlagSpec WarningFlag -> WarningFlag)
-> FlagSpec WarningFlag
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagSpec WarningFlag -> WarningFlag
forall flag. FlagSpec flag -> flag
flagSpecFlag) [FlagSpec WarningFlag]
wWarningFlags