module Telescope.Fits.Encoding where
import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow, throwM)
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Builder
import Data.ByteString.Lazy qualified as BL
import Data.Char (toUpper)
import Data.Fits qualified as Fits
import Data.Fits.MegaParser (Parser)
import Data.Fits.MegaParser qualified as Fits
import Data.Fits.Read (FitsError (..))
import Data.String (IsString (..))
import Data.Text (Text, isPrefixOf, pack, unpack)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Effectful
import Effectful.Error.Static
import Effectful.State.Static.Local
import Telescope.Fits.Checksum
import Telescope.Fits.Types
import Text.Megaparsec qualified as M
import Text.Megaparsec.State qualified as M
decode :: forall m. (MonadThrow m) => ByteString -> m Fits
decode :: forall (m :: * -> *). MonadThrow m => ByteString -> m Fits
decode ByteString
inp = do
let res :: Fits
res = Eff '[] Fits -> Fits
forall a. Eff '[] a -> a
runPureEff (Eff '[] Fits -> Fits) -> Eff '[] Fits -> Fits
forall a b. (a -> b) -> a -> b
$ ByteString -> Eff '[State ByteString] Fits -> Eff '[] Fits
forall s (es :: [(* -> *) -> * -> *]) a.
s -> Eff (State s : es) a -> Eff es a
evalState ByteString
inp Eff '[State ByteString] Fits
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es Fits
parseFits
Fits -> m Fits
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fits
res
dataArray :: Fits.Dimensions -> ByteString -> DataArray
dataArray :: Dimensions -> ByteString -> DataArray
dataArray Dimensions
dim ByteString
dat =
DataArray
{ $sel:bitpix:DataArray :: BitPix
bitpix = BitPixFormat -> BitPix
bitpix Dimensions
dim._bitpix
, $sel:axes:DataArray :: Axes Column
axes = Axes -> Axes Column
axes Dimensions
dim._axes
, $sel:rawData:DataArray :: ByteString
rawData = ByteString
dat
}
where
bitpix :: Fits.BitPixFormat -> BitPix
bitpix :: BitPixFormat -> BitPix
bitpix BitPixFormat
Fits.EightBitInt = BitPix
BPInt8
bitpix BitPixFormat
Fits.SixteenBitInt = BitPix
BPInt16
bitpix BitPixFormat
Fits.ThirtyTwoBitInt = BitPix
BPInt32
bitpix BitPixFormat
Fits.SixtyFourBitInt = BitPix
BPInt64
bitpix BitPixFormat
Fits.ThirtyTwoBitFloat = BitPix
BPFloat
bitpix BitPixFormat
Fits.SixtyFourBitFloat = BitPix
BPDouble
axes :: Fits.Axes -> Axes Column
axes :: Axes -> Axes Column
axes = Axes -> Axes Column
forall {k} (a :: k). Axes -> Axes a
Axes
parseFits :: (State ByteString :> es) => Eff es Fits
parseFits :: forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es Fits
parseFits = do
PrimaryHDU
p <- Eff es PrimaryHDU
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es PrimaryHDU
primary
[Extension]
es <- Eff es [Extension]
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es [Extension]
extensions
Fits -> Eff es Fits
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fits -> Eff es Fits) -> Fits -> Eff es Fits
forall a b. (a -> b) -> a -> b
$ PrimaryHDU -> [Extension] -> Fits
Fits PrimaryHDU
p [Extension]
es
where
primary :: (State ByteString :> es) => Eff es PrimaryHDU
primary :: forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es PrimaryHDU
primary = do
(Dimensions
dm, Header
hd) <- String
-> Parser (Dimensions, Header) -> Eff es (Dimensions, Header)
forall (es :: [(* -> *) -> * -> *]) a.
(State ByteString :> es) =>
String -> Parser a -> Eff es a
nextParserThrow String
"Primary Header" (Parser (Dimensions, Header) -> Eff es (Dimensions, Header))
-> Parser (Dimensions, Header) -> Eff es (Dimensions, Header)
forall a b. (a -> b) -> a -> b
$ do
Dimensions
dm <- Parser Dimensions
Fits.parsePrimaryKeywords
Header
hd <- Parser Header
Fits.parseHeader
(Dimensions, Header) -> Parser (Dimensions, Header)
forall a. a -> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dimensions
dm, Header
hd)
DataArray
darr <- Dimensions -> Eff es DataArray
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Dimensions -> Eff es DataArray
mainData Dimensions
dm
PrimaryHDU -> Eff es PrimaryHDU
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimaryHDU -> Eff es PrimaryHDU)
-> PrimaryHDU -> Eff es PrimaryHDU
forall a b. (a -> b) -> a -> b
$ Header -> DataArray -> PrimaryHDU
PrimaryHDU Header
hd DataArray
darr
image :: (Error HDUError :> es, State ByteString :> es) => Eff es ImageHDU
image :: forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es ImageHDU
image = do
(Dimensions
dm, Header
hd) <- Eff es (Dimensions, Header)
forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es (Dimensions, Header)
imageHeader
DataArray
darr <- Dimensions -> Eff es DataArray
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Dimensions -> Eff es DataArray
mainData Dimensions
dm
ImageHDU -> Eff es ImageHDU
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ImageHDU -> Eff es ImageHDU) -> ImageHDU -> Eff es ImageHDU
forall a b. (a -> b) -> a -> b
$ Header -> DataArray -> ImageHDU
ImageHDU Header
hd DataArray
darr
imageHeader :: (Error HDUError :> es, State ByteString :> es) => Eff es (Fits.Dimensions, Header)
imageHeader :: forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es (Dimensions, Header)
imageHeader = do
String
-> Parser (Dimensions, Header) -> Eff es (Dimensions, Header)
forall (es :: [(* -> *) -> * -> *]) a.
(Error HDUError :> es, State ByteString :> es) =>
String -> Parser a -> Eff es a
nextParser String
"Image Header" (Parser (Dimensions, Header) -> Eff es (Dimensions, Header))
-> Parser (Dimensions, Header) -> Eff es (Dimensions, Header)
forall a b. (a -> b) -> a -> b
$ do
Dimensions
dm <- Parser Dimensions
Fits.parseImageKeywords
Header
hd <- Parser Header
Fits.parseHeader
(Dimensions, Header) -> Parser (Dimensions, Header)
forall a. a -> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dimensions
dm, Header
hd)
extension :: (State ByteString :> es) => Eff es Extension
extension :: forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es Extension
extension = do
Either HDUError ImageHDU
resImg <- forall e (es :: [(* -> *) -> * -> *]) a.
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @HDUError Eff (Error HDUError : es) ImageHDU
forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es ImageHDU
image
Either HDUError BinTableHDU
resTbl <- forall e (es :: [(* -> *) -> * -> *]) a.
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @HDUError Eff (Error HDUError : es) BinTableHDU
forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es BinTableHDU
binTable
case (Either HDUError ImageHDU
resImg, Either HDUError BinTableHDU
resTbl) of
(Right ImageHDU
i, Either HDUError BinTableHDU
_) -> Extension -> Eff es Extension
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extension -> Eff es Extension) -> Extension -> Eff es Extension
forall a b. (a -> b) -> a -> b
$ ImageHDU -> Extension
Image ImageHDU
i
(Either HDUError ImageHDU
_, Right BinTableHDU
b) -> Extension -> Eff es Extension
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extension -> Eff es Extension) -> Extension -> Eff es Extension
forall a b. (a -> b) -> a -> b
$ BinTableHDU -> Extension
BinTable BinTableHDU
b
(Either HDUError ImageHDU
_, Left HDUError
be) -> HDUError -> Eff es Extension
forall e a. Exception e => e -> Eff es a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM HDUError
be
extensions :: (State ByteString :> es) => Eff es [Extension]
extensions :: forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es [Extension]
extensions = do
ByteString
inp <- forall s (es :: [(* -> *) -> * -> *]). (State s :> es) => Eff es s
get @ByteString
case ByteString
inp of
ByteString
"" -> [Extension] -> Eff es [Extension]
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
ByteString
_ -> do
Extension
e <- Eff es Extension
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es Extension
extension
[Extension]
es <- Eff es [Extension]
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Eff es [Extension]
extensions
[Extension] -> Eff es [Extension]
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extension
e Extension -> [Extension] -> [Extension]
forall a. a -> [a] -> [a]
: [Extension]
es)
binTable :: (Error HDUError :> es, State ByteString :> es) => Eff es BinTableHDU
binTable :: forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es BinTableHDU
binTable = do
(Dimensions
dm, Int
pcount, Header
hd) <- Eff es (Dimensions, Int, Header)
forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es (Dimensions, Int, Header)
binTableHeader
DataArray
darr <- Dimensions -> Eff es DataArray
forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Dimensions -> Eff es DataArray
mainData Dimensions
dm
ByteString
rest <- Eff es ByteString
forall s (es :: [(* -> *) -> * -> *]). (State s :> es) => Eff es s
get
let heap :: ByteString
heap = Int -> ByteString -> ByteString
BS.take Int
pcount ByteString
rest
ByteString -> Eff es ()
forall s (es :: [(* -> *) -> * -> *]).
(State s :> es) =>
s -> Eff es ()
put (ByteString -> Eff es ()) -> ByteString -> Eff es ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
pcount ByteString
rest
BinTableHDU -> Eff es BinTableHDU
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BinTableHDU -> Eff es BinTableHDU)
-> BinTableHDU -> Eff es BinTableHDU
forall a b. (a -> b) -> a -> b
$ Header -> Int -> ByteString -> DataArray -> BinTableHDU
BinTableHDU Header
hd Int
pcount ByteString
heap DataArray
darr
binTableHeader :: (Error HDUError :> es, State ByteString :> es) => Eff es (Fits.Dimensions, Int, Header)
binTableHeader :: forall (es :: [(* -> *) -> * -> *]).
(Error HDUError :> es, State ByteString :> es) =>
Eff es (Dimensions, Int, Header)
binTableHeader = do
String
-> Parser (Dimensions, Int, Header)
-> Eff es (Dimensions, Int, Header)
forall (es :: [(* -> *) -> * -> *]) a.
(Error HDUError :> es, State ByteString :> es) =>
String -> Parser a -> Eff es a
nextParser String
"BinTable Header" (Parser (Dimensions, Int, Header)
-> Eff es (Dimensions, Int, Header))
-> Parser (Dimensions, Int, Header)
-> Eff es (Dimensions, Int, Header)
forall a b. (a -> b) -> a -> b
$ do
(Dimensions
dm, Int
pcount) <- Parser (Dimensions, Int)
Fits.parseBinTableKeywords
Header
hd <- Parser Header
Fits.parseHeader
(Dimensions, Int, Header) -> Parser (Dimensions, Int, Header)
forall a. a -> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dimensions
dm, Int
pcount, Header
hd)
mainData :: (State ByteString :> es) => Fits.Dimensions -> Eff es DataArray
mainData :: forall (es :: [(* -> *) -> * -> *]).
(State ByteString :> es) =>
Dimensions -> Eff es DataArray
mainData Dimensions
dm = do
ByteString
rest <- Eff es ByteString
forall s (es :: [(* -> *) -> * -> *]). (State s :> es) => Eff es s
get
let len :: Int
len = Dimensions -> Int
Fits.dataSize Dimensions
dm
let dat :: DataArray
dat = Dimensions -> ByteString -> DataArray
dataArray Dimensions
dm (Int -> ByteString -> ByteString
BS.take Int
len ByteString
rest)
ByteString -> Eff es ()
forall s (es :: [(* -> *) -> * -> *]).
(State s :> es) =>
s -> Eff es ()
put (ByteString -> Eff es ()) -> ByteString -> Eff es ()
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
BS.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
len ByteString
rest
DataArray -> Eff es DataArray
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DataArray
dat
nextParserThrow :: (State ByteString :> es) => String -> Parser a -> Eff es a
nextParserThrow :: forall (es :: [(* -> *) -> * -> *]) a.
(State ByteString :> es) =>
String -> Parser a -> Eff es a
nextParserThrow String
src Parser a
parse = do
Either HDUError a
res <- forall e (es :: [(* -> *) -> * -> *]) a.
Eff (Error e : es) a -> Eff es (Either e a)
runErrorNoCallStack @HDUError (String -> Parser a -> Eff (Error HDUError : es) a
forall (es :: [(* -> *) -> * -> *]) a.
(Error HDUError :> es, State ByteString :> es) =>
String -> Parser a -> Eff es a
nextParser String
src Parser a
parse)
case Either HDUError a
res of
Right a
a -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Left HDUError
e -> HDUError -> Eff es a
forall e a. Exception e => e -> Eff es a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM HDUError
e
nextParser :: (Error HDUError :> es, State ByteString :> es) => String -> Parser a -> Eff es a
nextParser :: forall (es :: [(* -> *) -> * -> *]) a.
(Error HDUError :> es, State ByteString :> es) =>
String -> Parser a -> Eff es a
nextParser String
src Parser a
parse = do
ByteString
bs <- Eff es ByteString
forall s (es :: [(* -> *) -> * -> *]). (State s :> es) => Eff es s
get
let st1 :: State ByteString Void
st1 = String -> ByteString -> State ByteString Void
forall s e. String -> s -> State s e
M.initialState String
src ByteString
bs
case Parser a
-> State ByteString Void
-> (State ByteString Void,
Either (ParseErrorBundle ByteString Void) a)
forall e s a.
Parsec e s a
-> State s e -> (State s e, Either (ParseErrorBundle s e) a)
M.runParser' Parser a
parse State ByteString Void
st1 of
(State ByteString Void
st2, Right a
a) -> do
ByteString -> Eff es ()
forall s (es :: [(* -> *) -> * -> *]).
(State s :> es) =>
s -> Eff es ()
put (ByteString -> Eff es ()) -> ByteString -> Eff es ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop State ByteString Void
st2.stateOffset ByteString
bs
a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
(State ByteString Void
_, Left ParseErrorBundle ByteString Void
err) -> HDUError -> Eff es a
forall e (es :: [(* -> *) -> * -> *]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError (HDUError -> Eff es a) -> HDUError -> Eff es a
forall a b. (a -> b) -> a -> b
$ FitsError -> HDUError
FormatError (FitsError -> HDUError) -> FitsError -> HDUError
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle ByteString Void -> FitsError
ParseError ParseErrorBundle ByteString Void
err
data HDUError
= InvalidExtension String
| MissingPrimary
| FormatError FitsError
deriving (Int -> HDUError -> ShowS
[HDUError] -> ShowS
HDUError -> String
(Int -> HDUError -> ShowS)
-> (HDUError -> String) -> ([HDUError] -> ShowS) -> Show HDUError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HDUError -> ShowS
showsPrec :: Int -> HDUError -> ShowS
$cshow :: HDUError -> String
show :: HDUError -> String
$cshowList :: [HDUError] -> ShowS
showList :: [HDUError] -> ShowS
Show, Show HDUError
Typeable HDUError
Typeable HDUError
-> Show HDUError
-> (HDUError -> SomeException)
-> (SomeException -> Maybe HDUError)
-> (HDUError -> String)
-> Exception HDUError
SomeException -> Maybe HDUError
HDUError -> String
HDUError -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
$ctoException :: HDUError -> SomeException
toException :: HDUError -> SomeException
$cfromException :: SomeException -> Maybe HDUError
fromException :: SomeException -> Maybe HDUError
$cdisplayException :: HDUError -> String
displayException :: HDUError -> String
Exception)
encode :: Fits -> ByteString
encode :: Fits -> ByteString
encode Fits
f =
let primary :: ByteString
primary = PrimaryHDU -> ByteString
encodePrimaryHDU Fits
f.primaryHDU
exts :: [ByteString]
exts = (Extension -> ByteString) -> [Extension] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> ByteString
encodeExtension Fits
f.extensions
in [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
primary ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
exts
runRender :: BuilderBlock -> BL.ByteString
runRender :: BuilderBlock -> ByteString
runRender BuilderBlock
bb = Builder -> ByteString
toLazyByteString BuilderBlock
bb.builder
encodePrimaryHDU :: PrimaryHDU -> ByteString
encodePrimaryHDU :: PrimaryHDU -> ByteString
encodePrimaryHDU PrimaryHDU
p = (Checksum -> BuilderBlock) -> ByteString -> ByteString
encodeHDU (Header -> DataArray -> Checksum -> BuilderBlock
renderPrimaryHeader PrimaryHDU
p.header PrimaryHDU
p.dataArray) PrimaryHDU
p.dataArray.rawData
encodeImageHDU :: ImageHDU -> ByteString
encodeImageHDU :: ImageHDU -> ByteString
encodeImageHDU ImageHDU
p = (Checksum -> BuilderBlock) -> ByteString -> ByteString
encodeHDU (Header -> DataArray -> Checksum -> BuilderBlock
renderImageHeader ImageHDU
p.header ImageHDU
p.dataArray) ImageHDU
p.dataArray.rawData
encodeExtension :: Extension -> ByteString
encodeExtension :: Extension -> ByteString
encodeExtension (Image ImageHDU
hdu) = ImageHDU -> ByteString
encodeImageHDU ImageHDU
hdu
encodeExtension (BinTable BinTableHDU
_) = String -> ByteString
forall a. HasCallStack => String -> a
error String
"BinTableHDU rendering not supported"
encodeHDU :: (Checksum -> BuilderBlock) -> ByteString -> ByteString
encodeHDU :: (Checksum -> BuilderBlock) -> ByteString -> ByteString
encodeHDU Checksum -> BuilderBlock
buildHead ByteString
rawData =
let dsum :: Checksum
dsum = ByteString -> Checksum
checksum ByteString
rawData
in BuilderBlock -> Checksum -> ByteString
encodeHeader (Checksum -> BuilderBlock
buildHead Checksum
dsum) Checksum
dsum ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
encodeDataArray ByteString
rawData
encodeHeader :: BuilderBlock -> Checksum -> ByteString
BuilderBlock
buildHead Checksum
dsum =
let h :: ByteString
h = ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ BuilderBlock -> ByteString
runRender BuilderBlock
buildHead
hsum :: Checksum
hsum = ByteString -> Checksum
checksum ByteString
h
csum :: Checksum
csum = Checksum
hsum Checksum -> Checksum -> Checksum
forall a. Semigroup a => a -> a -> a
<> Checksum
dsum
in Checksum -> ByteString -> ByteString
replaceChecksum Checksum
csum ByteString
h
encodeDataArray :: ByteString -> ByteString
encodeDataArray :: ByteString -> ByteString
encodeDataArray ByteString
dat = ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ BuilderBlock -> ByteString
runRender (BuilderBlock -> ByteString) -> BuilderBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> BuilderBlock
renderData ByteString
dat
replaceChecksum :: Checksum -> ByteString -> ByteString
replaceChecksum :: Checksum -> ByteString -> ByteString
replaceChecksum Checksum
csum = ByteString -> Value -> Maybe Text -> ByteString -> ByteString
replaceKeywordLine ByteString
"CHECKSUM" (Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Checksum -> Text
encodeChecksum Checksum
csum) Maybe Text
forall a. Maybe a
Nothing
replaceKeywordLine :: ByteString -> Value -> Maybe Text -> ByteString -> ByteString
replaceKeywordLine :: ByteString -> Value -> Maybe Text -> ByteString -> ByteString
replaceKeywordLine ByteString
key Value
val Maybe Text
mc ByteString
header =
let (ByteString
start, ByteString
rest) = ByteString -> ByteString -> (ByteString, ByteString)
BS.breakSubstring ByteString
key ByteString
header
newKeyLine :: ByteString
newKeyLine = ByteString -> ByteString
BS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ BuilderBlock -> ByteString
runRender (BuilderBlock -> ByteString) -> BuilderBlock -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine (ByteString -> Text
TE.decodeUtf8 ByteString
key) Value
val Maybe Text
mc
in ByteString
start ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
newKeyLine ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> ByteString -> ByteString
BS.drop Int
80 ByteString
rest
renderData :: ByteString -> BuilderBlock
renderData :: ByteString -> BuilderBlock
renderData ByteString
s = (Int -> BuilderBlock) -> BuilderBlock -> BuilderBlock
fillBlock Int -> BuilderBlock
zeros (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Int -> Builder -> BuilderBlock
BuilderBlock (ByteString -> Int
BS.length ByteString
s) (Builder -> BuilderBlock) -> Builder -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
s
renderImageHeader :: Header -> DataArray -> Checksum -> BuilderBlock
Header
h DataArray
d Checksum
dsum =
(Int -> BuilderBlock) -> BuilderBlock -> BuilderBlock
fillBlock Int -> BuilderBlock
spaces (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$
[BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
[ Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"XTENSION" (Text -> Value
String Text
"IMAGE") (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Image Extension")
, BitPix -> Axes Column -> BuilderBlock
renderDataKeywords DataArray
d.bitpix DataArray
d.axes
, Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"PCOUNT" (Int -> Value
Integer Int
0) Maybe Text
forall a. Maybe a
Nothing
, Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"GCOUNT" (Int -> Value
Integer Int
1) Maybe Text
forall a. Maybe a
Nothing
, Checksum -> BuilderBlock
renderDatasum Checksum
dsum
, Header -> BuilderBlock
renderOtherKeywords Header
h
, BuilderBlock
renderEnd
]
renderPrimaryHeader :: Header -> DataArray -> Checksum -> BuilderBlock
Header
h DataArray
d Checksum
dsum =
(Int -> BuilderBlock) -> BuilderBlock -> BuilderBlock
fillBlock Int -> BuilderBlock
spaces (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$
[BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
[ Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"SIMPLE" (LogicalConstant -> Value
Logic LogicalConstant
T) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Conforms to the FITS standard")
, BitPix -> Axes Column -> BuilderBlock
renderDataKeywords DataArray
d.bitpix DataArray
d.axes
, Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"EXTEND" (LogicalConstant -> Value
Logic LogicalConstant
T) Maybe Text
forall a. Maybe a
Nothing
, Checksum -> BuilderBlock
renderDatasum Checksum
dsum
, Header -> BuilderBlock
renderOtherKeywords Header
h
, BuilderBlock
renderEnd
]
renderDatasum :: Checksum -> BuilderBlock
renderDatasum :: Checksum -> BuilderBlock
renderDatasum Checksum
dsum =
[BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
[ Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"DATASUM" (Checksum -> Value
checksumValue Checksum
dsum) Maybe Text
forall a. Maybe a
Nothing
,
Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"CHECKSUM" (Text -> Value
String (Int -> Text -> Text
T.replicate Int
16 Text
"0")) Maybe Text
forall a. Maybe a
Nothing
]
renderEnd :: BuilderBlock
renderEnd :: BuilderBlock
renderEnd = Int -> BuilderBlock -> BuilderBlock
pad Int
80 BuilderBlock
"END"
renderDataKeywords :: BitPix -> Axes Column -> BuilderBlock
renderDataKeywords :: BitPix -> Axes Column -> BuilderBlock
renderDataKeywords BitPix
bp (Axes Axes
as) =
[BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
[ BuilderBlock
bitpix
, BuilderBlock
naxis_
, BuilderBlock
naxes
]
where
bitpix :: BuilderBlock
bitpix = Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"BITPIX" (Int -> Value
Integer (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ BitPix -> Int
bitPixCode BitPix
bp) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BitPix -> Text
bitPixType BitPix
bp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") array data type")
naxis_ :: BuilderBlock
naxis_ = Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
"NAXIS" (Int -> Value
Integer (Int -> Value) -> Int -> Value
forall a b. (a -> b) -> a -> b
$ Axes -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Axes
as) (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"number of axes in data array")
naxes :: BuilderBlock
naxes = [BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat ([BuilderBlock] -> BuilderBlock) -> [BuilderBlock] -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith @Int Int -> Int -> BuilderBlock
forall {a}. Show a => a -> Int -> BuilderBlock
naxisN [Int
1 ..] Axes
as
naxisN :: a -> Int -> BuilderBlock
naxisN a
n Int
a =
let nt :: Text
nt = String -> Text
pack (a -> String
forall a. Show a => a -> String
show a
n)
in Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine (Text
"NAXIS" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nt) (Int -> Value
Integer Int
a) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"axis " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" length")
bitPixType :: BitPix -> Text
bitPixType = String -> Text
pack (String -> Text) -> (BitPix -> String) -> BitPix -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
2 ShowS -> (BitPix -> String) -> BitPix -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitPix -> String
forall a. Show a => a -> String
show
renderOtherKeywords :: Header -> BuilderBlock
renderOtherKeywords :: Header -> BuilderBlock
renderOtherKeywords (Header [HeaderRecord]
ks) =
[BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat ([BuilderBlock] -> BuilderBlock) -> [BuilderBlock] -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ (HeaderRecord -> BuilderBlock) -> [HeaderRecord] -> [BuilderBlock]
forall a b. (a -> b) -> [a] -> [b]
map HeaderRecord -> BuilderBlock
toLine ([HeaderRecord] -> [BuilderBlock])
-> [HeaderRecord] -> [BuilderBlock]
forall a b. (a -> b) -> a -> b
$ (HeaderRecord -> Bool) -> [HeaderRecord] -> [HeaderRecord]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (HeaderRecord -> Bool) -> HeaderRecord -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderRecord -> Bool
isSystemKeyword) [HeaderRecord]
ks
where
toLine :: HeaderRecord -> BuilderBlock
toLine (Keyword KeywordRecord
kr) = Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine KeywordRecord
kr._keyword KeywordRecord
kr._value KeywordRecord
kr._comment
toLine (Comment Text
c) = Int -> BuilderBlock -> BuilderBlock
pad Int
80 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String
"COMMENT " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
c
toLine HeaderRecord
BlankLine = Int -> BuilderBlock -> BuilderBlock
pad Int
80 BuilderBlock
""
isSystemKeyword :: HeaderRecord -> Bool
isSystemKeyword (Keyword KeywordRecord
kr) =
let k :: Text
k = KeywordRecord
kr._keyword
in Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"BITPIX"
Bool -> Bool -> Bool
|| Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"EXTEND"
Bool -> Bool -> Bool
|| Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"DATASUM"
Bool -> Bool -> Bool
|| Text
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"CHECKSUM"
Bool -> Bool -> Bool
|| Text
"NAXIS" Text -> Text -> Bool
`isPrefixOf` Text
k
isSystemKeyword HeaderRecord
_ = Bool
False
fillBlock :: (Int -> BuilderBlock) -> BuilderBlock -> BuilderBlock
fillBlock :: (Int -> BuilderBlock) -> BuilderBlock -> BuilderBlock
fillBlock Int -> BuilderBlock
fill BuilderBlock
b =
let rm :: Int
rm = Int
hduBlockSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
b.length Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
hduBlockSize
in BuilderBlock
b BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> Int -> BuilderBlock
extraSpaces Int
rm
where
extraSpaces :: Int -> BuilderBlock
extraSpaces Int
n
| Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
hduBlockSize = BuilderBlock
forall a. Monoid a => a
mempty
| Bool
otherwise = Int -> BuilderBlock
fill Int
n
bitPixCode :: BitPix -> Int
bitPixCode :: BitPix -> Int
bitPixCode BitPix
BPInt8 = Int
8
bitPixCode BitPix
BPInt16 = Int
16
bitPixCode BitPix
BPInt32 = Int
32
bitPixCode BitPix
BPInt64 = Int
64
bitPixCode BitPix
BPFloat = -Int
32
bitPixCode BitPix
BPDouble = -Int
64
renderKeywordLine :: Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine :: Text -> Value -> Maybe Text -> BuilderBlock
renderKeywordLine Text
k Value
v Maybe Text
mc =
let kv :: BuilderBlock
kv = Text -> Value -> BuilderBlock
renderKeywordValue Text
k Value
v
in Int -> BuilderBlock -> BuilderBlock
pad Int
80 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ BuilderBlock -> Maybe Text -> BuilderBlock
addComment BuilderBlock
kv Maybe Text
mc
where
addComment :: BuilderBlock -> Maybe Text -> BuilderBlock
addComment BuilderBlock
kv Maybe Text
Nothing = BuilderBlock
kv
addComment BuilderBlock
kv (Just Text
c) =
let mx :: Int
mx = Int
80 Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
kv.length
in BuilderBlock
kv BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> BuilderBlock
renderComment Int
mx Text
c
renderKeywordValue :: Text -> Value -> BuilderBlock
renderKeywordValue :: Text -> Value -> BuilderBlock
renderKeywordValue Text
k Value
v =
[BuilderBlock] -> BuilderBlock
forall a. Monoid a => [a] -> a
mconcat
[ Text -> BuilderBlock
renderKeyword Text
k
, String -> BuilderBlock
string String
"= "
, Int -> BuilderBlock -> BuilderBlock
pad Int
20 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Value -> BuilderBlock
renderValue Value
v
]
renderKeyword :: Text -> BuilderBlock
renderKeyword :: Text -> BuilderBlock
renderKeyword Text
k = Int -> BuilderBlock -> BuilderBlock
pad Int
8 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
k
renderComment :: Int -> Text -> BuilderBlock
Int
mx Text
c = String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
mx ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
" / " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
c
renderValue :: Value -> BuilderBlock
renderValue :: Value -> BuilderBlock
renderValue (Logic LogicalConstant
T) = Int -> BuilderBlock -> BuilderBlock
justify Int
20 BuilderBlock
"T"
renderValue (Logic LogicalConstant
F) = Int -> BuilderBlock -> BuilderBlock
justify Int
20 BuilderBlock
"F"
renderValue (Float Float
f) = Int -> BuilderBlock -> BuilderBlock
justify Int
20 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. Show a => a -> String
show Float
f
renderValue (Integer Int
n) = Int -> BuilderBlock -> BuilderBlock
justify Int
20 (BuilderBlock -> BuilderBlock) -> BuilderBlock -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n
renderValue (String Text
s) = String -> BuilderBlock
string (String -> BuilderBlock) -> String -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ String
"'" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
s String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"'"
data BuilderBlock = BuilderBlock {BuilderBlock -> Int
length :: Int, BuilderBlock -> Builder
builder :: Builder}
builderBlock :: Int -> Builder -> BuilderBlock
builderBlock :: Int -> Builder -> BuilderBlock
builderBlock Int
n = Int -> Builder -> BuilderBlock
BuilderBlock (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n Int
0)
instance IsString BuilderBlock where
fromString :: String -> BuilderBlock
fromString = String -> BuilderBlock
string
instance Semigroup BuilderBlock where
BuilderBlock Int
l Builder
b <> :: BuilderBlock -> BuilderBlock -> BuilderBlock
<> BuilderBlock Int
l2 Builder
b2 = Int -> Builder -> BuilderBlock
BuilderBlock (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2) (Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b2)
instance Monoid BuilderBlock where
mempty :: BuilderBlock
mempty = Int -> Builder -> BuilderBlock
BuilderBlock Int
0 Builder
forall a. Monoid a => a
mempty
justify :: Int -> BuilderBlock -> BuilderBlock
justify :: Int -> BuilderBlock -> BuilderBlock
justify Int
n BuilderBlock
b = Int -> BuilderBlock
spaces (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
b.length) BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> BuilderBlock
b
pad :: Int -> BuilderBlock -> BuilderBlock
pad :: Int -> BuilderBlock -> BuilderBlock
pad Int
n BuilderBlock
b = BuilderBlock
b BuilderBlock -> BuilderBlock -> BuilderBlock
forall a. Semigroup a => a -> a -> a
<> Int -> BuilderBlock
spaces (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- BuilderBlock
b.length)
spaces :: Int -> BuilderBlock
spaces :: Int -> BuilderBlock
spaces = Builder -> Int -> BuilderBlock
padding (Char -> Builder
charUtf8 Char
' ')
zeros :: Int -> BuilderBlock
zeros :: Int -> BuilderBlock
zeros = Builder -> Int -> BuilderBlock
padding (Word8 -> Builder
word8 Word8
0)
padding :: Builder -> Int -> BuilderBlock
padding :: Builder -> Int -> BuilderBlock
padding Builder
b Int
n = Int -> Builder -> BuilderBlock
builderBlock Int
n (Builder -> BuilderBlock)
-> (Builder -> Builder) -> Builder -> BuilderBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> (Builder -> [Builder]) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Builder -> [Builder]
forall a. Int -> a -> [a]
replicate Int
n (Builder -> BuilderBlock) -> Builder -> BuilderBlock
forall a b. (a -> b) -> a -> b
$ Builder
b
string :: String -> BuilderBlock
string :: String -> BuilderBlock
string String
s = Int -> Builder -> BuilderBlock
builderBlock (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) (String -> Builder
stringUtf8 String
s)