import PrimPacked
import GlaExts
-import Addr ( Addr(..) )
+import PrelAddr ( Addr(..) )
+#if __GLASGOW_HASKELL__ < 407
import MutableArray ( MutableArray(..) )
+#else
+import PrelArr ( STArray(..), newSTArray )
+import IOExts ( hPutBuf, hPutBufBA )
+#endif
-- ForeignObj is now exported abstractly.
#if __GLASGOW_HASKELL__ >= 303
getByteArray# (FastString _ _ ba#) = ba#
getByteArray :: FastString -> ByteArray Int
+#if __GLASGOW_HASKELL__ < 405
getByteArray (FastString _ l# ba#) = ByteArray (0,I# l#) ba#
+#else
+getByteArray (FastString _ l# ba#) = ByteArray 0 (I# l#) ba#
+#endif
lengthFS :: FastString -> Int
lengthFS (FastString _ l# _) = I# l#
nullFastString (CharStr _ l#) = l# ==# 0#
unpackFS :: FastString -> String
-unpackFS (FastString _ l# ba#) = unpackCStringBA# ba# l#
+unpackFS (FastString _ l# ba#) = unpackNBytesBA# ba# l#
unpackFS (CharStr addr len#) =
unpack 0#
where
string_table :: FastStringTableVar
string_table =
unsafePerformIO (
- stToIO (newArray (0::Int,hASH_TBL_SIZE) []) >>= \ (MutableArray _ arr#) ->
+#if __GLASGOW_HASKELL__ < 405
+ stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
+ >>= \ (MutableArray _ arr#) ->
+#elif __GLASGOW_HASKELL__ < 407
+ stToIO (newArray (0::Int,hASH_TBL_SIZE) [])
+ >>= \ (MutableArray _ _ arr#) ->
+#else
+ stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
+ >>= \ (STArray _ _ arr#) ->
+#endif
newIORef (FastStringTable 0# arr#))
lookupTbl :: FastStringTable -> Int# -> IO [FastString]
-- the string into a ByteArray
-- _trace "empty bucket" $
case copyPrefixStr (A# a#) (I# len#) of
+#if __GLASGOW_HASKELL__ < 405
(ByteArray _ barr#) ->
+#else
+ (ByteArray _ _ barr#) ->
+#endif
let f_str = FastString uid# len# barr# in
updTbl string_table ft h [f_str] >>
({- _trace ("new: " ++ show f_str) $ -} return f_str)
case bucket_match ls len# a# of
Nothing ->
case copyPrefixStr (A# a#) (I# len#) of
- (ByteArray _ barr#) ->
+#if __GLASGOW_HASKELL__ < 405
+ (ByteArray _ barr#) ->
+#else
+ (ByteArray _ _ barr#) ->
+#endif
let f_str = FastString uid# len# barr# in
updTbl string_table ft h (f_str:ls) >>
( {- _trace ("new: " ++ show f_str) $ -} return f_str)
-- no match, add it to table by copying out the
-- the string into a ByteArray
case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
+#if __GLASGOW_HASKELL__ < 405
(ByteArray _ barr#) ->
+#else
+ (ByteArray _ _ barr#) ->
+#endif
let f_str = FastString uid# len# barr# in
updTbl string_table ft h [f_str] >>
return f_str
case bucket_match ls start# len# fo# of
Nothing ->
case copySubStrFO (_ForeignObj fo#) (I# start#) (I# len#) of
- (ByteArray _ barr#) ->
+#if __GLASGOW_HASKELL__ < 405
+ (ByteArray _ barr#) ->
+#else
+ (ByteArray _ _ barr#) ->
+#endif
let f_str = FastString uid# len# barr# in
updTbl string_table ft h (f_str:ls) >>
( {- _trace ("new: " ++ show f_str) $ -} return f_str)
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket(b)" $
+#if __GLASGOW_HASKELL__ < 405
case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
(ByteArray _ ba#) ->
+#else
+ case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
+ (ByteArray _ _ ba#) ->
+#endif
let f_str = FastString uid# len# ba# in
updTbl string_table ft h [f_str] >>
-- _trace ("new(b): " ++ show f_str) $
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls start# len# barr# of
Nothing ->
- case copySubStrBA (ByteArray (error "") barr#) (I# start#) (I# len#) of
+#if __GLASGOW_HASKELL__ < 405
+ case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of
(ByteArray _ ba#) ->
+#else
+ case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of
+ (ByteArray _ _ ba#) ->
+#endif
let f_str = FastString uid# len# ba# in
updTbl string_table ft h (f_str:ls) >>
-- _trace ("new(b): " ++ show f_str) $
mkFastString :: String -> FastString
mkFastString str =
case packString str of
+#if __GLASGOW_HASKELL__ < 405
(ByteArray (_,I# len#) frozen#) ->
+#else
+ (ByteArray _ (I# len#) frozen#) ->
+#endif
mkFastSubStringBA# frozen# 0# len#
{- 0-indexed array, len# == index to one beyond end of string,
i.e., (0,1) => empty string. -}
EQ
else
unsafePerformIO (
- _ccall_ strcmp (ByteArray bottom b1#) (ByteArray bottom b2#) >>= \ (I# res) ->
+#if __GLASGOW_HASKELL__ < 405
+ _ccall_ strcmp (ByteArray bot b1#) (ByteArray bot b2#) >>= \ (I# res) ->
+#else
+ _ccall_ strcmp (ByteArray bot bot b1#) (ByteArray bot bot b2#) >>= \ (I# res) ->
+#endif
return (
if res <# 0# then LT
else if res ==# 0# then EQ
else GT
))
where
- bottom :: (Int,Int)
- bottom = error "tagCmp"
+#if __GLASGOW_HASKELL__ < 405
+ bot :: (Int,Int)
+#else
+ bot :: Int
+#endif
+ bot = error "tagCmp"
cmpFS (CharStr bs1 len1) (CharStr bs2 len2)
= unsafePerformIO (
_ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
else GT
))
where
+#if __GLASGOW_HASKELL__ < 405
ba1 = ByteArray ((error "")::(Int,Int)) bs1
+#else
+ ba1 = ByteArray (error "") ((error "")::Int) bs1
+#endif
ba2 = A# bs2
cmpFS a@(CharStr _ _) b@(FastString _ _ _)
other ->
let fp = filePtr htype in
-- here we go..
+#if __GLASGOW_HASKELL__ < 405
_ccall_ writeFile (ByteArray ((error "")::(Int,Int)) ba#) fp (I# l#) >>= \rc ->
+#else
+ _ccall_ writeFile (ByteArray ((error "")::Int) ((error "")::Int) ba#) fp (I# l#) >>= \rc ->
+#endif
if rc==0 then
return ()
else
#else
hPutFS handle (FastString _ l# ba#)
| l# ==# 0# = return ()
- | otherwise = hPutBufBA handle (ByteArray bottom ba#) (I# l#)
+#if __GLASGOW_HASKELL__ < 405
+ | otherwise = hPutBufBA handle (ByteArray bot ba#) (I# l#)
+#elif __GLASGOW_HASKELL__ < 407
+ | otherwise = hPutBufBA handle (ByteArray bot bot ba#) (I# l#)
+#else
+ | otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
+ hPutBufBA handle mba (I# l#)
+ return ()
+#endif
where
- bottom = error "hPutFS.ba"
+ bot = error "hPutFS.ba"
--ToDo: avoid silly code duplic.
hPutFS handle (CharStr a# l#)
| l# ==# 0# = return ()
- | otherwise = hPutBuf handle (A# a#) (I# l#)
+ | otherwise = do hPutBuf handle (A# a#) (I# l#) ; return ()
#endif