{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE CPP #-}

module MonadicBang.Internal.Error where

import Prelude hiding ((<>))

import Control.Effect.Writer

import GHC
#if MIN_VERSION_ghc(9,8,0)
import GHC.Utils.Error
#endif
import GHC.Types.Error
import GHC.Types.Name.Occurrence
import GHC.Parser.Errors.Types
import GHC.Utils.Outputable

data Error = ErrOutOfScopeVariable OccName
           | ErrBangOutsideOfDo

type PsErrors = Writer (Messages PsError)

customError :: Error -> PsError
#if MIN_VERSION_ghc(9,8,0)
customError = PsUnknownMessage . mkUnknownDiagnostic . \cases
#elif MIN_VERSION_ghc(9,6,0)
customError :: Error -> PsError
customError = UnknownDiagnostic -> PsError
PsUnknownMessage (UnknownDiagnostic -> PsError)
-> (Error -> UnknownDiagnostic) -> Error -> PsError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticMessage -> UnknownDiagnostic
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic)
-> (Error -> DiagnosticMessage) -> Error -> UnknownDiagnostic
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \cases
#else
customError = PsUnknownMessage . \cases
#endif
  Error
ErrBangOutsideOfDo -> DiagnosticMessage
    { diagMessage :: DecoratedSDoc
diagMessage = [SDoc] -> DecoratedSDoc
mkDecorated [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Monadic ! outside of a 'do'-block is not allowed"]
    , diagReason :: DiagnosticReason
diagReason = DiagnosticReason
ErrorWithoutFlag
    , diagHints :: [GhcHint]
diagHints = [GhcHint
SuggestMissingDo]
    }
  (ErrOutOfScopeVariable OccName
name) -> DiagnosticMessage
    { diagMessage :: DecoratedSDoc
diagMessage = [SDoc] -> DecoratedSDoc
mkDecorated [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"The variable " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
quotes (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" cannot be used inside of ! here, since its desugaring would escape its scope"]
    , diagReason :: DiagnosticReason
diagReason = DiagnosticReason
ErrorWithoutFlag
    , diagHints :: [GhcHint]
diagHints = [SDoc -> GhcHint
forall a. (Outputable a, Typeable a) => a -> GhcHint
UnknownHint (SDoc -> GhcHint) -> SDoc -> GhcHint
forall a b. (a -> b) -> a -> b
$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Maybe you meant to open a new 'do'-block after " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" has been bound?"]
    }

tellPsError :: Has PsErrors sig m => PsError -> SrcSpan -> m ()
tellPsError :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has PsErrors sig m =>
PsError -> SrcSpan -> m ()
tellPsError PsError
err SrcSpan
srcSpan = Messages PsError -> m ()
forall w (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Writer w) sig m =>
w -> m ()
tell (Messages PsError -> m ())
-> (MsgEnvelope PsError -> Messages PsError)
-> MsgEnvelope PsError
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MsgEnvelope PsError -> Messages PsError
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope PsError -> m ()) -> MsgEnvelope PsError -> m ()
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_ghc(9,8,0)
  mkErrorMsgEnvelope srcSpan neverQualify err
#else
  SrcSpan -> NamePprCtx -> PsError -> Severity -> MsgEnvelope PsError
forall e. SrcSpan -> NamePprCtx -> e -> Severity -> MsgEnvelope e
MsgEnvelope SrcSpan
srcSpan NamePprCtx
neverQualify PsError
err Severity
SevError
#endif