{-|
Module      : Data.Fits
Description : Types for FITS Data Units
Copyright   : (c) Zac Slade, 2023
License     : BSD2
Maintainer  : krakrjak@gmail.com
Stability   : experimental

Definitions for the data types needed to parse an HDU in a FITS block.
-}

{-# LANGUAGE
    GeneralizedNewtypeDeriving
  , OverloadedStrings
  , TemplateHaskell
#-}
module Data.Fits
    ( -- * Data payload functions
      parsePix
    , pixsUnwrapI
    , pixsUnwrapD

      -- * Main data types
    , HeaderDataUnit(..)
      -- ^ lens exports
    , dimensions
    , header
    , extension
    , mainData
    , Pix(..)

      -- ** Header Data Types
    , Header(..)
    , keywords -- ^ get only keywords
    , records -- ^ access all header records
    , HeaderRecord(..)
    , KeywordRecord(..)
    , Extension(..)
    , getKeywords
    , Data.Fits.lookup
    , isKeyword
    , Value(..)
    , toInt, toFloat, toText
    , LogicalConstant(..)
    , Dimensions(..)
    , axes
    , bitpix
    , SimpleFormat(..)
    , BitPixFormat(..)
    , Axes

      -- * Utility
    , isBitPixInt
    , isBitPixFloat
    , bitPixToWordSize
    , bitPixToByteSize
    , pixDimsByCol
    , pixDimsByRow

      -- ** Constants
    , hduRecordLength
    , hduMaxRecords
    , hduBlockSize

    ) where

---- text
import qualified Data.Text as T
---- bytestring
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL

import Data.String (IsString)
import qualified Data.List as L
import Data.Maybe (mapMaybe)

---- ghc
import GHC.TypeNats (KnownNat, Nat)

---- text
import Data.Text ( Text )
import Data.List ( intercalate )

---- bytestring
import Data.ByteString ( ByteString )

---- microlens
import Lens.Micro ((^.), SimpleGetter, to)
---- microlens-th
import Lens.Micro.TH ( makeLenses )


import Data.Binary
import Data.Binary.Get

-- | A single record in the HDU is an eighty byte word.
{-@ type HDURecordLength = {v:Int | v = 80} @-}
{-@ hduRecordLength :: HDURecordLength @-}
hduRecordLength :: Int
hduRecordLength :: Int
hduRecordLength = Int
80

{-| The maximum amount of eighty byte records is thirty-six per the
    standard.
-}
{-@ type HDUMaxRecords = {v:Int | v = 36} @-}
{-@ hduMaxRecords :: HDUMaxRecords @-}
hduMaxRecords :: Int
hduMaxRecords :: Int
hduMaxRecords = Int
36

{-| The size of an HDU block is fixed at thirty-six eighty byte words. In
    other words 2,880 bytes. These blocks are padded with zeros to this
    boundary.
-}
{-@ type HDUBlockSize = {v:Int | v = 2880} @-}
{-@ hduBlockSize :: HDUBlockSize @-}
hduBlockSize :: Int
hduBlockSize :: Int
hduBlockSize = Int
hduRecordLength Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
hduMaxRecords
 

{-| The standard defines two possible values for the SIMPLE keyword, T and
    F. The T refers to a 'Conformant' format while F refers to
    a 'NonConformant' format. At this time only the 'Conformant', T, format
    is supported.
-}
data SimpleFormat = Conformant | NonConformant
    deriving (SimpleFormat -> SimpleFormat -> Bool
(SimpleFormat -> SimpleFormat -> Bool)
-> (SimpleFormat -> SimpleFormat -> Bool) -> Eq SimpleFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SimpleFormat -> SimpleFormat -> Bool
== :: SimpleFormat -> SimpleFormat -> Bool
$c/= :: SimpleFormat -> SimpleFormat -> Bool
/= :: SimpleFormat -> SimpleFormat -> Bool
Eq, Int -> SimpleFormat -> ShowS
[SimpleFormat] -> ShowS
SimpleFormat -> String
(Int -> SimpleFormat -> ShowS)
-> (SimpleFormat -> String)
-> ([SimpleFormat] -> ShowS)
-> Show SimpleFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SimpleFormat -> ShowS
showsPrec :: Int -> SimpleFormat -> ShowS
$cshow :: SimpleFormat -> String
show :: SimpleFormat -> String
$cshowList :: [SimpleFormat] -> ShowS
showList :: [SimpleFormat] -> ShowS
Show)
                    -- ^ Value of SIMPLE=T in the header. /supported/
                    -- NonConformat
                    -- ^ Value of SIMPLE=F in the header. /unsupported/data/fi

{-| Direct encoding of a `Bool` for parsing `Value` -}
data LogicalConstant = T | F
    deriving (Int -> LogicalConstant -> ShowS
[LogicalConstant] -> ShowS
LogicalConstant -> String
(Int -> LogicalConstant -> ShowS)
-> (LogicalConstant -> String)
-> ([LogicalConstant] -> ShowS)
-> Show LogicalConstant
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogicalConstant -> ShowS
showsPrec :: Int -> LogicalConstant -> ShowS
$cshow :: LogicalConstant -> String
show :: LogicalConstant -> String
$cshowList :: [LogicalConstant] -> ShowS
showList :: [LogicalConstant] -> ShowS
Show, LogicalConstant -> LogicalConstant -> Bool
(LogicalConstant -> LogicalConstant -> Bool)
-> (LogicalConstant -> LogicalConstant -> Bool)
-> Eq LogicalConstant
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogicalConstant -> LogicalConstant -> Bool
== :: LogicalConstant -> LogicalConstant -> Bool
$c/= :: LogicalConstant -> LogicalConstant -> Bool
/= :: LogicalConstant -> LogicalConstant -> Bool
Eq)


{-| `Value` datatype for discriminating valid FITS KEYWORD=VALUE types in an HDU. -}
data Value
    = Integer Int
    | Float Float
    | String Text
    | Logic LogicalConstant
    deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq)


