{-# LANGUAGE ScopedTypeVariables #-}
module Clash.GHC.Util where

import ErrUtils           (mkPlainErrMsg)
import GHC                (GhcMonad(..), printException)
import GhcPlugins         (DynFlags, SourceError, ($$), blankLine, empty, isGoodSrcSpan, liftIO, noSrcSpan, text, throwOneError)

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

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

handleClashException
  :: GhcMonad m
  => DynFlags
  -> ClashOpts
  -> SomeException
  -> m a
handleClashException :: DynFlags -> ClashOpts -> SomeException -> m a
handleClashException df :: DynFlags
df opts :: ClashOpts
opts e :: SomeException
e = case SomeException -> Maybe ClashException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
  Just (ClashException sp :: SrcSpan
sp s :: String
s eM :: Maybe String
eM) -> do
    let srcInfo' :: SDoc
srcInfo' | SrcSpan -> Bool
isGoodSrcSpan SrcSpan
sp = SDoc
srcInfo
                 | Bool
otherwise = SDoc
empty
    ErrMsg -> m a
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
df SrcSpan
sp (String -> SDoc
text String
s SDoc -> SDoc -> SDoc
$$ SDoc
srcInfo' SDoc -> SDoc -> SDoc
$$ Bool -> Maybe String -> SDoc
showExtra (ClashOpts -> Bool
opt_errorExtra ClashOpts
opts) Maybe String
eM))
  _ -> case SomeException -> Maybe ErrorCall
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
    Just (ErrorCall msg :: String
msg) ->
      ErrMsg -> m a
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
df SrcSpan
noSrcSpan (String -> SDoc
text "Clash error call:" SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
msg))
    _ -> case SomeException -> Maybe SourceError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (SourceError
e' :: SourceError) -> do
        SourceError -> m ()
forall (m :: * -> *). GhcMonad m => SourceError -> m ()
GHC.printException SourceError
e'
        IO a -> m a
forall (m :: * -> *) 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 1)
      _ -> ErrMsg -> m a
forall (m :: * -> *) ab. MonadIO m => ErrMsg -> m ab
throwOneError (DynFlags -> SrcSpan -> SDoc -> ErrMsg
mkPlainErrMsg DynFlags
df SrcSpan
noSrcSpan (String -> SDoc
text "Other error:" SDoc -> SDoc -> SDoc
$$ String -> SDoc
text (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)))
  where
    srcInfo :: SDoc
srcInfo = String -> SDoc
text "NB: The source location of the error is not exact, only indicative, as it is acquired after optimisations." SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text "The actual location of the error can be in a function that is inlined." SDoc -> SDoc -> SDoc
$$
              String -> SDoc
text "To prevent inlining of those functions, annotate them with a NOINLINE pragma."

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