{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Clash.GHCi.UI.Exception(printGhciException, GHCiMessage(..)) where

import GHC.Prelude

import GHC.Driver.Config.Diagnostic
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.Session

import GHC.Iface.Errors.Ppr
import GHC.Iface.Errors.Types

import qualified GHC.LanguageExtensions as LangExt

import GHC.Tc.Errors.Ppr
import GHC.Tc.Errors.Types

import GHC.Types.Error
import GHC.Types.SourceError

import GHC.Unit.State

import GHC.Utils.Logger
import GHC.Utils.Outputable

import Control.Monad.IO.Class


-- | Print the all diagnostics in a 'SourceError'.  Specialised for GHCi error reporting
-- for some error messages.
printGhciException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()
printGhciException :: forall (m :: Type -> Type).
(HasLogger m, MonadIO m, HasDynFlags m) =>
SourceError -> m ()
printGhciException SourceError
err = do
  dflags <- m DynFlags
forall (m :: Type -> Type). HasDynFlags m => m DynFlags
getDynFlags
  logger <- getLogger
  let !diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
      !print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
  liftIO $ printMessages logger print_config diag_opts (GHCiMessage <$> (srcErrorMessages err))


newtype GHCiMessage = GHCiMessage { GHCiMessage -> GhcMessage
_getGhciMessage :: GhcMessage }

instance Diagnostic GHCiMessage where
  type DiagnosticOpts GHCiMessage = DiagnosticOpts GhcMessage

  diagnosticMessage :: DiagnosticOpts GHCiMessage -> GHCiMessage -> DecoratedSDoc
diagnosticMessage DiagnosticOpts GHCiMessage
opts (GHCiMessage GhcMessage
msg) = GhcMessageOpts -> GhcMessage -> DecoratedSDoc
ghciDiagnosticMessage DiagnosticOpts GHCiMessage
GhcMessageOpts
opts GhcMessage
msg

  diagnosticReason :: GHCiMessage -> DiagnosticReason
diagnosticReason (GHCiMessage GhcMessage
msg) = GhcMessage -> DiagnosticReason
forall a. Diagnostic a => a -> DiagnosticReason
diagnosticReason GhcMessage
msg

  diagnosticHints :: GHCiMessage -> [GhcHint]
diagnosticHints (GHCiMessage GhcMessage
msg) = GhcMessage -> [GhcHint]
ghciDiagnosticHints GhcMessage
msg

  diagnosticCode :: GHCiMessage -> Maybe DiagnosticCode
diagnosticCode (GHCiMessage GhcMessage
msg)  = GhcMessage -> Maybe DiagnosticCode
forall a. Diagnostic a => a -> Maybe DiagnosticCode
diagnosticCode GhcMessage
msg


-- | Modifications to hint messages which we want to display in GHCi.
ghciDiagnosticHints :: GhcMessage -> [GhcHint]
ghciDiagnosticHints :: GhcMessage -> [GhcHint]
ghciDiagnosticHints GhcMessage
msg = (GhcHint -> GhcHint) -> [GhcHint] -> [GhcHint]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> GhcHint
modifyHintForGHCi (GhcMessage -> [GhcHint]
forall a. Diagnostic a => a -> [GhcHint]
diagnosticHints GhcMessage
msg)
  where
    modifyHintForGHCi :: GhcHint -> GhcHint
    modifyHintForGHCi :: GhcHint -> GhcHint
modifyHintForGHCi = \case
      SuggestExtension LanguageExtensionHint
extHint -> LanguageExtensionHint -> GhcHint
SuggestExtension (LanguageExtensionHint -> GhcHint)
-> LanguageExtensionHint -> GhcHint
forall a b. (a -> b) -> a -> b
$ LanguageExtensionHint -> LanguageExtensionHint
modifyExtHintForGHCi LanguageExtensionHint
extHint
      GhcHint
hint -> GhcHint
hint
    modifyExtHintForGHCi :: LanguageExtensionHint -> LanguageExtensionHint
    modifyExtHintForGHCi :: LanguageExtensionHint -> LanguageExtensionHint
modifyExtHintForGHCi = \case
      SuggestSingleExtension    SDoc
doc Extension
ext  -> SDoc -> Extension -> LanguageExtensionHint
SuggestSingleExtension    ([Extension] -> SDoc -> Bool -> SDoc
suggestSetExt [Extension
ext] SDoc
doc Bool
False) Extension
ext
      SuggestExtensionInOrderTo SDoc
doc Extension
ext  -> SDoc -> Extension -> LanguageExtensionHint
SuggestExtensionInOrderTo ([Extension] -> SDoc -> Bool -> SDoc
suggestSetExt [Extension
ext] SDoc
doc Bool
False) Extension
ext
      SuggestAnyExtension       SDoc
doc [Extension]
exts -> SDoc -> [Extension] -> LanguageExtensionHint
SuggestAnyExtension       ([Extension] -> SDoc -> Bool -> SDoc
suggestSetExt [Extension]
exts  SDoc
doc Bool
True ) [Extension]
exts
      SuggestExtensions         SDoc
doc [Extension]
exts -> SDoc -> [Extension] -> LanguageExtensionHint
SuggestExtensions         ([Extension] -> SDoc -> Bool -> SDoc
suggestSetExt [Extension]
exts  SDoc
doc Bool
False) [Extension]
exts
    -- Suggest enabling extension with :set -X<ext>
    -- SuggestAnyExtension will be on multiple lines so the user can select which to enable without editing
    suggestSetExt :: [LangExt.Extension] -> SDoc -> Bool -> SDoc
    suggestSetExt :: [Extension] -> SDoc -> Bool -> SDoc
suggestSetExt [Extension]
exts SDoc
doc Bool
enable_any = SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc -> Int -> SDoc -> SDoc
hang SDoc
header Int
2 SDoc
exts_cmds
      where
        header :: SDoc
header = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"You may enable" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
which SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"language extension" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Extension] -> SDoc
forall a. [a] -> SDoc
plural [Extension]
exts SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in GHCi with:"
        which :: SDoc
