{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,
   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,
   TypeApplications, ScopedTypeVariables, BangPatterns #-}
module GHC.Debugger.Utils
  ( module GHC.Debugger.Utils
  , module GHC.Utils.Outputable
  , module GHC.Utils.Trace
  , showSDoc
  ) where

import Control.Monad
import Control.Applicative
import Control.Exception
import System.IO

import GHC
import GHC.Data.FastString
import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Utils.Outputable hiding (char)
import GHC.Utils.Trace
import qualified Data.Text as T
import qualified Data.Text.IO as T

import Data.Attoparsec.Text

import Colog.Core as Logger
import GHC.Debugger.Interface.Messages

--------------------------------------------------------------------------------
-- * Handle utils
--------------------------------------------------------------------------------

-- | Read output from the given handle and write it to the given
-- log action (forever).
forwardHandleToLogger :: Handle -> LogAction IO T.Text -> IO ()
forwardHandleToLogger :: Handle -> LogAction IO Text -> IO ()
forwardHandleToLogger Handle
read_h LogAction IO Text
logger = do
  IO ()
forall {b}. IO b
forwarding IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` -- handles read EOF
    \(SomeException
_e::SomeException) -> do
      -- Cleanly exit on exception
      -- print _e
      () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    forwarding :: IO b
forwarding = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ do
      -- Mask exceptions to avoid being killed between reading
      -- a line and outputting it.
      IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        out_line <- Handle -> IO Text
T.hGetLine Handle
read_h -- See Note [External interpreter buffering]
        logger <& out_line

--------------------------------------------------------------------------------
-- * GHC Utilities
--------------------------------------------------------------------------------

-- | Convert a GHC's src span into an interface one
--   See Note [Paths should be made absolute at the source]
realSrcSpanToSourceSpan :: AbsFilePath -> RealSrcSpan -> SourceSpan
realSrcSpanToSourceSpan :: AbsFilePath -> RealSrcSpan -> SourceSpan
realSrcSpanToSourceSpan AbsFilePath
prefix RealSrcSpan
ss = SourceSpan
  { file :: AbsFilePath
file = AbsFilePath
prefix AbsFilePath -> FilePath -> AbsFilePath
/> FastString -> FilePath
unpackFS (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
ss)
  , startLine :: Int
startLine = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
ss
  , startCol :: Int
startCol = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
ss
  , endLine :: Int
endLine = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
ss
  , endCol :: Int
endCol = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
ss
  }

-- | Display an Outputable value as a String
display :: (GhcMonad m, Outputable a) => a -> m String
display :: forall (m :: * -> *) a.
(GhcMonad m, Outputable a) =>
a -> m FilePath
display a
x = do
  dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  return $ showSDoc dflags (ppr x)
{-# INLINE display #-}

--------------------------------------------------------------------------------
-- * Parsing
--------------------------------------------------------------------------------

-- | Takes a 'srcLoc' string from 'StackEntry' and returns a 'SourceSpan'.
--
-- === Example strings
--
-- - @hdb/Development/Debug/Adapter/Init.hs:(188,15)-(197,48)@
-- - @hdb/Development/Debug/Adapter/Proxy.hs:93:34-37@
-- See Note [Paths should be made absolute at the source]
srcSpanStringToSourceSpan :: AbsFilePath -> String -> Either String SourceSpan
srcSpanStringToSourceSpan :: AbsFilePath -> FilePath -> Either FilePath SourceSpan
srcSpanStringToSourceSpan AbsFilePath
prefix FilePath
s = Parser SourceSpan -> Text -> Either FilePath SourceSpan
forall a. Parser a -> Text -> Either FilePath a
parseOnly Parser SourceSpan
pSrcSpan (FilePath -> Text
T.pack FilePath
s)
  where
    pSrcSpan :: Parser SourceSpan
pSrcSpan = do
      fp <- (AbsFilePath
prefix AbsFilePath -> FilePath -> AbsFilePath
/>) (FilePath -> AbsFilePath)
-> Parser Text FilePath -> Parser Text AbsFilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text FilePath
pFile Parser Text AbsFilePath
-> Parser Text Char -> Parser Text AbsFilePath
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
':'
      pParenStyle fp <|> pColonStyle fp

    -- file:(l1,c1)-(l2,c2)
    pParenStyle :: AbsFilePath -> Parser SourceSpan
pParenStyle AbsFilePath
fp = do
      (l1, c1) <- (,) (Int -> Int -> (Int, Int))
-> Parser Text Int -> Parser Text (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Text Char
char Char
'(' Parser Text Char -> Parser Text Int -> Parser Text Int
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Int
num Parser Text Int -> Parser Text Char -> Parser Text Int
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
',') Parser Text (Int -> (Int, Int))
-> Parser Text Int -> Parser Text (Int, Int)
forall a b. Parser Text (a -> b) -> Parser Text a -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser Text Int
num Parser Text Int -> Parser Text Char -> Parser Text Int
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
')') Parser Text (Int, Int)
-> Parser Text Char -> Parser Text (Int, Int)
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
'-'
      (l2, c2) <- (,) <$> (char '(' *> num <* char ',') <*> (num <* char ')')
      pure (SourceSpan fp l1 l2 c1 c2)

    -- file:l1:c1-c2
    pColonStyle :: AbsFilePath -> Parser SourceSpan
pColonStyle AbsFilePath
fp = do
      l1 <- Parser Text Int
num Parser Text Int -> Parser Text Char -> Parser Text Int
forall a b. Parser Text a -> Parser Text b -> Parser Text a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Text Char
char Char
':'
      c1 <- num <* char '-'
      c2 <- num
      pure (SourceSpan fp l1 l1 c1 c2)

    pFile :: Parser FilePath
    pFile :: Parser Text FilePath
pFile = Text -> FilePath
T.unpack (Text -> FilePath) -> Parser Text Text -> Parser Text FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':')

    num :: Parser Int
    num :: Parser Text Int
num = Parser Text Int
forall a. Integral a => Parser a
decimal

--------------------------------------------------------------------------------
-- * DebugView utils
--------------------------------------------------------------------------------

showModule :: Module -> String
showModule :: Module -> FilePath
showModule = SDoc -> FilePath
showSDocUnsafe (SDoc -> FilePath) -> (Module -> SDoc) -> Module -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PprStyle -> SDoc -> SDoc
withPprStyle (NamePprCtx -> PprStyle
PprDump NamePprCtx
alwaysQualify) (SDoc -> SDoc) -> (Module -> SDoc) -> Module -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr