{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.Massiv.Array.IO
(
module Graphics.Pixel.ColorSpace
, Image
, readArray
, readArrayWithMetadata
, readImage
, readImageAuto
, writeArray
, writeImage
, writeImageAuto
, ExternalViewer(..)
, displayImage
, displayImageUsing
, displayImageFile
, defaultViewer
, eogViewer
, gpicviewViewer
, fehViewer
, gimpViewer
, module Data.Massiv.Array.IO.Image
, module Base
) where
import Control.Monad (void)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Massiv.Array as A
import Data.Massiv.Array.IO.Base (Image)
import Data.Massiv.Array.IO.Base as Base (Auto(..), ConvertError(..),
DecodeError(..), EncodeError(..),
FileFormat(..), MonadThrow(..),
Readable(..), Sequence(..),
Writable(..), convertEither,
convertImage, decode', decodeError,
defaultWriteOptions,
demoteLumaAlphaImage, demoteLumaImage,
encode', encodeError,
fromImageBaseModel, fromMaybeDecode,
fromMaybeEncode,
promoteLumaAlphaImage,
promoteLumaImage, toImageBaseModel,
toProxy)
import Data.Massiv.Array.IO.Image
import Graphics.Pixel.ColorSpace
import Prelude
import Prelude as P hiding (readFile, writeFile)
import System.FilePath ((</>))
import System.IO (IOMode(..), hClose, openBinaryTempFile)
import UnliftIO.Concurrent (forkIO)
import UnliftIO.Directory (createDirectoryIfMissing, getTemporaryDirectory)
import UnliftIO.Exception (bracket)
import UnliftIO.IO.File
import UnliftIO.Process (readProcess)
data ExternalViewer =
ExternalViewer FilePath [String] Int
deriving Int -> ExternalViewer -> ShowS
[ExternalViewer] -> ShowS
ExternalViewer -> String
(Int -> ExternalViewer -> ShowS)
-> (ExternalViewer -> String)
-> ([ExternalViewer] -> ShowS)
-> Show ExternalViewer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExternalViewer] -> ShowS
$cshowList :: [ExternalViewer] -> ShowS
show :: ExternalViewer -> String
$cshow :: ExternalViewer -> String
showsPrec :: Int -> ExternalViewer -> ShowS
$cshowsPrec :: Int -> ExternalViewer -> ShowS
Show
readArray :: (Readable f arr, MonadIO m) =>
f
-> FilePath
-> m arr
readArray :: f -> String -> m arr
readArray f
format String
path = IO arr -> m arr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
B.readFile String
path IO ByteString -> (ByteString -> IO arr) -> IO arr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f -> ByteString -> IO arr
forall f arr (m :: * -> *).
(Readable f arr, MonadThrow m) =>
f -> ByteString -> m arr
decodeM f
format)
{-# INLINE readArray #-}
readArrayWithMetadata ::
(Readable f arr, MonadIO m)
=> f
-> FilePath
-> m (arr, Metadata f)
readArrayWithMetadata :: f -> String -> m (arr, Metadata f)
readArrayWithMetadata f
format String
path = IO (arr, Metadata f) -> m (arr, Metadata f)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
B.readFile String
path IO ByteString
-> (ByteString -> IO (arr, Metadata f)) -> IO (arr, Metadata f)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= f -> ByteString -> IO (arr, Metadata f)
forall f arr (m :: * -> *).
(Readable f arr, MonadThrow m) =>
f -> ByteString -> m (arr, Metadata f)
decodeWithMetadataM f
format)
{-# INLINE readArrayWithMetadata #-}
writeLazyAtomically :: FilePath -> BL.ByteString -> IO ()
writeLazyAtomically :: String -> ByteString -> IO ()
writeLazyAtomically String
filepath ByteString
bss =
String -> IOMode -> (Handle -> IO ()) -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
String -> IOMode -> (Handle -> m r) -> m r
withBinaryFileDurableAtomic String
filepath IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
Prelude.mapM_ (Handle -> ByteString -> IO ()
B.hPut Handle
h) (ByteString -> [ByteString]
BL.toChunks ByteString
bss)
{-# INLINE writeLazyAtomically #-}
writeArray :: (Writable f arr, MonadIO m) =>
f
-> WriteOptions f
-> FilePath
-> arr
-> m ()
writeArray :: f -> WriteOptions f -> String -> arr -> m ()
writeArray f
format WriteOptions f
opts String
filepath arr
arr =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (f -> WriteOptions f -> arr -> IO ByteString
forall f arr (m :: * -> *).
(Writable f arr, MonadThrow m) =>
f -> WriteOptions f -> arr -> m ByteString
encodeM f
format WriteOptions f
opts arr
arr IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ()
writeLazyAtomically String
filepath)
{-# INLINE writeArray #-}
readImage ::
(ColorModel cs e, MonadIO m)
=> FilePath
-> m (Image S cs e)
readImage :: String -> m (Image S cs e)
readImage String
path = IO (Image S cs e) -> m (Image S cs e)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
B.readFile String
path IO ByteString
-> (ByteString -> IO (Image S cs e)) -> IO (Image S cs e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Decode (Image S cs e)]
-> String -> ByteString -> IO (Image S cs e)
forall (m :: * -> *) r cs e.
MonadThrow m =>
[Decode (Image r cs e)] -> String -> ByteString -> m (Image r cs e)
decodeImageM [Decode (Image S cs e)]
forall cs e. ColorModel cs e => [Decode (Image S cs e)]
imageReadFormats String
path)
{-# INLINE readImage #-}
readImageAuto ::
(Mutable r Ix2 (Pixel cs e), ColorSpace cs i e, MonadIO m)
=> FilePath
-> m (Image r cs e)
readImageAuto :: String -> m (Image r cs e)
readImageAuto String
path = IO (Image r cs e) -> m (Image r cs e)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
B.readFile String
path IO ByteString
-> (ByteString -> IO (Image r cs e)) -> IO (Image r cs e)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Decode (Image r cs e)]
-> String -> ByteString -> IO (Image r cs e)
forall (m :: * -> *) r cs e.
MonadThrow m =>
[Decode (Image r cs e)] -> String -> ByteString -> m (Image r cs e)
decodeImageM [Decode (Image r cs e)]
forall r cs e i.
(Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>
[Decode (Image r cs e)]
imageReadAutoFormats String
path)
{-# INLINE readImageAuto #-}
writeImage ::
(Source r Ix2 (Pixel cs e), ColorModel cs e, MonadIO m) => FilePath -> Image r cs e -> m ()
writeImage :: String -> Image r cs e -> m ()
writeImage String
path Image r cs e
img = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Encode (Image r cs e)] -> String -> Image r cs e -> IO ByteString
forall (m :: * -> *) r cs e.
MonadThrow m =>
[Encode (Image r cs e)] -> String -> Image r cs e -> m ByteString
encodeImageM [Encode (Image r cs e)]
forall r cs e.
(Source r Ix2 (Pixel cs e), ColorModel cs e) =>
[Encode (Image r cs e)]
imageWriteFormats String
path Image r cs e
img IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ()
writeLazyAtomically String
path)
writeImageAuto ::
(Source r Ix2 (Pixel cs e), ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, MonadIO m)
=> FilePath
-> Image r cs e
-> m ()
writeImageAuto :: String -> Image r cs e -> m ()
writeImageAuto String
path Image r cs e
img =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Encode (Image r cs e)] -> String -> Image r cs e -> IO ByteString
forall (m :: * -> *) r cs e.
MonadThrow m =>
[Encode (Image r cs e)] -> String -> Image r cs e -> m ByteString
encodeImageM [Encode (Image r cs e)]
forall r cs e i.
(Source r Ix2 (Pixel cs e), ColorSpace cs i e,
ColorSpace (BaseSpace cs) i e) =>
[Encode (Image r cs e)]
imageWriteAutoFormats String
path Image r cs e
img IO ByteString -> (ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> ByteString -> IO ()
writeLazyAtomically String
path)
displayImageUsing ::
(Writable (Auto TIF) (Image r cs e), MonadIO m)
=> ExternalViewer
-> Bool
-> Image r cs e
-> m ()
displayImageUsing :: ExternalViewer -> Bool -> Image r cs e -> m ()
displayImageUsing ExternalViewer
viewer Bool
block Image r cs e
img =
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
ByteString
bs <- Auto TIF
-> WriteOptions (Auto TIF) -> Image r cs e -> IO ByteString
forall f arr (m :: * -> *).
(Writable f arr, MonadThrow m) =>
f -> WriteOptions f -> arr -> m ByteString
encodeM (TIF -> Auto TIF
forall f. f -> Auto f
Auto TIF
TIF) () Image r cs e
img
(if Bool
block then IO () -> IO ()
forall a. a -> a
id else IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forall (m :: * -> *). MonadUnliftIO m => m () -> m ThreadId
forkIO) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
display ByteString
bs
where
display :: ByteString -> IO ()
display ByteString
bs = do
String
tmpDir <- ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ShowS
</> String
"massiv-io") IO String
forall (m :: * -> *). MonadIO m => m String
getTemporaryDirectory
Bool -> String -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> String -> m ()
createDirectoryIfMissing Bool
True String
tmpDir
IO (String, Handle)
-> ((String, Handle) -> IO ())
-> ((String, Handle) -> IO ())
-> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(String -> String -> IO (String, Handle)
openBinaryTempFile String
tmpDir String
"tmp-img.tiff")
(Handle -> IO ()
hClose (Handle -> IO ())
-> ((String, Handle) -> Handle) -> (String, Handle) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Handle) -> Handle
forall a b. (a, b) -> b
snd)
(\(String
imgPath, Handle
imgHandle) -> do
Handle -> ByteString -> IO ()
BL.hPut Handle
imgHandle ByteString
bs
Handle -> IO ()
hClose Handle
imgHandle
ExternalViewer -> String -> IO ()
forall (m :: * -> *). MonadIO m => ExternalViewer -> String -> m ()
displayImageFile ExternalViewer
viewer String
imgPath)
displayImageFile :: MonadIO m => ExternalViewer -> FilePath -> m ()
displayImageFile :: ExternalViewer -> String -> m ()
displayImageFile (ExternalViewer String
exe [String]
args Int
ix) String
imgPath =
m String -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m String -> m ()) -> m String -> m ()
forall a b. (a -> b) -> a -> b
$ IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> m String) -> IO String -> m String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO String
forall (m :: * -> *).
MonadIO m =>
String -> [String] -> String -> m String
readProcess String
exe ([String]
argsBefore [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
imgPath] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
argsAfter) String
""
where ([String]
argsBefore, [String]
argsAfter) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
P.splitAt Int
ix [String]
args
displayImage :: (Writable (Auto TIF) (Image r cs e), MonadIO m) => Image r cs e -> m ()
displayImage :: Image r cs e -> m ()
displayImage = ExternalViewer -> Bool -> Image r cs e -> m ()
forall r cs e (m :: * -> *).
(Writable (Auto TIF) (Image r cs e), MonadIO m) =>
ExternalViewer -> Bool -> Image r cs e -> m ()
displayImageUsing ExternalViewer
defaultViewer Bool
False
defaultViewer :: ExternalViewer
defaultViewer :: ExternalViewer
defaultViewer =
#if defined(OS_Win32)
ExternalViewer "explorer.exe" [] 0
#elif defined(OS_Linux)
String -> [String] -> Int -> ExternalViewer
ExternalViewer String
"xdg-open" [] Int
0
#elif defined(OS_Mac)
ExternalViewer "open" [] 0
#else
error "Graphics.Image.IO.defaultViewer: Could not determine default viewer."
#endif
eogViewer :: ExternalViewer
eogViewer :: ExternalViewer
eogViewer = String -> [String] -> Int -> ExternalViewer
ExternalViewer String
"eog" [] Int
0
fehViewer :: ExternalViewer
fehViewer :: ExternalViewer
fehViewer = String -> [String] -> Int -> ExternalViewer
ExternalViewer String
"feh" [String
"--fullscreen", String
"--auto-zoom"] Int
2
gpicviewViewer :: ExternalViewer
gpicviewViewer :: ExternalViewer
gpicviewViewer = String -> [String] -> Int -> ExternalViewer
ExternalViewer String
"gpicview" [] Int
0
gimpViewer :: ExternalViewer
gimpViewer :: ExternalViewer
gimpViewer = String -> [String] -> Int -> ExternalViewer
ExternalViewer String
"gimp" [] Int
0