stdin, stdout, stderr
) where
-#undef DEBUG_DUMP
-
import GHC.Base
import GHC.Num
import GHC.Real
import GHC.IO.BufferedIO
import qualified GHC.IO.Device
import GHC.IO.Device (SeekMode(..), IODeviceType(..))
-import GHC.Conc
+import GHC.Conc.IO
import GHC.IO.Exception
import Foreign
import qualified System.Posix.Internals
import System.Posix.Internals hiding (FD, setEcho, getEcho)
import System.Posix.Types
-import GHC.Ptr
+-- import GHC.Ptr
+
+c_DEBUG_DUMP :: Bool
+c_DEBUG_DUMP = False
-- -----------------------------------------------------------------------------
-- The file-descriptor IO device
readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
readBuf' fd buf = do
-#ifdef DEBUG_DUMP
- puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
-#endif
+ when c_DEBUG_DUMP $
+ puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
(r,buf') <- readBuf fd buf
-#ifdef DEBUG_DUMP
- puts ("after: " ++ summaryBuffer buf' ++ "\n")
-#endif
+ when c_DEBUG_DUMP $
+ puts ("after: " ++ summaryBuffer buf' ++ "\n")
return (r,buf')
-writeBuf' :: FD -> Buffer Word8 -> IO ()
+writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)
writeBuf' fd buf = do
-#ifdef DEBUG_DUMP
- puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
-#endif
+ when c_DEBUG_DUMP $
+ puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
writeBuf fd buf
-- -----------------------------------------------------------------------------
(fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
False{-not a socket-}
True{-is non-blocking-}
- `catchAny` \e -> do c_close fd; throwIO e
+ `catchAny` \e -> do _ <- c_close fd
+ throwIO e
#ifndef mingw32_HOST_OS
-- we want to truncate() if this is an open in WriteMode, but only
_ -> True
#ifdef mingw32_HOST_OS
- let _ = (dev,ino,write,fd) -- warning suppression
+ _ <- setmode fd True -- unconditionally set binary mode
+ let _ = (dev,ino,write) -- warning suppression
#endif
case fd_type of
},
fd_type)
+#ifdef mingw32_HOST_OS
+foreign import ccall unsafe "__hscore_setmode"
+ setmode :: CInt -> Bool -> IO CInt
+#endif
+
-- -----------------------------------------------------------------------------
-- Standard file descriptors
c_close (fdFD fd)
release :: FD -> IO ()
-release fd = do
-#ifndef mingw32_HOST_OS
- unlockFile (fdFD fd)
+#ifdef mingw32_HOST_OS
+release _ = return ()
+#else
+release fd = do _ <- unlockFile (fdFD fd)
+ return ()
#endif
- let _ = fd -- warning suppression
- return ()
#ifdef mingw32_HOST_OS
foreign import stdcall unsafe "HsBase.h closesocket"
seek :: FD -> SeekMode -> Integer -> IO ()
seek fd mode off = do
- throwErrnoIfMinus1Retry "seek" $
+ throwErrnoIfMinus1Retry_ "seek" $
c_lseek (fdFD fd) (fromIntegral off) seektype
- return ()
where
seektype :: CInt
seektype = case mode of
setSize :: FD -> Integer -> IO ()
setSize fd size = do
- throwErrnoIf (/=0) "GHC.IO.FD.setSize" $
+ throwErrnoIf_ (/=0) "GHC.IO.FD.setSize" $
c_ftruncate (fdFD fd) (fromIntegral size)
- return ()
devType :: FD -> IO IODeviceType
devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
dup2 :: FD -> FD -> IO FD
dup2 fd fdto = do
-- Windows' dup2 does not return the new descriptor, unlike Unix
- throwErrnoIfMinus1 "GHC.IO.FD.dup2" $
+ throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $
c_dup2 (fdFD fd) (fdFD fdto)
return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
-- Terminal-related stuff
isTerminal :: FD -> IO Bool
-isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
+isTerminal fd =
+#if defined(mingw32_HOST_OS)
+ is_console (fdFD fd) >>= return.toBool
+#else
+ c_isatty (fdFD fd) >>= return.toBool
+#endif
setEcho :: FD -> Bool -> IO ()
setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
unlockFile :: CInt -> IO CInt
#endif
-#if defined(DEBUG_DUMP)
puts :: String -> IO ()
-puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)
+puts s = do _ <- withCStringLen s $ \(p,len) ->
+ c_write 1 (castPtr p) (fromIntegral len)
return ()
-#endif