module Data.CompactString.Internal (
CompactString(..),
Proxy, encoding, Encoding(..),
PairS(..), MaybeS(..), unSP,
AccEFL, FoldEFL, ImperativeLoop, ImperativeLoop_,
ByteString(..), memcpy, inlinePerformIO,
withBuffer, withBufferEnd, unsafeWithBuffer, unsafeWithBufferEnd, create,
ord, unsafeChr, returnChr,
plusPtr, peekByteOff, pokeByteOff, peek, poke,
failMessage, moduleError, errorEmptyList, unsafeTry, unsafeTryIO
) where
import Foreign.Ptr (Ptr)
import qualified Foreign.Ptr (plusPtr)
import Foreign.Storable (Storable, peek, poke)
import qualified Foreign.Storable
import Foreign.ForeignPtr (withForeignPtr)
import Data.Word (Word8, Word32)
import Data.Char (ord)
import Control.Monad
import Control.Exception
import System.IO.Error (isUserError, ioeGetErrorString)
#if defined(__GLASGOW_HASKELL__)
import GHC.Base (unsafeChr)
#else
import Data.Char (chr)
#endif
import System.IO.Unsafe
import Data.ByteString.Internal (ByteString(..), memcpy, inlinePerformIO)
import qualified Data.ByteString.Internal as B
#define STRICT1(f) f _a | _a `seq` False = undefined
#define STRICT2(f) f _a _b | _a `seq` _b `seq` False = undefined
#define STRICT3(f) f _a _b _c | _a `seq` _b `seq` _c `seq` False = undefined
#define STRICT4(f) f _a _b _c _d | _a `seq` _b `seq` _c `seq` _d `seq` False = undefined
#define STRICT5(f) f _a _b _c _d _e | _a `seq` _b `seq` _c `seq` _d `seq` _e `seq` False = undefined
data PairS a b = !a :*: !b
data MaybeS a = NothingS | JustS !a
infixl 2 :*:
unSP :: PairS a b -> (a,b)
unSP (a :*: b) = (a,b)
newtype CompactString a = CS { unCS :: ByteString }
data Proxy a
class Encoding a where
pokeCharFun :: Proxy a -> Char -> (Int, Ptr Word8 -> IO ())
pokeCharLen :: Proxy a -> Char -> Int
pokeCharLen a = fst . pokeCharFun a
pokeChar :: Proxy a -> Ptr Word8 -> Char -> IO Int
pokeChar enc p c = case pokeCharFun enc c of (l,f) -> f p >> return l
pokeCharRev :: Proxy a -> Ptr Word8 -> Char -> IO Int
pokeCharRev enc p c = case pokeCharFun enc c of (l,f) -> f (p `plusPtr` (1l)) >> return l
peekChar :: Proxy a -> Ptr Word8 -> IO (Int, Char)
peekCharLen :: Proxy a -> Ptr Word8 -> IO Int
peekCharRev :: Proxy a -> Ptr Word8 -> IO (Int, Char)
peekCharLenRev :: Proxy a -> Ptr Word8 -> IO Int
peekCharSafe :: Proxy a -> Int -> Ptr Word8 -> IO (Int, Char)
validateLength :: Proxy a -> Int -> IO ()
validateLength _ _ = return ()
copyChar :: Proxy a -> Ptr Word8 -> Ptr Word8 -> IO Int
copyChar enc src dst = do
(l,c) <- peekChar enc src
pokeChar enc dst c
return l
copyCharRev :: Proxy a -> Ptr Word8 -> Ptr Word8 -> IO Int
copyCharRev enc src dst = do
(l,c) <- peekCharRev enc src
pokeChar enc dst c
return l
containsASCII :: Proxy a -> Bool
validEquality :: Proxy a -> Bool
validEquality _ = True
validOrdering :: Proxy a -> Bool
validSubstring :: Proxy a -> Bool
charCount :: Proxy a -> Int -> Int
charCount _ n = n
byteCount :: Proxy a -> Int -> Int
newSize :: Proxy a -> Int -> Int
newSize e = byteCount e . charCount e
doUpLoop :: Proxy a -> AccEFL acc -> acc -> ImperativeLoop acc
doUpLoop enc f acc0 src dest len = loop 0 0 acc0
where STRICT3(loop)
loop src_off dest_off acc
| src_off >= len = return (acc :*: 0 :*: dest_off)
| otherwise = do
(l,x) <- peekChar enc (src `plusPtr` src_off)
case f acc x of
(acc' :*: NothingS) -> loop (src_off+l) dest_off acc'
(acc' :*: JustS x') -> do l' <- pokeChar enc (dest `plusPtr` dest_off) x'
loop (src_off+l) (dest_off+l') acc'
doDownLoop :: Proxy a -> AccEFL acc -> acc -> ImperativeLoop acc
doDownLoop enc f acc0 src dest len = loop (len1) (newSize enc len1) acc0
where STRICT3(loop)
loop src_off dest_off acc
| src_off < 0 = return (acc :*: dest_off + 1 :*: newSize enc len (dest_off+1))
| otherwise = do
(l,x) <- peekCharRev enc (src `plusPtr` src_off)
case f acc x of
(acc' :*: NothingS) -> loop (src_offl) dest_off acc'
(acc' :*: JustS x') -> do l' <- pokeCharRev enc (dest `plusPtr` dest_off) x'
loop (src_offl) (dest_offl') acc'
doUpLoopFold :: Proxy a -> FoldEFL acc -> acc -> ImperativeLoop_ acc
doUpLoopFold enc f acc0 src len = loop 0 acc0
where STRICT2(loop)
loop src_off acc
| src_off >= len = return acc
| otherwise = do
(l,x) <- peekChar enc (src `plusPtr` src_off)
loop (src_off + l) (f acc x)
doDownLoopFold :: Proxy a -> FoldEFL acc -> acc -> ImperativeLoop_ acc
doDownLoopFold enc f acc0 src len = loop (len1) acc0
where STRICT2(loop)
loop src_off acc
| src_off < 0 = return acc
| otherwise = do
(l,x) <- peekCharRev enc (src `plusPtr` src_off)
loop (src_off l) (f acc x)
type AccEFL acc = acc -> Char -> (PairS acc (MaybeS Char))
type FoldEFL acc = acc -> Char -> acc
type ImperativeLoop acc =
Ptr Word8
-> Ptr Word8
-> Int
-> IO (PairS (PairS acc Int) Int)
type ImperativeLoop_ acc =
Ptr Word8
-> Int
-> IO acc
withBuffer :: CompactString a -> (Ptr Word8 -> IO b) -> IO b
withBuffer (CS (PS x s _)) f = withForeignPtr x $ \p -> f (p `plusPtr` s)
withBufferEnd :: CompactString a -> (Ptr Word8 -> IO b) -> IO b
withBufferEnd (CS (PS x s l)) f = withForeignPtr x $ \p -> f (p `plusPtr` (s + l 1))
unsafeWithBuffer :: CompactString a -> (Ptr Word8 -> IO b) -> b
unsafeWithBuffer cs f = inlinePerformIO $ withBuffer cs f
unsafeWithBufferEnd :: CompactString a -> (Ptr Word8 -> IO b) -> b
unsafeWithBufferEnd cs f = inlinePerformIO $ withBufferEnd cs f
create :: Int -> (Ptr Word8 -> IO ()) -> IO (CompactString a)
create len f = liftM CS $ B.create len f
#if !defined(__GLASGOW_HASKELL__)
unsafeChr = chr
#endif
returnChr :: Int -> Word32 -> IO (Int, Char)
returnChr a c
| c >= 0xD800 && c <= 0xDFFF = failMessage "decode" "Surrogate character"
| c > 0x10FFFF = failMessage "decode" "Character out of range"
| otherwise = return (a, unsafeChr $ fromIntegral c)
plusPtr :: Ptr a -> Int -> Ptr a
plusPtr = Foreign.Ptr.plusPtr
peekByteOff :: Storable a => Ptr a -> Int -> IO a
peekByteOff = Foreign.Storable.peekByteOff
pokeByteOff :: Storable a => Ptr a -> Int -> a -> IO ()
pokeByteOff = Foreign.Storable.pokeByteOff
encoding :: CompactString a -> Proxy a
encoding = undefined
failMessage :: String -> String -> IO a
failMessage fun msg = fail ("Data.CompactString." ++ fun ++ ':':' ':msg)
moduleError :: String -> String -> a
moduleError fun msg = error ("Data.CompactString." ++ fun ++ ':':' ':msg)
errorEmptyList :: String -> a
errorEmptyList fun = moduleError fun "empty CompactString"
unsafeTry :: MonadPlus m => IO a -> m a
unsafeTry ioa = unsafePerformIO (unsafeTryIO ioa)
unsafeTryIO :: MonadPlus m => IO a -> IO (m a)
unsafeTryIO ioa = handleJust userErrors (return . fail) (fmap return ioa)
userErrors :: IOError -> Maybe String
userErrors e = if isUserError e then Just (ioeGetErrorString e) else Nothing