{-# LANGUAGE
GeneralizedNewtypeDeriving
, OverloadedStrings
, TemplateHaskell
#-}
module Data.Fits
(
parsePix
, pixsUnwrapI
, pixsUnwrapD
, HeaderDataUnit(..)
, dimensions
, header
, extension
, mainData
, Pix(..)
, Header(..)
, keywords
, Extension(..)
, Data.Fits.lookup
, Keyword(..)
, Value(..)
, toInt, toFloat, toText
, LogicalConstant(..)
, Dimensions(..)
, axes
, bitpix
, Comment(..)
, SimpleFormat(..)
, BitPixFormat(..)
, Axes
, isBitPixInt
, isBitPixFloat
, bitPixToWordSize
, bitPixToByteSize
, pixDimsByCol
, pixDimsByRow
, hduRecordLength
, hduMaxRecords
, hduBlockSize
) where
import qualified Data.Text as T
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as Map
import Data.String (IsString)
import GHC.TypeNats (KnownNat, Nat)
import Data.Text ( Text )
import Data.Map ( Map )
import Data.List ( intercalate )
import Data.ByteString ( ByteString )
import Lens.Micro ((^.))
import Lens.Micro.TH ( makeLenses )
import Data.Binary
import Data.Binary.Get
hduRecordLength :: Int
hduRecordLength :: Int
hduRecordLength = Int
80
hduMaxRecords :: Int
hduMaxRecords :: Int
hduMaxRecords = Int
36
hduBlockSize :: Int
hduBlockSize :: Int
hduBlockSize = Int
hduRecordLength forall a. Num a => a -> a -> a
* Int
hduMaxRecords
data SimpleFormat = Conformant | NonConformant
deriving (SimpleFormat -> SimpleFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleFormat -> SimpleFormat -> Bool
$c/= :: SimpleFormat -> SimpleFormat -> Bool
== :: SimpleFormat -> SimpleFormat -> Bool
$c== :: SimpleFormat -> SimpleFormat -> Bool
Eq, Int -> SimpleFormat -> ShowS
[SimpleFormat] -> ShowS
SimpleFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimpleFormat] -> ShowS
$cshowList :: [SimpleFormat] -> ShowS
show :: SimpleFormat -> String
$cshow :: SimpleFormat -> String
showsPrec :: Int -> SimpleFormat -> ShowS
$cshowsPrec :: Int -> SimpleFormat -> ShowS
Show)
data LogicalConstant = T | F
deriving (Int -> LogicalConstant -> ShowS
[LogicalConstant] -> ShowS
LogicalConstant -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogicalConstant] -> ShowS
$cshowList :: [LogicalConstant] -> ShowS
show :: LogicalConstant -> String
$cshow :: LogicalConstant -> String
showsPrec :: Int -> LogicalConstant -> ShowS
$cshowsPrec :: Int -> LogicalConstant -> ShowS
Show, LogicalConstant -> LogicalConstant -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogicalConstant -> LogicalConstant -> Bool
$c/= :: LogicalConstant -> LogicalConstant -> Bool
== :: LogicalConstant -> LogicalConstant -> Bool
$c== :: LogicalConstant -> LogicalConstant -> Bool
Eq)
newtype Keyword = Keyword Text
deriving (Int -> Keyword -> ShowS
[Keyword] -> ShowS
Keyword -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Keyword] -> ShowS
$cshowList :: [Keyword] -> ShowS
show :: Keyword -> String
$cshow :: Keyword -> String
showsPrec :: Int -> Keyword -> ShowS
$cshowsPrec :: Int -> Keyword -> ShowS
Show, Keyword -> Keyword -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Keyword -> Keyword -> Bool
$c/= :: Keyword -> Keyword -> Bool
== :: Keyword -> Keyword -> Bool
$c== :: Keyword -> Keyword -> Bool
Eq, Eq Keyword
Keyword -> Keyword -> Bool
Keyword -> Keyword -> Ordering
Keyword -> Keyword -> Keyword
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Keyword -> Keyword -> Keyword
$cmin :: Keyword -> Keyword -> Keyword
max :: Keyword -> Keyword -> Keyword
$cmax :: Keyword -> Keyword -> Keyword
>= :: Keyword -> Keyword -> Bool
$c>= :: Keyword -> Keyword -> Bool
> :: Keyword -> Keyword -> Bool
$c> :: Keyword -> Keyword -> Bool
<= :: Keyword -> Keyword -> Bool
$c<= :: Keyword -> Keyword -> Bool
< :: Keyword -> Keyword -> Bool
$c< :: Keyword -> Keyword -> Bool
compare :: Keyword -> Keyword -> Ordering
$ccompare :: Keyword -> Keyword -> Ordering
Ord, String -> Keyword
forall a. (String -> a) -> IsString a
fromString :: String -> Keyword
$cfromString :: String -> Keyword
IsString)
data Value
= Integer Int
| Float Float
| String Text
| Logic LogicalConstant
deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Value -> Value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq)
type Axes = [Int]
data BitPixFormat =
EightBitInt
| SixteenBitInt
| ThirtyTwoBitInt
| SixtyFourBitInt
| ThirtyTwoBitFloat
| SixtyFourBitFloat
deriving (BitPixFormat -> BitPixFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BitPixFormat -> BitPixFormat -> Bool
$c/= :: BitPixFormat -> BitPixFormat -> Bool
== :: BitPixFormat -> BitPixFormat -> Bool
$c== :: BitPixFormat -> BitPixFormat -> Bool
Eq)
instance Show BitPixFormat where
show :: BitPixFormat -> String
show BitPixFormat
EightBitInt = String
"8 bit unsigned integer"
show BitPixFormat
SixteenBitInt = String
"16 bit signed integer"
show BitPixFormat
ThirtyTwoBitInt = String
"32 bit signed integer"
show BitPixFormat
SixtyFourBitInt = String
"64 bit signed interger"
show BitPixFormat
ThirtyTwoBitFloat = String
"32 bit IEEE single precision float"
show BitPixFormat
SixtyFourBitFloat = String
"64 bit IEEE double precision float"
bitPixToWordSize :: BitPixFormat -> Int
bitPixToWordSize :: BitPixFormat -> Int
bitPixToWordSize BitPixFormat
EightBitInt = Int
8
bitPixToWordSize BitPixFormat
SixteenBitInt = Int
16
bitPixToWordSize BitPixFormat
ThirtyTwoBitInt = Int
32
bitPixToWordSize BitPixFormat
ThirtyTwoBitFloat = Int
32
bitPixToWordSize BitPixFormat
SixtyFourBitInt = Int
64
bitPixToWordSize BitPixFormat
SixtyFourBitFloat = Int
64
bitPixToByteSize :: BitPixFormat -> Int
bitPixToByteSize :: BitPixFormat -> Int
bitPixToByteSize BitPixFormat
EightBitInt = Int
1
bitPixToByteSize BitPixFormat
SixteenBitInt = Int
2
bitPixToByteSize BitPixFormat
ThirtyTwoBitInt = Int
4
bitPixToByteSize BitPixFormat
ThirtyTwoBitFloat = Int
4
bitPixToByteSize BitPixFormat
SixtyFourBitInt = Int
8
bitPixToByteSize BitPixFormat
SixtyFourBitFloat = Int
8
isBitPixInt :: BitPixFormat -> Bool
isBitPixInt :: BitPixFormat -> Bool
isBitPixInt BitPixFormat
EightBitInt = Bool
True
isBitPixInt BitPixFormat
SixteenBitInt = Bool
True
isBitPixInt BitPixFormat
ThirtyTwoBitInt = Bool
True
isBitPixInt BitPixFormat
SixtyFourBitInt = Bool
True
isBitPixInt BitPixFormat
_ = Bool
False
isBitPixFloat :: BitPixFormat -> Bool
isBitPixFloat :: BitPixFormat -> Bool
isBitPixFloat BitPixFormat
ThirtyTwoBitFloat = Bool
True
isBitPixFloat BitPixFormat
SixtyFourBitFloat = Bool
True
isBitPixFloat BitPixFormat
_ = Bool
False
data Pix = PB Int | PI16 Int | PI32 Int | PI64 Int | PF Double | PD Double
unPixI :: Pix -> Int
unPixI :: Pix -> Int
unPixI (PB Int
b) = Int
b
unPixI (PI16 Int
i) = Int
i
unPixI (PI32 Int
i) = Int
i
unPixI (PI64 Int
i) = Int
i
unPixI Pix
_ = forall a. HasCallStack => String -> a
error String
"Pix are not stored as integers, invalid unpacking"
unPixD :: Pix -> Double
unPixD :: Pix -> Double
unPixD (PF Double
d) = Double
d
unPixD (PD Double
d) = Double
d
unPixD Pix
_ = forall a. HasCallStack => String -> a
error String
"Pix are not stored as floating point values, invalid unpacking"
pixsUnwrapI :: BitPixFormat -> [Pix] -> [Int]
pixsUnwrapI :: BitPixFormat -> [Pix] -> [Int]
pixsUnwrapI BitPixFormat
EightBitInt [Pix]
pxs = forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
SixteenBitInt [Pix]
pxs = forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
ThirtyTwoBitInt [Pix]
pxs = forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
SixtyFourBitInt [Pix]
pxs = forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
_ [Pix]
_ = forall a. HasCallStack => String -> a
error String
"BitPixFormat is not an integer type"
pixsUnwrapD :: BitPixFormat -> [Pix] -> [Double]
pixsUnwrapD :: BitPixFormat -> [Pix] -> [Double]
pixsUnwrapD BitPixFormat
ThirtyTwoBitFloat [Pix]
pxs = forall a b. (a -> b) -> [a] -> [b]
map Pix -> Double
unPixD [Pix]
pxs
pixsUnwrapD BitPixFormat
SixtyFourBitFloat [Pix]
pxs = forall a b. (a -> b) -> [a] -> [b]
map Pix -> Double
unPixD [Pix]
pxs
pixsUnwrapD BitPixFormat
_ [Pix]
_ = forall a. HasCallStack => String -> a
error String
"BitPixFormat is not a floating point type"
getPix :: BitPixFormat -> Get Pix
getPix :: BitPixFormat -> Get Pix
getPix BitPixFormat
EightBitInt = Int -> Pix
PB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
getInt8
getPix BitPixFormat
SixteenBitInt = Int -> Pix
PI16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be
getPix BitPixFormat
ThirtyTwoBitInt = Int -> Pix
PI32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32be
getPix BitPixFormat
SixtyFourBitInt = Int -> Pix
PI64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
getInt64be
getPix BitPixFormat
ThirtyTwoBitFloat = Double -> Pix
PF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Float
getFloatbe
getPix BitPixFormat
SixtyFourBitFloat = Double -> Pix
PD forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Double
getDoublebe
getPixs :: Int -> BitPixFormat -> Get [Pix]
getPixs :: Int -> BitPixFormat -> Get [Pix]
getPixs Int
c BitPixFormat
bpf = do
Bool
empty <- Get Bool
isEmpty
if Bool
empty
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
Pix
p <- BitPixFormat -> Get Pix
getPix BitPixFormat
bpf
[Pix]
ps <- Int -> BitPixFormat -> Get [Pix]
getPixs (Int
c forall a. Num a => a -> a -> a
- Int
1) BitPixFormat
bpf
forall (m :: * -> *) a. Monad m => a -> m a
return (Pix
pforall a. a -> [a] -> [a]
:[Pix]
ps)
parsePix :: Int -> BitPixFormat -> BL.ByteString -> IO [Pix]
parsePix :: Int -> BitPixFormat -> ByteString -> IO [Pix]
parsePix Int
c BitPixFormat
bpf ByteString
bs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Get a -> ByteString -> a
runGet (Int -> BitPixFormat -> Get [Pix]
getPixs Int
c BitPixFormat
bpf) ByteString
bs
pixDimsByCol :: Axes -> [Int]
pixDimsByCol :: [Int] -> [Int]
pixDimsByCol = forall a. a -> a
id
pixDimsByRow :: Axes -> [Int]
pixDimsByRow :: [Int] -> [Int]
pixDimsByRow = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
pixDimsByCol
newtype = { Header -> Map Keyword Value
_keywords :: Map Keyword Value }
deriving (Header -> Header -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c== :: Header -> Header -> Bool
Eq)
$(makeLenses ''Header)
instance Show Header where
show :: Header -> String
show Header
h =
let kvs :: [(Keyword, Value)]
kvs = forall k a. Map k a -> [(k, a)]
Map.toList (Header
h forall s a. s -> Getting a s a -> a
^. Lens' Header (Map Keyword Value)
keywords) :: [(Keyword, Value)]
in Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Keyword, Value) -> Text
line [(Keyword, Value)]
kvs
where
line :: (Keyword, Value) -> Text
line :: (Keyword, Value) -> Text
line (Keyword Text
k, Value
v) =
Int -> Char -> Text -> Text
T.justifyLeft Int
8 Char
' ' Text
k
forall a. Semigroup a => a -> a -> a
<> Text
"="
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
T.justifyLeft (Int
hduRecordLength forall a. Num a => a -> a -> a
- Int
10) Char
' ' (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Value -> String
val Value
v)
val :: Value -> String
val (Integer Int
n) = forall a. Show a => a -> String
show Int
n
val (Float Float
f) = forall a. Show a => a -> String
show Float
f
val (Logic LogicalConstant
T) = String
" T"
val (String Text
t) = Text -> String
T.unpack Text
t
lookup :: Keyword -> Header -> Maybe Value
lookup :: Keyword -> Header -> Maybe Value
lookup Keyword
k Header
h = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Keyword
k (Header
h forall s a. s -> Getting a s a -> a
^. Lens' Header (Map Keyword Value)
keywords)
data Extension
= Primary
| Image
| BinTable { Extension -> Int
pCount :: Int, Extension -> ByteString
heap :: ByteString }
deriving (Extension -> Extension -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Extension -> Extension -> Bool
$c/= :: Extension -> Extension -> Bool
== :: Extension -> Extension -> Bool
$c== :: Extension -> Extension -> Bool
Eq)
instance Show Extension where
show :: Extension -> String
show Extension
Primary = String
"Primary"
show Extension
Image = String
"Image"
show (BinTable Int
p ByteString
_) = String
"BinTable: heap = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
p forall a. Semigroup a => a -> a -> a
<> String
" Bytes"
toInt :: Value -> Maybe Int
toInt :: Value -> Maybe Int
toInt (Integer Int
i) = forall a. a -> Maybe a
Just Int
i
toInt Value
_ = forall a. Maybe a
Nothing
toFloat :: Value -> Maybe Float
toFloat :: Value -> Maybe Float
toFloat (Float Float
n) = forall a. a -> Maybe a
Just Float
n
toFloat Value
_ = forall a. Maybe a
Nothing
toText :: Value -> Maybe Text
toText :: Value -> Maybe Text
toText (String Text
s) = forall a. a -> Maybe a
Just Text
s
toText Value
_ = forall a. Maybe a
Nothing
data Dimensions = Dimensions
{ Dimensions -> BitPixFormat
_bitpix :: BitPixFormat
, Dimensions -> [Int]
_axes :: Axes
} deriving (Int -> Dimensions -> ShowS
[Dimensions] -> ShowS
Dimensions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dimensions] -> ShowS
$cshowList :: [Dimensions] -> ShowS
show :: Dimensions -> String
$cshow :: Dimensions -> String
showsPrec :: Int -> Dimensions -> ShowS
$cshowsPrec :: Int -> Dimensions -> ShowS
Show, Dimensions -> Dimensions -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dimensions -> Dimensions -> Bool
$c/= :: Dimensions -> Dimensions -> Bool
== :: Dimensions -> Dimensions -> Bool
$c== :: Dimensions -> Dimensions -> Bool
Eq)
$(makeLenses ''Dimensions)
newtype = Text
deriving (Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Comment] -> ShowS
$cshowList :: [Comment] -> ShowS
show :: Comment -> String
$cshow :: Comment -> String
showsPrec :: Int -> Comment -> ShowS
$cshowsPrec :: Int -> Comment -> ShowS
Show, Comment -> Comment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Comment -> Comment -> Bool
$c/= :: Comment -> Comment -> Bool
== :: Comment -> Comment -> Bool
$c== :: Comment -> Comment -> Bool
Eq, Eq Comment
Comment -> Comment -> Bool
Comment -> Comment -> Ordering
Comment -> Comment -> Comment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Comment -> Comment -> Comment
$cmin :: Comment -> Comment -> Comment
max :: Comment -> Comment -> Comment
$cmax :: Comment -> Comment -> Comment
>= :: Comment -> Comment -> Bool
$c>= :: Comment -> Comment -> Bool
> :: Comment -> Comment -> Bool
$c> :: Comment -> Comment -> Bool
<= :: Comment -> Comment -> Bool
$c<= :: Comment -> Comment -> Bool
< :: Comment -> Comment -> Bool
$c< :: Comment -> Comment -> Bool
compare :: Comment -> Comment -> Ordering
$ccompare :: Comment -> Comment -> Ordering
Ord, String -> Comment
forall a. (String -> a) -> IsString a
fromString :: String -> Comment
$cfromString :: String -> Comment
IsString)
data =
{ :: Header
, HeaderDataUnit -> Dimensions
_dimensions :: Dimensions
, HeaderDataUnit -> Extension
_extension :: Extension
, HeaderDataUnit -> ByteString
_mainData :: ByteString
}
$
instance Show HeaderDataUnit where
show :: HeaderDataUnit -> String
show HeaderDataUnit
hdu = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
[ String
"HeaderDataUnit:"
, String
" headers = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall k a. Map k a -> Int
Map.size (HeaderDataUnit
hdu forall s a. s -> Getting a s a -> a
^. Lens' HeaderDataUnit Header
header forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Header (Map Keyword Value)
keywords))
, String
" extension = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (HeaderDataUnit
hdu forall s a. s -> Getting a s a -> a
^. Lens' HeaderDataUnit Extension
extension)
, String
" mainData = " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (ByteString -> Int
BS.length (HeaderDataUnit
hdu forall s a. s -> Getting a s a -> a
^. Lens' HeaderDataUnit ByteString
mainData)) forall a. Semigroup a => a -> a -> a
<> String
" Bytes"
]