Codec-Compression-LZF-0.2: Codec/Compression/LZF.hs

module Codec.Compression.LZF (compress,decompress,compressString,decompressString) where

import Data.Char(ord,chr)
import Control.Monad (when)
import Foreign
import Foreign.C

{-# CFILES liblzf-1.5/lzf_c.c liblzf-1.5/lzf_d.c #-}
foreign import ccall unsafe "lzf_compress" _compress :: Ptr a -> CUInt -> Ptr b -> CUInt -> IO CUInt
foreign import ccall unsafe "lzf_decompress" _decompress :: Ptr a -> CUInt -> Ptr b -> CUInt -> IO CUInt

-- | Compress a block of data. The length of data is 
-- not recorded. Returns the length of output or 0
-- if it is longer than the size of the output buffer.
compress :: Ptr a -> Int -> Ptr b -> Int -> IO Int
compress input ilen output olen = do
  res <- _compress input (fromIntegral ilen) output (fromIntegral olen) 
  return (fromIntegral res)

-- | Decompress a block of data. Returns the length
-- of data uncompressed or 0 on error.
decompress :: Ptr a -> Int -> Ptr b -> Int -> IO Int
decompress input ilen output olen = do
  res <- _decompress input (fromIntegral ilen) output (fromIntegral olen) 
  return (fromIntegral res)

-- | Compress a string with worst case length = original + 1.
-- The first char of the string contains the length of the original.
compressString :: String -> IO String
compressString str =
  withCStringLen str $ \(inp,len) ->
    allocaBytes len $ \out -> do
      res <- compress inp len out (len-2)
      if res == 0 then return ("\0"++str)
                  else do c <- peekCStringLen (out,res)
                          return (chr len:c)

-- | Decompress a string compressed with compressString.
decompressString :: String -> IO String
decompressString ('\0':rest) = return rest
decompressString (ol:str) = 
  withCStringLen str $ \(inp,len) -> do
    let olen = ord ol
    allocaBytes olen $ \out -> do
      res <- decompress inp len out olen
      when (res == 0) $ fail "Codec.Compression.LZF.decompressString"
      peekCStringLen (out,res)


{-
t s = do c <- compressString s
         d <- decompressString c
         putStrLn $ unwords ["lzf test",show $ length s,"=>",show $ length c,show (s==d)]
-}