which
          | [ Extension
_ext ] <- [Extension]
exts
          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"this"
          | Bool
otherwise
          = if Bool
enable_any
            then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"these"
            else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"all of these"
        exts_cmds :: SDoc
exts_cmds
          | Bool
enable_any
          = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (Extension -> SDoc) -> [Extension] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Extension
ext -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
":set -X" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Extension -> SDoc
forall a. Outputable a => a -> SDoc
ppr Extension
ext) [Extension]
exts
          | Bool
otherwise
          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
":set" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ((Extension -> SDoc) -> [Extension] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\Extension
ext -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" -X" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Extension -> SDoc
forall a. Outputable a => a -> SDoc
ppr Extension
ext) [Extension]
exts)

-- Modifications to error messages which we want to display in GHCi
ghciDiagnosticMessage :: GhcMessageOpts -> GhcMessage -> DecoratedSDoc
ghciDiagnosticMessage :: GhcMessageOpts -> GhcMessage -> DecoratedSDoc
ghciDiagnosticMessage GhcMessageOpts
ghc_opts GhcMessage
msg =
  case GhcMessage
msg of
    GhcTcRnMessage TcRnMessage
tc_msg ->
      case TcRnMessageOpts -> TcRnMessage -> Maybe DecoratedSDoc
tcRnMessage (GhcMessageOpts -> DiagnosticOpts TcRnMessage
tcMessageOpts GhcMessageOpts
ghc_opts) TcRnMessage
tc_msg of
        Maybe DecoratedSDoc
Nothing -> DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts GhcMessage
GhcMessageOpts
ghc_opts GhcMessage
msg
        Just DecoratedSDoc
sdoc -> DecoratedSDoc
sdoc
    GhcDriverMessage  (DriverInterfaceError IfaceMessage
err) ->
      case IfaceMessage -> Maybe SDoc
ghciInterfaceError IfaceMessage
err of
        Just SDoc
sdoc -> SDoc -> DecoratedSDoc
mkSimpleDecorated SDoc
sdoc
        Maybe SDoc
Nothing -> DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts GhcMessage
GhcMessageOpts
ghc_opts GhcMessage
msg
    GhcDriverMessage {} -> DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts GhcMessage
GhcMessageOpts
ghc_opts GhcMessage
msg
    GhcPsMessage  {} -> DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts GhcMessage
GhcMessageOpts
ghc_opts GhcMessage
msg
    GhcDsMessage  {} -> DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts GhcMessage
GhcMessageOpts
ghc_opts GhcMessage
msg
    GhcUnknownMessage  {} -> DiagnosticOpts GhcMessage -> GhcMessage -> DecoratedSDoc
forall a. Diagnostic a => DiagnosticOpts a -> a -> DecoratedSDoc
diagnosticMessage DiagnosticOpts GhcMessage
GhcMessageOpts
ghc_opts GhcMessage
msg
  where
    tcRnMessage :: TcRnMessageOpts -> TcRnMessage -> Maybe DecoratedSDoc
tcRnMessage TcRnMessageOpts
tc_opts TcRnMessage
tc_msg =
      case TcRnMessage
tc_msg of
        TcRnInterfaceError IfaceMessage
err -> SDoc -> DecoratedSDoc
mkSimpleDecorated (SDoc -> DecoratedSDoc) -> Maybe SDoc -> Maybe DecoratedSDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (IfaceMessage -> Maybe SDoc
ghciInterfaceError IfaceMessage
err)
        TcRnMessageWithInfo UnitState
