{-|
Module      : Data.Fits.MegaParser
Description : MegaParsec based parser for an HDU.
Copyright   : (c) Zac Slade, 2023
License     : BSD2
Maintainer  : krakrjak@gmail.com
Stability   : experimental

Parsing rules for an HDU in a FITS file.
-}

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}

module Data.Fits.MegaParser where

-- qualified imports
---- bytestring
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS ( c2w )
---- containers
import qualified Data.Map.Lazy as Map
---- megaparsec
import qualified Text.Megaparsec as M
import qualified Text.Megaparsec.Stream as M
import qualified Text.Megaparsec.Pos as MP
import qualified Text.Megaparsec.Byte as M
import qualified Text.Megaparsec.Byte.Lexer as MBL
---- text
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
---- local imports
import qualified Data.Fits as Fits
import qualified Data.Text.Encoding as C8
import qualified Data.Binary as C8


-- symbol imports
---- bytestring
import Data.ByteString ( ByteString )
---- containers
import Data.Map ( Map )
---- text
import Data.Text ( Text )
---- megaparsec
import Text.Ascii ( isAscii )
import Text.Megaparsec ( Parsec, ParseErrorBundle, (<|>), (<?>))
---- microlens
import Lens.Micro ((^.))
---- base
import Control.Applicative ( (<$>) )
import Control.Exception ( Exception(displayException) )
import Control.Monad ( void, foldM )
import Data.Bifunctor ( first )
import Data.Char ( ord )
import Data.Maybe ( catMaybes, fromMaybe )
import Data.Word ( Word8, Word16, Word32, Word64 )
import Data.Void ( Void )
---- local imports
import Data.Fits
  ( Axes
  , Comment(Comment)
  , Dimensions(Dimensions)
  , Header(Header)
  , HeaderDataUnit(HeaderDataUnit)
  , Keyword(Keyword)
  , BitPixFormat(..)
  , Extension(..)
  , LogicalConstant(..)
  , Value(..)
  , bitPixToByteSize, hduRecordLength
  )


type Parser = Parsec Void ByteString
type ParseErr = ParseErrorBundle ByteString Void

data DataUnitValues
  = FITSUInt8 Word8
  | FITSInt16 Word16
  | FITSInt32 Word32
  | FITSInt64 Word64
  | FITSFloat32 Float
  | FITSFloat64 Double 


toWord :: Char -> Word8
toWord :: Char -> Word8
toWord = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord

wordsText :: [Word8] -> Text
wordsText :: [Word8] -> Text
wordsText = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ([Word8] -> ByteString) -> [Word8] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack


-- | Consumes ALL header blocks until end, then all remaining space
parseHeader :: Parser (Map Keyword Value)
parseHeader :: Parser (Map Keyword Value)
parseHeader = do
    [Maybe (Keyword, Value)]
pairs <- ParsecT Void ByteString Identity (Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Tokens ByteString)
-> ParsecT Void ByteString Identity [Maybe (Keyword, Value)]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
M.manyTill ParsecT Void ByteString Identity (Maybe (Keyword, Value))
parseRecordLine (Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' Tokens ByteString
"end")
    ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space -- consume space padding all the way to the end of the next 2880 bytes header block
    Map Keyword Value -> Parser (Map Keyword Value)
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map Keyword Value -> Parser (Map Keyword Value))
-> Map Keyword Value -> Parser (Map Keyword Value)
forall a b. (a -> b) -> a -> b
$ [(Keyword, Value)] -> Map Keyword Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Keyword, Value)] -> Map Keyword Value)
-> [(Keyword, Value)] -> Map Keyword Value
forall a b. (a -> b) -> a -> b
$ [Maybe (Keyword, Value)] -> [(Keyword, Value)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (Keyword, Value)]
pairs

