-- 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 ([(WarnReason, FileDiagnostic)], a)
withWarnings Text
diagSource (HscEnv -> HscEnv) -> IO a
action = do
  Var [[(WarnReason, FileDiagnostic)]]
warnings <- forall a. a -> IO (Var a)
newVar []
  let newAction :: DynFlags -> LogActionCompat
      newAction :: DynFlags -> LogActionCompat
newAction DynFlags
dynFlags DynFlags
logFlags WarnReason
wr Severity
_ SrcSpan
loc PrintUnqualified
prUnqual SDoc
msg = do
        let wr_d :: [(WarnReason, FileDiagnostic)]
wr_d = forall a b. (a -> b) -> [a] -> [b]
map ((WarnReason
wr,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c d a b. (c -> d) -> (a, b, c) -> (a, b, d)
third3 (WarnReason -> Diagnostic -> Diagnostic
attachReason WarnReason
wr)) forall a b. (a -> b) -> a -> b
$ Text -> DynFlags -> MsgEnvelope DecoratedSDoc -> [FileDiagnostic]
diagFromErrMsg Text
diagSource DynFlags
dynFlags forall a b. (a -> b) -> a -> b
$ forall a b.
a
-> b
-> DynFlags
-> SrcSpan
-> PrintUnqualified
-> SDoc
-> MsgEnvelope DecoratedSDoc
mkWarnMsg DynFlags
dynFlags WarnReason
wr DynFlags
logFlags SrcSpan
loc PrintUnqualified
prUnqual SDoc
msg
        forall a. Var a -> (a -> IO a) -> IO ()
modifyVar_ Var [[(WarnReason, FileDiagnostic)]]
warnings forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(WarnReason, FileDiagnostic)]
wr_dforall a. a -> [a] -> [a]
:)
      newLogger :: HscEnv -> Logger
newLogger HscEnv
env = (LogAction -> LogAction) -> Logger -> Logger
pushLogHook (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 forall a b. (a -> b) -> a -> b
$ \HscEnv
env -> Logger -> HscEnv -> HscEnv
putLogHook (HscEnv -> Logger
newLogger HscEnv
env) HscEnv
env
  [[(WarnReason, FileDiagnostic)]]
warns <- forall a. Var a -> IO a
readVar Var [[(WarnReason, FileDiagnostic)]]
warnings
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(WarnReason, 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 Nothing d = d
attachReason (Just wr) d = d{_code = InR <$> showReason wr}
 where
  showReason = \case
    WarningWithFlag flag -> showFlag flag
    _                    -> Nothing
#else
attachReason :: WarnReason -> Diagnostic -> Diagnostic
attachReason :: WarnReason -> Diagnostic -> Diagnostic
attachReason WarnReason
wr Diagnostic
d = Diagnostic
d{$sel:_code:Diagnostic :: Maybe (Int32 |? Text)
_code = forall a b. b -> a |? b
InR 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       -> forall a. Maybe a
Nothing
    Reason WarningFlag
flag    -> WarningFlag -> Maybe Text
showFlag WarningFlag
flag
    ErrReason Maybe WarningFlag
flag -> WarningFlag -> Maybe Text
showFlag forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe WarningFlag
flag
#endif

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