{-# LANGUAGE CPP #-}
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

-- | General utility functions, mostly focused around GHC operations.
module Development.IDE.GHC.Util(
    modifyDynFlags,
    evalGhcEnv,
    -- * GHC wrappers
    printRdrName,
    Development.IDE.GHC.Util.printName,
    ParseResult(..), runParser,
    lookupPackageConfig,
    textToStringBuffer,
    bytestringToStringBuffer,
    stringBufferToByteString,
    moduleImportPath,
    cgGutsToCoreModule,
    fingerprintToBS,
    fingerprintFromByteString,
    fingerprintFromStringBuffer,
    fingerprintFromPut,
    -- * General utilities
    readFileUtf8,
    hDuplicateTo',
    setHieDir,
    dontWriteHieFiles,
    disableWarningsAsErrors,
    traceAst,
    printOutputable
    ) where

#if MIN_VERSION_ghc(9,2,0)
import           GHC.Data.FastString
import           GHC.Data.StringBuffer
import           GHC.Driver.Env
import           GHC.Driver.Monad
import           GHC.Driver.Session                hiding (ExposePackage)
import           GHC.Parser.Lexer
import           GHC.Runtime.Context
import           GHC.Types.Name.Occurrence
import           GHC.Types.Name.Reader
import           GHC.Types.SrcLoc
import           GHC.Unit.Module.ModDetails
import           GHC.Unit.Module.ModGuts
import           GHC.Utils.Fingerprint
import           GHC.Utils.Outputable
#else
import           Development.IDE.GHC.Compat.Util
#endif
import           Control.Concurrent
import           Control.Exception                 as E
import           Data.Binary.Put                   (Put, runPut)
import qualified Data.ByteString                   as BS
import           Data.ByteString.Internal          (ByteString (..))
import qualified Data.ByteString.Internal          as BS
import qualified Data.ByteString.Lazy              as LBS
import           Data.Data                         (Data)
import           Data.IORef
import           Data.List.Extra
import           Data.Maybe
import qualified Data.Text                         as T
import qualified Data.Text.Encoding                as T
import qualified Data.Text.Encoding.Error          as T
import           Data.Time.Clock.POSIX             (POSIXTime, getCurrentTime,
                                                    utcTimeToPOSIXSeconds)
import           Data.Typeable
import qualified Data.Unique                       as U
import           Debug.Trace
import           Development.IDE.GHC.Compat        as GHC
import qualified Development.IDE.GHC.Compat.Parser as Compat
import qualified Development.IDE.GHC.Compat.Units  as Compat
import           Development.IDE.GHC.Dump          (showAstDataHtml)
import           Development.IDE.Types.Location
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Foreign.Storable
import           GHC
import           GHC.IO.BufferedIO                 (BufferedIO)
import           GHC.IO.Device                     as IODevice
import           GHC.IO.Encoding
import           GHC.IO.Exception
import           GHC.IO.Handle.Internals
import           GHC.IO.Handle.Types
import           GHC.Stack
import           System.Environment.Blank          (getEnvDefault)
import           System.FilePath
import           System.IO.Unsafe
import           Text.Printf


----------------------------------------------------------------------
-- GHC setup

-- | Used to modify dyn flags in preference to calling 'setSessionDynFlags',
--   since that function also reloads packages (which is very slow).
modifyDynFlags :: GhcMonad m => (DynFlags -> DynFlags) -> m ()
modifyDynFlags :: (DynFlags -> DynFlags) -> m ()
modifyDynFlags DynFlags -> DynFlags
f = do
  DynFlags
newFlags <- DynFlags -> DynFlags
f (DynFlags -> DynFlags) -> m DynFlags -> m DynFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
  -- We do not use setSessionDynFlags here since we handle package
  -- initialization separately.
  (HscEnv -> HscEnv) -> m ()
forall (m :: * -> *). GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ \HscEnv
h ->
    DynFlags -> HscEnv -> HscEnv
hscSetFlags DynFlags
newFlags HscEnv
h { hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
h) {ic_dflags :: DynFlags
ic_dflags = DynFlags
newFlags} }

-- | Given a 'Unit' try and find the associated 'PackageConfig' in the environment.
lookupPackageConfig :: Unit -> HscEnv -> Maybe GHC.UnitInfo
lookupPackageConfig :: Unit -> HscEnv -> Maybe UnitInfo
lookupPackageConfig Unit
unit HscEnv
env =
    Bool -> UnitInfoMap -> () -> Unit -> Maybe UnitInfo
