{-# 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
    prettyPrint,
    unsafePrintSDoc,
    printRdrName,
    printName,
    ParseResult(..), runParser,
    lookupPackageConfig,
    textToStringBuffer,
    bytestringToStringBuffer,
    stringBufferToByteString,
    moduleImportPath,
    cgGutsToCoreModule,
    fingerprintToBS,
    fingerprintFromByteString,
    fingerprintFromStringBuffer,
    fingerprintFromPut,
    -- * General utilities
    readFileUtf8,
    hDuplicateTo',
    setHieDir,
    dontWriteHieFiles,
    disableWarningsAsErrors,
    ) where

import           Control.Concurrent
import           Control.Exception
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
import           Development.IDE.Types.Location
import           FastString                     (mkFastString)
import           FileCleanup
import           Fingerprint
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Foreign.Storable
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           GhcMonad
import           HscTypes                       (CgGuts, HscEnv (hsc_dflags),
                                                 ModDetails, cg_binds,
                                                 cg_module, hsc_IC, ic_dflags,
                                                 md_types)
import           Lexer
import           Module                         (moduleNameSlashes)
import           OccName                        (parenSymOcc)
import           Outputable                     (Depth (..), Outputable, SDoc,
                                                 mkUserStyle, neverQualify, ppr,
                                                 renderWithStyle,
                                                 showSDocUnsafe)
import           PackageConfig                  (PackageConfig)
import           Packages                       (getPackageConfigMap,
                                                 lookupPackage')
import           RdrName                        (nameRdrName, rdrNameOcc)
import           SrcLoc                         (mkRealSrcLoc)
import           StringBuffer
import           System.FilePath


----------------------------------------------------------------------
-- 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 ->
    HscEnv
h { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
newFlags, hsc_IC :: InteractiveContext
hsc_IC = (HscEnv -> InteractiveContext
hsc_IC HscEnv
h) {ic_dflags :: DynFlags
ic_dflags = DynFlags
newFlags} }

-- | Given a 'UnitId' try and find the associated 'PackageConfig' in the environment.
lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
lookupPackageConfig :: UnitId -> HscEnv -> Maybe PackageConfig
lookupPackageConfig UnitId
unitId HscEnv
env =
    Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' Bool
False PackageConfigMap
pkgConfigMap UnitId
unitId
    where
        pkgConfigMap :: PackageConfigMap
pkgConfigMap =
            -- For some weird reason, the GHC API does not provide a way to get the PackageConfigMap
            -- from PackageState so we have to wrap it in DynFlags first.
            DynFlags -> PackageConfigMap
getPackageConfigMap (DynFlags -> PackageConfigMap) -> DynFlags -> PackageConfigMap
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags 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
mkPState 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 GHC value using 'unsafeGlobalDynFlags '.
prettyPrint :: Outputable a => a -> String
prettyPrint :: a -> String
prettyPrint = SDoc -> String
unsafePrintSDoc (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr

unsafePrintSDoc :: SDoc -> String
unsafePrintSDoc :: SDoc -> String
unsafePrintSDoc SDoc
sdoc = DynFlags -> SDoc -> PprStyle -> String
renderWithStyle DynFlags
dflags SDoc
sdoc (DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle DynFlags
dflags PrintUnqualified
neverQualify Depth
AllTheWay)
  where
    dflags :: DynFlags
dflags = DynFlags
unsafeGlobalDynFlags

-- | Pretty print a 'RdrName' wrapping operators in parens
printRdrName :: RdrName -> String
printRdrName :: RdrName -> String
printRdrName RdrName
name = SDoc -> String
showSDocUnsafe (SDoc -> String) -> SDoc -> String
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
    IORef FilesToClean
filesToClean <- FilesToClean -> IO (IORef FilesToClean)
forall a. a -> IO (IORef a)
newIORef FilesToClean
emptyFilesToClean
    IORef (Map String String)
dirsToClean <- Map String String -> IO (IORef (Map String String))
forall a. a -> IO (IORef a)
newIORef Map String String
forall a. Monoid a => a
mempty
    let dflags :: DynFlags
dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
env){filesToClean :: IORef FilesToClean
filesToClean=IORef FilesToClean
filesToClean, dirsToClean :: IORef (Map String String)
dirsToClean=IORef (Map String String)
dirsToClean, useUnicode :: Bool
useUnicode=Bool
True}
    IORef HscEnv
ref <- HscEnv -> IO (IORef HscEnv)
forall a. a -> IO (IORef a)
newIORef HscEnv
env{hsc_dflags :: DynFlags
hsc_dflags=DynFlags
dflags}
    a
res <- Ghc a -> Session -> IO a
forall a. Ghc a -> Session -> IO a
unGhc Ghc a
act (IORef HscEnv -> Session
Session IORef HscEnv
ref) IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` do
        DynFlags -> IO ()
cleanTempFiles DynFlags
dflags
        DynFlags -> IO ()
cleanTempDirs DynFlags
dflags
    (,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
`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!
dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
           -> 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 _h_ :: Handle__
_h_@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)