telescope 0.3.0 → 0.4.0

raw patch · 16 files changed

+198/−79 lines, 16 files

Files

• README.md +18/−6
• example/output/hubble1.png binary
• src/Telescope/Asdf/Encoding.hs +2/−4
• src/Telescope/Asdf/Encoding/Stream.hs +2/−2
• src/Telescope/Asdf/GWCS.hs +11/−11
• src/Telescope/Data/DataCube.hs +29/−29
• src/Telescope/Data/Parser.hs +18/−3
• src/Telescope/Data/WCS.hs +3/−3
• src/Telescope/Fits.hs +1/−0
• src/Telescope/Fits/Encoding.hs +7/−5
• src/Telescope/Fits/Header/Class.hs +24/−0
• telescope.cabal +2/−2
• test/Test/Asdf/DecodeSpec.hs +3/−2
• test/Test/DataCubeSpec.hs +65/−0
• test/Test/Fits/ClassSpec.hs +7/−6
• test/Test/Fits/EncodingSpec.hs +6/−6

@@ -1,16 +1,15 @@- Telescope ========= -[![Hackage](https://img.shields.io/hackage/v/telescope.svg&color=success)](https://hackage.haskell.org/package/telescope)+[![Hackage Version](https://img.shields.io/hackage/v/telescope?color=success)](https://hackage.haskell.org/package/telescope) -Haskell library to read and write Astronomical images from telescopes+Haskell library to work with scientific data files commonly used in astronomy  * [FITS](https://fits.gsfc.nasa.gov/fits_standard.html) (Flexible Image Transport System) Files * [ASDF](https://asdf-standard.readthedocs.io/) (Advanced Scientific Data Format) Files  FITS Example--------+------------  ``` import Telescope.Fits@@ -191,6 +190,19 @@ ```  -### Collaborators+Getting Raw Telescope Data+-------------------------- -* The FITS code was developed in collaboration with @krakrjak+* [NSO DKIST Solar Telescope](https://dkist.data.nso.edu/)+* [MAST](https://mast.stsci.edu/portal/Mashup/Clients/Mast/Portal.html) - Hubble and JWST++++Attributions+---------------------------++<a href="https://nso.edu">+  <img alt="National Solar Observatory" src="https://nso1.b-cdn.net/wp-content/uploads/2020/03/NSO-logo-orange-text.png" width="400"/>+</a>++FITS code was developed in collaboration with [@krakrjak](https://github.com/krakrjak/fits-parse)

binary file changed (248996 → absent bytes)

@@ -118,7 +118,5 @@ runYamlError = runErrorNoCallStackWith @YamlError (throwError . YamlError . show)  -runParseError :: (Error AsdfError :> es) => Eff es (Either ParseError a) -> Eff es a-runParseError eff = do-  res <- eff-  either (throwError . ParseError . show) pure res+runParseError :: (Error AsdfError :> es) => Eff (Error ParseError : es) a -> Eff es a+runParseError = runErrorNoCallStackWith @ParseError (throwError . ParseError . show)

@@ -20,7 +20,7 @@ import Telescope.Asdf.NDArray (NDArrayData (..)) import Telescope.Asdf.Node import Telescope.Data.Axes-import Telescope.Data.Parser (runParser)+import Telescope.Data.Parser (runParserPure) import Text.Libyaml (Event (..), MappingStyle (..), SequenceStyle (..), Style (..), Tag (..)) import Text.Libyaml qualified as Yaml import Text.Read (readMaybe)@@ -240,7 +240,7 @@    parseLocal :: (FromAsdf a, Error YamlError :> es) => String -> Value -> Eff es a   parseLocal expected val = do-    res <- runParser . runReader @Anchors mempty $ parseValue val+    let res = runParserPure . runReader @Anchors mempty $ parseValue val     case res of       Left _ -> throwError $ NDArrayExpected expected val       Right a -> pure a

@@ -69,11 +69,11 @@   toAxes = fmap ("lin_" <>) (toAxes @a)  -newtype Lon = Lon Float+newtype Lon = Lon Double   deriving newtype (ToAsdf)-newtype Lat = Lat Float+newtype Lat = Lat Double   deriving newtype (ToAsdf)-newtype LonPole = LonPole Float+newtype LonPole = LonPole Double   deriving newtype (ToAsdf)  @@ -181,15 +181,15 @@   toValue = String . T.toLower . pack . show  -data Shift a = Shift Float deriving (Show, Eq)-data Scale a = Scale Float deriving (Show, Eq)+data Shift a = Shift Double deriving (Show, Eq)+data Scale a = Scale Double deriving (Show, Eq) data Identity = Identity deriving (Show, Eq)-data Intercept = Intercept Float deriving (Show, Eq)-data Affine = Affine {matrix :: Array M.D Ix2 Float, translation :: (Float, Float)}+data Intercept = Intercept Double deriving (Show, Eq)+data Affine = Affine {matrix :: Array M.D Ix2 Double, translation :: (Double, Double)} data Projection = Projection Direction data Rotate3d = Rotate3d {direction :: Direction, phi :: Lon, theta :: Lat, psi :: LonPole}   deriving (Generic)-data Linear a = Linear1d {intercept :: Float, slope :: Float}+data Linear a = Linear1d {intercept :: Double, slope :: Double}   deriving (Generic)  @@ -447,11 +447,11 @@  -- Transforms ----------------------------------------------- -shift :: forall a f. (ToAxes (f a), ToAxes (Shift a)) => Float -> Transform (f a) (Shift a)+shift :: forall a f. (ToAxes (f a), ToAxes (Shift a)) => Double -> Transform (f a) (Shift a) shift d = transform $ Shift d  -scale :: forall a f. (ToAxes (f a), ToAxes (Scale a)) => Float -> Transform (f a) (Scale a)+scale :: forall a f. (ToAxes (f a), ToAxes (Scale a)) => Double -> Transform (f a) (Scale a) scale d = transform $ Scale d  @@ -459,7 +459,7 @@ linear (Intercept dlt) (Scale scl) = transform $ Linear1d{intercept = dlt, slope = scl}  -rotate :: (ToAxes x, ToAxes y) => Array M.D Ix2 Float -> Transform (Linear x, Linear y) (Rot (x, y))+rotate :: (ToAxes x, ToAxes y) => Array M.D Ix2 Double -> Transform (Linear x, Linear y) (Rot (x, y)) rotate arr =   transform $ Affine arr (0, 0) 

@@ -12,16 +12,16 @@  -- Results ------------------------------------------------------------------------------ -newtype DataCube (as :: [Type]) = DataCube-  { array :: Array D (IndexOf as) Double+newtype DataCube (as :: [Type]) f = DataCube+  { array :: Array D (IndexOf as) f   }  -instance (Index (IndexOf as)) => Eq (DataCube as) where+instance (Index (IndexOf as), Eq f) => Eq (DataCube as f) where   DataCube arr == DataCube arr2 = arr == arr2  -instance (Ragged L (IndexOf as) Double) => Show (DataCube as) where+instance (Ragged L (IndexOf as) f, Show f) => Show (DataCube as f) where   show (DataCube a) = show a  @@ -44,32 +44,32 @@   outerList-  :: forall a as+  :: forall a as f    . (Lower (IndexOf (a : as)) ~ IndexOf as, Index (IndexOf as), Index (IndexOf (a : as)))-  => DataCube (a : as)-  -> [DataCube as]+  => DataCube (a : as) f+  -> [DataCube as f] outerList (DataCube a) = foldOuterSlice row a  where-  row :: Array D (IndexOf as) Double -> [DataCube as]+  row :: Array D (IndexOf as) f -> [DataCube as f]   row r = [DataCube r]   transposeMajor   :: (IndexOf (a : b : xs) ~ IndexOf (b : a : xs), Index (Lower (IndexOf (b : a : xs))), Index (IndexOf (b : a : xs)))-  => DataCube (a : b : xs)-  -> DataCube (b : a : xs)+  => DataCube (a : b : xs) f+  -> DataCube (b : a : xs) f transposeMajor (DataCube arr) = DataCube $ transposeInner arr   transposeMinor4-  :: DataCube [a, b, c, d]-  -> DataCube [a, b, d, c]+  :: DataCube [a, b, c, d] f+  -> DataCube [a, b, d, c] f transposeMinor4 (DataCube arr) = DataCube $ transposeOuter arr   transposeMinor3-  :: DataCube [a, b, c]-  -> DataCube [a, c, b]+  :: DataCube [a, b, c] f+  -> DataCube [a, c, b] f transposeMinor3 (DataCube arr) = DataCube $ transposeOuter arr  @@ -80,21 +80,21 @@      , Index (IndexOf (a : xs))      )   => Int-  -> DataCube (a : xs)-  -> DataCube xs+  -> DataCube (a : xs) f+  -> DataCube xs f sliceM0 a (DataCube arr) = DataCube (arr !> a)   -- Slice along the 2nd major dimension sliceM1-  :: forall a b xs+  :: forall a b xs f    . ( Lower (IndexOf (a : b : xs)) ~ IndexOf (a : xs)      , Index (IndexOf (a : xs))      , Index (IndexOf (a : b : xs))      )   => Int-  -> DataCube (a : b : xs)-  -> DataCube (a : xs)+  -> DataCube (a : b : xs) f+  -> DataCube (a : xs) f sliceM1 b (DataCube arr) =   let dims = fromIntegral $ natVal @(Dimensions (IndexOf (a : b : xs))) Proxy    in DataCube $ arr <!> (Dim (dims - 1), b)@@ -102,27 +102,27 @@  -- Slice along the 3rd major dimension sliceM2-  :: forall a b c xs+  :: forall a b c xs f    . ( Lower (IndexOf (a : b : c : xs)) ~ IndexOf (a : b : xs)      , Index (IndexOf (a : b : xs))      , Index (IndexOf (a : b : c : xs))      )   => Int-  -> DataCube (a : b : c : xs)-  -> DataCube (a : b : xs)+  -> DataCube (a : b : c : xs) f+  -> DataCube (a : b : xs) f sliceM2 c (DataCube arr) =   let dims = fromIntegral $ natVal @(Dimensions (IndexOf (a : b : c : xs))) Proxy    in DataCube $ arr <!> (Dim (dims - 2), c)   splitM0-  :: forall a xs m+  :: forall a xs f m    . ( Index (IndexOf (a : xs))      , MonadThrow m      )   => Int-  -> DataCube (a : xs)-  -> m (DataCube (a : xs), DataCube (a : xs))+  -> DataCube (a : xs) f+  -> m (DataCube (a : xs) f, DataCube (a : xs) f) splitM0 a (DataCube arr) = do   let dims = fromIntegral $ natVal @(Dimensions (IndexOf (a : xs))) Proxy   (arr1, arr2) <- M.splitAtM (Dim dims) a arr@@ -130,21 +130,21 @@   splitM1-  :: forall a b xs m+  :: forall a b xs f m    . ( Index (IndexOf (a : xs))      , Index (IndexOf (a : b : xs))      , MonadThrow m      )   => Int-  -> DataCube (a : b : xs)-  -> m (DataCube (a : b : xs), DataCube (a : b : xs))+  -> DataCube (a : b : xs) f+  -> m (DataCube (a : b : xs) f, DataCube (a : b : xs) f) splitM1 b (DataCube arr) = do   let dims = fromIntegral $ natVal @(Dimensions (IndexOf (a : xs))) Proxy   (arr1, arr2) <- M.splitAtM (Dim dims) b arr   pure (DataCube arr1, DataCube arr2)  -dataCubeAxes :: (Index (IndexOf as), AxesIndex (IndexOf as)) => DataCube as -> Axes Row+dataCubeAxes :: (Index (IndexOf as), AxesIndex (IndexOf as)) => DataCube as f -> Axes Row dataCubeAxes (DataCube arr) =   let Sz ix = M.size arr    in indexAxes ix

@@ -19,15 +19,30 @@ type instance DispatchOf Parser = 'Dynamic  +-- runParser+--   :: Eff (Parser : es) a+--   -> Eff es (Either ParseError a)+-- runParser = reinterpret (runErrorNoCallStack @ParseError . runReader @Path mempty) $ \env -> \case+--   ParseFail e -> do+--     path <- ask @Path+--     throwError $ ParseFailure path e+--   PathMod mp m -> do+--     localSeqUnlift env $ \unlift -> local mp (unlift m)+ runParser-  :: Eff (Parser : es) a-  -> Eff es (Either ParseError a)-runParser = reinterpret (runErrorNoCallStack @ParseError . runReader @Path mempty) $ \env -> \case+  :: (Error ParseError :> es)+  => Eff (Parser : es) a+  -> Eff es a+runParser = reinterpret (runReader @Path mempty) $ \env -> \case   ParseFail e -> do     path <- ask @Path     throwError $ ParseFailure path e   PathMod mp m -> do     localSeqUnlift env $ \unlift -> local mp (unlift m)+++runParserPure :: Eff '[Parser, Error ParseError] a -> Either ParseError a+runParserPure = runPureEff . runErrorNoCallStack @ParseError . runParser   -- copied from Effectful.Reader.Dynamic

@@ -24,9 +24,9 @@ data WCSAxis (alt :: WCSAlt) axis = WCSAxis   { ctype :: CType   , cunit :: CUnit-  , crpix :: Float-  , crval :: Float-  , cdelt :: Float+  , crpix :: Double+  , crval :: Double+  , cdelt :: Double   }   deriving (Generic, Eq, Show) 

@@ -31,6 +31,7 @@   , encodeDataArray      -- * Headers+  , keywords   , lookupKeyword   , Header   , Value (..)

@@ -7,6 +7,7 @@ import Data.Text.Encoding qualified as TE import Effectful import Effectful.Dispatch.Dynamic+import Effectful.Error.Static import Effectful.State.Static.Local import Telescope.Data.Parser import Telescope.Fits.Checksum@@ -38,16 +39,16 @@    in mconcat $ prim : exts  -fitsParseThrow :: (MonadThrow m) => Eff '[State ByteString, Parser] a -> ByteString -> m a+fitsParseThrow :: (MonadThrow m) => Eff '[State ByteString, Parser, Error ParseError] a -> ByteString -> m a fitsParseThrow parse inp =   case runFitsParse parse inp of     Left e -> throwM e     Right a -> pure a  -runFitsParse :: Eff '[State ByteString, Parser] a -> BS.ByteString -> Either ParseError a+runFitsParse :: Eff '[State ByteString, Parser, Error ParseError] a -> BS.ByteString -> Either ParseError a runFitsParse parse inp = do-  runPureEff $ runParser $ evalState inp parse+  runParserPure $ evalState inp parse   parseFits :: forall es. (State ByteString :> es, Parser :> es) => Eff es Fits@@ -82,8 +83,9 @@  extension :: (State ByteString :> es, Parser :> es) => Eff es Extension extension = do-  resImg <- runParser image-  resTbl <- runParser binTable+  -- I don't understand how to use NonDet to fix this+  resImg <- runErrorNoCallStack @ParseError $ runParser image+  resTbl <- runErrorNoCallStack @ParseError $ runParser binTable   case (resImg, resTbl) of     (Right i, _) -> pure $ Image i     (_, Right b) -> pure $ BinTable b

@@ -46,6 +46,14 @@     v -> expected "Float" v  +instance ToKeyword Double where+  toKeywordValue = Float+instance FromKeyword Double where+  parseKeywordValue = \case+    Float n -> pure n+    v -> expected "Double" v++ instance ToKeyword Text where   toKeywordValue = String instance FromKeyword Text where@@ -105,6 +113,14 @@   toHeader = mconcat . fmap toHeader  +instance ToHeader Header where+  toHeader = id+++instance ToHeader HeaderRecord where+  toHeader hr = Header [hr]++ instance (AxisOrder ax, KnownText alt) => ToHeader (WCSAxis alt ax) where   toHeader axis =     mconcat@@ -126,6 +142,14 @@   parseHeader :: (Parser :> es) => Header -> Eff es a   default parseHeader :: (Generic a, GFromHeader (Rep a), Parser :> es) => Header -> Eff es a   parseHeader h = to <$> gParseHeader h+++instance FromHeader Header where+  parseHeader = pure+++instance FromHeader [HeaderRecord] where+  parseHeader h = pure h.records   instance (AxisOrder ax, KnownText alt) => FromHeader (WCSAxis alt ax) where

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:               telescope-version:            0.3.0+version:            0.4.0 synopsis:           Astronomical Observations (FITS, ASDF, WCS, etc) description:        Work with astronomical observations from modern telescopes license:            BSD3@@ -20,7 +20,6 @@     README.md     src/checksum.c     src/checksum.h-    example/output/hubble1.png  library     exposed-modules:@@ -109,6 +108,7 @@         Test.Asdf.GWCSSpec         Test.Asdf.NDArraySpec         Test.BinarySpec+        Test.DataCubeSpec         Test.Fits.ChecksumSpec         Test.Fits.ClassSpec         Test.Fits.EncodingSpec

@@ -7,6 +7,7 @@ import Data.Massiv.Array qualified as M import Data.Text (Text, unpack) import Effectful+import Effectful.Error.Static import GHC.Generics (Generic) import GHC.Int (Int64) import Skeletest@@ -265,9 +266,9 @@     pure $ noCleanup $ RefTreeFix tree  -parseIO :: Eff '[Parser, IOE] a -> IO a+parseIO :: Eff '[Parser, Error ParseError, IOE] a -> IO a parseIO p = do-  res <- runEff $ runParser p+  res <- runEff $ runErrorNoCallStack @ParseError $ runParser p   case res of     Left e -> throwM e     Right a -> pure a

@@ -0,0 +1,65 @@+module Test.DataCubeSpec where+++import Data.Massiv.Array as M+import Skeletest+import Telescope.Data.DataCube++data Row+data Column+data Depth+++spec :: Spec+spec = do+  describe "DataCube" $ do+    describe "assumptions" $ do+      it "should have expected size" $ do+        M.size sampleRC.array `shouldBe` Sz (2 :. 3)++      it "should have expected values" $ do+        M.toLists sampleRC.array `shouldBe` [[0, 1, 2], [1, 2, 3]]++    describe "transpose" $ do+      it "should swap two dimensions" $ do+        M.size (transposeMajor sampleRC).array `shouldBe` Sz (3 :. 2)+        toLists (computeAs P (transposeMajor sampleRC).array) `shouldBe` [[0, 1], [1, 2], [2, 3]]++      it "should swap three dimensions" $ do+        M.size (transposeMajor sampleDRC).array `shouldBe` Sz (2 :> 1 :. 3)++    describe "slice major 0" $ do+      it "should row access" $ do+        toLists (computeAs P (sliceM0 0 sampleRC).array) `shouldBe` [0.0, 1.0, 2.0]++      it "should depth access" $ do+        toLists (computeAs P (sliceM0 0 sampleDRC).array) `shouldBe` [[0.0, 1.0, 2.0], [1.0, 2.0, 3.0]]++    describe "slice major 1" $ do+      it "should slice square column" $ do+        toLists (computeAs P (sliceM1 0 sampleRC).array) `shouldBe` [0.0, 1.0]+        toLists (computeAs P (sliceM1 1 sampleRC).array) `shouldBe` [1.0, 2.0]++      it "should slice cube by row" $ do+        -- print sampleDRC+        size (sliceM1 0 sampleDRC).array `shouldBe` Sz (1 :. 3)+        -- \| 0 1 2 |+        -- \| 1 2 3 |+        toLists (computeAs P (sliceM1 0 sampleDRC).array) `shouldBe` [[0.0, 1.0, 2.0]]++    describe "slice major 2" $ do+      it "should slice cube by column" $ do+        size (sliceM2 0 sampleDRC).array `shouldBe` Sz (1 :. 2)+        toLists (computeAs P (sliceM2 2 sampleDRC).array) `shouldBe` [[2.0, 3.0]]+++sampleRC :: DataCube [Row, Column] Float+sampleRC = DataCube $ M.makeArray Seq (Sz (2 :. 3)) sumIndex+ where+  sumIndex (r :. c) = fromIntegral r + fromIntegral c+++sampleDRC :: DataCube [Depth, Row, Column] Float+sampleDRC = DataCube $ M.makeArray @D @Ix3 Seq (Sz (1 :> 2 :. 3)) sumIndex+ where+  sumIndex (d :> r :. c) = fromIntegral d + fromIntegral r + fromIntegral c

@@ -3,6 +3,7 @@ import Control.Monad.Catch (throwM) import Data.Text (Text) import Effectful+import Effectful.Error.Static import GHC.Generics import Skeletest import Skeletest.Predicate qualified as P@@ -51,9 +52,9 @@       toKeywordValue True `shouldBe` Logic T      it "should parseKeywordValue" $ do-      runPureEff (runParser (parseKeywordValue @Int $ Integer 23)) `shouldBe` Right 23-      runPureEff (runParser (parseKeywordValue @Text $ String "woot")) `shouldBe` Right "woot"-      runPureEff (runParser (parseKeywordValue @Bool $ Logic F)) `shouldBe` Right False+      runParserPure (parseKeywordValue @Int $ Integer 23) `shouldBe` Right 23+      runParserPure (parseKeywordValue @Text $ String "woot") `shouldBe` Right "woot"+      runParserPure (parseKeywordValue @Bool $ Logic F) `shouldBe` Right False    describe "ToHeader" $ do     it "should uppercase and snake keywords" $ do@@ -77,7 +78,7 @@   describe "FromHeader" $ do     it "should convert datatype" $ do       let h = toHeader (Test 40 "Alice")-      let et = runPureEff $ runParser $ parseHeader h+      let et = runParserPure $ parseHeader h       et `shouldSatisfy` P.right (P.con Test{age = P.eq 40})       et `shouldSatisfy` P.right (P.con Test{firstName = P.eq "Alice"}) @@ -112,9 +113,9 @@   wcsAY = WCSAxis (CType "Y") (CUnit "M") 4 5 6 :: WCSAxis 'A Y  -parseIO :: Eff '[Parser, IOE] a -> IO a+parseIO :: Eff '[Parser, Error ParseError, IOE] a -> IO a parseIO p = do-  res <- runEff $ runParser p+  res <- runEff $ runErrorNoCallStack @ParseError $ runParser p   case res of     Left e -> throwM e     Right a -> pure a

@@ -153,16 +153,16 @@    describe "renderOtherKeywords" $ do     it "should render comments" $ do-      let h = Header [Comment "hello world"]-      run (renderOtherKeywords h) `shouldBe` pad 80 "COMMENT hello world"+      let rs = [Comment "hello world"]+      run (renderRecords rs) `shouldBe` pad 80 "COMMENT hello world"      it "should render blanks" $ do-      let h = Header [BlankLine, Keyword (KeywordRecord "WOOT" (Integer 12345) Nothing)]-      run (renderOtherKeywords h) `shouldBe` headers ["", "WOOT    = " <> justify 20 "12345"]+      let rs = [BlankLine, Keyword (KeywordRecord "WOOT" (Integer 12345) Nothing)]+      run (renderRecords rs) `shouldBe` headers ["", "WOOT    = " <> justify 20 "12345"]      it "should render blanks between" $ do-      let h = Header [Comment "comment", BlankLine, Keyword (KeywordRecord "WOOT" (Integer 12345) Nothing)]-      run (renderOtherKeywords h) `shouldBe` headers ["COMMENT comment", "", "WOOT    = " <> justify 20 "12345"]+      let rs = [Comment "comment", BlankLine, Keyword (KeywordRecord "WOOT" (Integer 12345) Nothing)]+      run (renderRecords rs) `shouldBe` headers ["COMMENT comment", "", "WOOT    = " <> justify 20 "12345"]  where   runValue :: Value -> String   runValue = run . renderValue