unit_state TcRnMessageDetailed
msg_with_info ->
          case TcRnMessageDetailed
msg_with_info of
           TcRnMessageDetailed ErrInfo
err_info TcRnMessage
wrapped_msg
             -> UnitState -> ErrInfo -> Bool -> DecoratedSDoc -> DecoratedSDoc
messageWithInfoDiagnosticMessage UnitState
unit_state ErrInfo
err_info
                  (TcRnMessageOpts -> Bool
tcOptsShowContext TcRnMessageOpts
tc_opts)
                  (DecoratedSDoc -> DecoratedSDoc)
-> Maybe DecoratedSDoc -> Maybe DecoratedSDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnMessageOpts -> TcRnMessage -> Maybe DecoratedSDoc
tcRnMessage TcRnMessageOpts
tc_opts TcRnMessage
wrapped_msg
        TcRnWithHsDocContext HsDocContext
ctxt TcRnMessage
wrapped_msg ->
          TcRnMessageOpts -> HsDocContext -> DecoratedSDoc -> DecoratedSDoc
messageWithHsDocContext TcRnMessageOpts
tc_opts HsDocContext
ctxt (DecoratedSDoc -> DecoratedSDoc)
-> Maybe DecoratedSDoc -> Maybe DecoratedSDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> TcRnMessageOpts -> TcRnMessage -> Maybe DecoratedSDoc
tcRnMessage TcRnMessageOpts
tc_opts TcRnMessage
wrapped_msg
        TcRnMessage
_ -> Maybe DecoratedSDoc
forall a. Maybe a
Nothing

    opts :: IfaceMessageOpts
opts = TcRnMessageOpts -> IfaceMessageOpts
tcOptsIfaceOpts (GhcMessageOpts -> DiagnosticOpts TcRnMessage
tcMessageOpts GhcMessageOpts
ghc_opts)

    ghciInterfaceError :: IfaceMessage -> Maybe SDoc
ghciInterfaceError (Can'tFindInterface MissingInterfaceError
err InterfaceLookingFor
looking_for) =
      SDoc -> Int -> SDoc -> SDoc
hangNotEmpty (InterfaceLookingFor -> SDoc
lookingForHerald InterfaceLookingFor
looking_for) Int
2 (SDoc -> SDoc) -> Maybe SDoc -> Maybe SDoc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MissingInterfaceError -> Maybe SDoc
ghciMissingInterfaceErrorDiagnostic MissingInterfaceError
err
    ghciInterfaceError IfaceMessage
_ = Maybe SDoc
forall a. Maybe a
Nothing

    ghciMissingInterfaceErrorDiagnostic :: MissingInterfaceError -> Maybe SDoc
ghciMissingInterfaceErrorDiagnostic MissingInterfaceError
reason =
      case MissingInterfaceError
reason of
        CantFindErr UnitState
us FindingModuleOrInterface
module_or_interface CantFindInstalled
cfi -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
us (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (UnitInfo -> SDoc)
-> ([String] -> SDoc)
-> FindingModuleOrInterface
-> CantFindInstalled
-> SDoc
cantFindErrorX UnitInfo -> SDoc
pkg_hidden_hint [String] -> SDoc
may_show_locations FindingModuleOrInterface
module_or_interface CantFindInstalled
cfi)
        MissingInterfaceError
_ -> Maybe SDoc
forall a. Maybe a
Nothing
      where

        may_show_locations :: [String] -> SDoc
may_show_locations = String -> Bool -> [String] -> SDoc
mayShowLocations String
":set -v" (IfaceMessageOpts -> Bool
ifaceShowTriedFiles IfaceMessageOpts
opts)

        pkg_hidden_hint :: UnitInfo -> SDoc
pkg_hidden_hint = (UnitInfo -> SDoc) -> BuildingCabalPackage -> UnitInfo -> SDoc
pkgHiddenHint UnitInfo -> SDoc
forall {a} {srcpkgid} {uid} {modulename} {mod}.
Outputable a =>
GenericUnitInfo srcpkgid a uid modulename mod -> SDoc
hidden_msg (IfaceMessageOpts -> BuildingCabalPackage
ifaceBuildingCabalPackage IfaceMessageOpts
opts)
          where
            hidden_msg :: GenericUnitInfo srcpkgid a uid modulename mod -> SDoc
hidden_msg GenericUnitInfo srcpkgid a uid modulename mod
pkg =
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"You can run" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
              SDoc -> SDoc
quotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
":set -package " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenericUnitInfo srcpkgid a uid modulename mod -> a
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName GenericUnitInfo srcpkgid a uid modulename mod
pkg)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"to expose it." SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
              String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(Note: this unloads all the modules in the current scope.)"