diff --git a/fits-parse.cabal b/fits-parse.cabal --- a/fits-parse.cabal +++ b/fits-parse.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: fits-parse -version: 0.3.6 +version: 0.4.1 license: BSD2 license-file: LICENSE copyright: Copyright (c) 2023 Zac Slade @@ -18,7 +18,6 @@ README.md stack.yaml stack.yaml.lock - package.yaml docs/Makefile docs/make.bat docs/conf.py @@ -46,14 +45,13 @@ default-language: Haskell2010 build-depends: base >=4.7 && <5, - binary, - bytestring, - containers, - megaparsec, - microlens, - microlens-th, - text, - text-latin1 + binary >=0.8.9.1 && <0.9, + bytestring >=0.11.5.3 && <0.12, + megaparsec >=9.5.0 && <9.6, + microlens >=0.4.13.1 && <0.5, + microlens-th >=0.4.3.15 && <0.5, + text >=2.0.2 && <2.1, + text-latin1 >=0.3.1 && <0.4 executable omnibus main-is: Main.hs @@ -61,16 +59,16 @@ other-modules: Paths_fits_parse default-language: Haskell2010 build-depends: - JuicyPixels, + JuicyPixels >=3.3.9 && <3.4, base >=4.7 && <5, - bytestring, - fast-logger, + bytestring >=0.11.5.3 && <0.12, + fast-logger >=3.2.3 && <3.3, fits-parse, - microlens, - microlens-th, - optparse-applicative, - statistics, - vector + microlens >=0.4.13.1 && <0.5, + microlens-th >=0.4.3.15 && <0.5, + optparse-applicative >=0.18.1.0 && <0.19, + statistics >=0.16.2.1 && <0.17, + vector >=0.13.1.0 && <0.14 if flag(examples) @@ -82,13 +80,12 @@ default-language: Haskell2010 build-depends: base >=4.7 && <5, - bytestring, - containers, + bytestring >=0.11.5.3 && <0.12, fits-parse, - megaparsec, - microlens, - microlens-th, - mtl, - tasty, - tasty-hunit, - text + megaparsec >=9.5.0 && <9.6, + microlens >=0.4.13.1 && <0.5, + microlens-th >=0.4.3.15 && <0.5, + mtl >=2.3.1 && <2.4, + tasty >=1.4.3 && <1.5, + tasty-hunit >=0.10.2 && <0.11, + text >=2.0.2 && <2.1 diff --git a/package.yaml b/package.yaml deleted file mode 100644 --- a/package.yaml +++ /dev/null @@ -1,76 +0,0 @@ -name: fits-parse -version: 0.3.6 -synopsis: Parse FITS files -description: Parse and manipulate FITS data natively in Haskell -homepage: https://github.com/krakrjak/fits-parse#readme -license: BSD2 -author: Zac Slade -maintainer: - - Zac Slade - - Sean Hess -copyright: Copyright (c) 2023 Zac Slade -category: Science -extra-source-files: - - README.md - - stack.yaml - - stack.yaml.lock - - package.yaml - - docs/Makefile - - docs/make.bat - - docs/conf.py - - docs/index.rst - - docs/examples/omnibus.rst - - fits_files/*.fits - - fits_files/*.txt - - fits_files/nonconformant/*.fits - -flags: - examples: - description: Do you want to build the examples? - manual: true - default: false - -dependencies: - - base >= 4.7 && < 5 - - bytestring - - microlens - - microlens-th - -library: - source-dirs: src - dependencies: - - containers - - text - - megaparsec - - text-latin1 - - binary - -executables: - omnibus: - when: - - condition: flag(examples) - buildable: true - source-dirs: examples/omnibus - main: Main.hs - dependencies: - - fits-parse - - optparse-applicative - - JuicyPixels - - fast-logger - - vector - - statistics - - -tests: - fits-tests: - source-dirs: test - main: Spec.hs - dependencies: - - fits-parse - - containers - - tasty - - tasty-hunit - - text - - megaparsec - - mtl - diff --git a/src/Data/Fits.hs b/src/Data/Fits.hs --- a/src/Data/Fits.hs +++ b/src/Data/Fits.hs @@ -31,17 +31,20 @@ -- ** Header Data Types , Header(..) - , keywords -- ^ lens for Keyword Map in Header + , keywords -- ^ get only keywords + , records -- ^ access all header records + , HeaderRecord(..) + , KeywordRecord(..) , Extension(..) + , getKeywords , Data.Fits.lookup - , Keyword(..) + , isKeyword , Value(..) , toInt, toFloat, toText , LogicalConstant(..) , Dimensions(..) , axes , bitpix - , Comment(..) , SimpleFormat(..) , BitPixFormat(..) , Axes @@ -66,23 +69,23 @@ ---- bytestring import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as Map 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.Map ( Map ) import Data.List ( intercalate ) ---- bytestring import Data.ByteString ( ByteString ) ---- microlens -import Lens.Micro ((^.)) +import Lens.Micro ((^.), SimpleGetter, to) ---- microlens-th import Lens.Micro.TH ( makeLenses ) @@ -123,17 +126,12 @@ deriving (Eq, Show) -- ^ Value of SIMPLE=T in the header. /supported/ -- NonConformat - -- ^ Value of SIMPLE=F in the header. /unsupported/ + -- ^ Value of SIMPLE=F in the header. /unsupported/data/fi {-| Direct encoding of a `Bool` for parsing `Value` -} data LogicalConstant = T | F deriving (Show, Eq) -{-| The `Text` wrapper for HDU the keyword data for lines of the form: - KEYWORD=VALUE --} -newtype Keyword = Keyword Text - deriving (Show, Eq, Ord, IsString) {-| `Value` datatype for discriminating valid FITS KEYWORD=VALUE types in an HDU. -} data Value @@ -144,6 +142,28 @@ deriving (Show, Eq) +{-| A single 80 character header keyword line of the form: KEYWORD = VALUE / comment + KEYWORD=VALUE +-} +data KeywordRecord = KeywordRecord + { _keyword :: Text + , _value :: Value + , _comment :: Maybe Text + } + deriving (Show, 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 (Show, Eq) {-| 'Axes' represents the combination of NAXIS + NAXISn. The spec supports up to 999 axes -} type Axes = [Int] @@ -283,37 +303,54 @@ 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 { _keywords :: Map Keyword Value } - deriving (Eq) +newtype Header = Header { _records :: [HeaderRecord] } + deriving (Eq, Semigroup, Monoid) $(makeLenses ''Header) + +-- | Return all 'KeywordRecord's from the header, filtering out full-line comments and blanks +keywords :: SimpleGetter Header [KeywordRecord] +keywords = to getKeywords + + +-- | Return all 'KeywordRecord's from the header, filtering out full-line comments and blanks +getKeywords :: Header -> [KeywordRecord] +getKeywords h = mapMaybe toKeyword $ h ^. records + where + toKeyword (Keyword k) = Just k + toKeyword _ = Nothing + + instance Show Header where show h = - let kvs = Map.toList (h ^. keywords) :: [(Keyword, Value)] - in T.unpack $ T.intercalate "\n" $ fmap line kvs + T.unpack $ T.intercalate "\n" $ fmap line $ h ^. records where - -- - -- init :: [Text] - -- init = map T.pack - -- [ "BITPIX =" <> show h.size.bitpix - -- , "NAXES =" <> show h.size.naxes - -- ] - - line :: (Keyword, Value) -> Text - line (Keyword k, v) = + line :: HeaderRecord -> Text + line (Keyword (KeywordRecord k v mc)) = T.justifyLeft 8 ' ' k <> "=" <> T.justifyLeft (hduRecordLength - 10) ' ' (T.pack $ val v) + <> inlineComment mc + line (Comment c) = c + line BlankLine = " " + inlineComment Nothing = "" + inlineComment (Just c) = " / " <> c + val (Integer n) = show n val (Float f) = show f val (Logic T) = " T" val (String t) = T.unpack t -lookup :: Keyword -> Header -> Maybe Value -lookup k h = Map.lookup k (h ^. keywords) +lookup :: Text -> Header -> Maybe Value +lookup k h = do + kr <- L.find (isKeyword k) (h ^. keywords) + pure $ kr ^. value +isKeyword :: Text -> KeywordRecord -> Bool +isKeyword k kr = kr ^. keyword == k + data Extension -- | Any header data unit can use the primary format. The first MUST be -- Primary. This is equivalent to having no extension @@ -354,10 +391,7 @@ } deriving (Show, Eq) $(makeLenses ''Dimensions) -newtype Comment = Comment Text - deriving (Show, Eq, Ord, IsString) - {-| The 'HeaderDataUnit' is the full HDU. Both the header information is encoded alongside the data payload. -} @@ -373,7 +407,7 @@ instance Show HeaderDataUnit where show hdu = intercalate "\n" [ "HeaderDataUnit:" - , " headers = " <> show (Map.size (hdu ^. header . keywords)) + , " headers = " <> show (length (hdu ^. header . keywords)) , " extension = " <> show (hdu ^. extension) , " mainData = " <> show (BS.length (hdu ^. mainData)) <> " Bytes" ] diff --git a/src/Data/Fits/MegaParser.hs b/src/Data/Fits/MegaParser.hs --- a/src/Data/Fits/MegaParser.hs +++ b/src/Data/Fits/MegaParser.hs @@ -18,10 +18,9 @@ ---- 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.Char as MC import qualified Text.Megaparsec.Stream as M import qualified Text.Megaparsec.Pos as MP import qualified Text.Megaparsec.Byte as M @@ -31,15 +30,13 @@ 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.ByteString.Char8 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 @@ -50,7 +47,7 @@ ---- base import Control.Applicative ( (<$>) ) import Control.Exception ( Exception(displayException) ) -import Control.Monad ( void, foldM ) +import Control.Monad ( void, foldM, replicateM_ ) import Data.Bifunctor ( first ) import Data.Char ( ord ) import Data.Maybe ( catMaybes, fromMaybe ) @@ -59,11 +56,11 @@ ---- local imports import Data.Fits ( Axes - , Comment(Comment) , Dimensions(Dimensions) , Header(Header) + , KeywordRecord(..) + , HeaderRecord(..) , HeaderDataUnit(HeaderDataUnit) - , Keyword(Keyword) , BitPixFormat(..) , Extension(..) , LogicalConstant(..) @@ -92,65 +89,102 @@ -- | Consumes ALL header blocks until end, then all remaining space -parseHeader :: Parser (Map Keyword Value) +parseHeader :: Parser Header parseHeader = do pairs <- M.manyTill parseRecordLine (M.string' "end") M.space -- consume space padding all the way to the end of the next 2880 bytes header block - return $ Map.fromList $ catMaybes pairs + return $ Header pairs -parseRecordLine :: Parser (Maybe (Keyword, Value)) +parseRecordLine :: Parser HeaderRecord parseRecordLine = do - M.try $ Just <$> parseKeywordRecord - <|> Nothing <$ parseLineComment - <|> Nothing <$ M.string' (BS.replicate hduRecordLength (toWord ' ')) + M.try (Keyword <$> parseKeywordRecord) + <|> M.try (Comment <$> parseLineComment) + <|> BlankLine <$ parseLineBlank --- | Combinator to allow for parsing a record with inline comments -withComments :: Parser a -> Parser a -withComments parse = do - start <- parsePos - a <- parse - M.space - M.optional $ parseInlineComment start - M.space - return a -parseKeywordRecord :: Parser (Keyword, Value) -parseKeywordRecord = withComments parseKeywordValue +parseKeywordRecord :: Parser KeywordRecord +parseKeywordRecord = do + ((k, v), mc) <- withComments parseKeywordValue + pure $ KeywordRecord k v mc -- | Parses the specified keyword parseKeywordRecord' :: ByteString -> Parser a -> Parser a -parseKeywordRecord' k pval = withComments $ do +parseKeywordRecord' k pval = ignoreComments $ do M.string' k parseEquals pval -parseKeywordValue :: Parser (Keyword, Value) + + + +-- | Combinator to allow for parsing a record with inline comments +withComments :: Parser a -> Parser (a, Maybe Text) +withComments parse = do + -- assumes we are at the beginning of the line + lineStart <- parsePos + a <- parse + mc <- parseLineEnd lineStart + return (a, mc) + +ignoreComments :: Parser a -> Parser a +ignoreComments parse = do + (a, _) <- withComments parse + pure a + + +parseKeywordValue :: Parser (Text, Value) parseKeywordValue = do key <- parseKeyword parseEquals val <- parseValue return (key, val) -parseInlineComment :: Int -> Parser Comment -parseInlineComment start = do - M.char $ toWord '/' + +parseLineEnd :: Int -> Parser (Maybe Text) +parseLineEnd lineStart = do + M.try (Nothing <$ spacesToLineEnd lineStart) <|> (Just <$> parseInlineComment lineStart) + + +spacesToLineEnd :: Int -> Parser () +spacesToLineEnd lineStart = do + curr <- parsePos + let used = curr - lineStart + parseSpacesN (hduRecordLength - used) + pure () + +parseSpacesN :: Int -> Parser () +parseSpacesN n = replicateM_ n (M.char $ toWord ' ') + +parseInlineComment :: Int -> Parser Text +parseInlineComment lineStart = do + -- any number of spaces... the previous combinator has eaten up blank lines already M.space - com <- parsePos - let end = start + hduRecordLength - let rem = end - com - c <- M.count rem M.anySingle - return $ Comment (wordsText c) + M.char $ toWord '/' + M.optional charSpace + curr <- parsePos + let used = curr - lineStart + c <- M.count (hduRecordLength - used) M.anySingle + return $ T.strip $ wordsText c + where + charSpace = M.char $ toWord ' ' -parseLineComment :: Parser Comment + +parseLineComment :: Parser Text parseLineComment = do let keyword = "COMMENT " :: ByteString M.string' keyword c <- M.count (hduRecordLength - BS.length keyword) M.anySingle - return $ Comment (wordsText c) + return $ wordsText c +parseLineBlank :: Parser () +parseLineBlank = do + M.string' (BS.replicate hduRecordLength (toWord ' ')) + pure () + + -- | Anything but a space or equals -parseKeyword :: Parser Keyword -parseKeyword = Keyword . wordsText <$> M.some (M.noneOf $ fmap toWord [' ', '=']) +parseKeyword :: Parser Text +parseKeyword = wordsText <$> M.some (M.noneOf $ fmap toWord [' ', '=']) parseValue :: Parser Value parseValue = @@ -168,8 +202,7 @@ parseLogic :: Parser LogicalConstant parseLogic = do - M.string' "T" - return T + T <$ M.string' "T" <|> F <$ M.string' "F" parseStringContinue :: Parser Text parseStringContinue = do @@ -195,7 +228,7 @@ return (T.stripEnd $ wordsText ls) where quote = toWord '\'' -requireKeyword :: Keyword -> Header -> Parser Value +requireKeyword :: Text -> Header -> Parser Value requireKeyword k kvs = do case Fits.lookup k kvs of Nothing -> fail $ "Missing: " <> show k @@ -243,11 +276,7 @@ mapM parseN [1..n] where parseN :: Int -> Parser Int - parseN n = withComments $ do - M.string' "NAXIS" - M.string' $ BS.pack $ map toWord (show n) - parseEquals - parseInt + parseN n = parseKeywordRecord' (C8.pack $ "NAXIS" <> show n) parseInt -- | We don't parse simple here, because it isn't required on all HDUs parseDimensions :: Parser Dimensions @@ -257,20 +286,30 @@ parsePrimary :: Parser HeaderDataUnit parsePrimary = do - parseKeywordRecord' "SIMPLE" parseLogic - dm <- M.lookAhead parseDimensions + dm <- parsePrimaryKeywords hd <- parseHeader dt <- parseMainData dm - return $ HeaderDataUnit (Header hd) dm Primary dt + return $ HeaderDataUnit hd dm Primary dt + +parsePrimaryKeywords :: Parser Dimensions +parsePrimaryKeywords = do + parseKeywordRecord' "SIMPLE" parseLogic + M.lookAhead parseDimensions + + parseImage :: Parser HeaderDataUnit parseImage = do - withComments $ M.string' "XTENSION= 'IMAGE '" - dm <- M.lookAhead parseDimensions + dm <- parseImageKeywords hd <- parseHeader dt <- parseMainData dm - return $ HeaderDataUnit (Header hd) dm Image dt + return $ HeaderDataUnit hd dm Image dt +parseImageKeywords :: Parser Dimensions +parseImageKeywords = do + ignoreComments $ M.string' "XTENSION= 'IMAGE '" + M.lookAhead parseDimensions + parseBinTable :: Parser HeaderDataUnit parseBinTable = do (dm, pc) <- M.lookAhead parseBinTableKeywords @@ -278,13 +317,13 @@ dt <- parseMainData dm hp <- parseBinTableHeap let tab = BinTable pc hp - return $ HeaderDataUnit (Header hd) dm tab dt + return $ HeaderDataUnit hd dm tab dt where parseBinTableHeap = return "" parseBinTableKeywords :: Parser (Dimensions, Int) parseBinTableKeywords = do - withComments $ M.string' "XTENSION= 'BINTABLE'" + ignoreComments $ M.string' "XTENSION= 'BINTABLE'" sz <- parseDimensions pc <- parseKeywordRecord' "PCOUNT" parseInt return (sz, pc) diff --git a/src/Data/Fits/Read.hs b/src/Data/Fits/Read.hs --- a/src/Data/Fits/Read.hs +++ b/src/Data/Fits/Read.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module Data.Fits.Read where @@ -8,9 +7,10 @@ import Data.Maybe ( listToMaybe ) import Data.Text ( Text, unpack ) import qualified Data.ByteString as BS -import qualified Data.Map.Lazy as Map +import qualified Data.List as L import qualified Text.Megaparsec as M import Data.List ( find ) +import Lens.Micro ((^.)) ---- local imports import Data.Fits as Fits @@ -31,12 +31,8 @@ -- | Look up a keyword and parse it into the expected format getKeyword :: Text -> (Value -> Maybe a) -> HeaderDataUnit -> Either String a getKeyword k fromVal hdu = do - let key = Keyword k - v <- maybeError (MissingKey key) $ Map.lookup key (_keywords . _header $ hdu) - maybeError (InvalidKey key v) $ fromVal v - where - findKey :: Keyword -> Header -> Maybe Value - findKey key h = Map.lookup key (_keywords h) + v <- maybeError (MissingKey k) $ Fits.lookup k (hdu ^. header) + maybeError (InvalidKey k v) $ fromVal v -- | Get the HDU at an index and fail with a readable error getHDU :: String -> Int -> [HeaderDataUnit] -> Either String HeaderDataUnit @@ -53,16 +49,16 @@ data FitsError = ParseError ParseErr - | MissingKey Keyword - | InvalidKey Keyword Value + | MissingKey Text + | InvalidKey Text Value | MissingHDU String Int | InvalidData String deriving (Eq) instance Show FitsError where show (ParseError e) = displayException e - show (MissingKey (Keyword k)) = "Keyword Missing: " <> unpack k - show (InvalidKey (Keyword k) val) = "Keyword: " <> unpack k <> " was invalid. Got " <> show val + show (MissingKey k) = "Keyword Missing: " <> unpack k + show (InvalidKey k val) = "Keyword: " <> unpack k <> " was invalid. Got " <> show val show (MissingHDU name n) = "HDU Missing: " <> name <> " at index " <> show n show (InvalidData err) = "Data Invalid: " <> err diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-21.16 +resolver: lts-22.31 pvp-bounds: both ### Uncomment the next three lines to build the examples diff --git a/stack.yaml.lock b/stack.yaml.lock --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - sha256: 1d663bec402f77fa09fa3e8cf288c3c7eb18a1f28a5e0c331ac47adeacd21346 - size: 640034 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/16.yaml - original: lts-21.16 + sha256: acaab6ca693211938d1542abcb1c83a2f298b9f6b571854a9d38febe39b6408e + size: 719577 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/31.yaml + original: lts-22.31 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,7 +5,8 @@ module Main where -- qualified imports ---- base -import qualified Data.Map.Strict as Map +import Prelude hiding (lookup) +import qualified Data.List as L ---- bytestring import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 @@ -40,28 +41,34 @@ import Data.Fits ( Axes , BitPixFormat(..) , bitPixToByteSize - , Comment(Comment) , Dimensions , axes , bitpix , Extension(..) , Header + , KeywordRecord(..) , keywords + , records , HeaderDataUnit , header + , HeaderRecord(..) , dimensions , extension , mainData - , Keyword(Keyword) + , lookup , LogicalConstant(..) , Value(..) , hduBlockSize ) import Data.Fits.MegaParser import Data.Fits.Read +import System.IO + main :: IO () -main = +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering testMain $ runTests "Tests" $ do basicParsing keywordValueLines @@ -103,11 +110,11 @@ it "should parse a keyword" $ do res <- parse parseKeyword "WS_TEMP =" - res @?= Keyword "WS_TEMP" + res @?= "WS_TEMP" it "should handle keyword symbols" $ do res <- parse parseKeyword "OBSGEO-X= -5466045.256954942 / [m]" - res @?= Keyword "OBSGEO-X" + res @?= "OBSGEO-X" @@ -134,9 +141,12 @@ res @?= ("KEY", Float ( -44.88 )) it "should parse a logical constant" $ do - res <- parse parseKeywordValue "KEY= T " - res @?= ("KEY", Logic T) + res <- parse parseKeywordValue "KEYT= T " + res @?= ("KEYT", Logic T) + res <- parse parseKeywordValue "KEYF= F " + res @?= ("KEYF", Logic F) + it "should ignore comments" $ do res <- parse parseKeywordValue "SIMPLE = T / conforms to FITS standard" res @?= ("SIMPLE", Logic T) @@ -149,55 +159,100 @@ fullRecord = describe "parseKeywordRecord" $ do it "should parse an 80 character record" $ do res <- parse parseKeywordRecord (flattenKeywords ["KEYWORD = 12345"]) - res @?= ("KEYWORD", Integer 12345) + res @?= KeywordRecord "KEYWORD" (Integer 12345) Nothing it "should parse an a record and comment" $ do res <- parse parseKeywordRecord (flattenKeywords ["KEYWORD = 12345 / this is a comment"]) - res @?= ("KEYWORD", Integer 12345) + res @?= KeywordRecord "KEYWORD" (Integer 12345) (Just "this is a comment") it "should parse a record, comment, followed by next keyword" $ do res <- parse parseKeywordRecord $ flattenKeywords ["SIMPLE = T / conforms to FITS standard"] - res @?= ("SIMPLE", Logic T) + res @?= KeywordRecord "SIMPLE" (Logic T) (Just "conforms to FITS standard") it "should handle keyword symbols" $ do res <- parse parseKeywordRecord $ flattenKeywords ["OBSGEO-X= -5466045.256954942 / [m]"] - res @?= ("OBSGEO-X", Float (-5466045.256954942)) + res @?= KeywordRecord "OBSGEO-X" (Float (-5466045.256954942)) (Just "[m]") it "should handle extension" $ do res <- parse parseKeywordRecord $ flattenKeywords ["XTENSION= 'IMAGE '"] - res @?= ("XTENSION", String "IMAGE") + res @?= KeywordRecord "XTENSION" (String "IMAGE") Nothing + it "should not consume blank lines" $ do + let inp = flattenKeywords ["SIMPLE = T" , " "] + res <- flip parse inp $ do + kv <- parseKeywordRecord + _ <- parseLineBlank + pure kv + res @?= KeywordRecord "SIMPLE" (Logic T) Nothing + + fullRecordLine :: Test () fullRecordLine = describe "parseRecordLine" $ do it "should parse a normal line" $ do res <- parse parseRecordLine "NAXIS1 = 100 / [pix] END" - res @?= Just ("NAXIS1", Integer 100) + res @?= Keyword (KeywordRecord "NAXIS1" (Integer 100) (Just "[pix]")) it "should parse a comment line" $ do res <- parse parseRecordLine "COMMENT ------------------------------ Telescope -------------------------------END" - res @?= Nothing + res @?= Comment "------------------------------ Telescope -------------------------------" it "should parse a blank line" $ do res <- parse parseRecordLine $ flattenKeywords [" "] - res @?= Nothing + res @?= BlankLine comments :: Test () -comments = describe "Full-line comments" $ do +comments = do + describe "Full-line comments" $ do it "should parse full-line comments" $ do res <- parse parseLineComment $ flattenKeywords ["COMMENT --------------------------- VISP Instrument ----------------------------"] - res @?= Comment "--------------------------- VISP Instrument ----------------------------" + res @?= "--------------------------- VISP Instrument ----------------------------" it "should parse comments with text" $ do res <- parse parseLineComment $ flattenKeywords ["COMMENT Keys describing the pointing and operation of the telescope. Including "] - res @?= Comment " Keys describing the pointing and operation of the telescope. Including " + res @?= " Keys describing the pointing and operation of the telescope. Including " it "should parse blank comments" $ do res <- parse parseLineComment $ flattenKeywords ["COMMENT "] - res @?= Comment " " + res @?= " " + + describe "inline comments" $ do + it "should parse comment" $ do + res <- parse (parseInlineComment 0) $ " / Telescope" <> C8.replicate 68 ' ' + res @?= "Telescope" + describe "parse to line end" $ do + it "should parse comment line end" $ do + res <- parse (parseLineEnd 0) $ " / Telescope" <> C8.replicate 68 ' ' + res @?= Just "Telescope" + it "should ignore blanks" $ do + res <- parse (parseLineEnd 0) $ C8.replicate 80 ' ' + res @?= Nothing + + it "should parse comment after blanks" $ do + res <- parse (parseLineEnd 0) $ " / comment " <> C8.replicate 60 ' ' + res @?= Just "comment" + + describe "withComments" $ do + it "should parse a number, ignoring" $ do + res <- parse (withComments parseValue) $ "12345 / Woot" <> C8.replicate 68 ' ' + res @?= (Integer 12345, Just "Woot") + + it "should parse no comment" $ do + res <- parse (withComments parseValue) $ "12345 " <> C8.replicate 68 ' ' + res @?= (Integer 12345, Nothing) + + it "should ignore comments on bintable" $ do + -- parse (withComments parseValue) $ "12345 " <> C8.replicate 68 ' ' + let inp = flattenKeywords ["XTENSION= 'BINTABLE' / binary table extension"] + (_, mc) <- flip parse inp $ do + withComments $ M.string' "XTENSION= 'BINTABLE'" + mc @?= Just "binary table extension" + + + continue :: Test () continue = describe "Continue Keyword" $ do @@ -210,45 +265,51 @@ , "CONTINUE 'ml' " ] - m <- parse parseHeader $ flattenKeywords h - Map.lookup "CAL_URL" m @?= Just (String "https://docs.dkist.nso.edu/projects/visp/en/v2.0.1/l0_to_l1_visp.html") + h <- parse parseHeader $ flattenKeywords h + Fits.lookup "CAL_URL" h @?= Just (String "https://docs.dkist.nso.edu/projects/visp/en/v2.0.1/l0_to_l1_visp.html") headerMap :: Test () headerMap = describe "full header" $ do it "should parse single header" $ do - res <- parse parseHeader $ flattenKeywords ["KEY1='value'"] - Map.size res @?= 1 - Map.lookup "KEY1" res @?= Just (String "value") + h <- parse parseHeader $ flattenKeywords ["KEY1='value'"] + length (h ^. keywords) @?= 1 + Fits.lookup "KEY1" h @?= Just (String "value") it "should parse multiple headers " $ do res <- parse parseHeader $ flattenKeywords ["KEY1='value'", "KEY2= 23"] - Map.size res @?= 2 - Map.lookup "KEY2" res @?= Just (Integer 23) + length (res ^. keywords) @?= 2 + Fits.lookup "KEY2" res @?= Just (Integer 23) it "should ignore comments" $ do res <- parse parseHeader $ flattenKeywords ["KEY1='value' / this is a comment"] - Map.size res @?= 1 - Map.lookup "KEY1" res @?= Just (String "value") + length (res ^. keywords) @?= 1 + Fits.lookup "KEY1" res @?= Just (String "value") it "should handle xtension" $ do res <- parse parseHeader $ flattenKeywords ["XTENSION= 'IMAGE '"] - Map.size res @?= 1 - Map.lookup "XTENSION" res @?= Just (String "IMAGE") + length (res ^. keywords) @?= 1 + Fits.lookup "XTENSION" res @?= Just (String "IMAGE") + it "should parse blank line before keyword" $ do + res <- parse parseHeader $ flattenKeywords [" ", "KEY2 = 22"] + (res ^. records) @?= [BlankLine, Keyword (KeywordRecord "KEY2" (Integer 22) Nothing)] + + it "should parse line after keyword" $ do + res <- parse parseHeader $ flattenKeywords ["KEY1 = 11", " ", "KEY2 = 22"] + (res ^. records) @?= [Keyword (KeywordRecord "KEY1" (Integer 11) Nothing), BlankLine, Keyword (KeywordRecord "KEY2" (Integer 22) Nothing)] -requiredHeaders :: Test () -requiredHeaders = describe "required headers" $ do - -- res <- parse parseSimple $ keywords ["SIMPLE= T"] - -- res @?= Primary +requiredHeaders :: Test () +requiredHeaders = + describe "required headers" $ do it "should parse bitpix" $ do res <- parse parseBitPix $ flattenKeywords ["BITPIX = 16"] res @?= SixteenBitInt - it "should parse NAxes" $ do - res <- parse parseNaxes $ flattenKeywords ["NAXIS = 3", "NAXIS1=1", "NAXIS2=2", "NAXIS3=3"] + it "should parse NAXES" $ do + res <- parse parseNaxes $ flattenKeywords ["NAXIS =3", "NAXIS1 =1", "NAXIS2 =2", "NAXIS3 =3"] res @?= [1,2,3] it "should parse size" $ do @@ -260,8 +321,8 @@ let fakeData = "1234" -- Related to NAXIS! h <- parse parsePrimary $ flattenKeywords ["SIMPLE = T", "BITPIX = 8", "NAXIS=2", "NAXIS1=2", "NAXIS2=2", "TEST='hi'"] <> fakeData (h ^. extension) @?= Primary - Map.size (h ^. header . keywords) @?= 5 - Fits.lookup "NAXIS" (h ^. header) @?= Just (Integer 2) + length (h ^. header . keywords) @?= 5 + lookup "NAXIS" (h ^. header) @?= Just (Integer 2) it "should parse full extension" $ do h <- parse parseBinTable $ flattenKeywords ["XTENSION= 'BINTABLE'", "BITPIX = -32", "NAXIS=0", "PCOUNT=0", "GCOUNT=1"] @@ -284,7 +345,7 @@ hdu <- eitherFail $ readPrimaryHDU bs -- hdu.header.size.bitpix @?= ThirtyTwoBitFloat -- hdu.header.size.naxes @?= NAxes [621, 621] - -- + Fits.lookup "NAXIS" (hdu ^. header) @?= Just (Integer 2) let payloadSize = BS.length (hdu ^. mainData) @@ -304,8 +365,8 @@ , "COMMENT Keys describing the pointing and operation of the telescope. Including " , "COMMENT the FITS WCS keys describing the world coordinates of the array. " ] - m <- parse parseHeader $ flattenKeywords h - Map.size m @?= 1 + h <- parse parseHeader $ flattenKeywords h + length (h ^. keywords) @?= 1 describe "sample header file" $ do @@ -317,7 +378,11 @@ _ <- parse parseRecordLine $ flattenKeywords [TE.encodeUtf8 t] pure () - it "should parse NAxes correctly" $ do + it "should parse xtension bintable" $ do + (sz, _) <- parse parseBinTableKeywords $ mconcat $ C8.lines bs + (sz ^. axes) @?= [32, 998] + + it "should parse NAXES correctly" $ do (sz, _) <- parse parseBinTableKeywords $ mconcat $ C8.lines bs (sz ^. axes) @?= [32, 998]