{-| A single 80 character header keyword line of the form: KEYWORD = VALUE / comment
    KEYWORD=VALUE
-}
data KeywordRecord = KeywordRecord
  { KeywordRecord -> Text
_keyword :: Text
  , KeywordRecord -> Value
_value :: Value
  , KeywordRecord -> Maybe Text
_comment :: Maybe Text
  }
  deriving (Int -> KeywordRecord -> ShowS
[KeywordRecord] -> ShowS
KeywordRecord -> String
(Int -> KeywordRecord -> ShowS)
-> (KeywordRecord -> String)
-> ([KeywordRecord] -> ShowS)
-> Show KeywordRecord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeywordRecord -> ShowS
showsPrec :: Int -> KeywordRecord -> ShowS
$cshow :: KeywordRecord -> String
show :: KeywordRecord -> String
$cshowList :: [KeywordRecord] -> ShowS
showList :: [KeywordRecord] -> ShowS
Show, KeywordRecord -> KeywordRecord -> Bool
(KeywordRecord -> KeywordRecord -> Bool)
-> (KeywordRecord -> KeywordRecord -> Bool) -> Eq KeywordRecord
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeywordRecord -> KeywordRecord -> Bool
== :: KeywordRecord -> KeywordRecord -> Bool
$c/= :: KeywordRecord -> KeywordRecord -> Bool
/= :: KeywordRecord -> KeywordRecord -> Bool
Eq)
$(makeLenses ''KeywordRecord)

