-- 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(
    -- * HcsEnv and environment

    HscEnvEq,
    hscEnv, newHscEnvEq,
    hscEnvWithImportPaths,
    envImportPaths,
    modifyDynFlags,
    evalGhcEnv,
    deps,
    -- * GHC wrappers

    prettyPrint,
    printRdrName,
    printName,
    ParseResult(..), runParser,
    lookupPackageConfig,
    textToStringBuffer,
    bytestringToStringBuffer,
    stringBufferToByteString,
    moduleImportPath,
    cgGutsToCoreModule,
    fingerprintToBS,
    fingerprintFromStringBuffer,
    -- * General utilities

    readFileUtf8,
    hDuplicateTo',
    setHieDir,
    dontWriteHieFiles,
    disableWarningsAsErrors,
    newHscEnvEqPreserveImportPaths,
    newHscEnvEqWithImportPaths) where

import Control.Concurrent
import Data.List.Extra
import Data.ByteString.Internal (ByteString(..))
import Data.Maybe
import Data.Typeable
import qualified Data.ByteString.Internal as BS
import Fingerprint
import GhcMonad
import Control.Exception
import Data.IORef
import FileCleanup
import Foreign.Ptr
import Foreign.ForeignPtr
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.Types
import GHC.IO.Handle.Internals
import Data.Unique
import Development.Shake.Classes
import qualified Data.Text                as T
import qualified Data.Text.Encoding       as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.ByteString          as BS
import Lexer
import StringBuffer
import System.FilePath
import HscTypes (cg_binds, md_types, cg_module, ModDetails, CgGuts, ic_dflags, hsc_IC, HscEnv(hsc_dflags))
import PackageConfig (PackageConfig)
import Outputable (showSDocUnsafe, ppr, showSDoc, Outputable)
import Packages (getPackageConfigMap, lookupPackage')
import SrcLoc (mkRealSrcLoc)
import FastString (mkFastString)
import Module (moduleNameSlashes, InstalledUnitId)
import OccName (parenSymOcc)
import RdrName (nameRdrName, rdrNameOcc)

import Development.IDE.GHC.Compat as GHC
import Development.IDE.Types.Location
import System.Directory (canonicalizePath)


----------------------------------------------------------------------

-- 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 = DynFlags -> SDoc -> String
showSDoc DynFlags
unsafeGlobalDynFlags (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

-- | 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

-- | An 'HscEnv' with equality. Two values are considered equal

--   if they are created with the same call to 'newHscEnvEq'.

data HscEnvEq = HscEnvEq
    { HscEnvEq -> Unique
envUnique :: !Unique
    , HscEnvEq -> HscEnv
hscEnv :: !HscEnv
    , HscEnvEq -> [(InstalledUnitId, DynFlags)]
deps   :: [(InstalledUnitId, DynFlags)]
               -- ^ In memory components for this HscEnv

               -- This is only used at the moment for the import dirs in

               -- the DynFlags

    , HscEnvEq -> Maybe [String]
envImportPaths :: Maybe [String]
        -- ^ If Just, import dirs originally configured in this env

        --   If Nothing, the env import dirs are unaltered

    }

-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

newHscEnvEq :: FilePath -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq :: String -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEq String
cradlePath HscEnv
hscEnv0 [(InstalledUnitId, DynFlags)]
deps = do
    Unique
envUnique <- IO Unique
newUnique
    let relativeToCradle :: String -> String
relativeToCradle = (String -> String
takeDirectory String
cradlePath String -> String -> String
</>)
        hscEnv :: HscEnv
hscEnv = HscEnv -> HscEnv
removeImportPaths HscEnv
hscEnv0

    -- Canonicalize import paths since we also canonicalize targets

    [String]
importPathsCanon <-
      (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
canonicalizePath ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> String
relativeToCradle (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> [String]
importPaths (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv0)
    let envImportPaths :: Maybe [String]
envImportPaths = [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
importPathsCanon

    HscEnvEq -> IO HscEnvEq
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnvEq :: Unique
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> Maybe [String]
-> HscEnvEq
HscEnvEq{[(InstalledUnitId, DynFlags)]
Maybe [String]
Unique
HscEnv
envImportPaths :: Maybe [String]
hscEnv :: HscEnv
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
envImportPaths :: Maybe [String]
hscEnv :: HscEnv
..}

newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths :: Maybe [String]
-> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqWithImportPaths Maybe [String]
envImportPaths HscEnv
hscEnv [(InstalledUnitId, DynFlags)]
deps = do
    Unique
envUnique <- IO Unique
newUnique
    HscEnvEq -> IO HscEnvEq
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnvEq :: Unique
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> Maybe [String]
-> HscEnvEq
HscEnvEq{[(InstalledUnitId, DynFlags)]
Maybe [String]
Unique
HscEnv
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
hscEnv :: HscEnv
envImportPaths :: Maybe [String]
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
envImportPaths :: Maybe [String]
hscEnv :: HscEnv
..}

-- | Wrap an 'HscEnv' into an 'HscEnvEq'.

newHscEnvEqPreserveImportPaths
    :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths :: HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq
newHscEnvEqPreserveImportPaths HscEnv
hscEnv [(InstalledUnitId, DynFlags)]
deps = do
    let envImportPaths :: Maybe a
envImportPaths = Maybe a
forall a. Maybe a
Nothing
    Unique
envUnique <- IO Unique
newUnique
    HscEnvEq -> IO HscEnvEq
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnvEq :: Unique
-> HscEnv
-> [(InstalledUnitId, DynFlags)]
-> Maybe [String]
-> HscEnvEq
HscEnvEq{[(InstalledUnitId, DynFlags)]
Maybe [String]
Unique
HscEnv
forall a. Maybe a
envUnique :: Unique
envImportPaths :: forall a. Maybe a
deps :: [(InstalledUnitId, DynFlags)]
hscEnv :: HscEnv
envUnique :: Unique
deps :: [(InstalledUnitId, DynFlags)]
envImportPaths :: Maybe [String]
hscEnv :: HscEnv
..}

-- | Unwrap the 'HscEnv' with the original import paths.

--   Used only for locating imports

hscEnvWithImportPaths :: HscEnvEq -> HscEnv
hscEnvWithImportPaths :: HscEnvEq -> HscEnv
hscEnvWithImportPaths HscEnvEq{[(InstalledUnitId, DynFlags)]
Maybe [String]
Unique
HscEnv
envImportPaths :: Maybe [String]
deps :: [(InstalledUnitId, DynFlags)]
hscEnv :: HscEnv
envUnique :: Unique
envUnique :: HscEnvEq -> Unique
deps :: HscEnvEq -> [(InstalledUnitId, DynFlags)]
envImportPaths :: HscEnvEq -> Maybe [String]
hscEnv :: HscEnvEq -> HscEnv
..}
    | Just [String]
imps <- Maybe [String]
envImportPaths
    = HscEnv
hscEnv{hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hscEnv){importPaths :: [String]
importPaths = [String]
imps}}
    | Bool
otherwise
    = HscEnv
hscEnv

removeImportPaths :: HscEnv -> HscEnv
removeImportPaths :: HscEnv -> HscEnv
removeImportPaths HscEnv
hsc = HscEnv
hsc{hsc_dflags :: DynFlags
hsc_dflags = (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc){importPaths :: [String]
importPaths = []}}

instance Show HscEnvEq where
  show :: HscEnvEq -> String
show HscEnvEq{Unique
envUnique :: Unique
envUnique :: HscEnvEq -> Unique
envUnique} = String
"HscEnvEq " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Unique -> Int
hashUnique Unique
envUnique)

instance Eq HscEnvEq where
  HscEnvEq
a == :: HscEnvEq -> HscEnvEq -> Bool
== HscEnvEq
b = HscEnvEq -> Unique
envUnique HscEnvEq
a Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== HscEnvEq -> Unique
envUnique HscEnvEq
b

instance NFData HscEnvEq where
  rnf :: HscEnvEq -> ()
rnf (HscEnvEq Unique
a HscEnv
b [(InstalledUnitId, DynFlags)]
c Maybe [String]
d) = Int -> ()
forall a. NFData a => a -> ()
rnf (Unique -> Int
hashUnique Unique
a) () -> () -> ()
`seq` HscEnv
b HscEnv -> () -> ()
`seq` [(InstalledUnitId, DynFlags)]
c [(InstalledUnitId, DynFlags)] -> () -> ()
`seq` Maybe [String] -> ()
forall a. NFData a => a -> ()
rnf Maybe [String]
d

instance Hashable HscEnvEq where
  hashWithSalt :: Int -> HscEnvEq -> Int
hashWithSalt Int
s = Int -> Unique -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (Unique -> Int) -> (HscEnvEq -> Unique) -> HscEnvEq -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnvEq -> Unique
envUnique

-- Fake instance needed to persuade Shake to accept this type as a key.

-- No harm done as ghcide never persists these keys currently

instance Binary HscEnvEq where
  put :: HscEnvEq -> Put
put HscEnvEq
_ = String -> Put
forall a. HasCallStack => String -> a
error String
"not really"
  get :: Get HscEnvEq
get = String -> Get HscEnvEq
forall a. HasCallStack => String -> a
error String
"not really"

-- | 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


-- | 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)