parseRecordLine :: Parser (Maybe (Keyword, Value))
parseRecordLine :: ParsecT Void ByteString Identity (Maybe (Keyword, Value))
parseRecordLine = do
    ParsecT Void ByteString Identity (Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.try (ParsecT Void ByteString Identity (Maybe (Keyword, Value))
 -> ParsecT Void ByteString Identity (Maybe (Keyword, Value)))
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
forall a b. (a -> b) -> a -> b
$ (Keyword, Value) -> Maybe (Keyword, Value)
forall a. a -> Maybe a
Just ((Keyword, Value) -> Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Keyword, Value)
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity (Keyword, Value)
parseKeywordRecord
    ParsecT Void ByteString Identity (Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Keyword, Value)
forall a. Maybe a
Nothing Maybe (Keyword, Value)
-> ParsecT Void ByteString Identity Comment
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
forall a b.
a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void ByteString Identity Comment
parseLineComment
    ParsecT Void ByteString Identity (Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Keyword, Value)
forall a. Maybe a
Nothing Maybe (Keyword, Value)
-> ParsecT Void ByteString Identity (Tokens ByteString)
-> ParsecT Void ByteString Identity (Maybe (Keyword, Value))
forall a b.
a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' (Int -> Word8 -> ByteString
BS.replicate Int
hduRecordLength (Char -> Word8
toWord Char
' '))

-- | Combinator to allow for parsing a record with inline comments
withComments :: Parser a -> Parser a
withComments :: forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
withComments Parser a
parse = do
    Int
start <- Parser Int
parsePos
    a
a <- Parser a
parse
    ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space
    ParsecT Void ByteString Identity Comment
-> ParsecT Void ByteString Identity (Maybe Comment)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
M.optional (ParsecT Void ByteString Identity Comment
 -> ParsecT Void ByteString Identity (Maybe Comment))
-> ParsecT Void ByteString Identity Comment
-> ParsecT Void ByteString Identity (Maybe Comment)
forall a b. (a -> b) -> a -> b
$ Int -> ParsecT Void ByteString Identity Comment
parseInlineComment Int
start
    ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space
    a -> Parser a
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

parseKeywordRecord :: Parser (Keyword, Value)
parseKeywordRecord :: ParsecT Void ByteString Identity (Keyword, Value)
parseKeywordRecord = ParsecT Void ByteString Identity (Keyword, Value)
-> ParsecT Void ByteString Identity (Keyword, Value)
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
withComments ParsecT Void ByteString Identity (Keyword, Value)
parseKeywordValue

-- | Parses the specified keyword
parseKeywordRecord' :: ByteString -> Parser a -> Parser a
parseKeywordRecord' :: forall a. ByteString -> Parser a -> Parser a
parseKeywordRecord' ByteString
k Parser a
pval = Parser a -> Parser a
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
withComments (Parser a -> Parser a) -> Parser a -> Parser a
forall a b. (a -> b) -> a -> b
$ do
    Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' ByteString
Tokens ByteString
k
    ParsecT Void ByteString Identity ()
parseEquals
    Parser a
pval

parseKeywordValue :: Parser (Keyword, Value)
parseKeywordValue :: ParsecT Void ByteString Identity (Keyword, Value)
parseKeywordValue = do
    Keyword
key <- Parser Keyword
parseKeyword
    ParsecT Void ByteString Identity ()
parseEquals
    Value
val <- Parser Value
parseValue
    (Keyword, Value)
-> ParsecT Void ByteString Identity (Keyword, Value)
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Keyword
key, Value
val)

parseInlineComment :: Int -> Parser Comment
parseInlineComment :: Int -> ParsecT Void ByteString Identity Comment
parseInlineComment Int
start = do
    Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
M.char (Token ByteString
 -> ParsecT Void ByteString Identity (Token ByteString))
-> Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall a b. (a -> b) -> a -> b
$ Char -> Word8
toWord Char
'/'
    ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space
    Int
com <- Parser Int
parsePos
    let end :: Int
end = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
hduRecordLength
    let rem :: Int
rem = Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
com
    [Word8]
c <- Int
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
M.count Int
rem ParsecT Void ByteString Identity Word8
ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
M.anySingle
    Comment -> ParsecT Void ByteString Identity Comment
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Comment -> ParsecT Void ByteString Identity Comment)
-> Comment -> ParsecT Void ByteString Identity Comment
forall a b. (a -> b) -> a -> b
$ Text -> Comment
Comment ([Word8] -> Text
wordsText [Word8]
c)

parseLineComment :: Parser Comment
parseLineComment :: ParsecT Void ByteString Identity Comment
parseLineComment = do
    let keyword :: ByteString
keyword = ByteString
"COMMENT " :: ByteString
    Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' ByteString
Tokens ByteString
keyword
    [Word8]
c <- Int
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
M.count (Int
hduRecordLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
keyword) ParsecT Void ByteString Identity Word8
ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
M.anySingle
    Comment -> ParsecT Void ByteString Identity Comment
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Comment -> ParsecT Void ByteString Identity Comment)
-> Comment -> ParsecT Void ByteString Identity Comment
forall a b. (a -> b) -> a -> b
$ Text -> Comment
Comment ([Word8] -> Text
wordsText [Word8]
c)