Compat.lookupUnit' Bool
False UnitInfoMap
unitState ()
prClsre Unit
unit
    where
        unitState :: UnitInfoMap
unitState = HscEnv -> UnitInfoMap
Compat.getUnitInfoMap HscEnv
env
        prClsre :: ()
prClsre = HscEnv -> ()
preloadClosureUs HscEnv
env


-- | Convert from the @text@ package to the @GHC@ 'StringBuffer'.
--   Currently implemented somewhat inefficiently (if it ever comes up in a profile).
textToStringBuffer :: T.Text -> StringBuffer
textToStringBuffer :: Text -> StringBuffer
textToStringBuffer = String -> StringBuffer
stringToStringBuffer (String -> StringBuffer)
-> (Text -> String) -> Text -> StringBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

runParser :: DynFlags -> String -> P a -> ParseResult a
runParser :: DynFlags -> String -> P a -> ParseResult a
runParser DynFlags
flags String
str P a
parser = P a -> PState -> ParseResult a
forall a. P a -> PState -> ParseResult a
unP P a
parser PState
parseState
    where
      filename :: String
filename = String
"<interactive>"
      location :: RealSrcLoc
location = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
mkFastString String
filename) Int
1 Int
1
      buffer :: StringBuffer
buffer = String -> StringBuffer
stringToStringBuffer String
str
      parseState :: PState
parseState = DynFlags -> StringBuffer -> RealSrcLoc -> PState
Compat.initParserState (DynFlags -> DynFlags
Compat.initParserOpts DynFlags
flags) StringBuffer
buffer RealSrcLoc
location

stringBufferToByteString :: StringBuffer -> ByteString
stringBufferToByteString :: StringBuffer -> ByteString
stringBufferToByteString StringBuffer{Int
ForeignPtr Word8
buf :: StringBuffer -> ForeignPtr Word8
len :: StringBuffer -> Int
cur :: StringBuffer -> Int
cur :: Int
len :: Int
buf :: ForeignPtr Word8
..} = ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
buf Int
cur Int
len

bytestringToStringBuffer :: ByteString -> StringBuffer
bytestringToStringBuffer :: ByteString -> StringBuffer
bytestringToStringBuffer (PS ForeignPtr Word8
buf Int
cur Int
len) = StringBuffer :: ForeignPtr Word8 -> Int -> Int -> StringBuffer
StringBuffer{Int
ForeignPtr Word8
len :: Int
cur :: Int
buf :: ForeignPtr Word8
buf :: ForeignPtr Word8
len :: Int
cur :: Int
..}

-- | Pretty print a 'RdrName' wrapping operators in parens
printRdrName :: RdrName -> String
printRdrName :: RdrName -> String
printRdrName RdrName
name = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ SDoc -> Text
forall a. Outputable a => a -> Text
printOutputable (SDoc -> Text) -> SDoc -> Text
forall a b. (a -> b) -> a -> b
$ OccName -> SDoc -> SDoc
parenSymOcc OccName
rn (OccName -> SDoc
forall a. Outputable a => a -> SDoc
ppr OccName
rn)
  where
    rn :: OccName
rn = RdrName -> OccName
rdrNameOcc RdrName
name

-- | Pretty print a 'Name' wrapping operators in parens
printName :: Name -> String
printName :: Name -> String
printName = RdrName -> String
printRdrName (RdrName -> String) -> (Name -> RdrName) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> RdrName
nameRdrName

-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
--   pieces, but designed to be more efficient than a standard 'runGhc'.
evalGhcEnv :: HscEnv -> Ghc b -> IO b
evalGhcEnv :: HscEnv -> Ghc b -> IO b
evalGhcEnv HscEnv
env Ghc b
act = (HscEnv, b) -> b
forall a b. (a, b) -> b
snd ((HscEnv, b) -> b) -> IO (HscEnv, b) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Ghc b -> IO (HscEnv, b)
forall a. HscEnv -> Ghc a -> IO (HscEnv, a)
runGhcEnv HscEnv
env Ghc b
act

-- | Run a 'Ghc' monad value using an existing 'HscEnv'. Sets up and tears down all the required
--   pieces, but designed to be more efficient than a standard 'runGhc'.
runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
runGhcEnv :: HscEnv -> Ghc a -> IO (HscEnv, a)
runGhcEnv HscEnv
env Ghc a
act = do
    HscEnv
hsc_env <- HscEnv -> IO HscEnv
initTempFs HscEnv
env
    IORef HscEnv
