{-# LANGUAGE LambdaCase #-}

module MonadicBang.Error where

import Prelude hiding ((<>))

import Control.Effect.Writer

import GHC
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
customError :: Error -> PsError
customError = DiagnosticMessage -> PsError
forall a. (Diagnostic a, Typeable a) => a -> PsError
PsUnknownMessage (DiagnosticMessage -> PsError)
-> (Error -> DiagnosticMessage) -> Error -> PsError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \cases
  Error
ErrBangOutsideOfDo -> DiagnosticMessage
    { diagMessage :: DecoratedSDoc
diagMessage = [SDoc] -> DecoratedSDoc
mkDecorated [String -> SDoc
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
text String
"The variable " SDoc -> SDoc -> SDoc
<> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name SDoc -> SDoc -> SDoc
<> String -> SDoc
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
text String
"Maybe you meant to open a new 'do'-block after " SDoc -> SDoc -> SDoc
<> OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
name SDoc -> SDoc -> SDoc
<> String -> SDoc
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
$ SrcSpan
-> PrintUnqualified -> PsError -> Severity -> MsgEnvelope PsError
forall e.
SrcSpan -> PrintUnqualified -> e -> Severity -> MsgEnvelope e
MsgEnvelope SrcSpan
srcSpan PrintUnqualified
neverQualify PsError
err Severity
SevError