-- | Anything but a space or equals
parseKeyword :: Parser Keyword
parseKeyword :: Parser Keyword
parseKeyword = Text -> Keyword
Keyword (Text -> Keyword) -> ([Word8] -> Text) -> [Word8] -> Keyword
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> Text
wordsText ([Word8] -> Keyword)
-> ParsecT Void ByteString Identity [Word8] -> Parser Keyword
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.some ([Token ByteString]
-> ParsecT Void ByteString Identity (Token ByteString)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
M.noneOf ([Token ByteString]
 -> ParsecT Void ByteString Identity (Token ByteString))
-> [Token ByteString]
-> ParsecT Void ByteString Identity (Token ByteString)
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Word8
toWord [Char
' ', Char
'='])

parseValue :: Parser Value
parseValue :: Parser Value
parseValue =
    -- try is required here because Megaparsec doesn't automatically backtrack if the parser consumes anything
    Parser Value -> Parser Value
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.try (Float -> Value
Float (Float -> Value)
-> ParsecT Void ByteString Identity Float -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity Float
parseFloat)
    Parser Value -> Parser Value -> Parser Value
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Value -> Parser Value
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.try (Int -> Value
Integer (Int -> Value) -> Parser Int -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
forall a. Num a => Parser a
parseInt)
    Parser Value -> Parser Value -> Parser Value
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (LogicalConstant -> Value
Logic (LogicalConstant -> Value)
-> ParsecT Void ByteString Identity LogicalConstant -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity LogicalConstant
parseLogic)
    Parser Value -> Parser Value -> Parser Value
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Value
String (Text -> Value)
-> ParsecT Void ByteString Identity Text -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity Text
parseStringContinue)

parseInt :: Num a => Parser a
parseInt :: forall a. Num a => Parser a
parseInt = ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m () -> m a -> m a
MBL.signed ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m a
MBL.decimal

parseFloat :: Parser Float
parseFloat :: ParsecT Void ByteString Identity Float
parseFloat = ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity Float
-> ParsecT Void ByteString Identity Float
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m () -> m a -> m a
MBL.signed ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space ParsecT Void ByteString Identity Float
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, RealFloat a) =>
m a
MBL.float

parseLogic :: Parser LogicalConstant
parseLogic :: ParsecT Void ByteString Identity LogicalConstant
parseLogic = do
    Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' Tokens ByteString
"T"
    LogicalConstant -> ParsecT Void ByteString Identity LogicalConstant
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return LogicalConstant
T

parseStringContinue :: Parser Text
parseStringContinue :: ParsecT Void ByteString Identity Text
parseStringContinue = do
    Text
t <- ParsecT Void ByteString Identity Text
parseStringValue

    Maybe Text
mc <- ParsecT Void ByteString Identity Text
-> ParsecT Void ByteString Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
M.optional (ParsecT Void ByteString Identity Text
 -> ParsecT Void ByteString Identity (Maybe Text))
-> ParsecT Void ByteString Identity Text
-> ParsecT Void ByteString Identity (Maybe Text)
forall a b. (a -> b) -> a -> b
$ do
      Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' Tokens ByteString
"CONTINUE"
      ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space
      ParsecT Void ByteString Identity Text
parseStringContinue

    case Maybe Text
mc of
      Maybe Text
Nothing -> Text -> ParsecT Void ByteString Identity Text
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
      Just Text
tc -> Text -> ParsecT Void ByteString Identity Text
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ParsecT Void ByteString Identity Text)
-> Text -> ParsecT Void ByteString Identity Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'&') Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tc

parseStringValue :: Parser Text
parseStringValue :: ParsecT Void ByteString Identity Text
parseStringValue = do
    -- The rules are weird, NULL means a NULL string, '' is an empty
    -- string, a ' followed by a bunch of spaces and a close ' is
    -- considered an empty string, and trailing whitespace is ignored
    -- within the quotes, but not leading spaces.
    [Word8]
