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

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

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

import           Development.IDE.GHC.Compat
import           Development.IDE.GHC.Error
import           Development.IDE.Types.Diagnostics
import           Language.LSP.Protocol.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
#if MIN_VERSION_ghc(9,3,0)
withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
#else
withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(WarnReason, FileDiagnostic)], a)
#endif
withWarnings :: forall a.
Text
-> ((HscEnv -> HscEnv) -> IO a)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
withWarnings Text
diagSource (HscEnv -> HscEnv) -> IO a
action = do
  Var [[(Maybe DiagnosticReason, FileDiagnostic)]]
warnings <- [[(Maybe DiagnosticReason, FileDiagnostic)]]
-> IO (Var [[(Maybe DiagnosticReason, FileDiagnostic)]])
forall a. a -> IO (Var a)
newVar []
  let newAction :: DynFlags -> LogActionCompat
      newAction :: DynFlags -> LogActionCompat
newAction DynFlags
dynFlags LogFlags
logFlags Maybe DiagnosticReason
wr Maybe Severity
_ SrcSpan
loc PrintUnqualified
prUnqual SDoc
msg = do
        let wr_d :: [(Maybe DiagnosticReason, FileDiagnostic)]
wr_d = (FileDiagnostic -> (Maybe DiagnosticReason, FileDiagnostic))
-> [FileDiagnostic] -> [(Maybe DiagnosticReason, FileDiagnostic)]
forall a b. (a -> b) -> [a] -> [b]
map ((Maybe DiagnosticReason
wr,) (FileDiagnostic -> (Maybe DiagnosticReason, FileDiagnostic))
-> (FileDiagnostic -> FileDiagnostic)
-> FileDiagnostic
-> (Maybe DiagnosticReason, 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 (Maybe DiagnosticReason -> Diagnostic -> Diagnostic
attachReason Maybe DiagnosticReason
wr)) ([FileDiagnostic] -> [(Maybe DiagnosticReason, FileDiagnostic)])
-> [FileDiagnostic] -> [(Maybe DiagnosticReason, FileDiagnostic)]
forall a b. (a -> b) -> a -> b
$ Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dynFlags (MsgEnvelope DecoratedSDoc -> [FileDiagnostic])
-> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Maybe DiagnosticReason
-> LogFlags
-> SrcSpan
-> PrintUnqualified
-> SDoc
-> MsgEnvelope DecoratedSDoc
forall b.
DynFlags
-> Maybe DiagnosticReason
-> b
-> SrcSpan
-> PrintUnqualified
-> SDoc
-> MsgEnvelope DecoratedSDoc
mkWarnMsg DynFlags
dynFlags Maybe DiagnosticReason
wr LogFlags
logFlags SrcSpan
loc PrintUnqualified
prUnqual SDoc
msg
        Var [[(Maybe DiagnosticReason, FileDiagnostic)]]
-> ([[(Maybe DiagnosticReason, FileDiagnostic)]]
    -> IO [[(Maybe DiagnosticReason, FileDiagnostic)]])
-> IO ()
forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var [[(Maybe DiagnosticReason, FileDiagnostic)]]
warnings (([[(Maybe DiagnosticReason, FileDiagnostic)]]
  -> IO [[(Maybe DiagnosticReason, FileDiagnostic)]])
 -> IO ())
-> ([[(Maybe DiagnosticReason, FileDiagnostic)]]
    -> IO [[(Maybe DiagnosticReason, FileDiagnostic)]])
-> IO ()
forall a b. (a -> b) -> a -> b
$ [[(Maybe DiagnosticReason, FileDiagnostic)]]
-> IO [[(Maybe DiagnosticReason, FileDiagnostic)]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[(Maybe DiagnosticReason, FileDiagnostic)]]
 -> IO [[(Maybe DiagnosticReason, FileDiagnostic)]])
-> ([[(Maybe DiagnosticReason, FileDiagnostic)]]
    -> [[(Maybe DiagnosticReason, FileDiagnostic)]])
-> [[(Maybe DiagnosticReason, FileDiagnostic)]]
-> IO [[(Maybe DiagnosticReason, FileDiagnostic)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Maybe DiagnosticReason, FileDiagnostic)]
wr_d:)
      newLogger :: HscEnv -> Logger
newLogger HscEnv
env = (LogAction -> LogAction) -> Logger -> Logger
pushLogHook (LogAction -> LogAction -> LogAction
forall a b. a -> b -> a
const (LogActionCompat -> LogAction
logActionCompat (DynFlags -> LogActionCompat
newAction (HscEnv -> DynFlags
hsc_dflags HscEnv
env)))) (HscEnv -> Logger
hsc_logger HscEnv
env)
  a
res <- (HscEnv -> HscEnv) -> IO a
action ((HscEnv -> HscEnv) -> IO a) -> (HscEnv -> HscEnv) -> IO a
forall a b. (a -> b) -> a -> b
$ \HscEnv
env -> Logger -> HscEnv -> HscEnv
putLogHook (HscEnv -> Logger
newLogger HscEnv
env) HscEnv
env
  [[(Maybe DiagnosticReason, FileDiagnostic)]]
warns <- Var [[(Maybe DiagnosticReason, FileDiagnostic)]]
-> IO [[(Maybe DiagnosticReason, FileDiagnostic)]]
forall a. Var a -> IO a
readVar Var [[(Maybe DiagnosticReason, FileDiagnostic)]]
warnings
  ([(Maybe DiagnosticReason, FileDiagnostic)], a)
-> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Maybe DiagnosticReason, FileDiagnostic)]
-> [(Maybe DiagnosticReason, FileDiagnostic)]
forall a. [a] -> [a]
reverse ([(Maybe DiagnosticReason, FileDiagnostic)]
 -> [(Maybe DiagnosticReason, FileDiagnostic)])
-> [(Maybe DiagnosticReason, FileDiagnostic)]
-> [(Maybe DiagnosticReason, FileDiagnostic)]
forall a b. (a -> b) -> a -> b
$ [[(Maybe DiagnosticReason, FileDiagnostic)]]
-> [(Maybe DiagnosticReason, FileDiagnostic)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Maybe DiagnosticReason, FileDiagnostic)]]
warns, a
res)
  where
    third3 :: (c -> d) -> (a, b, c) -> (a, b, d)
    third3 :: forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d)
third3 c -> d
f (a
a, b
b, c
c) = (a
a, b
b, c -> d
f c
c)

#if MIN_VERSION_ghc(9,3,0)
attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
attachReason :: Maybe DiagnosticReason -> Diagnostic -> Diagnostic
attachReason Maybe DiagnosticReason
Nothing Diagnostic
d = Diagnostic
d
attachReason (Just DiagnosticReason
wr) Diagnostic
d = Diagnostic
d{_code = InR <$> showReason wr}
 where
  showReason :: DiagnosticReason -> Maybe Text
showReason = \case
    WarningWithFlag WarningFlag
flag -> WarningFlag -> Maybe Text
showFlag WarningFlag
flag
    DiagnosticReason
_                    -> Maybe Text
forall a. Maybe a
Nothing
#else
attachReason :: WarnReason -> Diagnostic -> Diagnostic
attachReason wr d = d{_code = InR <$> showReason wr}
 where
  showReason = \case
    NoReason       -> Nothing
    Reason flag    -> showFlag flag
    ErrReason flag -> showFlag =<< flag
#endif

showFlag :: WarningFlag -> Maybe T.Text
showFlag :: WarningFlag -> Maybe Text
showFlag WarningFlag
flag = (Text
"-W" <>) (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