-syslib misc meets Haskell 98.
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
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
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 ()
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
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 ?
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
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
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 ()
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 ()
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)
\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
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
_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
| 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
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
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
-> 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
-}
-- 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
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)
-- (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)
-- 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
-- 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
\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 [] =
-> [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
\begin{code}
flattenS :: FAST_BOOL -> [WorkItem] -> String
-flattenS nlp [] = ""
+flattenS _ [] = ""
flattenS nlp ((WI col seq):seqs) = flatten col nlp seq seqs
\end{code}
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
disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool
-disjointLists [] bs = True
+disjointLists [] _ = True
disjointLists (a:as) bs
| a `elem` bs = False
| otherwise = disjointLists as bs
-> [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
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,
-> 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
-> 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 }
str
= search str
where
- global = 'g' `elem` flags
case_insensitive = 'i' `elem` flags
mode = 's' `elem` flags -- single-line mode
pat = unsafePerformIO (
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}
-> 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
\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
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)
\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
\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}
~~~~~~~~~~~~~~~
\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
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}
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
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 [])
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) ->
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 (
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)
= 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
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 ()
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}
-- = [ 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 = []
where
ch = indexCharArray# bytes nh
-unpackPS (CPS addr len)
- = unpack 0#
+unpackPS (CPS addr _) = unpack 0#
where
unpack nh
| ch `eqChar#` '\0'# = []
| 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)
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
{-# INLINE lengthPS# #-}
+lengthPS# :: PackedString -> Int#
lengthPS# (PS _ i _) = i
lengthPS# (CPS _ i) = i
{-# 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
(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
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
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!
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"
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 ()
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)
%***************************************************************************
\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 :-(
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
(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 >>
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 >>
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
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
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
-> 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}
status <- _ccall_ createSocket (packFamily family)
(packSocketType stype)
protocol
- case status of
+ case (status::Int) of
-1 -> constructErrorAndFail "socket"
n -> do
socket_status <- newIORef NotConnected
-> 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
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
-> 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
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
-> 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
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}
%************************************************************************
-> 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
-> 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
-> 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 =
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}
\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,
\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)
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)
-> 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"
iNADDR_ANY :: HostAddress
iNADDR_ANY = unsafePerformIO (_casm_ `` %r = htonl(INADDR_ANY); '')
-sOMAXCONN = ``SOMAXCONN''::Int
+sOMAXCONN :: Int
+sOMAXCONN = ``SOMAXCONN''
+
+maxListenQueue :: Int
maxListenQueue = sOMAXCONN
-------------------------------------------------------------------------------
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)
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
#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)
projects / ghc-hetmet.git / commitdiff