{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}

module Clash.GHC.Util
  ( module Clash.GHC.Util
#if MIN_VERSION_ghc(9,2,0)
  , module X
#endif
  )
where

#if MIN_VERSION_ghc(9,8,0)
import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage))
import GHC.Utils.Outputable as X (showPprUnsafe, showSDocUnsafe)
import GHC.Utils.Outputable (SDoc, neverQualify)
import GHC.Utils.Error (mkErrorMsgEnvelope, mkPlainError)
import GHC.Plugins
  (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO,
   noSrcSpan, text, throwOneError)
import GHC.Types.Error (mkSimpleUnknownDiagnostic)
#elif MIN_VERSION_ghc(9,6,0)
import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage))
import GHC.Utils.Outputable as X (showPprUnsafe, showSDocUnsafe)
import GHC.Utils.Outputable (SDoc, neverQualify)
import GHC.Utils.Error (mkErrorMsgEnvelope, mkPlainError)
import GHC.Plugins
  (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO,
   noSrcSpan, text, throwOneError)
import GHC.Types.Error (UnknownDiagnostic(..))
#elif MIN_VERSION_ghc(9,4,0)
import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage))
import GHC.Utils.Outputable as X (showPprUnsafe, showSDocUnsafe)
import GHC.Utils.Outputable (SDoc, neverQualify)
import GHC.Utils.Error (mkErrorMsgEnvelope, mkPlainError)
import GHC.Plugins
  (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO,
   noSrcSpan, text, throwOneError)
#elif MIN_VERSION_ghc(9,2,0)
import GHC.Utils.Outputable as X (showPprUnsafe, showSDocUnsafe)
import GHC.Utils.Outputable (SDoc, neverQualify)
import GHC.Utils.Error (mkMsgEnvelope)
import GHC.Plugins
  (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO,
   noSrcSpan, text, throwOneError)
#elif MIN_VERSION_ghc(9,0,0)
import GHC.Driver.Session (unsafeGlobalDynFlags)
import GHC.Utils.Outputable (Outputable, SDoc, showPpr, showSDoc)
import GHC.Utils.Error (mkPlainErrMsg)
import GHC.Plugins
  (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO,
   noSrcSpan, text, throwOneError)
#else
import DynFlags           (unsafeGlobalDynFlags)
import Outputable         (Outputable, SDoc, showPpr, showSDoc)
import ErrUtils           (mkPlainErrMsg)
import GhcPlugins         (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO, noSrcSpan, text, throwOneError)
#endif
import GHC                (GhcMonad(..), printException)

import Control.Exception  (Exception(..), ErrorCall(..))
import GHC.Exception      (SomeException)
import System.Exit        (ExitCode(ExitFailure), exitWith)

import Clash.Util         (ClashException(..))
import Clash.Util.Interpolate (i)
import Clash.Driver.Types (ClashOpts(..))

-- | Like 'lines', but returning a horizontally spaced SDoc instead of a list:
--
-- >>> textLines "a\nb"
-- a $$ b
textLines :: String -> SDoc
textLines :: String -> SDoc
textLines String
s = (SDoc -> SDoc -> SDoc) -> [SDoc] -> SDoc
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
($$) ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> [String]
lines String
s))

handleClashException
  :: GhcMonad m
  => DynFlags
  -> ClashOpts
  -> SomeException
  -> m a
#if MIN_VERSION_ghc(9,2,0)
handleClashException :: forall (m :: Type -> Type) a.
GhcMonad m =>
DynFlags -> ClashOpts -> SomeException -> m a
handleClashException DynFlags
_df ClashOpts
opts SomeException
e = case SomeException -> Maybe ClashException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
#else
handleClashException df opts e = case fromException e of
#endif
  Just (ClashException SrcSpan
sp String
s Maybe String
eM) -> do
    let srcInfo' :: SDoc
srcInfo' | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
sp = SDoc
srcInfo
                 | Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty
    MsgEnvelope GhcMessage -> m a