{-| Headers contain lines that are any of the following

 > KEYWORD = VALUE / inline comment
 > COMMENT full line comment
 > (blank)
-}
data HeaderRecord
    = Keyword KeywordRecord
    | Comment Text
    | BlankLine
    deriving (Int -> HeaderRecord -> ShowS
[HeaderRecord] -> ShowS
HeaderRecord -> String
(Int -> HeaderRecord -> ShowS)
-> (HeaderRecord -> String)
-> ([HeaderRecord] -> ShowS)
-> Show HeaderRecord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HeaderRecord -> ShowS
showsPrec :: Int -> HeaderRecord -> ShowS
$cshow :: HeaderRecord -> String
show :: HeaderRecord -> String
$cshowList :: [HeaderRecord] -> ShowS
showList :: [HeaderRecord] -> ShowS
Show, HeaderRecord -> HeaderRecord -> Bool
(HeaderRecord -> HeaderRecord -> Bool)
-> (HeaderRecord -> HeaderRecord -> Bool) -> Eq HeaderRecord
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HeaderRecord -> HeaderRecord -> Bool
== :: HeaderRecord -> HeaderRecord -> Bool
$c/= :: HeaderRecord -> HeaderRecord -> Bool
/= :: HeaderRecord -> HeaderRecord -> Bool
Eq)
{-| 'Axes' represents the combination of NAXIS + NAXISn. The spec supports up to 999 axes -}
type Axes = [Int]

