{-# 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,
    printOutputable,
    getExtensions
    ) where

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.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.Typeable
import           Development.IDE.GHC.Compat        as GHC hiding (unitState)
import qualified Development.IDE.GHC.Compat.Parser as Compat
import qualified Development.IDE.GHC.Compat.Units  as Compat
import           Development.IDE.Types.Location
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Foreign.Storable
import           GHC                               hiding (ParsedModule (..),
                                                    parser)
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           Ide.PluginUtils                   (unescape)
import           System.FilePath

import           GHC.Data.EnumSet
import           GHC.Data.FastString
import           GHC.Data.StringBuffer
import           GHC.Utils.Fingerprint
----------------------------------------------------------------------
-- 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 :: forall (m :: * -> *). GhcMonad m => (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 = (hsc_IC h) {ic_dflags = 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 -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
Compat.lookupUnit' Bool
False UnitInfoMap
unitState PreloadUnitClosure
prClsre Unit
unit
    where
        unitState :: UnitInfoMap
unitState = HscEnv -> UnitInfoMap
Compat.getUnitInfoMap HscEnv
env
        prClsre :: PreloadUnitClosure
prClsre = HscEnv -> PreloadUnitClosure
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 = FilePath -> StringBuffer
stringToStringBuffer (FilePath -> StringBuffer)
-> (Text -> FilePath) -> Text -> StringBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack

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

stringBufferToByteString :: StringBuffer -> ByteString
stringBufferToByteString :: StringBuffer -> ByteString
stringBufferToByteString StringBuffer{Int
ForeignPtr Word8
buf :: ForeignPtr Word8
len :: Int
cur :: Int
buf :: StringBuffer -> ForeignPtr Word8
len :: StringBuffer -> Int
cur :: StringBuffer -> Int
..} = 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{Int
ForeignPtr Word8
buf :: ForeignPtr Word8
len :: Int
cur :: Int
buf :: ForeignPtr Word8
cur :: Int
len :: Int
..}

-- | Pretty print a 'RdrName' wrapping operators in parens
printRdrName :: RdrName -> String
printRdrName :: RdrName -> FilePath
printRdrName RdrName
name = Text -> FilePath
T.unpack (Text -> FilePath) -> Text -> FilePath
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 -> FilePath
printName = RdrName -> FilePath
printRdrName (RdrName -> FilePath) -> (Name -> RdrName) -> Name -> FilePath
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 :: forall b. 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 :: forall a. 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 FilePath
moduleImportPath (FilePath -> FilePath
takeDirectory (FilePath -> FilePath)
-> (NormalizedFilePath -> FilePath)
-> NormalizedFilePath
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NormalizedFilePath -> FilePath
fromNormalizedFilePath -> FilePath
pathDir) ModuleName
mn
    -- This happens for single-component modules since takeDirectory "A" == "."
    | FilePath
modDir FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
pathDir
    | Bool
otherwise = FilePath -> FilePath
dropTrailingPathSeparator (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix FilePath
modDir FilePath
pathDir
  where
    -- A for module A.B
    modDir :: FilePath
modDir =
        FilePath -> FilePath
takeDirectory (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
        NormalizedFilePath -> FilePath
fromNormalizedFilePath (NormalizedFilePath -> FilePath) -> NormalizedFilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> NormalizedFilePath
toNormalizedFilePath' (FilePath -> NormalizedFilePath) -> FilePath -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$
        ModuleName -> FilePath
moduleNameSlashes ModuleName
mn

-- | Read a UTF8 file, with lenient decoding, so it will never raise a decoding error.
readFileUtf8 :: FilePath -> IO T.Text
readFileUtf8 :: FilePath -> IO Text
readFileUtf8 FilePath
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
<$> FilePath -> IO ByteString
BS.readFile FilePath
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
    let ptr' :: Ptr b
ptr' = Ptr Word8 -> Ptr b
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
forall {b}. Ptr b
ptr' Int
0 Word64
a
    Ptr Word64 -> Int -> Word64 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word64
forall {b}. Ptr b
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 FilePath
path MVar Handle__
m1) h2 :: Handle
h2@(FileHandle FilePath
_ MVar Handle__
m2)  = do
 FilePath
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO ()
withHandle__' FilePath
"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 a. a -> IO a
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.
   FilePath
-> Handle
-> MVar Handle__
-> (Handle__ -> IO Handle__)
-> IO Handle__
forall a.
FilePath -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' FilePath
"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
     FilePath
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo FilePath
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 FilePath
path MVar Handle__
r1 MVar Handle__
w1) h2 :: Handle
h2@(DuplexHandle FilePath
_ MVar Handle__
r2 MVar Handle__
w2)  = do
 FilePath
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO ()
withHandle__' FilePath
"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_
   FilePath
-> Handle
-> MVar Handle__
-> (Handle__ -> IO Handle__)
-> IO Handle__
forall a.
FilePath -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' FilePath
"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
     FilePath
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo FilePath
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)
 FilePath
-> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO ()
withHandle__' FilePath
"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_
   FilePath
-> Handle
-> MVar Handle__
-> (Handle__ -> IO Handle__)
-> IO Handle__
forall a.
FilePath -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' FilePath
"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
     FilePath
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo FilePath
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 :: FilePath
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle__
dupHandleTo FilePath
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 FilePath
_ MVar Handle__
m <- dev
-> FilePath
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
forall dev.
(RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> FilePath
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandle_ dev
dev' FilePath
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!
dupHandle_ :: (RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) => dev
           -> FilePath
           -> Maybe (MVar Handle__)
           -> Handle__
           -> Maybe HandleFinalizer
           -> IO Handle
dupHandle_ :: forall dev.
(RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> FilePath
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandle_ dev
new_dev FilePath
filepath Maybe (MVar Handle__)
other_side Handle__{dev
Maybe (MVar Handle__)
Maybe TextEncoding
Maybe (TextEncoder enc_state)
Maybe (TextDecoder dec_state)
IORef (dec_state, Buffer Word8)
IORef (Buffer Char)
IORef (Buffer Word8)
IORef (BufferList Char)
Newline
BufferMode
HandleType
haDevice :: ()
haDevice :: dev
haType :: HandleType
haByteBuffer :: IORef (Buffer Word8)
haBufferMode :: BufferMode
haLastDecode :: IORef (dec_state, Buffer Word8)
haCharBuffer :: IORef (Buffer Char)
haBuffers :: IORef (BufferList Char)
haEncoder :: Maybe (TextEncoder enc_state)
haDecoder :: Maybe (TextDecoder dec_state)
haCodec :: Maybe TextEncoding
haInputNL :: Newline
haOutputNL :: Newline
haOtherSide :: Maybe (MVar Handle__)
haType :: Handle__ -> HandleType
haByteBuffer :: Handle__ -> IORef (Buffer Word8)
haBufferMode :: Handle__ -> BufferMode
haLastDecode :: ()
haCharBuffer :: Handle__ -> IORef (Buffer Char)
haBuffers :: Handle__ -> IORef (BufferList Char)
haEncoder :: ()
haDecoder :: ()
haCodec :: Handle__ -> Maybe TextEncoding
haInputNL :: Handle__ -> Newline
haOutputNL :: Handle__ -> Newline
haOtherSide :: Handle__ -> Maybe (MVar Handle__)
..} 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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe TextEncoding
forall a. Maybe a
Nothing
  dev
-> FilePath
-> HandleType
-> Bool
-> Maybe TextEncoding
-> NewlineMode
-> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
forall dev.
(RawIO dev, IODevice dev, BufferedIO dev, Typeable dev) =>
dev
-> FilePath
-> HandleType
-> Bool
-> Maybe TextEncoding
-> NewlineMode
-> Maybe HandleFinalizer
-> Maybe (MVar Handle__)
-> IO Handle
mkHandle dev
new_dev FilePath
filepath HandleType
haType Bool
True{-buffered-} Maybe TextEncoding
mb_codec
      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 :: forall a. Handle -> IO a
ioe_dupHandlesNotCompatible Handle
h =
   IOException -> IO a
forall a. IOException -> IO a
ioException (Maybe Handle
-> IOErrorType
-> FilePath
-> FilePath
-> Maybe CInt
-> Maybe FilePath
-> IOException
IOError (Handle -> Maybe Handle
forall a. a -> Maybe a
Just Handle
h) IOErrorType
IllegalOperation FilePath
"hDuplicateTo"
                FilePath
"handles are incompatible" Maybe CInt
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing)

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

-- | Print a GHC value in `defaultUserStyle` without unique symbols.
-- It uses `showSDocUnsafe` with `unsafeGlobalDynFlags` internally.
--
-- This is the most common print utility.
-- It will do something additionally compared to what the 'Outputable' instance does.
--
--   1. print with a user-friendly style: `a_a4ME` as `a`.
--   2. unescape escape sequences of printable unicode characters within a pair of double quotes
printOutputable :: Outputable a => a -> T.Text
printOutputable :: forall a. Outputable a => a -> Text
printOutputable =
    -- IfaceTyLit from GHC.Iface.Type implements Outputable with 'show'.
    -- Showing a String escapes non-ascii printable characters. We unescape it here.
    -- More discussion at https://github.com/haskell/haskell-language-server/issues/3115.
    Text -> Text
unescape (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Outputable a => a -> FilePath
printWithoutUniques
{-# INLINE printOutputable #-}

getExtensions :: ParsedModule -> [Extension]
getExtensions :: ParsedModule -> [Extension]
getExtensions = EnumSet Extension -> [Extension]
forall a. Enum a => EnumSet a -> [a]
toList (EnumSet Extension -> [Extension])
-> (ParsedModule -> EnumSet Extension)
-> ParsedModule
-> [Extension]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> EnumSet Extension
extensionFlags (DynFlags -> EnumSet Extension)
-> (ParsedModule -> DynFlags) -> ParsedModule -> EnumSet Extension
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> DynFlags
ms_hspp_opts (ModSummary -> DynFlags)
-> (ParsedModule -> ModSummary) -> ParsedModule -> DynFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary