    {-# 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.)"