{-| The 'BitPixFormat' is the nitty gritty of how the 'Axis' data is layed
    out in the file. The standard recognizes six formats: unsigned 8 bit
    integer, two's complement binary integers at 16, 32, and 64 bits along
    with 32 and 64 bit IEEE floating point formats.
-}
data BitPixFormat =
      EightBitInt       -- ^ BITPIX = 8; unsigned binary integer of 8 bits
    | SixteenBitInt     -- ^ BITPIX = 16; two's complement binary integer of 16 bits
    | ThirtyTwoBitInt   -- ^ BITPIX = 32; two's complement binary integer of 32 bits
    | SixtyFourBitInt   -- ^ BITPIX = 64; two's complement binary integer of 64 bits
    | ThirtyTwoBitFloat -- ^ BITPIX = -32; IEEE single precision floating point of 32 bits
    | SixtyFourBitFloat -- ^ BITPIX = -64; IEEE double precision floating point of 64 bits
    deriving (BitPixFormat -> BitPixFormat -> Bool
(BitPixFormat -> BitPixFormat -> Bool)
-> (BitPixFormat -> BitPixFormat -> Bool) -> Eq BitPixFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BitPixFormat -> BitPixFormat -> Bool
== :: BitPixFormat -> BitPixFormat -> Bool
$c/= :: BitPixFormat -> BitPixFormat -> Bool
/= :: 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"

{-| This utility function can be used to get the word count for data in an
    HDU.
-}
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

{-| This utility function can be used to get the size in bytes of the
-   format.
-}
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

{- | This utility functions quickly lets you know if you are dealing with
     integer data.
-}
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

{- | This utility functions quickly lets you know if you are dealing with
     floating point data.
-}
isBitPixFloat :: BitPixFormat -> Bool
isBitPixFloat :: BitPixFormat -> Bool
isBitPixFloat BitPixFormat
ThirtyTwoBitFloat = Bool
True
isBitPixFloat BitPixFormat
SixtyFourBitFloat = Bool
True
isBitPixFloat BitPixFormat
_ = Bool
False

{- | Following `BitPixFormat` we have a tag for integer and floating point
     values. We box them up to ease parsing.
-}
data Pix = PB Int | PI16 Int | PI32 Int | PI64 Int | PF Double | PD Double

{- | Removes the `Pix` tag from an `Int` type within. -}
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
_        = String -> Int
forall a. HasCallStack => String -> a
error String
"Pix are not stored as integers, invalid unpacking"

{- | Removes the `Pix` tag from a `Double` type within. -}
unPixD :: Pix -> Double
unPixD :: Pix -> Double
unPixD (PF Double
d)   = Double
d
unPixD (PD Double
d)   = Double
d
unPixD Pix
_        = String -> Double
forall a. HasCallStack => String -> a
error String
"Pix are not stored as floating point values, invalid unpacking"

{- | Remove the Pix wrapper for integer `Pix` lists.  -}
pixsUnwrapI :: BitPixFormat -> [Pix] -> [Int]
pixsUnwrapI :: BitPixFormat -> [Pix] -> [Int]
pixsUnwrapI BitPixFormat
EightBitInt       [Pix]
pxs = (Pix -> Int) -> [Pix] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
SixteenBitInt     [Pix]
pxs = (Pix -> Int) -> [Pix] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
ThirtyTwoBitInt   [Pix]
pxs = (Pix -> Int) -> [Pix] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
SixtyFourBitInt   [Pix]
pxs = (Pix -> Int) -> [Pix] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Pix -> Int
unPixI [Pix]
pxs
pixsUnwrapI BitPixFormat
_ [Pix]
_ = String -> [Int]
forall a. HasCallStack => String -> a
error String
"BitPixFormat is not an integer type"

{- | Remove the `Pix` wrapper for floating point `Pix` lists.  -}
pixsUnwrapD :: BitPixFormat -> [Pix] -> [Double]
pixsUnwrapD :: BitPixFormat -> [Pix] -> [Double]
pixsUnwrapD BitPixFormat
ThirtyTwoBitFloat [Pix]
pxs = (Pix -> Double) -> [Pix] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Pix -> Double
unPixD [Pix]
pxs
pixsUnwrapD BitPixFormat
SixtyFourBitFloat [Pix]
pxs = (Pix -> Double) -> [Pix] -> [Double]
forall a b. (a -> b) -> [a] -> [b]
map Pix -> Double
unPixD [Pix]
pxs
pixsUnwrapD BitPixFormat
_ [Pix]
_ = String -> [Double]
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 (Int -> Pix) -> (Int8 -> Int) -> Int8 -> Pix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int8 -> Pix) -> Get Int8 -> Get Pix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
getInt8
getPix BitPixFormat
SixteenBitInt     = Int -> Pix
PI16 (Int -> Pix) -> (Int16 -> Int) -> Int16 -> Pix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int16 -> Pix) -> Get Int16 -> Get Pix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be
getPix BitPixFormat
ThirtyTwoBitInt   = Int -> Pix
PI32 (Int -> Pix) -> (Int32 -> Int) -> Int32 -> Pix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int32 -> Pix) -> Get Int32 -> Get Pix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32be
getPix BitPixFormat
SixtyFourBitInt   = Int -> Pix
PI64 (Int -> Pix) -> (Int64 -> Int) -> Int64 -> Pix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Pix) -> Get Int64 -> Get Pix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
getInt64be
getPix BitPixFormat
ThirtyTwoBitFloat = Double -> Pix
PF (Double -> Pix) -> (Float -> Double) -> Float -> Pix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Float -> Pix) -> Get Float -> Get Pix
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Float
getFloatbe
getPix BitPixFormat
SixtyFourBitFloat = Double -> Pix
PD (Double -> Pix) -> (Double -> Double) -> Double -> Pix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> Pix) -> Get Double -> Get Pix
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 [Pix] -> Get [Pix]
forall a. a -> Get a
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) BitPixFormat
bpf
        [Pix] -> Get [Pix]
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pix
pPix -> [Pix] -> [Pix]
forall a. a -> [a] -> [a]
:[Pix]
ps)

{- | This is the main low-level function which parses the data portion of an
     HDU. You need and element count, a format and a bytestring. The resulting
     list is produced in column-row major order as specified in the standard.
-}
parsePix :: Int -> BitPixFormat -> BL.ByteString -> IO [Pix]
parsePix :: Int -> BitPixFormat -> ByteString -> IO [Pix]
parsePix Int
c BitPixFormat
bpf ByteString
bs = [Pix] -> IO [Pix]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pix] -> IO [Pix]) -> [Pix] -> IO [Pix]
forall a b. (a -> b) -> a -> b
$ Get [Pix] -> ByteString -> [Pix]
forall a. Get a -> ByteString -> a
runGet (Int -> BitPixFormat -> Get [Pix]
getPixs Int
c BitPixFormat
bpf) ByteString
bs