ref <- HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef HscEnv
hsc_env
    a
res <- Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
unGhc (Ghc a -> Ghc a
forall (m :: * -> *) a. GhcMonad m => m a -> m a
withCleanupSession Ghc a
act) (IORef HscEnv -> Session
Session IORef HscEnv
ref)
    (,a
res) (HscEnv -> (HscEnv, a)) -> IO HscEnv -> IO (HscEnv, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef HscEnv -> IO HscEnv
forall a. IORef a -> IO a
readIORef IORef HscEnv
ref

-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
--   For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
--   @\/usr\/Test@ should be on the include path to find sibling modules.
moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
-- The call to takeDirectory is required since DAML does not require that
-- the file name matches the module name in the last component.
-- Once that has changed we can get rid of this.
moduleImportPath :: NormalizedFilePath -> ModuleName -> Maybe String
moduleImportPath (String -> String
takeDirectory (String -> String)
-> (NormalizedFilePath -> String) -> NormalizedFilePath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> String
fromNormalizedFilePath -> String
pathDir) ModuleName
mn
    -- This happens for single-component modules since takeDirectory "A" == "."
    | String
modDir String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." = String -> Maybe String
forall a. a -> Maybe a
Just String
pathDir
    | Bool
otherwise = String -> String
dropTrailingPathSeparator (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
modDir String
pathDir
  where
    -- A for module A.B
    modDir :: String
modDir =
        String -> String
takeDirectory (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
        NormalizedFilePath -> String
fromNormalizedFilePath (NormalizedFilePath -> String) -> NormalizedFilePath -> String
forall a b. (a -> b) -> a -> b
$ String -> NormalizedFilePath
toNormalizedFilePath' (String -> NormalizedFilePath) -> String -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$
        ModuleName -> String
moduleNameSlashes ModuleName
mn

-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
readFileUtf8 :: FilePath -> IO T.Text
readFileUtf8 :: String -> IO Text
readFileUtf8 String
f = OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
f

-- | Convert from a 'CgGuts' to a 'CoreModule'.
cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
cgGutsToCoreModule :: SafeHaskellMode -> CgGuts -> ModDetails -> CoreModule
cgGutsToCoreModule SafeHaskellMode
safeMode CgGuts
guts ModDetails
modDetails = Module -> TypeEnv -> CoreProgram -> SafeHaskellMode -> CoreModule
CoreModule
    (CgGuts -> Module
cg_module CgGuts
guts)
    (ModDetails -> TypeEnv
md_types ModDetails
modDetails)
    (CgGuts -> CoreProgram
cg_binds CgGuts
guts)
    SafeHaskellMode
safeMode

-- | Convert a 'Fingerprint' to a 'ByteString' by copying the byte across.
--   Will produce an 8 byte unreadable ByteString.
fingerprintToBS :: Fingerprint -> BS.ByteString
fingerprintToBS :: Fingerprint -> ByteString
fingerprintToBS (Fingerprint Word64
a Word64
b) = Int -> (Ptr Word8 -> IO ()) -> ByteString
BS.unsafeCreate Int
8 ((Ptr Word8 -> IO ()) -> ByteString)
-> (Ptr Word8 -> IO ()) -> ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
    Ptr Word64
ptr <- Ptr Word64 -> IO (Ptr Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ptr Word64 -> IO (Ptr Word64)) -> Ptr Word64 -> IO (Ptr Word64)
forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr
    Ptr Word64 -> Int -> Word64 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word64
ptr Int
0 Word64
a
    Ptr Word64 -> Int -> Word64 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word64
ptr Int
1 Word64
b

-- | Take the 'Fingerprint' of a 'StringBuffer'.
fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
fingerprintFromStringBuffer :: StringBuffer -> IO Fingerprint
fingerprintFromStringBuffer (StringBuffer ForeignPtr Word8
buf Int
len Int
cur) =
    ForeignPtr Word8 -> (Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
buf ((Ptr Word8 -> IO Fingerprint) -> IO Fingerprint)
-> (Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> Ptr Word8 -> Int -> IO Fingerprint
fingerprintData (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
cur) Int
len

fingerprintFromByteString :: ByteString -> IO Fingerprint
fingerprintFromByteString :: ByteString -> IO Fingerprint
fingerprintFromByteString ByteString
bs = do
    let (ForeignPtr Word8
fptr, Int
offset, Int
len) = ByteString -> (ForeignPtr Word8, Int, Int)
BS.toForeignPtr ByteString
bs
    ForeignPtr Word8 -> (Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO Fingerprint) -> IO Fingerprint)
-> (Ptr Word8 -> IO Fingerprint) -> IO Fingerprint
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr ->
        Ptr Word8 -> Int -> IO Fingerprint
fingerprintData (Ptr Word8
ptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offset) Int
len

fingerprintFromPut :: Put -> IO Fingerprint
fingerprintFromPut :: Put -> IO Fingerprint
fingerprintFromPut = ByteString -> IO Fingerprint
fingerprintFromByteString (ByteString -> IO Fingerprint)
-> (Put -> ByteString) -> Put -> IO Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut

-- | A slightly modified version of 'hDuplicateTo' from GHC.
--   Importantly, it avoids the bug listed in https://gitlab.haskell.org/ghc/ghc/merge_requests/2318.
hDuplicateTo' :: Handle -> Handle -> IO ()
hDuplicateTo' :: Handle -> Handle -> IO ()
hDuplicateTo' h1 :: Handle
h1@(FileHandle String
path MVar Handle__
m1) h2 :: Handle
h2@(FileHandle String
_ MVar Handle__
m2)  = do
 String
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO ()
withHandle__' String
"hDuplicateTo" Handle
h2 MVar Handle__
m2 ((Handle__ -> IO Handle__) -> IO ())
-> (Handle__ -> IO Handle__) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle__
h2_ -> do
   -- The implementation in base has this call to hClose_help.
   -- _ <- hClose_help h2_
   -- hClose_help does two things:
   -- 1. It flushes the buffer, we replicate this here
   ()
_ <- Handle__ -> IO ()
flushWriteBuffer Handle__
h2_ IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(IOException
_ :: IOException) -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
   -- 2. It closes the handle. This is redundant since dup2 takes care of that
   -- but even worse it is actively harmful! Once the handle has been closed
   -- another thread is free to reallocate it. This leads to dup2 failing with EBUSY
   -- if it happens just in the right moment.
   String
-> Handle
-> MVar Handle__
-> (Handle__ -> IO Handle__)
-> IO Handle__
forall a.
String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' String
"hDuplicateTo" Handle
h1 MVar Handle__
m1 ((Handle__ -> IO Handle__) -> IO Handle__)
-> (Handle__ -> IO Handle__) -> IO Handle__
forall a b. (a -> b) -> a -> b
$ \Handle__
h1_ -> do
     String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo String
path Handle
h1 Maybe (MVar Handle__)
forall a. Maybe a
Nothing Handle__
h2_ Handle__
h1_ (HandleFinalizer -> Maybe HandleFinalizer
forall a. a -> Maybe a
Just HandleFinalizer
handleFinalizer)
hDuplicateTo' h1 :: Handle
h1@(DuplexHandle String
path MVar Handle__
r1 MVar Handle__
w1) h2 :: Handle
h2@(DuplexHandle String
_ MVar Handle__
r2 MVar Handle__
w2)  = do
 String
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO ()
withHandle__' String
"hDuplicateTo" Handle
h2 MVar Handle__
w2  ((Handle__ -> IO Handle__) -> IO ())
-> (Handle__ -> IO Handle__) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle__
w2_ -> do
   (Handle__, Maybe SomeException)
_ <- Handle__ -> IO (Handle__, Maybe SomeException)
hClose_help Handle__
w2_
   String
-> Handle
-> MVar Handle__
-> (Handle__ -> IO Handle__)
-> IO Handle__
forall a.
String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' String
"hDuplicateTo" Handle
h1 MVar Handle__
w1 ((Handle__ -> IO Handle__) -> IO Handle__)
-> (Handle__ -> IO Handle__) -> IO Handle__
forall a b. (a -> b) -> a -> b
$ \Handle__
w1_ -> do
     String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo String
path Handle
h1 Maybe (MVar Handle__)
forall a. Maybe a
Nothing Handle__
w2_ Handle__
w1_ (HandleFinalizer -> Maybe HandleFinalizer
forall a. a -> Maybe a
Just HandleFinalizer
handleFinalizer)
 String
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO ()
withHandle__' String
"hDuplicateTo" Handle
h2 MVar Handle__
r2  ((Handle__ -> IO Handle__) -> IO ())
-> (Handle__ -> IO Handle__) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle__
r2_ -> do
   (Handle__, Maybe SomeException)
_ <- Handle__ -> IO (Handle__, Maybe SomeException)
hClose_help Handle__
r2_
   String
-> Handle
-> MVar Handle__
-> (Handle__ -> IO Handle__)
-> IO Handle__
forall a.
String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' String
"hDuplicateTo" Handle
h1 MVar Handle__
r1 ((Handle__ -> IO Handle__) -> IO Handle__)
-> (Handle__ -> IO Handle__) -> IO Handle__
forall a b. (a -> b) -> a -> b
$ \Handle__
r1_ -> do
     String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo String
path Handle
h1 (MVar Handle__ -> Maybe (MVar Handle__)
forall a. a -> Maybe a
Just MVar Handle__
w1) Handle__
r2_ Handle__
r1_ Maybe HandleFinalizer
forall a. Maybe a
Nothing
hDuplicateTo' Handle
h1 Handle
_ =
  Handle -> IO ()
forall a. Handle -> IO a
ioe_dupHandlesNotCompatible Handle
h1

-- | This is copied unmodified from GHC since it is not exposed.
dupHandleTo :: FilePath
            -> Handle
            -> Maybe (MVar Handle__)
            -> Handle__
            -> Handle__
            -> Maybe HandleFinalizer
            -> IO Handle__
dupHandleTo :: String
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo String
filepath Handle
h Maybe (MVar Handle__)
other_side
            _hto_ :: Handle__
_hto_@Handle__{haDevice :: ()
haDevice=dev
devTo}
            h_ :: Handle__
h_@Handle__{haDevice :: ()
haDevice=dev
dev} Maybe HandleFinalizer
mb_finalizer = do
  Handle__ -> IO ()
flushBuffer Handle__
h_
  case dev -> Maybe dev
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast dev
devTo of
    Maybe dev
Nothing   -> Handle -> IO Handle__
forall a. Handle -> IO a
ioe_dupHandlesNotCompatible Handle
h
    Just dev
dev' -> do
      dev
_ <- dev -> dev -> IO dev
forall a. IODevice a => a -> a -> IO a
IODevice.dup2 dev
dev dev
dev'
      FileHandle String
_ MVar Handle__
m <- dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
forall dev.
(IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandle_ dev
dev' String
filepath Maybe (MVar Handle__)
other_side Handle__
h_ Maybe HandleFinalizer
mb_finalizer
      MVar Handle__ -> IO Handle__
forall a. MVar a -> IO a
takeMVar MVar Handle__
m

-- | This is copied unmodified from GHC since it is not exposed.
-- Note the beautiful inline comment!
#if MIN_VERSION_ghc(9,0,0)
dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
#else
dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
#endif
           -> FilePath
           -> Maybe (MVar Handle__)
           -> Handle__
           -> Maybe HandleFinalizer
           -> IO Handle
dupHandle_ :: dev
-> String
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandle_ dev
new_dev String
filepath Maybe (MVar Handle__)
other_side Handle__{dev
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
Maybe TextEncoding
Maybe (MVar Handle__)
HandleType
BufferMode
Newline
IORef (dec_state, Buffer Word8)
IORef (BufferList CharBufElem)
IORef (Buffer CharBufElem)
IORef (Buffer Word8)
haType :: Handle__ -> HandleType
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haBufferMode :: Handle__ -> BufferMode
haLastDecode :: ()
haCharBuffer :: Handle__ -> IORef (Buffer CharBufElem)
haBuffers :: Handle__ -> IORef (BufferList CharBufElem)
haEncoder :: ()
haDecoder :: ()
haCodec :: Handle__ -> Maybe TextEncoding
haInputNL :: Handle__ -> Newline
haOutputNL :: Handle__ -> Newline
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
haOtherSide :: Maybe (MVar Handle__)
haOutputNL :: Newline
haInputNL :: Newline
haCodec :: Maybe TextEncoding
haDecoder :: Maybe (TextDecoder dec_state)
haEncoder :: Maybe (TextEncoder enc_state)
haBuffers :: IORef (BufferList CharBufElem)
haCharBuffer :: IORef (Buffer CharBufElem)
haLastDecode :: IORef (dec_state, Buffer Word8)
haBufferMode :: BufferMode
haByteBuffer :: IORef (Buffer Word8)
haType :: HandleType
haDevice :: dev
haDevice :: ()
..} Maybe HandleFinalizer
mb_finalizer = do
   -- XXX wrong!
  Maybe TextEncoding
mb_codec <- if Maybe (TextEncoder enc_state) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TextEncoder enc_state)
haEncoder then (TextEncoding -> Maybe TextEncoding)
-> IO TextEncoding -> IO (Maybe TextEncoding)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> Maybe TextEncoding
forall a. a -> Maybe a
Just IO TextEncoding
getLocaleEncoding else Maybe TextEncoding -> IO (Maybe TextEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TextEncoding
forall a. Maybe a
Nothing
  dev
-> String
-> HandleType
-> Bool
-> Maybe TextEncoding
-> NewlineMode
-> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
forall dev.
(IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> String
-> HandleType
-> Bool
-> Maybe TextEncoding
-> NewlineMode
-> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
mkHandle dev
new_dev String
filepath HandleType
haType Bool
True{-buffered-} Maybe TextEncoding
mb_codec
      NewlineMode :: Newline -> Newline -> NewlineMode
NewlineMode { inputNL :: Newline
inputNL = Newline
haInputNL, outputNL :: Newline
outputNL = Newline
haOutputNL }
      Maybe HandleFinalizer
mb_finalizer Maybe (MVar Handle__)
other_side

-- | This is copied unmodified from GHC since it is not exposed.
ioe_dupHandlesNotCompatible :: Handle -> IO a
ioe_dupHandlesNotCompatible :: Handle -> IO a
ioe_dupHandlesNotCompatible Handle
h =
   IOException -> IO a
forall a. IOException -> IO a
ioException (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h) IOErrorType
IllegalOperation String
"hDuplicateTo"
                String
"handles are incompatible" Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)

--------------------------------------------------------------------------------
-- Tracing exactprint terms

{-# NOINLINE timestamp #-}
timestamp :: POSIXTime
timestamp :: POSIXTime
timestamp = UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> POSIXTime) -> UTCTime -> POSIXTime
forall a b. (a -> b) -> a -> b
$ IO UTCTime -> UTCTime
forall a. IO a -> a
unsafePerformIO IO UTCTime
getCurrentTime

debugAST :: Bool
debugAST :: Bool
debugAST = IO String -> String
forall a. IO a -> a
unsafePerformIO (String -> String -> IO String
getEnvDefault String
"GHCIDE_DEBUG_AST" String
"0") String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"1"

-- | Prints an 'Outputable' value to stderr and to an HTML file for further inspection
traceAst :: (Data a, ExactPrint a, Outputable a, HasCallStack) => String -> a -> a
traceAst :: String -> a -> a
traceAst String
lbl a
x
  | Bool
debugAST = String -> a -> a
forall a. String -> a -> a
trace String
doTrace a
x
  | Bool
otherwise = a
x
  where
#if MIN_VERSION_ghc(9,2,0)
    renderDump = renderWithContext defaultSDocContext{sdocStyle = defaultDumpStyle, sdocPprDebug = True}
#else
    renderDump :: SDoc -> String
renderDump = SDoc -> String
showSDocUnsafe (SDoc -> String) -> (SDoc -> SDoc) -> SDoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr
#endif
    htmlDump :: SDoc
htmlDump = a -> SDoc
forall a. (Data a, Outputable a) => a -> SDoc
showAstDataHtml a
x
    doTrace :: String
doTrace = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
        Unique
u <- IO Unique
U.newUnique
        let htmlDumpFileName :: String
htmlDumpFileName = String -> String -> String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"/tmp/hls/%s-%s-%d.html" (POSIXTime -> String
forall a. Show a => a -> String
show POSIXTime
timestamp) String
lbl (Unique -> Int
U.hashUnique Unique
u)
        String -> String -> IO ()
writeFile String
htmlDumpFileName (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ SDoc -> String
renderDump SDoc
htmlDump
        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
            [CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
#if MIN_VERSION_ghc(9,2,0)
            , exactPrint x
#endif
            , String
"file://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
htmlDumpFileName]

-- Should in `Development.IDE.GHC.Orphans`,
-- leave it here to prevent cyclic module dependency
#if !MIN_VERSION_ghc(8,10,0)
instance Outputable SDoc where
  ppr = id
#endif

-- | Print a GHC value in `defaultUserStyle` without unique symbols.
--
-- This is the most common print utility, will print with a user-friendly style like: `a_a4ME` as `a`.
--
-- It internal using `showSDocUnsafe` with `unsafeGlobalDynFlags`.
printOutputable :: Outputable a => a -> T.Text
printOutputable :: a -> Text
printOutputable = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Outputable a => a -> String
printWithoutUniques
{-# INLINE printOutputable #-}