Commit 94ac8915 authored by sof's avatar sof
Browse files

[project @ 1999-01-14 18:17:32 by sof]

-syslib misc meets Haskell 98.
parent a9d0fc54
......@@ -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
......
......@@ -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)
......
......@@ -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 [] =
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 [])
......
......@@ -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)
......
......@@ -53,8 +53,8 @@ type RlCallbackFunction =
%***************************************************************************