CreatePipe.hs 2.38 KB
Newer Older
1
2
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
3
{-# LANGUAGE RankNTypes #-}
4

5
module Distribution.Compat.CreatePipe (createPipe) where
ttuegel's avatar
ttuegel committed
6

7
import System.IO (Handle, hSetEncoding, localeEncoding)
ttuegel's avatar
ttuegel committed
8

9
10
import Prelude ()
import Distribution.Compat.Prelude
11
import Distribution.Compat.Stack
12

ttuegel's avatar
ttuegel committed
13
14
-- The mingw32_HOST_OS CPP macro is GHC-specific
#if mingw32_HOST_OS
15
import qualified Prelude
ttuegel's avatar
ttuegel committed
16
17
18
19
20
21
22
23
24
25
import Control.Exception (onException)
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types (CInt(..), CUInt(..))
import Foreign.Ptr (Ptr)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Storable (peek, peekElemOff)
import GHC.IO.FD (mkFD)
import GHC.IO.Device (IODeviceType(Stream))
import GHC.IO.Handle.FD (mkHandleFromFD)
import System.IO (IOMode(ReadMode, WriteMode))
26
#elif ghcjs_HOST_OS
ttuegel's avatar
ttuegel committed
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
#else
import System.Posix.IO (fdToHandle)
import qualified System.Posix.IO as Posix
#endif

createPipe :: IO (Handle, Handle)
-- The mingw32_HOST_OS CPP macro is GHC-specific
#if mingw32_HOST_OS
createPipe = do
    (readfd, writefd) <- allocaArray 2 $ \ pfds -> do
        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)
        readfd <- peek pfds
        writefd <- peekElemOff pfds 1
        return (readfd, writefd)
    (do readh <- fdToHandle readfd ReadMode
        writeh <- fdToHandle writefd WriteMode
43
44
        hSetEncoding readh localeEncoding
        hSetEncoding writeh localeEncoding
ttuegel's avatar
ttuegel committed
45
46
        return (readh, writeh)) `onException` (close readfd >> close writefd)
  where
47
    fdToHandle :: CInt -> IOMode -> NoCallStackIO Handle
ttuegel's avatar
ttuegel committed
48
49
50
51
52
53
    fdToHandle fd mode = do
        (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False
        mkHandleFromFD fd' deviceType "" mode False Nothing

    close :: CInt -> IO ()
    close = throwErrnoIfMinus1_ "_close" . c__close
54
55
56
      where _ = callStack -- TODO: attach call stack to exception

    _ = callStack -- TODO: attach call stack to exceptions
ttuegel's avatar
ttuegel committed
57
58

foreign import ccall "io.h _pipe" c__pipe ::
59
    Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt
ttuegel's avatar
ttuegel committed
60
61

foreign import ccall "io.h _close" c__close ::
62
    CInt -> Prelude.IO CInt
63
64
#elif ghcjs_HOST_OS
createPipe = error "createPipe"
65
66
  where
    _ = callStack
ttuegel's avatar
ttuegel committed
67
68
69
70
71
#else
createPipe = do
    (readfd, writefd) <- Posix.createPipe
    readh <- fdToHandle readfd
    writeh <- fdToHandle writefd
72
73
    hSetEncoding readh localeEncoding
    hSetEncoding writeh localeEncoding
ttuegel's avatar
ttuegel committed
74
    return (readh, writeh)
75
76
  where
    _ = callStack
ttuegel's avatar
ttuegel committed
77
#endif