darcs-cabalized-2.0.2: src/FastPackedString.hs
{-# OPTIONS_GHC -fffi -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : FastPackedString
-- Copyright : (c) The University of Glasgow 2001,
-- David Roundy 2003-2005
-- License : GPL (I'm happy to also license this file BSD style but don't
-- want to bother distributing two license files with darcs.
--
-- Maintainer : droundy@abridgegame.org
-- Stability : experimental
-- Portability : portable
--
-- An efficient implementation of strings.
--
-----------------------------------------------------------------------------
-- Original GHC implementation by Bryan O\'Sullivan,
-- rewritten to use UArray by Simon Marlow.
-- rewritten to support slices and use ForeignPtr by David Roundy
module FastPackedString (
-- * The @PackedString@ type
PackedString, -- abstract, instances: Eq, Ord, Show, Typeable
unsafeWithInternals, -- :: PackedString -> (Ptr Word8 -> Int -> IO a) -> IO a
-- * Converting to and from @PackedString@s
generatePS, -- :: Int -> (Ptr Word8 -> Int -> IO Int) -> IO PackedString
packString, -- :: String -> PackedString
withCStringPS, -- :: PackedString -> (CString -> IO a) -> IO a
unsafeWithCStringLenPS, -- :: PackedString -> ((CString,Int) -> IO a) -> IO a
packWords, -- :: [Word8] -> PackedString
unpackPS, -- :: PackedString -> String
unpackPSfromUTF8, -- :: PackedString -> String
-- * I\/O with @PackedString@s
hPutPS, -- :: Handle -> PackedString -> IO ()
hGetPS, -- :: Handle -> Int -> IO PackedString
hGetContentsPS, -- :: Handle -> IO PackedString
readFilePS, -- :: FilePath -> IO PackedString
writeFilePS, -- :: FilePath -> PackedString -> IO ()
gzReadFilePS,-- :: FilePath -> IO PackedString
mmapFilePS, -- :: FilePath -> IO PackedString
gzWriteFilePS, -- :: FilePath -> PackedString -> IO ()
gzWriteFilePSs, -- :: FilePath -> [PackedString] -> IO ()
-- * List-like manipulation functions
nilPS, -- :: PackedString
ifHeadThenTail, -- :: Word8 -> PackedString -> Maybe PackedString
headPS, -- :: PackedString -> Char
tailPS, -- :: PackedString -> PackedString
initPS, -- :: PackedString -> PackedString
lastPS, -- :: PackedString -> Char
nullPS, -- :: PackedString -> Bool
appendPS, -- :: PackedString -> PackedString -> PackedString
lengthPS, -- :: PackedString -> Int
indexPS, -- :: PackedString -> Int -> Char
indexPSW, -- :: PackedString -> Int -> Word8
reversePS, -- :: PackedString -> PackedString
concatPS, -- :: [PackedString] -> PackedString
takePS, -- :: Int -> PackedString -> PackedString
dropPS, -- :: Int -> PackedString -> PackedString
splitAtPS, -- :: Int -> PackedString -> (PackedString, PackedString)
anyPS,
takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
dropWhitePS, -- :: PackedString -> PackedString
breakWhitePS,-- :: PackedString -> Maybe (PackedString,PackedString)
spanEndPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
breakOnPS, -- :: Char -> PackedString -> (PackedString, PackedString)
linesPS, -- :: PackedString -> [PackedString]
unlinesPS, -- :: [PackedString] -> PackedString
findPS,
hashPS,
splitPS, -- :: Char -> PackedString -> [PackedString]
breakFirstPS,-- :: Char -> PackedString -> Maybe (PackedString,PackedString)
breakLastPS, -- :: Char -> PackedString -> Maybe (PackedString,PackedString)
substrPS, -- :: PackedString -> PackedString -> Maybe Int
readIntPS, -- :: PackedString -> Maybe (Int, PackedString)
is_funky, -- :: PackedString -> Bool
fromHex2PS, -- :: PackedString -> PackedString
fromPS2Hex, -- :: PackedString -> PackedString
betweenLinesPS,-- :: PackedString -> PackedString -> PackedString -> Maybe (PackedString)
break_after_nth_newline,
break_before_nth_newline,
) where
#ifndef HAVE_BYTESTRING
import OldFastPackedString
#else
import System.IO ( Handle, hClose, hFileSize, IOMode(ReadMode),
hSeek, SeekMode(SeekFromEnd), hGetChar )
import Autoconf ( use_mmap )
import Foreign.Storable ( peekElemOff, peek )
import Foreign.Marshal.Alloc ( free )
import Foreign.Marshal.Array ( pokeArray, mallocArray,
peekArray, advancePtr )
import Foreign.C.String
import Foreign.C.Types ( CInt, CSize )
import Data.Bits ( rotateL )
import Data.Char
import Data.Word
import Data.Int ( Int32 )
import qualified Data.List as L
import Control.Monad ( liftM, when )
import System.IO.Unsafe ( unsafePerformIO )
import System.IO ( hGetBuf )
import System.IO ( openBinaryFile, )
import Foreign.Ptr ( nullPtr, plusPtr, Ptr )
import Foreign.ForeignPtr( ForeignPtr, withForeignPtr )
#if defined(__GLASGOW_HASKELL__)
import qualified Foreign.Concurrent as FC ( newForeignPtr )
import System.Posix ( handleToFd )
#endif
#ifdef DEBUG_PS
import Foreign.ForeignPtr ( addForeignPtrFinalizer )
import Foreign.Ptr ( FunPtr )
#endif
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Unsafe as BU
debugForeignPtr :: ForeignPtr a -> String -> IO ()
#ifdef DEBUG_PS
foreign import ccall unsafe "static fpstring.h debug_alloc" debug_alloc
:: Ptr a -> CString -> IO ()
foreign import ccall unsafe "static fpstring.h & debug_free" debug_free
:: FunPtr (Ptr a -> IO ())
debugForeignPtr fp n =
withCString n $ \cname-> withForeignPtr fp $ \p->
do debug_alloc p cname
addForeignPtrFinalizer debug_free fp
#else
debugForeignPtr _ _ = return ()
#endif
mallocForeignPtr :: Int -> IO (ForeignPtr Word8)
mallocForeignPtr = BI.mallocByteString
----------------------------------------------------------------------------
--A way of creating ForeignPtrs outside the IO monad (althogh it still
--isn't entirely "safe", but at least it's convenient.
createPS :: Int -> (Ptr Word8 -> IO ()) -> PackedString
createPS = BI.unsafeCreate
-- -----------------------------------------------------------------------------
-- PackedString type declaration
-- | A space-efficient representation of a 'String', which supports various
-- efficient operations. A 'PackedString' contains full Unicode 'Char's.
type PackedString = BC.ByteString
-- -----------------------------------------------------------------------------
-- unsafeWithInternals
-- | Do something with the internals of a PackedString. Beware of
-- altering the contents!
unsafeWithInternals :: PackedString -> (Ptr Word8 -> Int -> IO a) -> IO a
unsafeWithInternals ps f
= case BI.toForeignPtr ps of
(fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l
-- -----------------------------------------------------------------------------
-- generatePS
-- | Given the maximum size needed and a function to make the contents
-- of a PackedString, generatePS makes the PackedString. The generating
-- function is required to return the actual size (<= the maximum size).
generatePS :: Int -> (Ptr Word8 -> IO Int) -> IO PackedString
generatePS = BI.createAndTrim
-- -----------------------------------------------------------------------------
-- Constructor functions
nilPS :: PackedString
nilPS = BC.empty
-- | Convert a 'String' into a 'PackedString'
packString :: String -> PackedString
packString = BC.pack
packWords :: [Word8] -> PackedString
packWords s = createPS (length s) $ \p -> pokeArray p s
withCStringPS :: PackedString -> (CString -> IO a) -> IO a
withCStringPS = BC.useAsCString
unsafeWithCStringLenPS :: PackedString -> ((CString, Int) -> IO a) -> IO a
unsafeWithCStringLenPS = BU.unsafeUseAsCStringLen
-- -----------------------------------------------------------------------------
-- Destructor functions (taking PackedStrings apart)
-- | Convert a 'PackedString' into a 'String'
unpackPS :: PackedString -> String
unpackPS = BC.unpack
unpackPSfromUTF8 :: PackedString -> String
unpackPSfromUTF8 ps =
case BI.toForeignPtr ps of
(_,_, 0) -> ""
(x,s,l) ->
unsafePerformIO $ withForeignPtr x $ \p->
do outbuf <- mallocArray l
lout <- fromIntegral `liftM`
utf8_to_ints outbuf (p `plusPtr` s) (fromIntegral l)
when (lout < 0) $ error "Bad UTF8!"
str <- (map (chr . fromIntegral)) `liftM` peekArray lout outbuf
free outbuf
return str
foreign import ccall unsafe "static fpstring.h utf8_to_ints" utf8_to_ints
:: Ptr Int -> Ptr Word8 -> CInt -> IO CInt
-- -----------------------------------------------------------------------------
-- List-mimicking functions for PackedStrings
{-# INLINE lengthPS #-}
lengthPS :: PackedString -> Int
lengthPS = BC.length
{-# INLINE indexPSW #-}
indexPSW :: PackedString -> Int -> Word8
indexPSW ps i = BI.c2w $ BC.index ps i
{-# INLINE indexPS #-}
indexPS :: PackedString -> Int -> Char
indexPS p i = BC.index p i
{-# INLINE lastPS #-}
lastPS :: PackedString -> Char
lastPS = BC.last
{-# INLINE ifHeadThenTail #-}
ifHeadThenTail :: Word8 -> PackedString -> Maybe PackedString
ifHeadThenTail w ps =
case BI.toForeignPtr ps of
(x,s,l) ->
if l > 0 && w == unsafePerformIO (withForeignPtr x $ \p -> peekElemOff p s)
then Just $ BI.fromForeignPtr x (s+1) (l-1)
else Nothing
{-# INLINE headPS #-}
headPS :: PackedString -> Char
headPS = BC.head
-- | Extract the elements after the head of a packed string, which must be non-empty.
{-# INLINE tailPS #-}
tailPS :: PackedString -> PackedString
tailPS = BC.tail
-- | Return all the elements of a packed string except the last one.
-- The string must be finite and non-empty.
{-# INLINE initPS #-}
initPS :: PackedString -> PackedString
initPS = BC.init
{-# INLINE nullPS #-}
nullPS :: PackedString -> Bool
nullPS = BC.null
appendPS :: PackedString -> PackedString -> PackedString
appendPS = BC.append
{-# INLINE takePS #-}
takePS :: Int -> PackedString -> PackedString
takePS = BC.take
{-# INLINE dropPS #-}
dropPS :: Int -> PackedString -> PackedString
dropPS = BC.drop
{-# INLINE splitAtPS #-}
splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
splitAtPS = BC.splitAt
-- This must be fast, it's used heavily in Printer. -- jch
anyPS :: (Char -> Bool) -> PackedString -> Bool
anyPS = BC.any
{-# INLINE takeWhilePS #-}
takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
takeWhilePS = BC.takeWhile
{-# INLINE dropWhilePS #-}
dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
dropWhilePS = BC.dropWhile
{-# INLINE dropWhitePS #-}
dropWhitePS :: PackedString -> PackedString
dropWhitePS ps =
case BI.toForeignPtr ps of
(x,s,l) ->
unsafePerformIO $ withForeignPtr x $ \p->
do i <- fromIntegral `liftM`
first_nonwhite (p `plusPtr` s) (fromIntegral l)
return $ if i == l then nilPS
else BI.fromForeignPtr x (s+i) (l-i)
foreign import ccall unsafe "fpstring.h first_nonwhite" first_nonwhite
:: Ptr Word8 -> CInt -> IO CInt
foreign import ccall unsafe "fpstring.h first_white" first_white
:: Ptr Word8 -> CInt -> IO CInt
{-# INLINE is_funky #-}
is_funky :: PackedString -> Bool
is_funky ps = case BI.toForeignPtr ps of
(x,s,l) ->
unsafePerformIO $ withForeignPtr x $ \p->
(/=0) `liftM` has_funky_char (p `plusPtr` s) (fromIntegral l)
foreign import ccall unsafe "fpstring.h has_funky_char" has_funky_char
:: Ptr Word8 -> CInt -> IO CInt
spanEndPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
spanEndPS = BC.spanEnd
breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
breakPS = BC.break
{-# INLINE breakOnPS #-}
breakOnPS :: Char -> PackedString -> (PackedString, PackedString)
breakOnPS c p = case findPS c p of
Nothing -> (p,nilPS)
Just n -> (takePS n p, dropPS n p)
{-# INLINE hashPS #-}
hashPS :: PackedString -> Int32
hashPS ps =
case BI.toForeignPtr ps of
(x,s,l) ->
unsafePerformIO $ withForeignPtr x $ \p->
do hash (p `plusPtr` s) l
hash :: Ptr Word8 -> Int -> IO Int32
hash ptr len = f (0 :: Int32) ptr len
where f h _ 0 = return h
f h p n = do x <- peek p
let h' = (fromIntegral x) + (rotateL h 8)
f h' (p `advancePtr` 1) (n-1)
{-# INLINE substrPS #-}
substrPS :: PackedString -> PackedString -> Maybe Int
substrPS tok str
| nullPS tok = Just 0
| lengthPS tok > lengthPS str = Nothing
| otherwise = do n <- findPS (headPS tok) str
let ttok = tailPS tok
reststr = dropPS (n+1) str
if ttok == takePS (lengthPS ttok) reststr
then Just n
else ((n+1)+) `fmap` substrPS tok reststr
{-# INLINE breakWhitePS #-}
breakWhitePS :: PackedString -> (PackedString,PackedString)
breakWhitePS ps =
case BI.toForeignPtr ps of
(x,s,l) ->
unsafePerformIO $ withForeignPtr x $ \p->
do i <- fromIntegral `liftM` first_white (p `plusPtr` s) (fromIntegral l)
if i == 0 then return (nilPS, BI.fromForeignPtr x s l)
else if i == l
then return (BI.fromForeignPtr x s l, nilPS)
else return (BI.fromForeignPtr x s i, BI.fromForeignPtr x (s+i) (l-i))
-- TODO: replace breakFirstPS and breakLastPS with definitions based on
-- ByteString's break/breakEnd
{-# INLINE breakFirstPS #-}
breakFirstPS :: Char -> PackedString -> Maybe (PackedString,PackedString)
breakFirstPS c p = case findPS c p of
Nothing -> Nothing
Just n -> Just (takePS n p, dropPS (n+1) p)
{-# INLINE breakLastPS #-}
breakLastPS :: Char -> PackedString -> Maybe (PackedString,PackedString)
breakLastPS c p = case findLastPS c p of
Nothing -> Nothing
Just n -> Just (takePS n p, dropPS (n+1) p)
-- TODO: rename
{-# INLINE linesPS #-}
linesPS :: PackedString -> [PackedString]
linesPS ps
| ps == BC.empty = [BC.pack ""]
| otherwise = BC.split '\n' ps
{- QuickCheck property:
import Test.QuickCheck
import qualified Data.ByteString.Char8 as BC
import Data.Char
instance Arbitrary BC.ByteString where
arbitrary = fmap BC.pack arbitrary
instance Arbitrary Char where
arbitrary = chr `fmap` choose (32,127)
deepCheck = check (defaultConfig { configMaxTest = 10000})
testLines = deepCheck (\x -> (linesPS x == linesPSOld x))
linesPSOld ps = case BC.elemIndex '\n' ps of
Nothing -> [ps]
Just n -> takePS n ps : linesPS (dropPS (n+1) ps) -}
{-| This function acts exactly like the "Prelude" unlines function, or like
"Data.ByteString.Char8" 'unlines', but with one important difference: it will
produce a string which may not end with a newline! That is:
> unlinesPS ["foo", "bar"]
evaluates to \"foo\nbar\", not \"foo\nbar\n"! This point should hold true for
'linesPS' as well.
TODO: rename this function. -}
{-# INLINE unlinesPS #-}
unlinesPS :: [PackedString] -> PackedString
unlinesPS [] = BC.empty
unlinesPS x = BC.init $ BC.unlines x
{- QuickCheck property:
testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x))
unlinesPSOld ss = BC.concat $ intersperse_newlines ss
where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s)
intersperse_newlines s = s
newline = BC.pack "\n" -}
reversePS :: PackedString -> PackedString
reversePS = BC.reverse
concatPS :: [PackedString] -> PackedString
concatPS = BC.concat
{-# INLINE findPS #-}
findPS :: Char -> PackedString -> Maybe Int
findPS = BC.elemIndex
{-# INLINE findLastPS #-}
findLastPS :: Char -> PackedString -> Maybe Int
findLastPS = BC.elemIndexEnd
------------------------------------------------------------
{-# INLINE splitPS #-}
splitPS :: Char -> PackedString -> [PackedString]
splitPS = BC.split
-- -----------------------------------------------------------------------------
-- hPutPS
-- | Outputs a 'PackedString' to the specified 'Handle'.
--
-- NOTE: the representation of the 'PackedString' in the file is assumed to
-- be in the ISO-8859-1 encoding. In other words, only the least signficant
-- byte is taken from each character in the 'PackedString'.
hPutPS :: Handle -> PackedString -> IO ()
hPutPS = B.hPut
-- -----------------------------------------------------------------------------
-- hGetPS
-- | Read a 'PackedString' directly from the specified 'Handle'. This
-- is far more efficient than reading the characters into a 'String'
-- and then using 'packString'.
--
-- NOTE: as with 'hPutPS', the string representation in the file is
-- assumed to be ISO-8859-1.
hGetPS :: Handle -> Int -> IO PackedString
hGetPS = B.hGet
-- -----------------------------------------------------------------------------
-- hGetContentsPS
-- | Read entire handle contents into a 'PackedString'. Note that since we use strict
-- ByteString, hGetContentsPS is not lazy either (unlike most 'getContents' functions).
--
-- NOTE: as with 'hGetPS', the string representation in the file is
-- assumed to be ISO-8859-1.
hGetContentsPS :: Handle -> IO PackedString
hGetContentsPS = B.hGetContents -- ratify hGetContents: just a Data.ByteString import
-- -----------------------------------------------------------------------------
-- readFilePS
-- | Read an entire file directly into a 'PackedString'. This is far more
-- efficient than reading the characters into a 'String' and then using
-- 'packString'. It also may be more efficient than opening the file and
-- reading it using hGetPS.
--
-- NOTE: as with 'hGetPS', the string representation in the file is
-- assumed to be ISO-8859-1.
readFilePS :: FilePath -> IO PackedString
readFilePS = B.readFile -- ratify readFile: just a Data.ByteString import
-- -----------------------------------------------------------------------------
-- writeFilePS
-- | Write a 'PackedString' to a file.
writeFilePS :: FilePath -> PackedString -> IO ()
writeFilePS = B.writeFile
-- -----------------------------------------------------------------------------
-- gzReadFilePS
-- | Read an entire file, which may or may not be gzip compressed, directly
-- into a 'PackedString'.
foreign import ccall unsafe "static zlib.h gzopen" c_gzopen
:: CString -> CString -> IO (Ptr ())
foreign import ccall unsafe "static zlib.h gzclose" c_gzclose
:: Ptr () -> IO ()
foreign import ccall unsafe "static zlib.h gzread" c_gzread
:: Ptr () -> Ptr Word8 -> CInt -> IO CInt
foreign import ccall unsafe "static zlib.h gzwrite" c_gzwrite
:: Ptr () -> Ptr Word8 -> CInt -> IO CInt
gzReadFilePS :: FilePath -> IO PackedString
gzReadFilePS f = do
h <- openBinaryFile f ReadMode
header <- hGetPS h 2
if header /= packString "\31\139"
then do hClose h
mmapFilePS f
else do hSeek h SeekFromEnd (-4)
len <- hGetLittleEndInt h
hClose h
withCString f $ \fstr-> withCString "rb" $ \rb-> do
gzf <- c_gzopen fstr rb
when (gzf == nullPtr) $ fail $ "problem opening file "++f
fp <- mallocForeignPtr len
debugForeignPtr fp $ "gzReadFilePS "++f
lread <- withForeignPtr fp $ \p ->
c_gzread gzf p (fromIntegral len)
c_gzclose gzf
when (fromIntegral lread /= len) $
fail $ "problem gzreading file "++f
return $ BI.fromForeignPtr fp 0 len
hGetLittleEndInt :: Handle -> IO Int
hGetLittleEndInt h = do
b1 <- ord `liftM` hGetChar h
b2 <- ord `liftM` hGetChar h
b3 <- ord `liftM` hGetChar h
b4 <- ord `liftM` hGetChar h
return $ b1 + 256*b2 + 65536*b3 + 16777216*b4
gzWriteFilePS :: FilePath -> PackedString -> IO ()
gzWriteFilePS f ps = gzWriteFilePSs f [ps]
gzWriteFilePSs :: FilePath -> [PackedString] -> IO ()
gzWriteFilePSs f pss =
withCString f $ \fstr -> withCString "wb" $ \wb -> do
gzf <- c_gzopen fstr wb
when (gzf == nullPtr) $ fail $ "problem gzopening file for write: "++f
mapM_ (gzWriteToGzf gzf) pss `catch`
\_ -> fail $ "problem gzwriting file: "++f
c_gzclose gzf
gzWriteToGzf :: Ptr () -> PackedString -> IO ()
gzWriteToGzf gzf ps = case BI.toForeignPtr ps of
(x,s,l) -> do
lw <- withForeignPtr x $ \p -> c_gzwrite gzf (p `plusPtr` s)
(fromIntegral l)
when (fromIntegral lw /= l) $ fail $ "problem in gzWriteToGzf"
-- -----------------------------------------------------------------------------
-- mmapFilePS
-- | Like readFilePS, this reads an entire file directly into a
-- 'PackedString', but it is even more efficient. It involves directly
-- mapping the file to memory. This has the advantage that the contents of
-- the file never need to be copied. Also, under memory pressure the page
-- may simply be discarded, wile in the case of readFilePS it would need to
-- be written to swap. If you read many small files, mmapFilePS will be
-- less memory-efficient than readFilePS, since each mmapFilePS takes up a
-- separate page of memory. Also, you can run into bus errors if the file
-- is modified. NOTE: as with 'readFilePS', the string representation in
-- the file is assumed to be ISO-8859-1.
mmapFilePS :: FilePath -> IO PackedString
mmapFilePS f = if use_mmap
then do (fp,l) <- mmap f
return $ BI.fromForeignPtr fp 0 l
else readFilePS f
#if defined(__GLASGOW_HASKELL__)
foreign import ccall unsafe "static fpstring.h my_mmap" my_mmap
:: CSize -> CInt -> IO (Ptr Word8)
foreign import ccall unsafe "static sys/mman.h munmap" c_munmap
:: Ptr Word8 -> CSize -> IO CInt
foreign import ccall unsafe "static unistd.h close" c_close
:: CInt -> IO CInt
#endif
mmap :: FilePath -> IO (ForeignPtr Word8, Int)
mmap f = do
h <- openBinaryFile f ReadMode
l <- fromIntegral `liftM` hFileSize h
-- Don't bother mmaping small files because each mmapped file takes up
-- at least one full VM block.
if l < mmap_limit
then do thefp <- mallocForeignPtr l
debugForeignPtr thefp $ "mmap short file "++f
withForeignPtr thefp $ \p-> hGetBuf h p l
hClose h
return (thefp, l)
else do
#if defined(__GLASGOW_HASKELL__)
fd <- fromIntegral `liftM` handleToFd h
p <- my_mmap (fromIntegral l) fd
fp <- if p == nullPtr
then
#else
fp <-
#endif
do thefp <- mallocForeignPtr l
debugForeignPtr thefp $ "mmap short file "++f
withForeignPtr thefp $ \p' -> hGetBuf h p' l
return thefp
#if defined(__GLASGOW_HASKELL__)
else do
fp <- FC.newForeignPtr p
(do {c_munmap p $ fromIntegral l;
return (); })
debugForeignPtr fp $ "mmap "++f
return fp
c_close fd
#endif
hClose h
return (fp, l)
where mmap_limit = 16*1024
-- -------------------------------------------------------------------------
-- readIntPS
-- | readIntPS skips any whitespace at the beginning of its argument, and
-- reads an Int from the beginning of the PackedString. If there is no
-- integer at the beginning of the string, it returns Nothing, otherwise it
-- just returns the int read, along with a PackedString containing the
-- remainder of its input.
readIntPS :: PackedString -> Maybe (Int, PackedString)
readIntPS = BC.readInt . BC.dropWhile isSpace
-- -------------------------------------------------------------------------
-- fromPS2Hex
foreign import ccall unsafe "static fpstring.h conv_to_hex" conv_to_hex
:: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()
fromPS2Hex :: PackedString -> PackedString
fromPS2Hex ps = case BI.toForeignPtr ps of
(x,s,l) ->
createPS (2*l) $ \p -> withForeignPtr x $ \f ->
conv_to_hex p (f `plusPtr` s) $ fromIntegral l
-- -------------------------------------------------------------------------
-- fromHex2PS
foreign import ccall unsafe "static fpstring.h conv_from_hex" conv_from_hex
:: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()
fromHex2PS :: PackedString -> PackedString
fromHex2PS ps = case BI.toForeignPtr ps of
(x,s,l) ->
createPS (l `div` 2) $ \p -> withForeignPtr x $ \f ->
conv_from_hex p (f `plusPtr` s) (fromIntegral $ l `div` 2)
-- -------------------------------------------------------------------------
-- betweenLinesPS
-- | betweenLinesPS returns the PackedString between the two lines given,
-- or Nothing if they do not appear.
betweenLinesPS :: PackedString -> PackedString -> PackedString
-> Maybe (PackedString)
betweenLinesPS start end ps
= case break (start ==) (linesPS ps) of
(_, _:rest@(bs1:_)) ->
case BI.toForeignPtr bs1 of
(ps1,s1,_) ->
case break (end ==) rest of
(_, bs2:_) -> case BI.toForeignPtr bs2 of (_,s2,_) -> Just $ BI.fromForeignPtr ps1 s1 (s2 - s1)
_ -> Nothing
_ -> Nothing
-- -------------------------------------------------------------------------
-- break_after_nth_newline
break_after_nth_newline :: Int -> PackedString
-> Maybe (PackedString, PackedString)
break_after_nth_newline 0 the_ps | nullPS the_ps = Just (nilPS, nilPS)
break_after_nth_newline n the_ps =
case BI.toForeignPtr the_ps of
(fp,the_s,l) ->
unsafePerformIO $ withForeignPtr fp $ \p ->
do let findit 0 s | s == end = return $ Just (the_ps, nilPS)
findit _ s | s == end = return Nothing
findit 0 s = let left_l = s - the_s
in return $ Just (BI.fromForeignPtr fp the_s left_l,
BI.fromForeignPtr fp s (l - left_l))
findit i s = do w <- peekElemOff p s
if w == nl then findit (i-1) (s+1)
else findit i (s+1)
nl = BI.c2w '\n'
end = the_s + l
findit n the_s
-- -------------------------------------------------------------------------
-- break_before_nth_newline
break_before_nth_newline :: Int -> PackedString -> (PackedString, PackedString)
break_before_nth_newline 0 the_ps
| nullPS the_ps = (nilPS, nilPS)
break_before_nth_newline n the_ps =
case BI.toForeignPtr the_ps of
(fp,the_s,l) ->
unsafePerformIO $ withForeignPtr fp $ \p ->
do let findit _ s | s == end = return (the_ps, nilPS)
findit i s = do w <- peekElemOff p s
if w == nl
then if i == 0
then let left_l = s - the_s
in return (BI.fromForeignPtr fp the_s left_l,
BI.fromForeignPtr fp s (l - left_l))
else findit (i-1) (s+1)
else findit i (s+1)
nl = BI.c2w '\n'
end = the_s + l
findit n the_s
#endif