{- `pixDimsByCol` takes a list of Axis and gives a column-row major list of
    axes dimensions.
-}
pixDimsByCol :: Axes -> [Int]
pixDimsByCol :: [Int] -> [Int]
pixDimsByCol = [Int] -> [Int]
forall a. a -> a
id

{- `pixDimsByRow` takes a list of Axis and gives a row-column major list of
    axes dimensions.
-}
pixDimsByRow :: Axes -> [Int]
pixDimsByRow :: [Int] -> [Int]
pixDimsByRow = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> ([Int] -> [Int]) -> [Int] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
pixDimsByCol

{-| The header part of the HDU is vital carrying not only authorship
    metadata, but also specifying how to make sense of the binary payload
    that starts 2,880 bytes after the start of the 'HeaderData'.
-}
newtype Header = Header { Header -> [HeaderRecord]
_records :: [HeaderRecord] }
    deriving (Header -> Header -> Bool
(Header -> Header -> Bool)
-> (Header -> Header -> Bool) -> Eq Header
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Header -> Header -> Bool
== :: Header -> Header -> Bool
$c/= :: Header -> Header -> Bool
/= :: Header -> Header -> Bool
Eq, NonEmpty Header -> Header
Header -> Header -> Header
(Header -> Header -> Header)
-> (NonEmpty Header -> Header)
-> (forall b. Integral b => b -> Header -> Header)
-> Semigroup Header
forall b. Integral b => b -> Header -> Header
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Header -> Header -> Header
<> :: Header -> Header -> Header
$csconcat :: NonEmpty Header -> Header
sconcat :: NonEmpty Header -> Header
$cstimes :: forall b. Integral b => b -> Header -> Header
stimes :: forall b. Integral b => b -> Header -> Header
Semigroup, Semigroup Header
Header
Semigroup Header =>
Header
-> (Header -> Header -> Header)
-> ([Header] -> Header)
-> Monoid Header
[Header] -> Header
Header -> Header -> Header
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Header
mempty :: Header
$cmappend :: Header -> Header -> Header
mappend :: Header -> Header -> Header
$cmconcat :: [Header] -> Header
mconcat :: [Header] -> Header
Monoid)
$(makeLenses ''Header)


-- | Return all 'KeywordRecord's from the header, filtering out full-line comments and blanks
keywords :: SimpleGetter Header [KeywordRecord]
keywords :: SimpleGetter Header [KeywordRecord]
keywords = (Header -> [KeywordRecord]) -> SimpleGetter Header [KeywordRecord]
forall s a. (s -> a) -> SimpleGetter s a
to Header -> [KeywordRecord]
getKeywords


-- | Return all 'KeywordRecord's from the header, filtering out full-line comments and blanks
getKeywords :: Header -> [KeywordRecord]
getKeywords :: Header -> [KeywordRecord]
getKeywords Header
h = (HeaderRecord -> Maybe KeywordRecord)
-> [HeaderRecord] -> [KeywordRecord]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HeaderRecord -> Maybe KeywordRecord
toKeyword ([HeaderRecord] -> [KeywordRecord])
-> [HeaderRecord] -> [KeywordRecord]
forall a b. (a -> b) -> a -> b
$ Header
h Header
-> Getting [HeaderRecord] Header [HeaderRecord] -> [HeaderRecord]
forall s a. s -> Getting a s a -> a
^. Getting [HeaderRecord] Header [HeaderRecord]
Lens' Header [HeaderRecord]
records
  where
    toKeyword :: HeaderRecord -> Maybe KeywordRecord
toKeyword (Keyword KeywordRecord
k) = KeywordRecord -> Maybe KeywordRecord
forall a. a -> Maybe a
Just KeywordRecord
k
    toKeyword HeaderRecord
