From 94ac8915eb5ea8e47022d30405e5de0b88eb3f83 Mon Sep 17 00:00:00 2001 From: sof Date: Thu, 14 Jan 1999 18:17:37 +0000 Subject: [PATCH] [project @ 1999-01-14 18:17:32 by sof] -syslib misc meets Haskell 98. --- ghc/lib/misc/BSD.lhs | 38 +++++------ ghc/lib/misc/Bag.lhs | 22 +++--- ghc/lib/misc/CString.lhs | 12 ++-- ghc/lib/misc/CharSeq.lhs | 14 ++-- ghc/lib/misc/ListSetOps.lhs | 6 +- ghc/lib/misc/MatchPS.lhs | 41 ++++------- ghc/lib/misc/Maybes.lhs | 18 ++--- ghc/lib/misc/Native.lhs | 1 + ghc/lib/misc/PackedString.lhs | 47 ++++++------- ghc/lib/misc/Readline.lhs | 4 +- ghc/lib/misc/Regex.lhs | 22 +++--- ghc/lib/misc/SocketPrim.lhs | 150 +++++++++++++++++++++-------------------- 12 files changed, 183 insertions(+), 192 deletions(-) diff --git a/ghc/lib/misc/BSD.lhs b/ghc/lib/misc/BSD.lhs index 7d1d66d..c63d7df 100644 --- a/ghc/lib/misc/BSD.lhs +++ b/ghc/lib/misc/BSD.lhs @@ -161,7 +161,7 @@ getServiceByName :: ServiceName -- Service Name getServiceByName name proto = do ptr <- _ccall_ getservbyname name proto if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getServiceByName" "no such service entry") + then ioError (IOError Nothing NoSuchThing "getServiceByName" "no such service entry") else unpackServiceEntry ptr getServiceByPort :: PortNumber @@ -170,7 +170,7 @@ getServiceByPort :: PortNumber getServiceByPort (PNum port) proto = do ptr <- _ccall_ getservbyport port proto if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getServiceByPort" "no such service entry") + then ioError (IOError Nothing NoSuchThing "getServiceByPort" "no such service entry") else unpackServiceEntry ptr getServicePortNumber :: ServiceName -> IO PortNumber @@ -183,7 +183,7 @@ getServiceEntry :: IO ServiceEntry getServiceEntry = do ptr <- _ccall_ getservent if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getServiceEntry" "no such service entry") + then ioError (IOError Nothing NoSuchThing "getServiceEntry" "no such service entry") else unpackServiceEntry ptr setServiceEntry :: Bool -> IO () @@ -227,14 +227,14 @@ getProtocolEntries :: Bool -> IO [ProtocolEntry] getProtocolByName name = do ptr <- _ccall_ getprotobyname name if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getProtocolByName" "no such protocol entry") + then ioError (IOError Nothing NoSuchThing "getProtocolByName" "no such protocol entry") else unpackProtocolEntry ptr --getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry getProtocolByNumber num = do ptr <- _ccall_ getprotobynumber num if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getProtocolByNumber" "no such protocol entry") + then ioError (IOError Nothing NoSuchThing "getProtocolByNumber" "no such protocol entry") else unpackProtocolEntry ptr --getProtocolNumber :: ProtocolName -> IO ProtocolNumber @@ -247,7 +247,7 @@ getProtocolNumber proto = do getProtocolEntry = do ptr <- _ccall_ getprotoent if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getProtocolEntry" "no such protocol entry") + then ioError (IOError Nothing NoSuchThing "getProtocolEntry" "no such protocol entry") else unpackProtocolEntry ptr --setProtocolEntry :: Bool -> IO () -- Keep DB Open ? @@ -270,7 +270,7 @@ getHostByName :: HostName -> IO HostEntry getHostByName name = do ptr <- _ccall_ gethostbyname name if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getHostByName" "no such host entry") + then ioError (IOError Nothing NoSuchThing "getHostByName" "no such host entry") else unpackHostEntry ptr getHostByAddr :: Family -> HostAddress -> IO HostEntry @@ -281,7 +281,7 @@ getHostByAddr family addr = do addr (packFamily family) if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getHostByAddr" "no such host entry") + then ioError (IOError Nothing NoSuchThing "getHostByAddr" "no such host entry") else unpackHostEntry ptr #ifndef cygwin32_TARGET_OS @@ -289,7 +289,7 @@ getHostEntry :: IO HostEntry getHostEntry = do ptr <- _ccall_ gethostent if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getHostEntry" "unable to retrieve host entry") + then ioError (IOError Nothing NoSuchThing "getHostEntry" "unable to retrieve host entry") else unpackHostEntry ptr setHostEntry :: Bool -> IO () @@ -333,21 +333,21 @@ getNetworkByName :: NetworkName -> IO NetworkEntry getNetworkByName name = do ptr <- _ccall_ getnetbyname name if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getNetworkByName" "no such network entry") + then ioError (IOError Nothing NoSuchThing "getNetworkByName" "no such network entry") else unpackNetworkEntry ptr getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry getNetworkByAddr addr family = do ptr <- _ccall_ getnetbyaddr addr (packFamily family) if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getNetworkByAddr" "no such network entry") + then ioError (IOError Nothing NoSuchThing "getNetworkByAddr" "no such network entry") else unpackNetworkEntry ptr getNetworkEntry :: IO NetworkEntry getNetworkEntry = do ptr <- _ccall_ getnetent if ptr == nullAddr - then fail (IOError Nothing NoSuchThing "getNetworkEntry" "no more network entries") + then ioError (IOError Nothing NoSuchThing "getNetworkEntry" "no more network entries") else unpackNetworkEntry ptr setNetworkEntry :: Bool -> IO () @@ -379,8 +379,8 @@ getHostName :: IO HostName getHostName = do ptr <- stToIO (newCharArray (0,256)) rc <- _casm_ ``%r=gethostname(%0, 256);'' ptr - if rc == -1 - then fail (userError "getHostName: unable to determine host name") + if rc == ((-1)::Int) + then ioError (userError "getHostName: unable to determine host name") else do ba <- stToIO (unsafeFreezeByteArray ptr) return (unpackCStringBA ba) @@ -424,8 +424,8 @@ getEntries getOne atEnd = loop \begin{code} unpackServiceEntry :: Addr -> PrimIO ServiceEntry unpackServiceEntry ptr = do - str <- _casm_ ``%r = ((struct servent*)%0)->s_name;'' ptr - name <- unpackCStringIO str + pname <- _casm_ ``%r = ((struct servent*)%0)->s_name;'' ptr + name <- unpackCStringIO pname alias <- _casm_ ``%r = ((struct servent*)%0)->s_aliases;'' ptr aliases <- unvectorize alias 0 port <- _casm_ ``%r = (int)(((struct servent*)%0)->s_port);'' ptr @@ -499,13 +499,13 @@ unvectorizeHostAddrs ptr n = do symlink :: String -> String -> IO () symlink actual_path sym_path = do rc <- _ccall_ symlink actual_path sym_path - if rc == 0 then + if rc == (0::Int) then return () else do _ccall_ convertErrno cstr <- _ccall_ getErrStr__ estr <- unpackCStringIO cstr - fail (userError ("BSD.symlink: " ++ estr)) + ioError (userError ("BSD.symlink: " ++ estr)) #endif #ifdef HAVE_READLINK @@ -520,7 +520,7 @@ readlink sym = do _ccall_ convertErrno cstr <- _ccall_ getErrStr__ estr <- unpackCStringIO cstr - fail (userError ("BSD.readlink: " ++ estr)) + ioError (userError ("BSD.readlink: " ++ estr)) where path_max = (``PATH_MAX''::Int) #endif diff --git a/ghc/lib/misc/Bag.lhs b/ghc/lib/misc/Bag.lhs index acf1b97..2e20af5 100644 --- a/ghc/lib/misc/Bag.lhs +++ b/ghc/lib/misc/Bag.lhs @@ -26,22 +26,26 @@ data Bag a | ListBag [a] -- The list is non-empty | ListOfBags [Bag a] -- The list is non-empty +emptyBag :: Bag a emptyBag = EmptyBag + +unitBag :: a -> Bag a unitBag = UnitBag elemBag :: Eq a => a -> Bag a -> Bool - -elemBag x EmptyBag = False +elemBag _ EmptyBag = False elemBag x (UnitBag y) = x==y elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 elemBag x (ListBag ys) = any (x ==) ys elemBag x (ListOfBags bs) = any (x `elemBag`) bs +unionManyBags :: [Bag a] -> Bag a unionManyBags [] = EmptyBag unionManyBags xs = ListOfBags xs -- This one is a bit stricter! The bag will get completely evaluated. +unionBags :: Bag a -> Bag a -> Bag a unionBags EmptyBag b = b unionBags b EmptyBag = b unionBags b1 b2 = TwoBags b1 b2 @@ -52,14 +56,15 @@ snocBag :: Bag a -> a -> Bag a consBag elt bag = (unitBag elt) `unionBags` bag snocBag bag elt = bag `unionBags` (unitBag elt) +isEmptyBag :: Bag a -> Bool isEmptyBag EmptyBag = True -isEmptyBag (UnitBag x) = False +isEmptyBag (UnitBag _) = False isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe isEmptyBag (ListBag xs) = null xs -- Paranoid, but safe isEmptyBag (ListOfBags bs) = all isEmptyBag bs filterBag :: (a -> Bool) -> Bag a -> Bag a -filterBag pred EmptyBag = EmptyBag +filterBag _ EmptyBag = EmptyBag filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 where @@ -80,7 +85,7 @@ concatBag (ListOfBags bbs) = ListOfBags (map concatBag bbs) partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, Bag a {- Don't -}) -partitionBag pred EmptyBag = (EmptyBag, EmptyBag) +partitionBag _ EmptyBag = (EmptyBag, EmptyBag) partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b) partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) where @@ -101,7 +106,7 @@ foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative -> r {- Standard definition -foldBag t u e EmptyBag = e +foldBag _ _ e EmptyBag = e foldBag t u e (UnitBag x) = u x foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) foldBag t u e (ListBag xs) = foldr (t.u) e xs @@ -109,7 +114,7 @@ foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs -} -- More tail-recursive definition, exploiting associativity of "t" -foldBag t u e EmptyBag = e +foldBag _ _ e EmptyBag = e foldBag t u e (UnitBag x) = u x `t` e foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 foldBag t u e (ListBag xs) = foldr (t.u) e xs @@ -117,7 +122,7 @@ foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs mapBag :: (a -> b) -> Bag a -> Bag b -mapBag f EmptyBag = EmptyBag +mapBag _ EmptyBag = EmptyBag mapBag f (UnitBag x) = UnitBag (f x) mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) mapBag f (ListBag xs) = ListBag (map f xs) @@ -135,6 +140,7 @@ bagToList b = bagToList_append b [] -- (bagToList_append b xs) flattens b and puts xs on the end. -- (not exported) +bagToList_append :: Bag a -> [a] -> [a] bagToList_append EmptyBag xs = xs bagToList_append (UnitBag x) xs = x:xs bagToList_append (TwoBags b1 b2) xs = bagToList_append b1 (bagToList_append b2 xs) diff --git a/ghc/lib/misc/CString.lhs b/ghc/lib/misc/CString.lhs index 48c1f55..83712be 100644 --- a/ghc/lib/misc/CString.lhs +++ b/ghc/lib/misc/CString.lhs @@ -80,7 +80,7 @@ unpackCStringIO addr -- unpack 'len' chars unpackCStringLenIO :: Addr -> Int -> IO String unpackCStringLenIO addr l@(I# len#) - | len# <# 0# = fail (userError ("CString.unpackCStringLenIO: negative length (" ++ show l ++ ")")) + | len# <# 0# = ioError (userError ("CString.unpackCStringLenIO: negative length (" ++ show l ++ ")")) | len# ==# 0# = return "" | otherwise = unpack [] (len# -# 1#) where @@ -102,8 +102,8 @@ unpackNBytesBAIO ba l = unpackNBytesAccBAIO ba l [] -- note: no bounds checking! unpackNBytesAccBAIO :: ByteArray Int -> Int -> [Char] -> IO [Char] -unpackNBytesAccBAIO ba 0 rest = return rest -unpackNBytesAccBAIO (ByteArray _ ba) (I# len#) rest = unpack rest (len# -# 1#) +unpackNBytesAccBAIO _ 0 rest = return rest +unpackNBytesAccBAIO (ByteArray _ ba) (I# len#) rest = unpack rest (len# -# 1#) where unpack acc i# | i# <# 0# = return acc @@ -134,13 +134,13 @@ strings No indices...I hate indices. Death to Ix. \begin{code} vectorize :: [String] -> IO (ByteArray Int) -vectorize xs = do +vectorize vs = do arr <- allocWords (len + 1) - fill arr 0 xs + fill arr 0 vs freeze arr where len :: Int - len = length xs + len = length vs fill :: MutableByteArray RealWorld Int -> Int -> [String] -> IO () fill arr n [] = diff --git a/ghc/lib/misc/CharSeq.lhs b/ghc/lib/misc/CharSeq.lhs index 43dfb7f..b400a00 100644 --- a/ghc/lib/misc/CharSeq.lhs +++ b/ghc/lib/misc/CharSeq.lhs @@ -139,17 +139,17 @@ flatten :: FAST_INT -- Indentation -> [WorkItem] -- Work list with indentation -> String -flatten n nlp CNil seqs = flattenS nlp seqs +flatten _ nlp CNil seqs = flattenS nlp seqs flatten n nlp (CAppend seq1 seq2) seqs = flatten n nlp seq1 ((WI n seq2) : seqs) flatten n nlp (CIndent IBOX(n2) seq) seqs = flatten (n2 _ADD_ n) nlp seq seqs -flatten n _FALSE_ CNewline seqs = '\n' : flattenS _TRUE_ seqs -flatten n _TRUE_ CNewline seqs = flattenS _TRUE_ seqs -- Already at start of line +flatten _ _FALSE_ CNewline seqs = '\n' : flattenS _TRUE_ seqs +flatten _ _TRUE_ CNewline seqs = flattenS _TRUE_ seqs -- Already at start of line -flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs -flatten n _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs -flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs +flatten _ _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs +flatten _ _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs +flatten _ _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs #if defined(COMPILING_GHC) flatten n _FALSE_ (CPStr s) seqs = _UNPK_ s ++ flattenS _FALSE_ seqs #endif @@ -164,7 +164,7 @@ flatten n _TRUE_ (CPStr s) seqs = mkIndent n ( _UNPK_ s ++ flattenS _FALSE_ seqs \begin{code} flattenS :: FAST_BOOL -> [WorkItem] -> String -flattenS nlp [] = "" +flattenS _ [] = "" flattenS nlp ((WI col seq):seqs) = flatten col nlp seq seqs \end{code} diff --git a/ghc/lib/misc/ListSetOps.lhs b/ghc/lib/misc/ListSetOps.lhs index 3917247..dfef227 100644 --- a/ghc/lib/misc/ListSetOps.lhs +++ b/ghc/lib/misc/ListSetOps.lhs @@ -41,8 +41,8 @@ unionLists (a:as) b intersectLists :: (Eq a) => [a] -> [a] -> [a] intersectLists [] [] = [] -intersectLists [] b = [] -intersectLists a [] = [] +intersectLists [] _ = [] +intersectLists _ [] = [] intersectLists (a:as) b | a `is_elem` b = a : intersectLists as b | otherwise = intersectLists as b @@ -71,7 +71,7 @@ minusList xs ys = [ x | x <- xs, x `not_elem` ys] disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool -disjointLists [] bs = True +disjointLists [] _ = True disjointLists (a:as) bs | a `elem` bs = False | otherwise = disjointLists as bs diff --git a/ghc/lib/misc/MatchPS.lhs b/ghc/lib/misc/MatchPS.lhs index 761f0a0..fc37651 100644 --- a/ghc/lib/misc/MatchPS.lhs +++ b/ghc/lib/misc/MatchPS.lhs @@ -194,11 +194,7 @@ substPS :: PackedString -- reg. exp -> [Char] -- flags -> PackedString -- string -> PackedString -substPS rexp - repl - flags - str - = search str +substPS rexp repl flags pstr = search pstr where global = 'g' `elem` flags case_insensitive = 'i' `elem` flags @@ -213,15 +209,13 @@ substPS rexp in case search_res of Nothing -> str - Just matcher@(REmatch arr before match after lst) -> + Just matcher@(REmatch _ before match after _) -> let (st,en) = match - prefix = chunkPS str before + prefix = chunkPS str before suffix - = if global && (st /= en) then - search (dropPS en str) - else - chunkPS str after + | global && (st /= en) = search (dropPS en str) + | otherwise = chunkPS str after in concatPS [prefix, replace matcher repl str, @@ -232,7 +226,7 @@ replace :: REmatch -> PackedString -> PackedString -> PackedString -replace (REmatch arr before@(_,b_end) match after lst) +replace (REmatch arr (_,b_end) match after lst) replacement str = concatPS (reverse acc) -- ToDo: write a `reversed' version of concatPS @@ -249,9 +243,8 @@ replace (REmatch arr before@(_,b_end) match after lst) -> Bool -> [PackedString] replace' acc repl escaped - = if (nullPS repl) then - acc - else + | nullPS repl = acc + | otherwise = let x = headPS repl x# = case x of { C# c -> c } @@ -339,7 +332,6 @@ replacePS rexp str = search str where - global = 'g' `elem` flags case_insensitive = 'i' `elem` flags mode = 's' `elem` flags -- single-line mode pat = unsafePerformIO ( @@ -352,7 +344,7 @@ replacePS rexp in case search_res of Nothing -> str - Just matcher@(REmatch arr before match after lst) -> + Just matcher@(REmatch arr _ match _ lst) -> replace matcher repl str \end{code} @@ -370,18 +362,13 @@ getMatchedGroup :: REmatch -> Int -> PackedString -> PackedString -getMatchedGroup (REmatch arr bef mtch after lst) nth str - = let +getMatchedGroup (REmatch arr bef mtch _ lst) nth str + | (nth >= 1) && (nth <= grps) = chunkPS str (arr!nth) + | otherwise = error "getMatchedGroup: group out of range" + where (1,grps) = bounds arr - in - if (nth >= 1) && (nth <= grps) then - chunkPS str (arr!nth) - else - error "getMatchedGroup: group out of range" -getWholeMatch :: REmatch - -> PackedString - -> PackedString +getWholeMatch :: REmatch -> PackedString -> PackedString getWholeMatch (REmatch _ _ mtch _ _) str = chunkPS str mtch diff --git a/ghc/lib/misc/Maybes.lhs b/ghc/lib/misc/Maybes.lhs index 1f17679..0f589db 100644 --- a/ghc/lib/misc/Maybes.lhs +++ b/ghc/lib/misc/Maybes.lhs @@ -57,7 +57,7 @@ import Maybe -- renamer will tell us if there are any conflicts \begin{code} maybeToBool :: Maybe a -> Bool maybeToBool Nothing = False -maybeToBool (Just x) = True +maybeToBool (Just _) = True \end{code} @catMaybes@ takes a list of @Maybe@s and returns a list of @@ -75,7 +75,7 @@ catMaybes (Just x : xs) = (x : catMaybes xs) allMaybes :: [Maybe a] -> Maybe [a] allMaybes [] = Just [] -allMaybes (Nothing : ms) = Nothing +allMaybes (Nothing : _) = Nothing allMaybes (Just x : ms) = case (allMaybes ms) of Nothing -> Nothing Just xs -> Just (x:xs) @@ -87,13 +87,13 @@ first @Just@ if there is one, or @Nothing@ otherwise. \begin{code} firstJust :: [Maybe a] -> Maybe a firstJust [] = Nothing -firstJust (Just x : ms) = Just x +firstJust (Just x : _) = Just x firstJust (Nothing : ms) = firstJust ms \end{code} \begin{code} findJust :: (a -> Maybe b) -> [a] -> Maybe b -findJust f [] = Nothing +findJust _ [] = Nothing findJust f (a:as) = case f a of Nothing -> findJust f as b -> b @@ -102,7 +102,7 @@ findJust f (a:as) = case f a of \begin{code} expectJust :: String -> Maybe a -> a {-# INLINE expectJust #-} -expectJust err (Just x) = x +expectJust _ (Just x) = x expectJust err Nothing = error ("expectJust " ++ err) \end{code} @@ -110,8 +110,8 @@ The Maybe monad ~~~~~~~~~~~~~~~ \begin{code} seqMaybe :: Maybe a -> Maybe a -> Maybe a -seqMaybe (Just x) _ = Just x -seqMaybe Nothing my = my +seqMaybe v@(Just _) _ = v +seqMaybe Nothing my = my returnMaybe :: a -> Maybe a returnMaybe = Just @@ -209,7 +209,7 @@ listMaybeErrs where combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs) combine (Failed err) (Succeeded _) = Failed [err] - combine (Succeeded v) (Failed errs) = Failed errs + combine (Succeeded _) (Failed errs) = Failed errs combine (Failed err) (Failed errs) = Failed (err:errs) \end{code} @@ -226,7 +226,7 @@ foldlMaybeErrs :: (acc -> input -> MaybeErr acc err) foldlMaybeErrs k accum ins = do_it [] accum ins where do_it [] acc [] = Succeeded acc - do_it errs acc [] = Failed errs + do_it errs _ [] = Failed errs do_it errs acc (v:vs) = case (k acc v) of Succeeded acc' -> do_it errs acc' vs Failed err -> do_it (err:errs) acc vs diff --git a/ghc/lib/misc/Native.lhs b/ghc/lib/misc/Native.lhs index 4ca85a1..5c35ac4 100644 --- a/ghc/lib/misc/Native.lhs +++ b/ghc/lib/misc/Native.lhs @@ -127,6 +127,7 @@ hasNElems 4 (_:_:_:_:_) = True -- speedup hasNElems _ [] = False hasNElems n (_:xs) = hasNElems (n-1) xs +lenLong, lenInt, lenShort, lenFloat, lenDouble :: Int lenLong = length (longToBytes 0 []) lenInt = length (intToBytes 0 []) lenShort = length (shortToBytes 0 []) diff --git a/ghc/lib/misc/PackedString.lhs b/ghc/lib/misc/PackedString.lhs index d34cc98..d01473b 100644 --- a/ghc/lib/misc/PackedString.lhs +++ b/ghc/lib/misc/PackedString.lhs @@ -152,7 +152,7 @@ comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2) ba1 = ByteArray (0, I# (len1 -# 1#)) bs1 ba2 = ByteArray (0, I# (len2 -# 1#)) bs2 -comparePS (PS bs1 len1 has_null1) (CPS bs2 len2) +comparePS (PS bs1 len1 has_null1) (CPS bs2 _) | not has_null1 = unsafePerformIO ( _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> @@ -165,7 +165,7 @@ comparePS (PS bs1 len1 has_null1) (CPS bs2 len2) ba1 = ByteArray (0, I# (len1 -# 1#)) bs1 ba2 = A# bs2 -comparePS (CPS bs1 len1) (CPS bs2 len2) +comparePS (CPS bs1 len1) (CPS bs2 _) = unsafePerformIO ( _ccall_ strcmp ba1 ba2 >>= \ (I# res) -> return ( @@ -233,7 +233,7 @@ packStringST str = packNCharsST len str packNCharsST :: Int -> [Char] -> ST s PackedString -packNCharsST len@(I# length#) str = +packNCharsST (I# length#) str = {- allocate an array that will hold the string (not forgetting the NUL byte at the end) @@ -294,8 +294,7 @@ unsafeByteArrayToPS (ByteArray _ frozen#) (I# n#) = PS frozen# n# (byteArrayHasNUL# frozen# n#) psToByteArray :: PackedString -> ByteArray Int -psToByteArray (PS bytes n has_null) - = ByteArray (0, I# (n -# 1#)) bytes +psToByteArray (PS bytes n _) = ByteArray (0, I# (n -# 1#)) bytes psToByteArray (CPS addr len#) = let @@ -314,10 +313,10 @@ isCString (CPS _ _ ) = True isCString _ = False psToCString :: PackedString -> Addr -psToCString (CPS addr _) = (A# addr) -psToCString (PS bytes n# has_null) = +psToCString (CPS addr _) = (A# addr) +psToCString (PS bytes l# _) = unsafePerformIO $ do - stuff <- _ccall_ malloc ((I# n#) * (``sizeof(char)'')) + stuff <- _ccall_ malloc ((I# l#) * (``sizeof(char)'')) let fill_in n# i# | n# ==# 0# = return () @@ -325,7 +324,7 @@ psToCString (PS bytes n# has_null) = let ch# = indexCharArray# bytes i# writeCharOffAddr stuff (I# i#) (C# ch#) fill_in (n# -# 1#) (i# +# 1#) - fill_in n# 0# + fill_in l# 0# return stuff \end{code} @@ -342,8 +341,7 @@ psToCString (PS bytes n# has_null) = -- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ] unpackPS :: PackedString -> [Char] -unpackPS (PS bytes len has_null) - = unpack 0# +unpackPS (PS bytes len _) = unpack 0# where unpack nh | nh >=# len = [] @@ -351,8 +349,7 @@ unpackPS (PS bytes len has_null) where ch = indexCharArray# bytes nh -unpackPS (CPS addr len) - = unpack 0# +unpackPS (CPS addr _) = unpack 0# where unpack nh | ch `eqChar#` '\0'# = [] @@ -374,9 +371,8 @@ unpackNBytesPS ps len@(I# l#) | otherwise = y# unpackPSIO :: PackedString -> IO String -unpackPSIO ps@(PS bytes len has_null) = return (unpackPS ps) -unpackPSIO (CPS addr len) - = unpack 0# +unpackPSIO ps@(PS bytes _ _) = return (unpackPS ps) +unpackPSIO (CPS addr _) = unpack 0# where unpack nh = do ch <- readCharOffAddr (A# addr) (I# nh) @@ -414,7 +410,7 @@ hGetPS hdl len@(I# len#) in hFillBufBA hdl byte_array len >>= \ (I# read#) -> if read# ==# 0# then -- EOF or other error - fail (userError "hGetPS: EOF reached or other error") + ioError (userError "hGetPS: EOF reached or other error") else {- The system call may not return the number of @@ -445,6 +441,7 @@ lengthPS ps = I# (lengthPS# ps) {-# INLINE lengthPS# #-} +lengthPS# :: PackedString -> Int# lengthPS# (PS _ i _) = i lengthPS# (CPS _ i) = i @@ -474,6 +471,7 @@ indexPS ps (I# n) = C# (indexPS# ps n) {-# INLINE indexPS# #-} +indexPS# :: PackedString -> Int# -> Char# indexPS# (PS bs i _) n = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10) indexCharArray# bs n @@ -591,7 +589,7 @@ filterPS pred ps = (I# off', cs) copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s () - copy_arr arr# [_] _ _ = return () + copy_arr _ [_] _ _ = return () copy_arr arr# ls n i = let (x,ls') = matchOffset 0# ls @@ -645,11 +643,9 @@ foldlPS f b ps foldrPS :: (Char -> a -> a) -> a -> PackedString -> a -foldrPS f b ps - = if nullPS ps then - b - else - whizzRL b len +foldrPS f v ps + | nullPS ps = v + | otherwise = whizzRL v len where len = lengthPS# ps @@ -772,7 +768,6 @@ concatPS [] = nilPS concatPS pss = let tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x } - tot_len = I# tot_len# in runST ( new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte! @@ -868,6 +863,7 @@ The definition of @_substrPS@ is essentially: substrPS :: PackedString -> Int -> Int -> PackedString substrPS ps (I# begin) (I# end) = substrPS# ps begin end +substrPS# :: PackedString -> Int# -> Int# -> PackedString substrPS# ps s e | s <# 0# || e <# s = error "substrPS: bounds out of range" @@ -889,7 +885,6 @@ substrPS# ps s e len = lengthPS# ps result_len# = (if e <# len then (e +# 1#) else len) -# s - result_len = I# result_len# ----------------------- fill_in :: MutableByteArray s Int -> Int# -> ST s () @@ -923,7 +918,7 @@ packCBytes :: Int -> Addr -> PackedString packCBytes len addr = runST (packCBytesST len addr) packCBytesST :: Int -> Addr -> ST s PackedString -packCBytesST len@(I# length#) (A# addr) = +packCBytesST (I# length#) (A# addr) = {- allocate an array that will hold the string (not forgetting the NUL byte at the end) diff --git a/ghc/lib/misc/Readline.lhs b/ghc/lib/misc/Readline.lhs index 7258726..0ddb80d 100644 --- a/ghc/lib/misc/Readline.lhs +++ b/ghc/lib/misc/Readline.lhs @@ -53,8 +53,8 @@ type RlCallbackFunction = %*************************************************************************** \begin{code} -readline :: String -> -- Prompt String - IO String -- Returned line +readline :: String -- Prompt String + -> IO String -- Returned line readline prompt = do --ToDo: Get the "Live register in _casm_GC_ " bug fixed -- this stops us passing the prompt string to readline directly :-( diff --git a/ghc/lib/misc/Regex.lhs b/ghc/lib/misc/Regex.lhs index 2153b62..6cf3c95 100644 --- a/ghc/lib/misc/Regex.lhs +++ b/ghc/lib/misc/Regex.lhs @@ -62,7 +62,7 @@ createPatBuffer :: Bool -> IO PatBuffer createPatBuffer insensitive = _casm_ ``%r = (int)sizeof(struct re_pattern_buffer);'' >>= \ sz -> - stToIO (newCharArray (0,sz)) >>= \ (MutableByteArray _ pbuf#) -> + stToIO (newCharArray (0::Int,sz)) >>= \ (MutableByteArray _ pbuf#) -> let pbuf = PatBuffer# pbuf# in @@ -161,7 +161,7 @@ re_match pbuf str start reg (lengthPS str) start regs >>= \ match_res -> - if match_res == (-2) then + if match_res == ((-2)::Int) then error "re_match: Internal error" else if match_res < 0 then _casm_ ``free((struct re_registers *)%0); '' regs >> @@ -208,7 +208,7 @@ re_match2 pbuf str1 str2 start stop reg start regs stop >>= \ match_res -> - if match_res == (-2) then + if match_res == ((-2)::Int) then error "re_match2: Internal error" else if match_res < 0 then _casm_ ``free((struct re_registers *)%0); '' regs >> @@ -244,7 +244,7 @@ re_search pbuf str start range reg start range regs >>= \ match_res -> - if match_res== (-1) then + if match_res== ((-1)::Int) then _casm_ `` free((struct re_registers *)%0); '' regs >> return Nothing else @@ -293,7 +293,7 @@ re_search2 pbuf str1 str2 start range stop reg range regs stop >>= \ match_res -> - if match_res== (-1) then + if match_res== ((-1)::Int) then _casm_ `` free((struct re_registers *)%0); '' regs >> return Nothing else @@ -331,8 +331,8 @@ build_re_match str_start str_end regs aft lst) where - match_reg_to_array regs len - = trundleIO regs (0,[]) len >>= \ (no,ls) -> + match_reg_to_array rs len + = trundleIO rs (0,[]) len >>= \ (no,ls) -> let (st,end,ls') = case ls of @@ -351,17 +351,17 @@ build_re_match str_start str_end regs -> Int -> IO (Int,[(Int,Int)]) - trundleIO regs (i,acc) len + trundleIO rs (i,acc) len | i==len = return (i,reverse acc) | otherwise - = _casm_ ``%r = (int)(((struct re_registers *)%0)->start)[(int)%1];'' regs i >>= \ start -> - _casm_ ``%r = (int)(((struct re_registers *)%0)->end)[(int)%1];'' regs i >>= \ end -> + = _casm_ ``%r = (int)(((struct re_registers *)%0)->start)[(int)%1];'' rs i >>= \ start -> + _casm_ ``%r = (int)(((struct re_registers *)%0)->end)[(int)%1];'' rs i >>= \ end -> let acc' = (start,end):acc in if (start == (-1)) && (end == (-1)) then return (i,reverse acc) else - trundleIO regs (i+1,acc') len + trundleIO rs (i+1,acc') len \end{code} diff --git a/ghc/lib/misc/SocketPrim.lhs b/ghc/lib/misc/SocketPrim.lhs index b0acd44..7f1472e 100644 --- a/ghc/lib/misc/SocketPrim.lhs +++ b/ghc/lib/misc/SocketPrim.lhs @@ -238,7 +238,7 @@ socket family stype protocol = do status <- _ccall_ createSocket (packFamily family) (packSocketType stype) protocol - case status of + case (status::Int) of -1 -> constructErrorAndFail "socket" n -> do socket_status <- newIORef NotConnected @@ -265,7 +265,7 @@ bindSocket :: Socket -- Unconnected Socket -> SockAddr -- Address to Bind to -> IO () -bindSocket (MkSocket s family stype protocol socketStatus) addr = do +bindSocket (MkSocket s _family _stype _protocol socketStatus) addr = do #ifndef cygwin32_TARGET_OS let isDomainSocket = if family == AF_UNIX then 1 else (0::Int) #else @@ -274,20 +274,20 @@ bindSocket (MkSocket s family stype protocol socketStatus) addr = do currentStatus <- readIORef socketStatus if currentStatus /= NotConnected then - fail (userError ("bindSocket: can't peform bind on socket in status " ++ + ioError (userError ("bindSocket: can't peform bind on socket in status " ++ show currentStatus)) else do addr' <- packSockAddr addr let (_,sz) = boundsOfByteArray addr' - status <- _ccall_ bindSocket s addr' sz isDomainSocket - case status of + status <- _ccall_ bindSocket s addr' sz (isDomainSocket::Int) + case (status::Int) of -1 -> constructErrorAndFail "bindSocket" - 0 -> writeIORef socketStatus (Bound) + _ -> writeIORef socketStatus (Bound) \end{code} Make a connection to an already opened socket on a given machine and port. -assumes that we have already called createSocket, othewise it will fail. +assumes that we have already called createSocket, otherwise it will fail. This is the dual to $bindSocket$. The {\em server} process will usually bind to a port number, the {\em client} will then connect to @@ -300,7 +300,7 @@ connect :: Socket -- Unconnected Socket -> SockAddr -- Socket address stuff -> IO () -connect (MkSocket s family stype protocol socketStatus) addr = do +connect (MkSocket s _family _stype _protocol socketStatus) addr = do #ifndef cygwin32_TARGET_OS let isDomainSocket = if family == AF_UNIX then 1 else (0::Int) #else @@ -309,15 +309,15 @@ connect (MkSocket s family stype protocol socketStatus) addr = do currentStatus <- readIORef socketStatus if currentStatus /= NotConnected then - fail (userError ("connect: can't peform connect on socket in status " ++ + ioError (userError ("connect: can't peform connect on socket in status " ++ show currentStatus)) else do addr' <- packSockAddr addr let (_,sz) = boundsOfByteArray addr' - status <- _ccall_ connectSocket s addr' sz isDomainSocket - case status of + status <- _ccall_ connectSocket s addr' sz (isDomainSocket::Int) + case (status::Int) of -1 -> constructErrorAndFail "connect" - 0 -> writeIORef socketStatus Connected + _ -> writeIORef socketStatus Connected \end{code} The programmer must call $listen$ to tell the system software @@ -335,17 +335,17 @@ listen :: Socket -- Connected & Bound Socket -> Int -- Queue Length -> IO () -listen (MkSocket s family stype protocol socketStatus) backlog = do +listen (MkSocket s _family _stype _protocol socketStatus) backlog = do currentStatus <- readIORef socketStatus if currentStatus /= Bound then - fail (userError ("listen: can't peform listen on socket in status " ++ + ioError (userError ("listen: can't peform listen on socket in status " ++ show currentStatus)) else do status <- _ccall_ listenSocket s backlog - case status of + case (status::Int) of -1 -> constructErrorAndFail "listen" - 0 -> writeIORef socketStatus Listening + _ -> writeIORef socketStatus Listening \end{code} A call to $accept$ only returns when data is available on the given @@ -364,20 +364,20 @@ accept sock@(MkSocket s family stype protocol status) = do okay <- sIsAcceptable sock if not okay then - fail (userError ("accept: can't peform accept on socket in status " ++ + ioError (userError ("accept: can't peform accept on socket in status " ++ show currentStatus)) else do (ptr, sz) <- allocSockAddr family int_star <- stToIO (newIntArray (0,1)) stToIO (writeIntArray int_star 0 sz) - sock <- _ccall_ acceptSocket s ptr int_star - case sock of + new_sock <- _ccall_ acceptSocket s ptr int_star + case (new_sock::Int) of -1 -> constructErrorAndFail "accept" _ -> do - sz <- stToIO (readIntArray int_star 0) - addr <- unpackSockAddr ptr sz - status <- newIORef Connected - return ((MkSocket sock family stype protocol status), addr) + a_sz <- stToIO (readIntArray int_star 0) + addr <- unpackSockAddr ptr a_sz + new_status <- newIORef Connected + return ((MkSocket new_sock family stype protocol new_status), addr) \end{code} %************************************************************************ @@ -399,15 +399,15 @@ writeSocket :: Socket -- Connected Socket -> String -- Data to send -> IO Int -- Number of Bytes sent -writeSocket (MkSocket s family stype protocol status) xs = do +writeSocket (MkSocket s _family _stype _protocol status) xs = do currentStatus <- readIORef status if not ((currentStatus == Connected) || (currentStatus == Listening)) then - fail (userError ("writeSocket: can't peform write on socket in status " ++ + ioError (userError ("writeSocket: can't peform write on socket in status " ++ show currentStatus)) else do nbytes <- _ccall_ writeDescriptor s xs (length xs) - case nbytes of + case (nbytes::Int) of -1 -> constructErrorAndFail "writeSocket" _ -> return nbytes @@ -417,17 +417,17 @@ sendTo :: Socket -- Bound/Connected Socket -> SockAddr -> IO Int -- Number of Bytes sent -sendTo (MkSocket s family stype protocol status) xs addr = do +sendTo (MkSocket s _family _stype _protocol status) xs addr = do currentStatus <- readIORef status if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound)) then - fail (userError ("sendTo: can't peform write on socket in status " ++ + ioError (userError ("sendTo: can't peform write on socket in status " ++ show currentStatus)) else do addr' <- packSockAddr addr let (_,sz) = boundsOfByteArray addr' nbytes <- _ccall_ sendTo__ s xs (length xs) addr' sz - case nbytes of + case (nbytes::Int) of -1 -> constructErrorAndFail "sendTo" _ -> return nbytes @@ -435,21 +435,21 @@ readSocket :: Socket -- Connected (or bound) Socket -> Int -- Number of Bytes to Read -> IO (String, Int) -- (Data Read, Number of Bytes) -readSocket (MkSocket s family stype protocol status) nbytes = do +readSocket (MkSocket s _family _stype _protocol status) nbytes = do currentStatus <- readIORef status if not ((currentStatus == Connected) || (currentStatus == Listening)) then - fail (userError ("readSocket: can't perform read on socket in status " ++ + ioError (userError ("readSocket: can't perform read on socket in status " ++ show currentStatus)) else do - ptr <- allocChars nbytes - nbytes <- _ccall_ readDescriptor s ptr nbytes - case nbytes of + ptr <- allocChars nbytes + rlen <- _ccall_ readDescriptor s ptr nbytes + case (rlen::Int) of -1 -> constructErrorAndFail "readSocket" n -> do barr <- stToIO (unsafeFreezeByteArray ptr) - s <- unpackNBytesBAIO barr n - return (s,n) + str <- unpackNBytesBAIO barr n + return (str, n) readSocketAll :: Socket -> IO String readSocketAll s = @@ -466,23 +466,23 @@ readSocketAll s = loop "" recvFrom :: Socket -> Int -> IO (String, Int, SockAddr) -recvFrom (MkSocket s family stype protocol status) nbytes = do +recvFrom (MkSocket s _family _stype _protocol status) nbytes = do currentStatus <- readIORef status if not ((currentStatus == Connected) || (currentStatus == Listening) || (currentStatus == Bound)) then - fail (userError ("recvFrom: can't perform read on socket in status " ++ + ioError (userError ("recvFrom: can't perform read on socket in status " ++ show currentStatus)) else do - ptr <- allocChars nbytes + ptr <- allocChars nbytes (ptr_addr,_) <- allocSockAddr AF_INET - nbytes <- _ccall_ recvFrom__ s ptr nbytes ptr_addr - case nbytes of + rlen <- _ccall_ recvFrom__ s ptr nbytes ptr_addr + case (rlen::Int) of -1 -> constructErrorAndFail "recvFrom" n -> do barr <- stToIO (unsafeFreezeByteArray ptr) addr <- unpackSockAddrInet ptr_addr - s <- unpackNBytesBAIO barr n - return (s, n, addr) + str <- unpackNBytesBAIO barr n + return (str, n, addr) \end{code} @@ -493,11 +493,11 @@ was given $aNY\_PORT$. \begin{code} socketPort :: Socket -- Connected & Bound Socket -> IO PortNumber -- Port Number of Socket -socketPort sock@(MkSocket s AF_INET stype protocol status) = +socketPort sock@(MkSocket _ AF_INET _ _ _) = getSocketName sock >>= \(SockAddrInet port _) -> return port -socketPort (MkSocket s family stype protocol status) = - fail (userError ("socketPort: not supported for Family " ++ show family)) +socketPort (MkSocket _ family _ _ _) = + ioError (userError ("socketPort: not supported for Family " ++ show family)) \end{code} Calling $getPeerName$ returns the address details of the machine, @@ -509,12 +509,12 @@ is $getSocketName$. \begin{code} getPeerName :: Socket -> IO SockAddr -getPeerName (MkSocket s family stype protocol status) = do - (ptr, sz) <- allocSockAddr family +getPeerName (MkSocket s family _ _ _) = do + (ptr, a_sz) <- allocSockAddr family int_star <- stToIO (newIntArray (0,1)) - stToIO (writeIntArray int_star 0 sz) + stToIO (writeIntArray int_star 0 a_sz) status <- _ccall_ getPeerName s ptr int_star - case status of + case (status::Int) of -1 -> constructErrorAndFail "getPeerName" _ -> do sz <- stToIO (readIntArray int_star 0) @@ -522,12 +522,12 @@ getPeerName (MkSocket s family stype protocol status) = do getSocketName :: Socket -> IO SockAddr -getSocketName (MkSocket s family stype protocol status) = do - (ptr, sz) <- allocSockAddr family +getSocketName (MkSocket s family _ _ _) = do + (ptr, a_sz) <- allocSockAddr family int_star <- stToIO (newIntArray (0,1)) - stToIO (writeIntArray int_star 0 sz) - status <- _ccall_ getSockName s ptr int_star - case status of + stToIO (writeIntArray int_star 0 a_sz) + rc <- _ccall_ getSockName s ptr int_star + case (rc::Int) of -1 -> constructErrorAndFail "getSocketName" _ -> do sz <- stToIO (readIntArray int_star 0) @@ -595,16 +595,16 @@ setSocketOption :: Socket -> SocketOption -- Option Name -> Int -- Option Value -> IO () -setSocketOption (MkSocket s family stype protocol status) so v = do +setSocketOption (MkSocket s _ _ _ _) so v = do rc <- _ccall_ setSocketOption__ s (packSocketOption so) v - if rc /= 0 + if rc /= (0::Int) then constructErrorAndFail "setSocketOption" else return () getSocketOption :: Socket -> SocketOption -- Option Name -> IO Int -- Option Value -getSocketOption (MkSocket s family stype protocol status) so = do +getSocketOption (MkSocket s _ _ _ _) so = do rc <- _ccall_ getSocketOption__ s (packSocketOption so) if rc == -1 -- let's just hope that value isn't taken.. then constructErrorAndFail "getSocketOption" @@ -1015,7 +1015,10 @@ aNY_PORT = mkPortNumber 0 iNADDR_ANY :: HostAddress iNADDR_ANY = unsafePerformIO (_casm_ `` %r = htonl(INADDR_ANY); '') -sOMAXCONN = ``SOMAXCONN''::Int +sOMAXCONN :: Int +sOMAXCONN = ``SOMAXCONN'' + +maxListenQueue :: Int maxListenQueue = sOMAXCONN ------------------------------------------------------------------------------- @@ -1033,59 +1036,58 @@ shutdown :: Socket -> ShutdownCmd -> IO () shutdown (MkSocket s _ _ _ _) stype = do let t = sdownCmdToInt stype status <- _ccall_ shutdownSocket s t - case status of + case (status::Int) of -1 -> constructErrorAndFail "shutdown" _ -> return () ------------------------------------------------------------------------------- sClose :: Socket -> IO () -sClose (MkSocket s family stype protocol status) = _ccall_ close s +sClose (MkSocket s _ _ _ _) = _ccall_ close s ------------------------------------------------------------------------------- sIsConnected :: Socket -> IO Bool -sIsConnected (MkSocket s family stype protocol status) = do +sIsConnected (MkSocket _ _ _ _ status) = do value <- readIORef status return (value == Connected) ------------------------------------------------------------------------------- sIsBound :: Socket -> IO Bool -sIsBound (MkSocket s family stype protocol status) = do +sIsBound (MkSocket _ _ _ _ status) = do value <- readIORef status return (value == Bound) ------------------------------------------------------------------------------- sIsListening :: Socket -> IO Bool -sIsListening (MkSocket s family stype protocol status) = do +sIsListening (MkSocket _ _ _ _ status) = do value <- readIORef status return (value == Listening) ------------------------------------------------------------------------------- sIsReadable :: Socket -> IO Bool -sIsReadable (MkSocket s family stype protocol status) = do +sIsReadable (MkSocket _ _ _ _ status) = do value <- readIORef status return (value == Listening || value == Connected) ------------------------------------------------------------------------------- sIsWritable :: Socket -> IO Bool -sIsWritable = sIsReadable +sIsWritable = sIsReadable -- sort of. ------------------------------------------------------------------------------- sIsAcceptable :: Socket -> IO Bool #ifndef cygwin32_TARGET_OS -sIsAcceptable (MkSocket s AF_UNIX Stream protocol status) = do +sIsAcceptable (MkSocket _ AF_UNIX Stream _ _) = do value <- readIORef status return (value == Connected || value == Bound || value == Listening) -sIsAcceptable (MkSocket s AF_UNIX _ protocol status) = - return False +sIsAcceptable (MkSocket _ AF_UNIX _ _ _) = return False #endif -sIsAcceptable (MkSocket s _ stype protocol status) = do +sIsAcceptable (MkSocket _ _ _ _ status) = do value <- readIORef status return (value == Connected || value == Listening) @@ -1105,7 +1107,7 @@ inet_addr :: String -> IO HostAddress inet_addr ipstr = do had <- _ccall_ inet_addr ipstr if had == (W# (int2Word# (negateInt# 1#))) -- hack to avoid depending on Int.intToWord here. - then fail (userError ("inet_addr: Malformed address: " ++ ipstr)) + then ioError (userError ("inet_addr: Malformed address: " ++ ipstr)) else return had -- network byte order inet_ntoa :: HostAddress -> IO String @@ -1201,9 +1203,9 @@ it subsequently. #ifndef __PARALLEL_HASKELL__ socketToHandle :: Socket -> IOMode -> IO Handle -socketToHandle (MkSocket fd family stype protocol status) m = do - fo <- _ccall_ openFd fd file_mode flush_on_close - fo <- makeForeignObj fo +socketToHandle (MkSocket fd _ _ _ _) m = do + fileobj <- _ccall_ openFd fd (file_mode::Int) (flush_on_close::Int) + fo <- makeForeignObj fileobj addForeignFinaliser fo (freeFileObject fo) mkBuffer__ fo 0 -- not buffered hndl <- newHandle (Handle__ fo htype NoBuffering socket_str) -- 1.7.10.4