{-|
  Copyright   :  (C) 2026, QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>

  Emit named warnings, respecting the warning options in 'ClashOpts'. See
  "Clash.Warning" for the warnings and the flags controlling them.

  This module is deliberately kept apart from "Clash.Warning": 'ClashOpts' has
  a 'Clash.Warning.WarningOpts' field, so "Clash.Driver.Types" imports
  "Clash.Warning". Anything mentioning 'ClashOpts' - everything below - would
  therefore introduce an import cycle if it lived in "Clash.Warning".
-}

{-# LANGUAGE DefaultSignatures #-}

module Clash.Driver.Warning
  ( PendingWarning(..)
  , warnAbout
  , warnAboutM
    -- * Monads that can emit warnings
  , CanWarn(..)
  ) where

import Control.Exception (throw)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import System.Console.ANSI
  (Color (Magenta), ColorIntensity (Vivid), ConsoleIntensity (BoldIntensity),
   ConsoleLayer (Foreground), SGR (Reset, SetColor, SetConsoleIntensity),
   hSetSGR)
import System.IO
  (hFlush, hIsTerminalDevice, hPutStrLn, stderr)

import GHC.Types.SrcLoc (SrcSpan, isGoodSrcSpan)
import GHC.Utils.Outputable (ppr, showSDocUnsafe)

import Clash.Driver.Bool (OverridingBool (..))
import Clash.Driver.Types (ClashOpts (..), HasClashOpts (..))
import Clash.Util (ClashException (..))
import Clash.Warning (ClashWarning, warningName, wopt, woptFatal)

-- | A warning waiting to be reported. Pure passes collect these; whether the
-- warning is enabled or fatal is decided by 'warnAbout' when it is reported.
data PendingWarning = PendingWarning
  { PendingWarning -> ClashWarning
pending_warning :: ClashWarning
  , PendingWarning -> SrcSpan
pending_srcSpan :: SrcSpan
  , PendingWarning -> String
pending_message :: String
  }

-- | Monads Clash can emit warnings from with 'warnAboutM'.
class HasClashOpts m => CanWarn m where
  -- | Deliver a warning. Monads that can do IO report it right away, which is
  -- what the default implementation does. Pure monads collect the warning
  -- instead, leaving it to the driver to report it with 'warnAbout' later.
  reportWarning :: PendingWarning -> m ()

  default reportWarning :: MonadIO m => PendingWarning -> m ()
  reportWarning PendingWarning
pw = do
    ClashOpts
opts <- m ClashOpts
forall (m :: Type -> Type). HasClashOpts m => m ClashOpts
askClashOpts
    IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (ClashOpts -> PendingWarning -> IO ()
warnAbout ClashOpts
opts PendingWarning
pw)

-- | Report the given warning: a no-op if the warning is disabled, a (colorized)
-- message on stderr if it is enabled, and a 'ClashException' if it is promoted
-- to an error (@-Werror@ or @-Werror=\<name\>@).
warnAbout :: ClashOpts -> PendingWarning -> IO ()
warnAbout :: ClashOpts -> PendingWarning -> IO ()
warnAbout ClashOpts
opts (PendingWarning ClashWarning
w SrcSpan
sp String
msg) = Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ClashWarning -> WarningOpts -> Bool
wopt ClashWarning
w (ClashOpts -> WarningOpts
opt_warnings ClashOpts
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
  if Bool -> ClashWarning -> WarningOpts -> Bool
woptFatal (ClashOpts -> Bool
opt_werror ClashOpts
opts) ClashWarning
w (ClashOpts -> WarningOpts
opt_warnings ClashOpts
opts) then
    ClashException -> IO ()
forall a e. Exception e => e -> a
throw (SrcSpan -> String -> Maybe String -> ClashException
ClashException SrcSpan
sp (String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" [-Werror=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClashWarning -> String
warningName ClashWarning
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]") Maybe String
forall a. Maybe a
Nothing)
  else do
    Bool
useColor <-
      case ClashOpts -> OverridingBool
opt_color ClashOpts
opts of
        OverridingBool
Always -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
True
        OverridingBool
Never  -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Bool
False
        OverridingBool
Auto   -> Handle -> IO Bool
hIsTerminalDevice Handle
stderr

    Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity]
    Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when Bool
useColor (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
Magenta]
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"[WARNING] " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
loc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" [-W" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ClashWarning -> String
warningName ClashWarning
w String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]")
    Handle -> [SGR] -> IO ()
hSetSGR Handle
stderr [SGR
Reset]
    Handle -> IO ()
hFlush Handle
stderr
 where
  loc :: String
loc
    | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
sp = SDoc -> String
showSDocUnsafe (SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
sp) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": "
    | Bool
otherwise = String
""

-- | 'warnAbout' in whatever monad Clash is currently running in. Disabled
-- warnings are dropped here, so pure monads don't collect warnings nobody is
-- going to report. Note that 'warnAbout' checks again, as a warning can also
-- be reported without going through this function.
warnAboutM :: CanWarn m => ClashWarning -> SrcSpan -> String -> m ()
warnAboutM :: forall (m :: Type -> Type).
CanWarn m =>
ClashWarning -> SrcSpan -> String -> m ()
warnAboutM ClashWarning
w SrcSpan
sp String
msg = do
  ClashOpts
opts <- m ClashOpts
forall (m :: Type -> Type). HasClashOpts m => m ClashOpts
askClashOpts
  Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (ClashWarning -> WarningOpts -> Bool
wopt ClashWarning
w (ClashOpts -> WarningOpts
opt_warnings ClashOpts
opts)) (PendingWarning -> m ()
forall (m :: Type -> Type). CanWarn m => PendingWarning -> m ()
reportWarning (ClashWarning -> SrcSpan -> String -> PendingWarning
PendingWarning ClashWarning
w SrcSpan
sp String
msg))