_ = Maybe KeywordRecord
forall a. Maybe a
Nothing


instance Show Header where
  show :: Header -> String
show Header
h =
    Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (HeaderRecord -> Text) -> [HeaderRecord] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HeaderRecord -> Text
line ([HeaderRecord] -> [Text]) -> [HeaderRecord] -> [Text]
forall a b. (a -> b) -> a -> b
$ Header
h Header
-> Getting [HeaderRecord] Header [HeaderRecord] -> [HeaderRecord]
forall s a. s -> Getting a s a -> a
^. Getting [HeaderRecord] Header [HeaderRecord]
Lens' Header [HeaderRecord]
records
    where
      line :: HeaderRecord -> Text
      line :: HeaderRecord -> Text
line (Keyword (KeywordRecord Text
k Value
v Maybe Text
mc)) =
        Int -> Char -> Text -> Text
T.justifyLeft Int
8 Char
' ' Text
k
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"="
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Text -> Text
T.justifyLeft (Int
hduRecordLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10) Char
' ' (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Value -> String
val Value
v)
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe Text -> Text
forall {a}. (IsString a, Semigroup a) => Maybe a -> a
inlineComment Maybe Text
mc
      line (Comment Text
c) = Text
c
      line HeaderRecord
BlankLine = Text
" "

      inlineComment :: Maybe a -> a
inlineComment Maybe a
Nothing = a
""
      inlineComment (Just a
c) = a
" / " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c

      val :: Value -> String
val (Integer Int
n) = Int -> String
forall a. Show a => a -> String
show Int
n
      val (Float Float
f) = Float -> String
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 :: Text -> Header -> Maybe Value
lookup :: Text -> Header -> Maybe Value
lookup Text
k Header
h = do
  KeywordRecord
kr <- (KeywordRecord -> Bool) -> [KeywordRecord] -> Maybe KeywordRecord
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Text -> KeywordRecord -> Bool
isKeyword Text
k) (Header
h Header
-> Getting [KeywordRecord] Header [KeywordRecord]
-> [KeywordRecord]
forall s a. s -> Getting a s a -> a
^. Getting [KeywordRecord] Header [KeywordRecord]
SimpleGetter Header [KeywordRecord]
keywords)
  Value -> Maybe Value
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ KeywordRecord
kr KeywordRecord -> Getting Value KeywordRecord Value -> Value
forall s a. s -> Getting a s a -> a
^. Getting Value KeywordRecord Value
Lens' KeywordRecord Value
value

isKeyword :: Text -> KeywordRecord -> Bool
isKeyword :: Text -> KeywordRecord -> Bool
isKeyword Text
k KeywordRecord
kr = KeywordRecord
kr KeywordRecord -> Getting Text KeywordRecord Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text KeywordRecord Text
Lens' KeywordRecord Text
keyword Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
k