ls <- ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
M.between (Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
M.char Word8
Token ByteString
quote) (Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
M.char Word8
Token ByteString
quote) (ParsecT Void ByteString Identity [Word8]
 -> ParsecT Void ByteString Identity [Word8])
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity [Word8]
forall a b. (a -> b) -> a -> b
$ ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.many (ParsecT Void ByteString Identity Word8
 -> ParsecT Void ByteString Identity [Word8])
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall a b. (a -> b) -> a -> b
$ Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
M.anySingleBut Word8
Token ByteString
quote
    ParsecT Void ByteString Identity ()
consumeDead
    Text -> ParsecT Void ByteString Identity Text
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Text
T.stripEnd (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Word8] -> Text
wordsText [Word8]
ls)
    where quote :: Word8
quote = Char -> Word8
toWord Char
'\''

requireKeyword :: Keyword -> Header -> Parser Value
requireKeyword :: Keyword -> Header -> Parser Value
requireKeyword Keyword
k Header
kvs = do
    case Keyword -> Header -> Maybe Value
Fits.lookup Keyword
k Header
kvs of
      Maybe Value
Nothing -> String -> Parser Value
forall a. String -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Value) -> String -> Parser Value
forall a b. (a -> b) -> a -> b
$ String
"Missing: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Keyword -> String
forall a. Show a => a -> String
show Keyword
k
      Just Value
v -> Value -> Parser Value
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

requireNaxis :: Header -> Parser Int
requireNaxis :: Header -> Parser Int
requireNaxis Header
kvs = do
    Value
v <- Keyword -> Header -> Parser Value
requireKeyword Keyword
"NAXIS" Header
kvs
    case Value
v of
      Integer Int
n -> Int -> Parser Int
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
      Value
_ -> String -> Parser Int
forall a. String -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid NAXIS header"

skipEmpty :: Parser ()
skipEmpty :: ParsecT Void ByteString Identity ()
skipEmpty = ParsecT Void ByteString Identity [Token ByteString]
-> ParsecT Void ByteString Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void ByteString Identity (Token ByteString)
-> ParsecT Void ByteString Identity [Token ByteString]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.many (ParsecT Void ByteString Identity (Token ByteString)
 -> ParsecT Void ByteString Identity [Token ByteString])
-> ParsecT Void ByteString Identity (Token ByteString)
-> ParsecT Void ByteString Identity [Token ByteString]
forall a b. (a -> b) -> a -> b
$ (Token ByteString -> Bool)
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
M.satisfy (Char -> Word8
toWord Char
'\0' Token ByteString -> Token ByteString -> Bool
forall a. Eq a => a -> a -> Bool
==))

consumeDead :: Parser ()
consumeDead :: ParsecT Void ByteString Identity ()
consumeDead = ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void ByteString Identity ()
skipEmpty

parseEnd :: Parser ()
parseEnd :: ParsecT Void ByteString Identity ()
parseEnd = Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' Tokens ByteString
"end" ParsecT Void ByteString Identity (Tokens ByteString)
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
M.eof

parseEquals :: Parser ()
parseEquals :: ParsecT Void ByteString Identity ()
parseEquals = ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Token s -> m (Token s)
M.char (Char -> Word8
toWord Char
'=') ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity ()
forall a b.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity b
-> ParsecT Void ByteString Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT Void ByteString Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
M.space

parsePos :: Parser Int
parsePos :: Parser Int
parsePos = Pos -> Int
MP.unPos (Pos -> Int) -> (SourcePos -> Pos) -> SourcePos -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourcePos -> Pos
MP.sourceColumn (SourcePos -> Int)
-> ParsecT Void ByteString Identity SourcePos -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
M.getSourcePos


parseBitPix :: Parser BitPixFormat
parseBitPix :: Parser BitPixFormat
parseBitPix = do
    Value
v <- ByteString -> Parser Value -> Parser Value
forall a. ByteString -> Parser a -> Parser a
parseKeywordRecord' ByteString
"BITPIX" Parser Value
parseValue
    Value -> Parser BitPixFormat
forall {m :: * -> *}. MonadFail m => Value -> m BitPixFormat
toBitpix Value
v
    where
      toBitpix :: Value -> m BitPixFormat
toBitpix (Integer Int
8) = BitPixFormat -> m BitPixFormat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BitPixFormat
EightBitInt
      toBitpix (Integer Int
16) = BitPixFormat -> m BitPixFormat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BitPixFormat
SixteenBitInt
      toBitpix (Integer Int
32) = BitPixFormat -> m BitPixFormat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BitPixFormat
ThirtyTwoBitInt
      toBitpix (Integer Int
64) = BitPixFormat -> m BitPixFormat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BitPixFormat
SixtyFourBitInt
      toBitpix (Integer (-32)) = BitPixFormat -> m BitPixFormat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BitPixFormat