forall (io :: Type -> Type) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError
#if MIN_VERSION_ghc(9,8,0)
      (mkErrorMsgEnvelope sp neverQualify $ GhcUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainError []
#elif MIN_VERSION_ghc(9,6,0)
      (SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
sp NamePprCtx
neverQualify (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic -> GhcMessage
GhcUnknownMessage (UnknownDiagnostic -> GhcMessage)
-> UnknownDiagnostic -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError []
#elif MIN_VERSION_ghc(9,4,0)
      (mkErrorMsgEnvelope sp neverQualify $ GhcUnknownMessage $ mkPlainError []
#elif MIN_VERSION_ghc(9,2,0)
      (mkMsgEnvelope sp neverQualify
#else
      (mkPlainErrMsg df sp
#endif
        (SDoc
blankLine SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
textLines String
s SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
srcInfo' SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Bool -> Maybe String -> SDoc
showExtra (ClashOpts -> Bool
opt_errorExtra ClashOpts
opts) Maybe String
eM))
  Maybe ClashException
_ -> case SomeException -> Maybe ErrorCall
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Just (ErrorCallWithLocation String
_ String
_) ->
      MsgEnvelope GhcMessage -> m a
forall (io :: Type -> Type) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError
#if MIN_VERSION_ghc(9,8,0)
        (mkErrorMsgEnvelope noSrcSpan neverQualify $ GhcUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainError []
#elif MIN_VERSION_ghc(9,6,0)
        (SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
noSrcSpan NamePprCtx
neverQualify (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic -> GhcMessage
GhcUnknownMessage (UnknownDiagnostic -> GhcMessage)
-> UnknownDiagnostic -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError []
#elif MIN_VERSION_ghc(9,4,0)
        (mkErrorMsgEnvelope noSrcSpan neverQualify $ GhcUnknownMessage $ mkPlainError []
#elif MIN_VERSION_ghc(9,2,0)
        (mkMsgEnvelope noSrcSpan neverQualify
#else
        (mkPlainErrMsg df noSrcSpan
#endif
        (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Clash error call:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
textLines (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)))
    Maybe ErrorCall
_ -> case SomeException -> Maybe SourceError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (SourceError
e' :: SourceError) -> do
        SourceError -> m ()
forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
GHC.printException SourceError
e'
        IO a -> m a
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
      Maybe SourceError
_ -> MsgEnvelope GhcMessage -> m a
forall (io :: Type -> Type) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError
#if MIN_VERSION_ghc(9,8,0)
              (mkErrorMsgEnvelope noSrcSpan neverQualify $ GhcUnknownMessage $ mkSimpleUnknownDiagnostic $ mkPlainError []
#elif MIN_VERSION_ghc(9,6,0)
              (SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
noSrcSpan NamePprCtx
neverQualify (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic -> GhcMessage
GhcUnknownMessage (UnknownDiagnostic -> GhcMessage)
-> UnknownDiagnostic -> GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> DiagnosticMessage -> UnknownDiagnostic
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError []
#elif MIN_VERSION_ghc(9,4,0)
              (mkErrorMsgEnvelope noSrcSpan neverQualify $ GhcUnknownMessage  $ mkPlainError []
#elif MIN_VERSION_ghc(9,2,0)
              (mkMsgEnvelope noSrcSpan neverQualify
#else
              (mkPlainErrMsg df noSrcSpan
#endif
              (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Other error:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
textLines (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)))
  where
    srcInfo :: SDoc
srcInfo = String -> SDoc
textLines [i|
      The source location of the error is not exact, only indicative, as it
      is acquired after optimizations. The actual location of the error can be
      in a function that is inlined. To prevent inlining of those functions,
      annotate them with a NOINLINE pragma.
    |]

    showExtra :: Bool -> Maybe String -> SDoc
showExtra Bool
False (Just String
_)   =
      SDoc
blankLine SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"This error contains additional information, rerun with '-fclash-error-extra' to show this information."
    showExtra Bool
True  (Just String
msg) =
      SDoc
blankLine SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Additional information:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
      String -> SDoc
textLines String
msg
    showExtra Bool
_ Maybe String
_ = SDoc
forall doc. IsOutput doc => doc
empty

#if !MIN_VERSION_ghc(9,2,0)
showPprUnsafe :: Outputable a => a -> String
showPprUnsafe = showPpr unsafeGlobalDynFlags

showSDocUnsafe :: SDoc -> String
showSDocUnsafe = showSDoc unsafeGlobalDynFlags
#endif