-- 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           Control.Lens                      (over)
import qualified Data.Text                         as T

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

{-
 Note [withWarnings and its dangers]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    withWarnings collects warnings by registering a custom logger which extracts
    the SDocs of those warnings. If you receive warnings this way, you will not
    get them in a structured form. In the medium term we'd like to remove all
    uses of withWarnings to get structured messages everywhere we can.

    For the time being, withWarnings is no longer used for anything in the main
    typecheckModule codepath, but it is still used for bytecode/object code
    generation, as well as a few other places.

    I suspect some of these functions (e.g. codegen) will need deeper changes to
    be able to get diagnostics as a list, though I don't have great evidence for
    that atm. I haven't taken a look to see if those functions that are wrapped
    with this could produce diagnostics another way.

    It would be good for someone to take a look. What we've done so far gives us
    diagnostics for renaming and typechecking, and doesn't require us to copy
    too much code from GHC or make any deeper changes, and lets us get started
    with the bulk of the useful plugin work, but it would be good to have all
    diagnostics with structure be collected that way.
-}

-- | 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
--
-- Also, See Note [withWarnings and its dangers] for some commentary on this function.
withWarnings :: T.Text -> ((HscEnv -> HscEnv) -> IO a) -> IO ([(Maybe DiagnosticReason, FileDiagnostic)], a)
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
. ASetter FileDiagnostic FileDiagnostic Diagnostic Diagnostic
-> (Diagnostic -> Diagnostic) -> FileDiagnostic -> FileDiagnostic
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter FileDiagnostic FileDiagnostic Diagnostic Diagnostic
Lens' FileDiagnostic Diagnostic
fdLspDiagnosticL (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]
diagFromSDocErrMsg Text
diagSource DynFlags
dynFlags (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)