ThirtyTwoBitFloat
      toBitpix (Integer (-64)) = BitPixFormat -> m BitPixFormat
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BitPixFormat
SixtyFourBitFloat
      toBitpix Value
_ = String -> m BitPixFormat
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid BITPIX header"

parseNaxes :: Parser Axes
parseNaxes :: Parser Axes
parseNaxes = do
    Int
n <- ByteString -> Parser Int -> Parser Int
forall a. ByteString -> Parser a -> Parser a
parseKeywordRecord' ByteString
"NAXIS" Parser Int
forall a. Num a => Parser a
parseInt
    (Int -> Parser Int) -> Axes -> Parser Axes
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Int -> Parser Int
parseN [Int
1..Int
n]
  where
    parseN :: Int -> Parser Int
    parseN :: Int -> Parser Int
parseN Int
n = Parser Int -> Parser Int
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
withComments (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ do
      Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' Tokens ByteString
"NAXIS"
      Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' (Tokens ByteString
 -> ParsecT Void ByteString Identity (Tokens ByteString))
-> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
toWord (Int -> String
forall a. Show a => a -> String
show Int
n)
      ParsecT Void ByteString Identity ()
parseEquals
      Parser Int
forall a. Num a => Parser a
parseInt

-- | We don't parse simple here, because it isn't required on all HDUs
parseDimensions :: Parser Dimensions
parseDimensions :: Parser Dimensions
parseDimensions = do
    BitPixFormat
bp <- Parser BitPixFormat
parseBitPix
    BitPixFormat -> Axes -> Dimensions
Dimensions BitPixFormat
bp (Axes -> Dimensions) -> Parser Axes -> Parser Dimensions
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Axes
parseNaxes

parsePrimary :: Parser HeaderDataUnit
parsePrimary :: Parser HeaderDataUnit
parsePrimary = do
    ByteString
-> ParsecT Void ByteString Identity LogicalConstant
-> ParsecT Void ByteString Identity LogicalConstant
forall a. ByteString -> Parser a -> Parser a
parseKeywordRecord' ByteString
"SIMPLE" ParsecT Void ByteString Identity LogicalConstant
parseLogic
    Dimensions
dm <- Parser Dimensions -> Parser Dimensions
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.lookAhead Parser Dimensions
parseDimensions
    Map Keyword Value
hd <- Parser (Map Keyword Value)
parseHeader
    ByteString
dt <- Dimensions -> Parser ByteString
parseMainData Dimensions
dm
    HeaderDataUnit -> Parser HeaderDataUnit
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderDataUnit -> Parser HeaderDataUnit)
-> HeaderDataUnit -> Parser HeaderDataUnit
forall a b. (a -> b) -> a -> b
$ Header -> Dimensions -> Extension -> ByteString -> HeaderDataUnit
HeaderDataUnit (Map Keyword Value -> Header
Header Map Keyword Value
hd) Dimensions
dm Extension
Primary ByteString
dt

parseImage :: Parser HeaderDataUnit
parseImage :: Parser HeaderDataUnit
parseImage = do
    ParsecT Void ByteString Identity (Tokens ByteString)
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
withComments (ParsecT Void ByteString Identity (Tokens ByteString)
 -> ParsecT Void ByteString Identity (Tokens ByteString))
-> ParsecT Void ByteString Identity (Tokens ByteString)
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall a b. (a -> b) -> a -> b
$ Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' Tokens ByteString
"XTENSION= 'IMAGE   '"
    Dimensions
dm <- Parser Dimensions -> Parser Dimensions
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.lookAhead Parser Dimensions
parseDimensions
    Map Keyword Value
hd <- Parser (Map Keyword Value)
parseHeader
    ByteString
dt <- Dimensions -> Parser ByteString
parseMainData Dimensions
dm
    HeaderDataUnit -> Parser HeaderDataUnit
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderDataUnit -> Parser HeaderDataUnit)
-> HeaderDataUnit -> Parser HeaderDataUnit
forall a b. (a -> b) -> a -> b
$ Header -> Dimensions -> Extension -> ByteString -> HeaderDataUnit
HeaderDataUnit (Map Keyword Value -> Header
Header Map Keyword Value
hd) Dimensions
dm Extension
Image ByteString
dt

