{-# LANGUAGE CPP, ForeignFunctionInterface #-}
module Data.Bitmap.IO.File
( readBitmap
, writeBitmap
, readRawData
, writeRawData
, hPutHeader
, hPutRawData
, hGetHeader
, hGetRawData
)
where
import Control.Monad
import System.IO
import Foreign.C
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.Marshal
import Data.Int
import Data.Bitmap.Base
import Data.Bitmap.Internal
import Data.Bitmap.IO
readBitmap :: PixelComponent t => FilePath -> IO (IOBitmap t)
readBitmap :: FilePath -> IO (IOBitmap t)
readBitmap FilePath
fpath = do
Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
ReadMode
(Size, NChn, PixelComponentType)
header <- Handle -> IO (Size, NChn, PixelComponentType)
hGetHeader Handle
h
IOBitmap t
bitmap <- Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
forall t.
PixelComponent t =>
Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
hGetRawData Handle
h (Size, NChn, PixelComponentType)
header
Handle -> IO ()
hClose Handle
h
IOBitmap t -> IO (IOBitmap t)
forall (m :: * -> *) a. Monad m => a -> m a
return IOBitmap t
bitmap
readRawData :: PixelComponent t => FilePath -> (Size,NChn,PixelComponentType) -> IO (IOBitmap t)
readRawData :: FilePath -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
readRawData FilePath
fpath (Size, NChn, PixelComponentType)
header = do
Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
ReadMode
IOBitmap t
bitmap <- Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
forall t.
PixelComponent t =>
Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
hGetRawData Handle
h (Size, NChn, PixelComponentType)
header
Handle -> IO ()
hClose Handle
h
IOBitmap t -> IO (IOBitmap t)
forall (m :: * -> *) a. Monad m => a -> m a
return IOBitmap t
bitmap
writeBitmap :: PixelComponent t => FilePath -> IOBitmap t -> IO ()
writeBitmap :: FilePath -> IOBitmap t -> IO ()
writeBitmap FilePath
fpath IOBitmap t
bm = do
Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
WriteMode
Handle -> IOBitmap t -> IO ()
forall t. PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutHeader Handle
h IOBitmap t
bm
Handle -> IOBitmap t -> IO ()
forall t. PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutRawData Handle
h IOBitmap t
bm
Handle -> IO ()
hClose Handle
h
writeRawData :: PixelComponent t => FilePath -> IOBitmap t -> IO ()
writeRawData :: FilePath -> IOBitmap t -> IO ()
writeRawData FilePath
fpath IOBitmap t
bm = do
Handle
h <- FilePath -> IOMode -> IO Handle
openFile FilePath
fpath IOMode
WriteMode
Handle -> IOBitmap t -> IO ()
forall t. PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutRawData Handle
h IOBitmap t
bm
Handle -> IO ()
hClose Handle
h
hPutHeader :: PixelComponent t => Handle -> IOBitmap t -> IO ()
Handle
h IOBitmap t
bm = do
let (NChn
xsize,NChn
ysize) = IOBitmap t -> Size
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> Size
bitmapSize IOBitmap t
bm
nchn :: NChn
nchn = IOBitmap t -> NChn
forall (bitmap :: * -> *) t. BitmapClass bitmap => bitmap t -> NChn
bitmapNChannels IOBitmap t
bm
typ :: CInt
typ = IOBitmap t -> CInt
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> CInt
bitmapCType IOBitmap t
bm
Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (NChn -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral NChn
xsize :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4
Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (NChn -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral NChn
ysize :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4
Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (NChn -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral NChn
nchn :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4
Int32 -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with (CInt -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
typ :: Int32) ((Ptr Int32 -> IO ()) -> IO ()) -> (Ptr Int32 -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> Handle -> Ptr Int32 -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Int32
p NChn
4
hPutRawData :: PixelComponent t => Handle -> IOBitmap t -> IO ()
hPutRawData :: Handle -> IOBitmap t -> IO ()
hPutRawData Handle
h IOBitmap t
bm =
IOBitmap t -> (Size -> NChn -> NChn -> Ptr t -> IO ()) -> IO ()
forall t a.
PixelComponent t =>
IOBitmap t -> (Size -> NChn -> NChn -> Ptr t -> IO a) -> IO a
withIOBitmap IOBitmap t
bm ((Size -> NChn -> NChn -> Ptr t -> IO ()) -> IO ())
-> (Size -> NChn -> NChn -> Ptr t -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(NChn
xres,NChn
yres) NChn
nchn NChn
padding Ptr t
ptr -> do
[NChn] -> (NChn -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [NChn
0..NChn
yresNChn -> NChn -> NChn
forall a. Num a => a -> a -> a
-NChn
1] ((NChn -> IO ()) -> IO ()) -> (NChn -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \NChn
k -> do
let q :: Ptr b
q = Ptr t
ptr Ptr t -> NChn -> Ptr b
forall a b. Ptr a -> NChn -> Ptr b
`plusPtr` (NChn
kNChn -> NChn -> NChn
forall a. Num a => a -> a -> a
*NChn
long)
Handle -> Ptr Any -> NChn -> IO ()
forall a. Handle -> Ptr a -> NChn -> IO ()
hPutBuf Handle
h Ptr Any
forall b. Ptr b
q NChn
short
where
long :: NChn
long = IOBitmap t -> NChn
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> NChn
bitmapPaddedRowSizeInBytes IOBitmap t
bm
short :: NChn
short = IOBitmap t -> NChn
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> NChn
bitmapUnpaddedRowSizeInBytes IOBitmap t
bm
hGetRawData :: PixelComponent t => Handle -> (Size,NChn,PixelComponentType) -> IO (IOBitmap t)
hGetRawData :: Handle -> (Size, NChn, PixelComponentType) -> IO (IOBitmap t)
hGetRawData Handle
h (Size
siz,NChn
nchn,PixelComponentType
pct) = do
IOBitmap t
bm <- Size -> NChn -> Maybe NChn -> IO (IOBitmap t)
forall t.
PixelComponent t =>
Size -> NChn -> Maybe NChn -> IO (IOBitmap t)
newIOBitmapUninitialized Size
siz NChn
nchn (NChn -> Maybe NChn
forall a. a -> Maybe a
Just NChn
1)
if IOBitmap t -> PixelComponentType
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> PixelComponentType
bitmapComponentType IOBitmap t
bm PixelComponentType -> PixelComponentType -> Bool
forall a. Eq a => a -> a -> Bool
/= PixelComponentType
pct
then FilePath -> IO (IOBitmap t)
forall a. HasCallStack => FilePath -> a
error FilePath
"bitmap/getRawData: bitmap component type does not match"
else do
IOBitmap t
-> (Size -> NChn -> NChn -> Ptr t -> IO (IOBitmap t))
-> IO (IOBitmap t)
forall t a.
PixelComponent t =>
IOBitmap t -> (Size -> NChn -> NChn -> Ptr t -> IO a) -> IO a
withIOBitmap IOBitmap t
bm ((Size -> NChn -> NChn -> Ptr t -> IO (IOBitmap t))
-> IO (IOBitmap t))
-> (Size -> NChn -> NChn -> Ptr t -> IO (IOBitmap t))
-> IO (IOBitmap t)
forall a b. (a -> b) -> a -> b
$ \(NChn
_,NChn
ysiz) NChn
_ NChn
_ Ptr t
ptr -> do
let n :: NChn
n = NChn
ysiz NChn -> NChn -> NChn
forall a. Num a => a -> a -> a
* IOBitmap t -> NChn
forall (bitmap :: * -> *) t.
(BitmapClass bitmap, PixelComponent t) =>
bitmap t -> NChn
bitmapUnpaddedRowSizeInBytes IOBitmap t
bm
NChn
k <- Handle -> Ptr t -> NChn -> IO NChn
forall a. Handle -> Ptr a -> NChn -> IO NChn
hGetBuf Handle
h Ptr t
ptr NChn
n
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NChn
kNChn -> NChn -> Bool
forall a. Eq a => a -> a -> Bool
/=NChn
n) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error FilePath
"bitmap/getRawData: not enough data"
IOBitmap t -> IO (IOBitmap t)
forall (m :: * -> *) a. Monad m => a -> m a
return IOBitmap t
bm
hGetHeader :: Handle -> IO (Size,NChn,PixelComponentType)
Handle
h = do
Int32
xsize <- IO Int32
loadInt32
Int32
ysize <- IO Int32
loadInt32
Int32
nchn <- IO Int32
loadInt32
Int32
ctyp <- IO Int32
loadInt32
(Size, NChn, PixelComponentType)
-> IO (Size, NChn, PixelComponentType)
forall (m :: * -> *) a. Monad m => a -> m a
return
( (Int32 -> NChn
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
xsize, Int32 -> NChn
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ysize)
, Int32 -> NChn
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
nchn
, CInt -> PixelComponentType
decodeCType (Int32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
ctyp)
)
where
loadInt32 :: IO Int32
loadInt32 :: IO Int32
loadInt32 = (Ptr Int32 -> IO Int32) -> IO Int32
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int32 -> IO Int32) -> IO Int32)
-> (Ptr Int32 -> IO Int32) -> IO Int32
forall a b. (a -> b) -> a -> b
$ \Ptr Int32
p -> do
Handle -> Ptr Int32 -> NChn -> IO NChn
forall a. Handle -> Ptr a -> NChn -> IO NChn
hGetBuf Handle
h Ptr Int32
p NChn
4
Ptr Int32 -> IO Int32
forall a. Storable a => Ptr a -> IO a
peek Ptr Int32
p