data Extension
    -- | Any header data unit can use the primary format. The first MUST be
    -- Primary. This is equivalent to having no extension
    = Primary

    -- | An encoded image. PCOUNT and GCOUNT are required but irrelevant
    | Image

    -- | A Binary table. PCOUNT is the number of bytes that follow the data
    -- in the 'heap'
    | BinTable { Extension -> Int
pCount :: Int, Extension -> ByteString
heap :: ByteString }
    deriving (Extension -> Extension -> Bool
(Extension -> Extension -> Bool)
-> (Extension -> Extension -> Bool) -> Eq Extension
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Extension -> Extension -> Bool
== :: Extension -> Extension -> Bool
$c/= :: Extension -> Extension -> Bool
/= :: 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 = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" Bytes"


toInt :: Value -> Maybe Int
toInt :: Value -> Maybe Int
toInt (Integer Int
i) = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
toInt Value
_ = Maybe Int
forall a. Maybe a
Nothing

toFloat :: Value -> Maybe Float
toFloat :: Value -> Maybe Float
toFloat (Float Float
n) = Float -> Maybe Float
forall a. a -> Maybe a
Just Float
n
toFloat Value
_ = Maybe Float
forall a. Maybe a
Nothing

toText :: Value -> Maybe Text
toText :: Value -> Maybe Text
toText (String Text
s) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
toText Value
_ = Maybe Text
forall a. Maybe a
Nothing

{-| When we load a header, we parse the BITPIX and NAXIS(N) keywords so we
 -  can know how long the data array is
-}
data Dimensions = Dimensions
    { Dimensions -> BitPixFormat
_bitpix :: BitPixFormat
    , Dimensions -> [Int]
_axes :: Axes
    } deriving (Int -> Dimensions -> ShowS
[Dimensions] -> ShowS
Dimensions -> String
(Int -> Dimensions -> ShowS)
-> (Dimensions -> String)
-> ([Dimensions] -> ShowS)
-> Show Dimensions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dimensions -> ShowS
showsPrec :: Int -> Dimensions -> ShowS
$cshow :: Dimensions -> String
show :: Dimensions -> String
$cshowList :: [Dimensions] -> ShowS
showList :: [Dimensions] -> ShowS
Show, Dimensions -> Dimensions -> Bool
(Dimensions -> Dimensions -> Bool)
-> (Dimensions -> Dimensions -> Bool) -> Eq Dimensions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dimensions -> Dimensions -> Bool
== :: Dimensions -> Dimensions -> Bool
$c/= :: Dimensions -> Dimensions -> Bool
/= :: Dimensions -> Dimensions -> Bool
Eq)
$(makeLenses ''Dimensions)


{-| The 'HeaderDataUnit' is the full HDU. Both the header information is
    encoded alongside the data payload.
-}
data HeaderDataUnit = HeaderDataUnit
    { HeaderDataUnit -> Header
_header :: Header         -- ^ The heeader contains metadata about the payload
    , HeaderDataUnit -> Dimensions
_dimensions :: Dimensions -- ^ This dimensions of the main data array
    , HeaderDataUnit -> Extension
_extension :: Extension   -- ^ Extensions may vary the data format
    , HeaderDataUnit -> ByteString
_mainData :: ByteString   -- ^ The main data array
    }
    
$(makeLenses ''HeaderDataUnit)

instance Show HeaderDataUnit where
    show :: HeaderDataUnit -> String
show HeaderDataUnit
hdu = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" 
      [ String
"HeaderDataUnit:"
      , String
"  headers = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([KeywordRecord] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HeaderDataUnit
hdu HeaderDataUnit
-> Getting [KeywordRecord] HeaderDataUnit [KeywordRecord]
-> [KeywordRecord]
forall s a. s -> Getting a s a -> a
^. (Header -> Const [KeywordRecord] Header)
-> HeaderDataUnit -> Const [KeywordRecord] HeaderDataUnit
Lens' HeaderDataUnit Header
header ((Header -> Const [KeywordRecord] Header)
 -> HeaderDataUnit -> Const [KeywordRecord] HeaderDataUnit)
-> Getting [KeywordRecord] Header [KeywordRecord]
-> Getting [KeywordRecord] HeaderDataUnit [KeywordRecord]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [KeywordRecord] Header [KeywordRecord]
SimpleGetter Header [KeywordRecord]
keywords))
      , String
"  extension = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Extension -> String
forall a. Show a => a -> String
show (HeaderDataUnit
hdu HeaderDataUnit
-> Getting Extension HeaderDataUnit Extension -> Extension
forall s a. s -> Getting a s a -> a
^. Getting Extension HeaderDataUnit Extension
Lens' HeaderDataUnit Extension
extension)
      , String
"  mainData = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length (HeaderDataUnit
hdu HeaderDataUnit
-> Getting ByteString HeaderDataUnit ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString HeaderDataUnit ByteString
Lens' HeaderDataUnit ByteString
mainData)) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" Bytes"
      ]