parseBinTable :: Parser HeaderDataUnit
parseBinTable :: Parser HeaderDataUnit
parseBinTable = do
    (Dimensions
dm, Int
pc) <- ParsecT Void ByteString Identity (Dimensions, Int)
-> ParsecT Void ByteString Identity (Dimensions, Int)
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
M.lookAhead ParsecT Void ByteString Identity (Dimensions, Int)
parseBinTableKeywords
    Map Keyword Value
hd <- Parser (Map Keyword Value)
parseHeader
    ByteString
dt <- Dimensions -> Parser ByteString
parseMainData Dimensions
dm
    ByteString
hp <- Parser ByteString
parseBinTableHeap
    let tab :: Extension
tab = Int -> ByteString -> Extension
BinTable Int
pc ByteString
hp
    HeaderDataUnit -> Parser HeaderDataUnit
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (HeaderDataUnit -> Parser HeaderDataUnit)
-> HeaderDataUnit -> Parser HeaderDataUnit
forall a b. (a -> b) -> a -> b
$ Header -> Dimensions -> Extension -> ByteString -> HeaderDataUnit
HeaderDataUnit (Map Keyword Value -> Header
Header Map Keyword Value
hd) Dimensions
dm Extension
tab ByteString
dt
    where
      parseBinTableHeap :: Parser ByteString
parseBinTableHeap = ByteString -> Parser ByteString
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""

parseBinTableKeywords :: Parser (Dimensions, Int)
parseBinTableKeywords :: ParsecT Void ByteString Identity (Dimensions, Int)
parseBinTableKeywords = do 
  ParsecT Void ByteString Identity (Tokens ByteString)
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
withComments (ParsecT Void ByteString Identity (Tokens ByteString)
 -> ParsecT Void ByteString Identity (Tokens ByteString))
-> ParsecT Void ByteString Identity (Tokens ByteString)
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall a b. (a -> b) -> a -> b
$ Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
M.string' Tokens ByteString
"XTENSION= 'BINTABLE'"
  Dimensions
sz <- Parser Dimensions
parseDimensions
  Int
pc <- ByteString -> Parser Int -> Parser Int
forall a. ByteString -> Parser a -> Parser a
parseKeywordRecord' ByteString
"PCOUNT" Parser Int
forall a. Num a => Parser a
parseInt
  (Dimensions, Int)
-> ParsecT Void ByteString Identity (Dimensions, Int)
forall a. a -> ParsecT Void ByteString Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Dimensions
sz, Int
pc)

parseMainData :: Dimensions -> Parser ByteString
parseMainData :: Dimensions -> Parser ByteString
parseMainData Dimensions
size = do
    let len :: Int
len = Dimensions -> Int
dataSize Dimensions
size
    Maybe String
-> Int -> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
M.takeP (String -> Maybe String
forall a. a -> Maybe a
Just (String
"Data Array of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
len String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" Bytes")) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)

parseHDU :: Parser HeaderDataUnit
parseHDU :: Parser HeaderDataUnit
parseHDU =
    Parser HeaderDataUnit
parsePrimary Parser HeaderDataUnit
-> Parser HeaderDataUnit -> Parser HeaderDataUnit
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser HeaderDataUnit
parseImage Parser HeaderDataUnit
-> Parser HeaderDataUnit -> Parser HeaderDataUnit
forall a.
ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
-> ParsecT Void ByteString Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser HeaderDataUnit
parseBinTable

parseHDUs :: Parser [HeaderDataUnit]
parseHDUs :: Parser [HeaderDataUnit]
parseHDUs = do
    Parser HeaderDataUnit -> Parser [HeaderDataUnit]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
M.many Parser HeaderDataUnit
parseHDU

dataSize :: Dimensions -> Int
dataSize :: Dimensions -> Int
dataSize (Dimensions BitPixFormat
bitpix Axes
axes) = BitPixFormat -> Int
size BitPixFormat
bitpix Int -> Int -> Int
forall a. Num a => a -> a -> a
* Axes -> Int
forall {a} {a}. (Integral a, Num a) => [a] -> a
count Axes
axes
  where
    count :: [a] -> a
count [] = a
0
    count [a]
ax = a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [a]
ax
    size :: BitPixFormat -> Int
size = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> (BitPixFormat -> Int) -> BitPixFormat -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BitPixFormat -> Int
bitPixToByteSize