{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} module Main where -- qualified imports ---- base import qualified Data.Map.Strict as Map ---- bytestring import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 ---- megaparsec import qualified Text.Megaparsec as M import qualified Text.Megaparsec.Char as M ---- text import qualified Data.Text as T import qualified Data.Text.Encoding as TE ---- local imports import qualified Data.Fits as Fits -- symbol based imports ---- base import Control.Monad ( forM_ ) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception (Exception(displayException), throwIO) import Data.List ( unfoldr ) ---- bytestring import Data.ByteString ( ByteString ) ---- ghc import GHC.RTS.Flags (MiscFlags(numIoWorkerThreads)) ---- microlens import Lens.Micro ((^.)) ---- mtl import Control.Monad.Writer ( MonadWriter, WriterT, execWriterT, tell) ---- tasty import Test.Tasty import Test.Tasty.HUnit ---- text import Data.Text ( Text ) ---- local-imports import Data.Fits ( Axes , BitPixFormat(..) , bitPixToByteSize , Comment(Comment) , Dimensions , axes , bitpix , Extension(..) , Header , keywords , HeaderDataUnit , header , dimensions , extension , mainData , Keyword(Keyword) , LogicalConstant(..) , Value(..) , hduBlockSize ) import Data.Fits.MegaParser import Data.Fits.Read main :: IO () main = testMain $ runTests "Tests" $ do basicParsing keywordValueLines comments continue fullRecord fullRecordLine headerMap requiredHeaders dataArray sampleSpiral sampleNSOHeaders sampleNSO parse :: Parser a -> ByteString -> IO a parse p inp = case M.parse p "Test" inp of Left e -> fail $ displayException e Right v -> pure v flattenKeywords :: [ByteString] -> ByteString flattenKeywords ts = mconcat (map pad ts) <> "END" pad :: ByteString -> ByteString pad m = let n = 80 - BS.length m in m <> C8.replicate n ' ' basicParsing :: Test () basicParsing = describe "Basic Parsing" $ do it "should parse a string" $ do res <- parse parseStringValue "'hello there' " res @?= "hello there" it "should parse a number value" $ do res <- parse parseValue "42 " res @?= Integer 42 it "should parse a keyword" $ do res <- parse parseKeyword "WS_TEMP =" res @?= Keyword "WS_TEMP" it "should handle keyword symbols" $ do res <- parse parseKeyword "OBSGEO-X= -5466045.256954942 / [m]" res @?= Keyword "OBSGEO-X" keywordValueLines :: Test () keywordValueLines = describe "parse keyword=value" $ do it "should parse an integer" $ do res <- parse parseKeywordValue "KEY=42 " res @?= ("KEY", Integer 42) it "should parse a string" $ do res <- parse parseKeywordValue "KEY='value'" res @?= ("KEY", String "value") it "should absorb spaces" $ do res <- parse parseKeywordValue "KEY = 'value' " res @?= ("KEY", String "value") it "should parse a float" $ do res <- parse parseKeywordValue "KEY = 44.88 " res @?= ("KEY", Float 44.88) it "should parse a negative number" $ do res <- parse parseKeywordValue "KEY = -44.88" res @?= ("KEY", Float ( -44.88 )) it "should parse a logical constant" $ do res <- parse parseKeywordValue "KEY= T " res @?= ("KEY", Logic T) it "should ignore comments" $ do res <- parse parseKeywordValue "SIMPLE = T / conforms to FITS standard" res @?= ("SIMPLE", Logic T) it "should strip trailing spaces from strings" $ do res <- parse parseKeywordValue "INSTRUME= 'VISP '" res @?= ("INSTRUME", String "VISP") fullRecord :: Test () fullRecord = describe "parseKeywordRecord" $ do it "should parse an 80 character record" $ do res <- parse parseKeywordRecord (flattenKeywords ["KEYWORD = 12345"]) res @?= ("KEYWORD", Integer 12345) it "should parse an a record and comment" $ do res <- parse parseKeywordRecord (flattenKeywords ["KEYWORD = 12345 / this is a comment"]) res @?= ("KEYWORD", Integer 12345) 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) it "should handle keyword symbols" $ do res <- parse parseKeywordRecord $ flattenKeywords ["OBSGEO-X= -5466045.256954942 / [m]"] res @?= ("OBSGEO-X", Float (-5466045.256954942)) it "should handle extension" $ do res <- parse parseKeywordRecord $ flattenKeywords ["XTENSION= 'IMAGE '"] res @?= ("XTENSION", String "IMAGE") 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) it "should parse a comment line" $ do res <- parse parseRecordLine "COMMENT ------------------------------ Telescope -------------------------------END" res @?= Nothing it "should parse a blank line" $ do res <- parse parseRecordLine $ flattenKeywords [" "] res @?= Nothing comments :: Test () comments = describe "Full-line comments" $ do it "should parse full-line comments" $ do res <- parse parseLineComment $ flattenKeywords ["COMMENT --------------------------- VISP Instrument ----------------------------"] res @?= Comment "--------------------------- 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 " it "should parse blank comments" $ do res <- parse parseLineComment $ flattenKeywords ["COMMENT "] res @?= Comment " " continue :: Test () continue = describe "Continue Keyword" $ do it "should be picked up in parseValue" $ do res <- parse parseValue $ flattenKeywords ["'hello&'CONTINUE '!'"] res @?= String "hello!" it "should combine continue into previous keyword" $ do let h = [ "CAL_URL = 'https://docs.dkist.nso.edu/projects/visp/en/v2.0.1/l0_to_l1_visp.ht&'" , "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") 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") 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) 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") it "should handle xtension" $ do res <- parse parseHeader $ flattenKeywords ["XTENSION= 'IMAGE '"] Map.size res @?= 1 Map.lookup "XTENSION" res @?= Just (String "IMAGE") requiredHeaders :: Test () requiredHeaders = describe "required headers" $ do -- res <- parse parseSimple $ keywords ["SIMPLE= T"] -- res @?= Primary 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"] res @?= [1,2,3] it "should parse size" $ do res <- parse parseDimensions $ flattenKeywords ["BITPIX = -32", "NAXIS=2", "NAXIS1=10", "NAXIS2=20"] (res ^. bitpix) @?= ThirtyTwoBitFloat (res ^. axes) @?= [10,20] it "should include required headers in the keywords" $ do 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) it "should parse full extension" $ do h <- parse parseBinTable $ flattenKeywords ["XTENSION= 'BINTABLE'", "BITPIX = -32", "NAXIS=0", "PCOUNT=0", "GCOUNT=1"] (h ^. extension) @?= BinTable 0 "" dataArray :: Test () dataArray = describe "data array" $ do it "should grab correct data array" $ do let fakeData = "1234" -- Related to NAXIS! h <- parse parsePrimary $ flattenKeywords ["SIMPLE = T", "BITPIX = 8", "NAXIS=2", "NAXIS1=2", "NAXIS2=2", "TEST='hi'"] <> " " <> fakeData (h ^. mainData) @?= fakeData sampleSpiral :: Test () sampleSpiral = describe "Spiral Sample FITS Parse" $ do it "should parse" $ do let fileSizeOnDisk = 1545444 bs <- BS.readFile "./fits_files/Spiral_2_30_0_300_10_0_NoGrad.fits" 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) -- Make sure we took the right number of bytes out of the file payloadSize @?= fileSizeOnDisk - hduBlockSize sampleNSOHeaders :: Test () sampleNSOHeaders = do describe "NSO Stripped Headers" $ do it "should parse comment block" $ do let h = [ "DATASUM = '550335088' / data unit checksum updated 2023-04-22T04:10:59 " , " " , "COMMENT ------------------------------ Telescope -------------------------------" , "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 describe "sample header file" $ do bs <- liftIO $ BS.readFile "./fits_files/nso_dkist_headers.txt" let ts = filter (not . ignore) $ T.lines $ TE.decodeUtf8 bs it "should parse all keywords individually" $ do forM_ ( zip [1..] ts ) $ \(n, t) -> do _ <- parse parseRecordLine $ flattenKeywords [TE.encodeUtf8 t] pure () it "should parse NAxes correctly" $ do (sz, _) <- parse parseBinTableKeywords $ mconcat $ C8.lines bs (sz ^. axes) @?= [32, 998] where ignore t = T.isPrefixOf "CONTINUE" t || T.isPrefixOf "END" t sampleNSO :: Test () sampleNSO = do describe "NSO Sample FITS Parse" $ do bs <- liftIO $ BS.readFile "./fits_files/nso_dkist.fits" it "should parse empty primary header" $ do h0 <- eitherFail $ readPrimaryHDU bs -- first header doesn't have any data BS.length (h0 ^. mainData) @?= 0 it "should parse both HDUs" $ do hdus <- eitherFail $ readHDUs bs length hdus @?= 2 [_, h2] <- pure hdus Fits.lookup "INSTRUME" (h2 ^. header) @?= Just (String "VISP") Fits.lookup "NAXIS" (h2 ^. header) @?= Just (Integer 2) let sizeOnDisk = 161280 countedHeaderBlocks = 11 -- this was manually counted... until end of all headers payloadLength = BS.length (h2 ^. mainData) headerLength = countedHeaderBlocks * hduBlockSize heapLength = pCount (h2 ^. extension) -- Payload size is as expected payloadLength @?= 32 * 998 * fromIntegral (bitPixToByteSize EightBitInt) pCount (h2 ^. extension) @?= 95968 assertBool "The end of the heap has some null data" $ do C8.all (/='\0') $ C8.take 100 $ C8.drop (headerLength + payloadLength + heapLength - 100) bs assertBool "The remainder of the file contains real data" $ do C8.all (=='\0') $ C8.drop (headerLength + payloadLength + heapLength) bs where pCount :: Extension -> Int pCount (BinTable p h) = p pCount _ = 0 -- Test monad with describe/it newtype Test a = Test {runTest :: WriterT [TestTree] IO a} deriving (Functor, Applicative, Monad, MonadIO, MonadWriter [TestTree]) runTests :: TestName -> Test () -> IO TestTree runTests n (Test t) = do tests <- execWriterT t :: IO [TestTree] return $ testGroup n tests describe :: TestName -> Test () -> Test () describe n t = do ts <- liftIO $ runTests n t tell [ts] it :: TestName -> IO () -> Test () it n a = do tell [testCase n a] testMain :: IO TestTree -> IO () testMain mtt = do tt <- mtt defaultMain tt