{-# LANGUAGE AllowAmbiguousTypes #-}

module Telescope.Fits.Types
  ( Fits (..)
  , PrimaryHDU (..)
  , ImageHDU (..)
  , BinTableHDU (..)
  , DataArray (..)
  , Extension (..)
  , Axis
  , Axes (..)
  , Major (..)
  , BitPix (..)
  , bitPixBits
  , Header (..)
  , getKeywords
  , HeaderRecord (..)
  , KeywordRecord (..)
  , Value (..)
  , LogicalConstant (..)
  , hduBlockSize
  , emptyDataArray
  , IsBitPix (..)
  ) where

import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.Fits (Header (..), HeaderRecord (..), KeywordRecord (..), LogicalConstant (..), Value (..), getKeywords, hduBlockSize)
import Data.List qualified as L
import GHC.Int
import Telescope.Data.Axes


data PrimaryHDU = PrimaryHDU
  { PrimaryHDU -> Header
header :: Header
  , PrimaryHDU -> DataArray
dataArray :: DataArray
  }


instance Show PrimaryHDU where
  show :: PrimaryHDU -> String
show PrimaryHDU
p = String -> Header -> DataArray -> String
showHDU String
"PrimaryHDU" PrimaryHDU
p.header PrimaryHDU
p.dataArray


data ImageHDU = ImageHDU
  { ImageHDU -> Header
header :: Header
  , ImageHDU -> DataArray
dataArray :: DataArray
  }


instance Show ImageHDU where
  show :: ImageHDU -> String
show ImageHDU
p = String -> Header -> DataArray -> String
showHDU String
"ImageHDU" ImageHDU
p.header ImageHDU
p.dataArray


data BinTableHDU = BinTableHDU
  { BinTableHDU -> Header
header :: Header
  , BinTableHDU -> Int
pCount :: Int
  , BinTableHDU -> ByteString
heap :: ByteString
  , BinTableHDU -> DataArray
dataArray :: DataArray
  }


instance Show BinTableHDU where
  show :: BinTableHDU -> String
show BinTableHDU
p = String -> Header -> DataArray -> String
showHDU String
"BinTableHDU" BinTableHDU
p.header BinTableHDU
p.dataArray


-- | Raw HDU Data. See 'Telescope.Fits.DataArray'
data DataArray = DataArray
  { DataArray -> BitPix
bitpix :: BitPix
  , DataArray -> Axes 'Column
axes :: Axes Column
  , DataArray -> ByteString
rawData :: BS.ByteString
  }


instance Show DataArray where
  show :: DataArray -> String
show DataArray
d =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate
      String
"\n"
      [ String
"  data: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
BS.length DataArray
d.rawData) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" bytes"
      , String
"  dimensions: "
      , String
"    format: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> ShowS
forall a. Int -> [a] -> [a]
L.drop Int
2 (BitPix -> String
forall a. Show a => a -> String
show DataArray
d.bitpix)
      , String
"    axes: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Int] -> String
forall a. Show a => a -> String
show DataArray
d.axes.axes
      ]


showHDU :: String -> Header -> DataArray -> String
showHDU :: String -> Header -> DataArray -> String
showHDU String
name Header
h DataArray
d =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate
    String
"\n"
    [ String
name
    , Header -> String
showHeader Header
h
    , DataArray -> String
forall a. Show a => a -> String
show DataArray
d
    ]


showHeader :: Header -> String
showHeader :: Header -> String
showHeader Header
h =
  String
"  Header: " 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 ([KeywordRecord] -> Int) -> [KeywordRecord] -> Int
forall a b. (a -> b) -> a -> b
$ Header -> [KeywordRecord]
getKeywords Header
h)


emptyDataArray :: DataArray
emptyDataArray :: DataArray
emptyDataArray = BitPix -> Axes 'Column -> ByteString -> DataArray
DataArray BitPix
BPInt8 ([Int] -> Axes 'Column
forall (a :: Major). [Int] -> Axes a
Axes []) ByteString
""


-- data BinaryTable = BinaryTable
--   { pCount :: Int
--   , heap :: ByteString
--   }

data Extension
  = Image ImageHDU
  | BinTable BinTableHDU


instance Show Extension where
  show :: Extension -> String
show (Image ImageHDU
i) = ImageHDU -> String
forall a. Show a => a -> String
show ImageHDU
i
  show (BinTable BinTableHDU
b) = BinTableHDU -> String
forall a. Show a => a -> String
show BinTableHDU
b


data Fits = Fits
  { Fits -> PrimaryHDU
primaryHDU :: PrimaryHDU
  , Fits -> [Extension]
extensions :: [Extension]
  }


instance Show Fits where
  show :: Fits -> String
show Fits
f =
    PrimaryHDU -> String
forall a. Show a => a -> String
show Fits
f.primaryHDU
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n"
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"\n" ((Extension -> String) -> [Extension] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Extension -> String
forall a. Show a => a -> String
show Fits
f.extensions)


data BitPix
  = BPInt8
  | BPInt16
  | BPInt32
  | BPInt64
  | BPFloat
  | BPDouble
  deriving (Int -> BitPix -> ShowS
[BitPix] -> ShowS
BitPix -> String
(Int -> BitPix -> ShowS)
-> (BitPix -> String) -> ([BitPix] -> ShowS) -> Show BitPix
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BitPix -> ShowS
showsPrec :: Int -> BitPix -> ShowS
$cshow :: BitPix -> String
show :: BitPix -> String
$cshowList :: [BitPix] -> ShowS
showList :: [BitPix] -> ShowS
Show, BitPix -> BitPix -> Bool
(BitPix -> BitPix -> Bool)
-> (BitPix -> BitPix -> Bool) -> Eq BitPix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BitPix -> BitPix -> Bool
== :: BitPix -> BitPix -> Bool
$c/= :: BitPix -> BitPix -> Bool
/= :: BitPix -> BitPix -> Bool
Eq)


bitPixBits :: BitPix -> Int
bitPixBits :: BitPix -> Int
bitPixBits BitPix
BPInt8 = Int
8
bitPixBits BitPix
BPInt16 = Int
16
bitPixBits BitPix
BPInt32 = Int
32
bitPixBits BitPix
BPInt64 = Int
64
bitPixBits BitPix
BPFloat = Int
32
bitPixBits BitPix
BPDouble = Int
64


class IsBitPix a where
  bitPix :: BitPix


instance IsBitPix Int8 where
  bitPix :: BitPix
bitPix = BitPix
BPInt8
instance IsBitPix Int16 where
  bitPix :: BitPix
bitPix = BitPix
BPInt16
instance IsBitPix Int32 where
  bitPix :: BitPix
bitPix = BitPix
BPInt32
instance IsBitPix Int64 where
  bitPix :: BitPix
bitPix = BitPix
BPInt64
instance IsBitPix Float where
  bitPix :: BitPix
bitPix = BitPix
BPFloat
instance IsBitPix Double where
  bitPix :: BitPix
bitPix = BitPix
BPDouble