{- | 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 (
    fromPJDoc
  , putLogMsg
  , putWarnMsg
  , putErrMsg
  , putErrMsg'
  , mkLongErrAt
  ) where

import Data.Maybe

import qualified TcRnMonad as GHC

import qualified Language.Haskell.Liquid.GHC.API as GHC
import qualified Text.PrettyPrint.HughesPJ as PJ
import qualified Outputable as O

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

fromPJDoc :: PJ.Doc -> O.SDoc
fromPJDoc :: Doc -> SDoc
fromPJDoc = String -> SDoc
O.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.DynFlags
          -> GHC.WarnReason
          -> GHC.Severity
          -> GHC.SrcSpan
          -> Maybe O.PprStyle
          -> PJ.Doc
          -> IO ()
putLogMsg :: DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> Maybe PprStyle
-> Doc
-> IO ()
putLogMsg DynFlags
dynFlags WarnReason
reason Severity
sev SrcSpan
srcSpan Maybe PprStyle
mbStyle =
  DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
GHC.putLogMsg DynFlags
dynFlags WarnReason
reason Severity
sev SrcSpan
srcSpan PprStyle
style' (SDoc -> IO ()) -> (Doc -> SDoc) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SDoc
O.text (String -> SDoc) -> (Doc -> String) -> Doc -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
PJ.render
  where
    style' :: O.PprStyle
    style' :: PprStyle
style' = PprStyle -> Maybe PprStyle -> PprStyle
forall a. a -> Maybe a -> a
fromMaybe (DynFlags -> PprStyle
O.defaultErrStyle DynFlags
dynFlags) Maybe PprStyle
mbStyle

putWarnMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()
putWarnMsg :: DynFlags -> SrcSpan -> Doc -> IO ()
putWarnMsg DynFlags
dynFlags SrcSpan
srcSpan Doc
doc =
  DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> Maybe PprStyle
-> Doc
-> IO ()
putLogMsg DynFlags
dynFlags WarnReason
GHC.NoReason Severity
GHC.SevWarning SrcSpan
srcSpan (PprStyle -> Maybe PprStyle
forall a. a -> Maybe a
Just (PprStyle -> Maybe PprStyle) -> PprStyle -> Maybe PprStyle
forall a b. (a -> b) -> a -> b
$ DynFlags -> PprStyle
O.defaultErrStyle DynFlags
dynFlags) Doc
doc

putErrMsg :: GHC.DynFlags -> GHC.SrcSpan -> PJ.Doc -> IO ()
putErrMsg :: DynFlags -> SrcSpan -> Doc -> IO ()
putErrMsg DynFlags
dynFlags SrcSpan
srcSpan Doc
doc = DynFlags
-> WarnReason
-> Severity
-> SrcSpan
-> Maybe PprStyle
-> Doc
-> IO ()
putLogMsg DynFlags
dynFlags WarnReason
GHC.NoReason Severity
GHC.SevError SrcSpan
srcSpan Maybe PprStyle
forall a. Maybe a
Nothing Doc
doc

-- | Like 'putErrMsg', but it uses GHC's internal 'Doc'. This can be very convenient when logging things
-- which comes directly from GHC rather than LiquidHaskell.
putErrMsg' :: GHC.DynFlags -> GHC.SrcSpan -> O.SDoc -> IO ()
putErrMsg' :: DynFlags -> SrcSpan -> SDoc -> IO ()
putErrMsg' DynFlags
dynFlags SrcSpan
srcSpan =
  DynFlags
-> WarnReason -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
GHC.putLogMsg DynFlags
dynFlags WarnReason
GHC.NoReason Severity
GHC.SevError SrcSpan
srcSpan (DynFlags -> PprStyle
O.defaultErrStyle DynFlags
dynFlags)

-- | Like GHC's 'mkLongErrAt', but it builds the final 'ErrMsg' out of two \"HughesPJ\"'s 'Doc's.
mkLongErrAt :: GHC.SrcSpan -> PJ.Doc -> PJ.Doc -> GHC.TcRn GHC.ErrMsg
mkLongErrAt :: SrcSpan -> Doc -> Doc -> TcRn ErrMsg
mkLongErrAt SrcSpan
srcSpan Doc
msg Doc
extra = SrcSpan -> SDoc -> SDoc -> TcRn ErrMsg
GHC.mkLongErrAt SrcSpan
srcSpan (Doc -> SDoc
fromPJDoc Doc
msg) (Doc -> SDoc
fromPJDoc Doc
extra)