{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Massiv.Array.IO.Base
( FileFormat(..)
, Readable(..)
, decode'
, Writable(..)
, encode'
, ConvertError(..)
, EncodeError(..)
, DecodeError(..)
, Sequence(..)
, Auto(..)
, Image
, convertImage
, toImageBaseModel
, fromImageBaseModel
, demoteLumaImage
, promoteLumaImage
, demoteLumaAlphaImage
, promoteLumaAlphaImage
, defaultWriteOptions
, encodeError
, decodeError
, toProxy
, fromMaybeEncode
, fromMaybeDecodeM
, fromMaybeDecode
, convertEither
, unsafeFromStorableVectorM
, MonadThrow(..)
) where
import Control.Exception (Exception, throw)
import Control.Monad.Catch (MonadThrow(..))
import qualified Data.ByteString as B (ByteString)
import qualified Data.ByteString.Lazy as BL (ByteString)
import Data.Default.Class (Default(..))
import qualified Data.Massiv.Array as A
import Data.Massiv.Array.Manifest.Vector
import Data.Typeable
import qualified Data.Vector.Storable as V
import Graphics.Pixel as CM
import Graphics.Pixel.ColorSpace
import Unsafe.Coerce
type Image r cs e = A.Array r A.Ix2 (Pixel cs e)
newtype ConvertError = ConvertError String deriving Show
instance Exception ConvertError
newtype DecodeError = DecodeError String deriving Show
instance Exception DecodeError
newtype EncodeError = EncodeError String deriving Show
instance Exception EncodeError
defaultWriteOptions :: FileFormat f => f -> WriteOptions f
defaultWriteOptions _ = def
newtype Sequence f = Sequence f deriving Show
newtype Auto f = Auto f deriving Show
class (Default (WriteOptions f), Show f) => FileFormat f where
type WriteOptions f
type WriteOptions f = ()
type Metadata f
type Metadata f = ()
ext :: f -> String
exts :: f -> [String]
exts f = [ext f]
isFormat :: String -> f -> Bool
isFormat e f = e `elem` exts f
instance FileFormat f => FileFormat (Auto f) where
type WriteOptions (Auto f) = WriteOptions f
type Metadata (Auto f) = Metadata f
ext (Auto f) = ext f
exts (Auto f) = exts f
class FileFormat f => Readable f arr where
{-# MINIMAL (decodeM | decodeWithMetadataM) #-}
decodeM :: MonadThrow m => f -> B.ByteString -> m arr
decodeM f bs = fst <$> decodeWithMetadataM f bs
decodeWithMetadataM :: MonadThrow m => f -> B.ByteString -> m (arr, Metadata f)
default decodeWithMetadataM :: (Metadata f ~ (), MonadThrow m) =>
f -> B.ByteString -> m (arr, Metadata f)
decodeWithMetadataM f bs = do
arr <- decodeM f bs
pure (arr, ())
encode' :: Writable f arr => f -> WriteOptions f -> arr -> BL.ByteString
encode' f opts = either throw id . encodeM f opts
decode' :: Readable f arr => f -> B.ByteString -> arr
decode' f = either throw id . decodeM f
class FileFormat f => Writable f arr where
encodeM :: MonadThrow m => f -> WriteOptions f -> arr -> m BL.ByteString
toProxy :: a -> Proxy a
toProxy _ = Proxy
showImageType ::
forall r cs e. (Typeable r, ColorModel cs e)
=> Proxy (Image r cs e)
-> String
showImageType _ =
("<Image " ++) .
showsTypeRep (typeRep (Proxy :: Proxy r)) .
(' ' :) .
showsColorModelName (Proxy :: Proxy (Color cs e)) .
(' ' :) . showsTypeRep (typeRep (Proxy :: Proxy e)) $
">"
fromMaybeEncode
:: forall f r cs e b m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m)
=> f -> Proxy (Image r cs e) -> Maybe b -> m b
fromMaybeEncode f imgProxy =
\case
Just b -> pure b
Nothing ->
throwM $
ConvertError ("Format " ++ show f ++ " cannot be encoded as " ++ showImageType imgProxy)
fromMaybeDecode ::
forall r cs e a f m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m)
=> f
-> (a -> String)
-> (a -> Maybe (Image r cs e))
-> a
-> m (Image r cs e)
fromMaybeDecode f showCS conv eImg =
case conv eImg of
Nothing ->
throwM $
ConvertError $
"Cannot decode " ++
show f ++
" image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e))
Just img -> pure img
fromMaybeDecodeM ::
forall r cs e a f m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m)
=> f
-> (a -> String)
-> (a -> m (Maybe (Image r cs e)))
-> a
-> m (Image r cs e)
fromMaybeDecodeM f showCS conv eImg =
conv eImg >>= \case
Nothing ->
throwM $
ConvertError $
"Cannot decode " ++
show f ++
" image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e))
Just img -> pure img
convertEither ::
forall r cs i e a f m. (ColorSpace cs i e, FileFormat f, Typeable r, MonadThrow m)
=> f
-> (a -> String)
-> (a -> Maybe (Image r cs e))
-> a
-> m (Image r cs e)
convertEither f showCS conv eImg =
maybe
(throwM $
ConvertError
("Cannot convert " ++
show f ++
" image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e))))
pure
(conv eImg)
encodeError :: MonadThrow m => Either String a -> m a
encodeError = either (throwM . EncodeError) pure
decodeError :: MonadThrow m => Either String a -> m a
decodeError = either (throwM . DecodeError) pure
convertImage ::
(A.Source r' A.Ix2 (Pixel cs' e'), ColorSpace cs' i' e', ColorSpace cs i e)
=> Image r' cs' e'
-> Image A.D cs e
convertImage = A.map convertPixel
toImageBaseModel :: A.Array A.S A.Ix2 (Pixel cs e) -> A.Array A.S A.Ix2 (Pixel (BaseModel cs) e)
toImageBaseModel = unsafeCoerce
fromImageBaseModel :: A.Array A.S A.Ix2 (Pixel (BaseModel cs) e) -> A.Array A.S A.Ix2 (Pixel cs e)
fromImageBaseModel = unsafeCoerce
demoteLumaImage :: A.Array A.S A.Ix2 (Pixel Y' e) -> A.Array A.S A.Ix2 (Pixel CM.Y e)
demoteLumaImage = unsafeCoerce
promoteLumaImage :: A.Array A.S A.Ix2 (Pixel CM.Y e) -> A.Array A.S A.Ix2 (Pixel Y' e)
promoteLumaImage = unsafeCoerce
demoteLumaAlphaImage ::
A.Array A.S A.Ix2 (Pixel (Alpha Y') e) -> A.Array A.S A.Ix2 (Pixel (Alpha CM.Y) e)
demoteLumaAlphaImage = unsafeCoerce
promoteLumaAlphaImage ::
A.Array A.S A.Ix2 (Pixel (Alpha CM.Y) e) -> A.Array A.S A.Ix2 (Pixel (Alpha Y') e)
promoteLumaAlphaImage = unsafeCoerce
unsafeFromStorableVectorM ::
(MonadThrow m, A.Index ix, A.Storable a, A.Storable b)
=> A.Sz ix
-> V.Vector a
-> m (A.Array A.S ix b)
unsafeFromStorableVectorM sz v =
#if MIN_VERSION_massiv(0,5,0)
A.resizeM sz $ A.fromStorableVector A.Par $ V.unsafeCast v
#else
fromVectorM A.Par sz $ V.unsafeCast v
#endif