{- | This module exposes variations over the standard GHC's logging functions to work with the 'Doc'
     type from the \"pretty\" package. We would like LiquidHaskell to emit diagnostic messages using the very
     same GHC machinery, so that IDE-like programs (e.g. \"ghcid\", \"ghcide\" etc) would be able to
     correctly show errors and warnings to the users, in ther editors.

     Unfortunately, this is not possible to do out of the box because LiquidHaskell uses the 'Doc' type from
     the \"pretty\" package but GHC uses (for historical reasons) its own version. Due to the fact none of
     the constructors are exported, we simply cannot convert between the two types effortlessly, but we have
     to pay the price of a pretty-printing \"roundtrip\".
-}

module Language.Haskell.Liquid.GHC.Logging
  ( addTcRnUnknownMessage
  , addTcRnUnknownMessages
  , fromPJDoc
  , putWarnMsg
  ) where

import qualified Liquid.GHC.API as GHC
import qualified Text.PrettyPrint.HughesPJ as PJ

-- Unfortunately we need the import below to bring in scope 'PPrint' instances.
import Language.Haskell.Liquid.Types.Errors ()

fromPJDoc :: PJ.Doc -> GHC.SDoc
fromPJDoc :: Doc -> SDoc
fromPJDoc = String -> SDoc
forall doc. IsLine doc => String -> doc
GHC.text (String -> SDoc) -> (Doc -> String) -> Doc -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
PJ.render

-- | Like the original 'putLogMsg', but internally converts the input 'Doc' (from the \"pretty\" library)
-- into GHC's internal 'SDoc'.
putLogMsg :: GHC.Logger
          -> GHC.Severity
          -> GHC.SrcSpan
          -> Maybe GHC.PprStyle
          -> PJ.Doc
          -> IO ()
putLogMsg :: Logger -> Severity -> SrcSpan -> Maybe PprStyle -> Doc -> IO ()
putLogMsg Logger
logger Severity
sev SrcSpan
srcSpan Maybe PprStyle
_mbStyle =
  Logger -> LogAction
GHC.putLogMsg
    Logger
logger
    (Logger -> LogFlags
GHC.logFlags Logger
logger)
    (Severity
-> ResolvedDiagnosticReason -> Maybe DiagnosticCode -> MessageClass
GHC.MCDiagnostic Severity
sev (DiagnosticReason -> ResolvedDiagnosticReason
GHC.ResolvedDiagnosticReason DiagnosticReason
GHC.WarningWithoutFlag) Maybe DiagnosticCode
forall a. Maybe a
Nothing)
    SrcSpan
srcSpan (SDoc -> IO ()) -> (Doc -> SDoc) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
forall doc. IsLine doc => String -> doc
GHC.text (String -> SDoc) -> (Doc -> String) -> Doc -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
PJ.render

putWarnMsg :: GHC.Logger -> GHC.SrcSpan -> PJ.Doc -> IO ()
putWarnMsg :: Logger -> SrcSpan -> Doc -> IO ()
putWarnMsg Logger
logger SrcSpan
srcSpan Doc
doc =
  Logger -> Severity -> SrcSpan -> Maybe PprStyle -> Doc -> IO ()
putLogMsg Logger
logger Severity
GHC.SevWarning SrcSpan
srcSpan (PprStyle -> Maybe PprStyle
forall a. a -> Maybe a
Just PprStyle
GHC.defaultErrStyle) Doc
doc

addTcRnUnknownMessage :: GHC.SrcSpan -> PJ.Doc -> GHC.TcRn ()
addTcRnUnknownMessage :: SrcSpan -> Doc -> TcRn ()
addTcRnUnknownMessage SrcSpan
srcSpan = SrcSpan -> TcRnMessage -> TcRn ()
GHC.addErrAt SrcSpan
srcSpan (TcRnMessage -> TcRn ()) -> (Doc -> TcRnMessage) -> Doc -> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
GHC.mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> (Doc -> DiagnosticMessage) -> Doc -> TcRnMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcHint] -> SDoc -> DiagnosticMessage
GHC.mkPlainError [] (SDoc -> DiagnosticMessage)
-> (Doc -> SDoc) -> Doc -> DiagnosticMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> SDoc
fromPJDoc

addTcRnUnknownMessages :: [(GHC.SrcSpan, PJ.Doc)] -> GHC.TcRn ()
addTcRnUnknownMessages :: [(SrcSpan, Doc)] -> TcRn ()
addTcRnUnknownMessages = [(SrcSpan, TcRnMessage)] -> TcRn ()
GHC.addErrs ([(SrcSpan, TcRnMessage)] -> TcRn ())
-> ([(SrcSpan, Doc)] -> [(SrcSpan, TcRnMessage)])
-> [(SrcSpan, Doc)]
-> TcRn ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SrcSpan, Doc) -> (SrcSpan, TcRnMessage))
-> [(SrcSpan, Doc)] -> [(SrcSpan, TcRnMessage)]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> TcRnMessage) -> (SrcSpan, Doc) -> (SrcSpan, TcRnMessage)
forall a b. (a -> b) -> (SrcSpan, a) -> (SrcSpan, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DiagnosticMessage -> TcRnMessage
forall a.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> TcRnMessage
GHC.mkTcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> (Doc -> DiagnosticMessage) -> Doc -> TcRnMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcHint] -> SDoc -> DiagnosticMessage
GHC.mkPlainError [] (SDoc -> DiagnosticMessage)
-> (Doc -> SDoc) -> Doc -> DiagnosticMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> SDoc
fromPJDoc))