[project @ 2002-06-14 08:17:08 by simonpj]

[ghc-base.git] / GHC / Handle.hs

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index db9e886..c927e13 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -1,14 +1,21 @@
-{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
 
 #undef DEBUG_DUMP
 #undef DEBUG
 
--- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.3 2002/02/05 17:32:26 simonmar Exp $
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Handle
+-- Copyright   :  (c) The University of Glasgow, 1994-2001
+-- License     :  see libraries/base/LICENSE
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable
 --
--- (c) The University of Glasgow, 1994-2001
+-- This module defines the basic operations on I\/O \"handles\".
 --
--- This module defines the basic operations on I/O "handles".
+-----------------------------------------------------------------------------
 
 module GHC.Handle (
   withHandle, withHandle', withHandle_,
@@ -29,7 +36,7 @@ module GHC.Handle (
   hClose, hClose_help,
 
   HandlePosn(..), hGetPosn, hSetPosn,
-  SeekMode(..), hSeek,
+  SeekMode(..), hSeek, hTell,
 
   hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
   hSetEcho, hGetEcho, hIsTerminalDevice,
@@ -118,6 +125,8 @@ withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
 withHandle fun h@(FileHandle m)     act = withHandle' fun h m act
 withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
 
+withHandle' :: String -> Handle -> MVar Handle__
+   -> (Handle__ -> IO (Handle__,a)) -> IO a
 withHandle' fun h m act = 
    block $ do
    h_ <- takeMVar m
@@ -756,6 +765,7 @@ hClose' h m = withHandle__' "hClose" h m $ hClose_help
 -- then closed immediately.  We have to be careful with DuplexHandles
 -- though: we have to leave the closing to the finalizer in that case,
 -- because the write side may still be in use.
+hClose_help :: Handle__ -> IO Handle__
 hClose_help handle_ =
   case haType handle_ of 
       ClosedHandle -> return handle_
@@ -962,32 +972,9 @@ type HandlePosition = Integer
 -- position of `hdl' to a previously obtained position `p'.
 
 hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle =
-    wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
-
-#if defined(mingw32_TARGET_OS)
-       -- urgh, on Windows we have to worry about \n -> \r\n translation, 
-       -- so we can't easily calculate the file position using the
-       -- current buffer size.  Just flush instead.
-      flushBuffer handle_
-#endif
-      let fd = fromIntegral (haFD handle_)
-      posn <- fromIntegral `liftM`
-               throwErrnoIfMinus1Retry "hGetPosn"
-                  (c_lseek fd 0 sEEK_CUR)
-
-      let ref = haBuffer handle_
-      buf <- readIORef ref
-
-      let real_posn 
-          | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
-          | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
-#     ifdef DEBUG_DUMP
-      puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
-      puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
-#     endif
-      return (HandlePosn handle real_posn)
-
+hGetPosn handle = do
+    posn <- hTell handle
+    return (HandlePosn handle posn)
 
 hSetPosn :: HandlePosn -> IO () 
 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
@@ -1061,6 +1048,34 @@ hSeek handle mode offset =
     writeIORef ref new_buf
     do_seek
 
+
+hTell :: Handle -> IO Integer
+hTell handle = 
+    wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+
+#if defined(mingw32_TARGET_OS)
+       -- urgh, on Windows we have to worry about \n -> \r\n translation, 
+       -- so we can't easily calculate the file position using the
+       -- current buffer size.  Just flush instead.
+      flushBuffer handle_
+#endif
+      let fd = fromIntegral (haFD handle_)
+      posn <- fromIntegral `liftM`
+               throwErrnoIfMinus1Retry "hGetPosn"
+                  (c_lseek fd 0 sEEK_CUR)
+
+      let ref = haBuffer handle_
+      buf <- readIORef ref
+
+      let real_posn 
+          | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
+          | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
+#     ifdef DEBUG_DUMP
+      puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
+      puts ("   (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
+#     endif
+      return real_posn
+
 -- -----------------------------------------------------------------------------
 -- Handle Properties
 
@@ -1173,6 +1188,7 @@ hIsTerminalDevice handle = do
 -- -----------------------------------------------------------------------------
 -- hSetBinaryMode
 
+hSetBinaryMode :: Handle -> Bool -> IO ()
 hSetBinaryMode handle bin =
   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
     do throwErrnoIfMinus1_ "hSetBinaryMode"