X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=System%2FPosix%2FInternals.hs;h=09243ac0fe6aafe48ad4970bc5c928138e8cae48;hb=882ba4a2b3d4a7f72ad3b1fd239903ec7a8c8bae;hp=5b9eb953527ab9a3405309cd60777a8a3a275c8d;hpb=2baa07fe445b54aaf5669b9c245e46cc3bf7399b;p=ghc-base.git

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index 5b9eb95..09243ac 100644
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -XNoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
@@ -22,9 +23,13 @@
 -- #hide
 module System.Posix.Internals where
 
-#include "HsBaseConfig.h"
+#ifndef __NHC__
+# include "HsBaseConfig.h"
+#endif
 
+#if ! (defined(mingw32_HOST_OS) || defined(__MINGW32__))
 import Control.Monad
+#endif
 import System.Posix.Types
 
 import Foreign
@@ -33,6 +38,10 @@ import Foreign.C
 import Data.Bits
 import Data.Maybe
 
+#if !defined(HTYPE_TCFLAG_T)
+import System.IO.Error
+#endif
+
 #if __GLASGOW_HASKELL__
 import GHC.Base
 import GHC.Num
@@ -41,8 +50,10 @@ import GHC.IOBase
 #elif __HUGS__
 import Hugs.Prelude (IOException(..), IOErrorType(..))
 import Hugs.IO (IOMode(..))
-#else
+#elif __NHC__
 import System.IO
+import Control.Exception
+import DIOError
 #endif
 
 #ifdef __HUGS__
@@ -83,8 +94,8 @@ fdFileSize fd =
     if not (s_isreg c_mode)
         then return (-1)
         else do
-    c_size <- st_size p_stat
-    return (fromIntegral c_size)
+      c_size <- st_size p_stat
+      return (fromIntegral c_size)
 
 data FDType  = Directory | Stream | RegularFile | RawDevice
                deriving (Eq)
@@ -112,6 +123,7 @@ fdStat fd =
 fdType :: FD -> IO FDType
 fdType fd = do (ty,_,_) <- fdStat fd; return ty
 
+statGetType :: Ptr CStat -> IO FDType
 statGetType p_stat = do
   c_mode <- st_mode p_stat :: IO CMode
   case () of
@@ -123,9 +135,17 @@ statGetType p_stat = do
         | s_isblk c_mode        -> return RawDevice
         | otherwise             -> ioError ioe_unknownfiletype
     
-
+ioe_unknownfiletype :: IOException
+#ifndef __NHC__
 ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
-                        "unknown file type" Nothing
+                        "unknown file type"
+#  if __GLASGOW_HASKELL__
+                        Nothing
+#  endif
+                        Nothing
+#else
+ioe_unknownfiletype = UserError "fdType" "unknown file type"
+#endif
 
 #if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
 closeFd :: Bool -> CInt -> IO CInt
@@ -138,12 +158,13 @@ foreign import stdcall unsafe "HsBase.h closesocket"
 #endif
 
 fdGetMode :: FD -> IO IOMode
-fdGetMode fd = do
 #if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+fdGetMode _ = do
     -- We don't have a way of finding out which flags are set on FDs
     -- on Windows, so make a handle that thinks that anything goes.
     let flags = o_RDWR
 #else
+fdGetMode fd = do
     flags <- throwErrnoIfMinus1Retry "fdGetMode" 
                 (c_fcntl_read fd const_f_getfl)
 #endif
@@ -171,27 +192,27 @@ fdIsTTY fd = c_isatty fd >>= return.toBool
 setEcho :: FD -> Bool -> IO ()
 setEcho fd on = do
   tcSetAttr fd $ \ p_tios -> do
-    c_lflag <- c_lflag p_tios :: IO CTcflag
-    let new_c_lflag
-         | on        = c_lflag .|. fromIntegral const_echo
-         | otherwise = c_lflag .&. complement (fromIntegral const_echo)
-    poke_c_lflag p_tios (new_c_lflag :: CTcflag)
+    lflag <- c_lflag p_tios :: IO CTcflag
+    let new_lflag
+         | on        = lflag .|. fromIntegral const_echo
+         | otherwise = lflag .&. complement (fromIntegral const_echo)
+    poke_c_lflag p_tios (new_lflag :: CTcflag)
 
 getEcho :: FD -> IO Bool
 getEcho fd = do
   tcSetAttr fd $ \ p_tios -> do
-    c_lflag <- c_lflag p_tios :: IO CTcflag
-    return ((c_lflag .&. fromIntegral const_echo) /= 0)
+    lflag <- c_lflag p_tios :: IO CTcflag
+    return ((lflag .&. fromIntegral const_echo) /= 0)
 
 setCooked :: FD -> Bool -> IO ()
 setCooked fd cooked = 
   tcSetAttr fd $ \ p_tios -> do
 
     -- turn on/off ICANON
-    c_lflag <- c_lflag p_tios :: IO CTcflag
-    let new_c_lflag | cooked    = c_lflag .|. (fromIntegral const_icanon)
-                    | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
-    poke_c_lflag p_tios (new_c_lflag :: CTcflag)
+    lflag <- c_lflag p_tios :: IO CTcflag
+    let new_lflag | cooked    = lflag .|. (fromIntegral const_icanon)
+                  | otherwise = lflag .&. complement (fromIntegral const_icanon)
+    poke_c_lflag p_tios (new_lflag :: CTcflag)
 
     -- set VMIN & VTIME to 1/0 respectively
     when (not cooked) $ do
@@ -259,8 +280,13 @@ setCooked fd cooked = do
    then ioError (ioe_unk_error "setCooked" "failed to set buffering")
    else return ()
 
+ioe_unk_error :: String -> String -> IOException
 ioe_unk_error loc msg 
- = IOError Nothing OtherError loc msg Nothing
+#ifndef __NHC__
+ = ioeSetErrorString (mkIOError OtherError loc Nothing Nothing) msg
+#else
+ = UserError loc msg
+#endif
 
 -- Note: echoing goes hand in hand with enabling 'line input' / raw-ness
 -- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.
@@ -292,8 +318,8 @@ foreign import ccall unsafe "consUtils.h get_console_echo__"
 -- ---------------------------------------------------------------------------
 -- Turning on non-blocking for a file descriptor
 
+setNonBlockingFD :: FD -> IO ()
 #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-
 setNonBlockingFD fd = do
   flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
                  (c_fcntl_read fd const_f_getfl)
@@ -306,7 +332,7 @@ setNonBlockingFD fd = do
 #else
 
 -- bogus defns for win32
-setNonBlockingFD fd = return ()
+setNonBlockingFD _ = return ()
 
 #endif
 
@@ -503,11 +529,10 @@ foreign import ccall unsafe "HsBase.h __hscore_poke_lflag" poke_c_lflag :: Ptr C
 foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc  :: Ptr CTermios -> IO (Ptr Word8)
 #endif
 
-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
-foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt
 s_issock :: CMode -> Bool
+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)
 s_issock cmode = c_s_issock cmode /= 0
+foreign import ccall unsafe "HsBase.h __hscore_s_issock" c_s_issock :: CMode -> CInt
 #else
-s_issock :: CMode -> Bool
-s_issock cmode = False
+s_issock _ = False
 #endif