packages feed

telescope (empty) → 0.2.0

raw patch · 44 files changed

+6060/−0 lines, 44 filesdep +basedep +binarydep +byte-order

Dependencies added: base, binary, byte-order, bytestring, casing, conduit, containers, effectful, exceptions, fits-parse, libyaml, massiv, megaparsec, resourcet-effectful, scientific, skeletest, telescope, text, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, Sean Hess++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sean Hess nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,12 @@++Telescope+=========+++[![Hackage](https://img.shields.io/hackage/v/telescope.svg&color=success)](https://hackage.haskell.org/package/telescope)++Haskell library to read and write Astronomical images from telescopes++* [FITS](https://fits.gsfc.nasa.gov/fits_standard.html) File Format+* [ASDF](https://asdf-standard.readthedocs.io/) File Format+
+ src/Telescope/Asdf.hs view
@@ -0,0 +1,35 @@+module Telescope.Asdf+  ( ToAsdf (..)+  , FromAsdf (..)+  , decodeM+  , decodeEither+  , decode+  , encodeM+  , encode+  , AsdfError+  , FromNDArray (..)+  , ToNDArray (..)+  , SchemaTag+  , Node (..)+  , Value (..)+  , Key+  , Object+  , fromValue+  , NDArrayData (..)+  , jsonPointer+  , jsonReference+  , JSONReference (..)+  , JSONPointer (..)+  , Anchor (..)+  , Parser+  , Asdf (..)+  )+where++import Telescope.Asdf.Class+import Telescope.Asdf.Core (Asdf (..))+import Telescope.Asdf.Encoding+import Telescope.Asdf.Error+import Telescope.Asdf.NDArray+import Telescope.Asdf.Node+
+ src/Telescope/Asdf/Class.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Asdf.Class where++import Data.List ((!?))+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Massiv.Array (Array, Prim)+import Data.Massiv.Array qualified as M+import Data.Scientific (fromFloatDigits, toRealFloat)+import Data.Text (Text, pack, unpack)+import Data.Time.Clock (UTCTime)+import Data.Time.Format.ISO8601+import Effectful+import Effectful.Fail+import GHC.Generics+import GHC.Int+import Telescope.Asdf.Encoding.File (BlockSource (..))+import Telescope.Asdf.NDArray+import Telescope.Asdf.Node+import Telescope.Data.Array+import Telescope.Data.Axes+import Telescope.Data.Binary+import Telescope.Data.Parser+++{- | Convert a type to an Asdf 'Value' or 'Node'. The generic instance will encode to an 'Object' with field names matching record selectors++> data Example = Example+>   { name :: Text+>   , age :: Int+>   , tags :: [Text]+>   }+>   deriving (Generic, ToAsdf)+>+> instance ToAsdf Example where+>   schema _ = "tag:example.org/schemas/example-1.0.0"+-}+class ToAsdf a where+  -- | Specify how an object encodes to a 'Value'+  --+  -- > instance User ToAsdf where+  -- >   toValue user =+  -- >     Object+  -- >       [ ("name", toNode user.name)+  -- >       , ("age", toNode user.age)+  -- >       ]+  toValue :: a -> Value+  default toValue :: (Generic a, GToObject (Rep a)) => a -> Value+  toValue a = Object $ gToObject (from a)+++  -- | Specify the schema for a type+  --+  -- > instance ToAsdf Unit where+  -- >   schema _ = "!unit/unit-1.0.0"+  schema :: a -> SchemaTag+  default schema :: a -> SchemaTag+  schema _ = mempty+++  -- | Specify that this node be saved as an anchor+  --+  -- > instance ToAsdf Config where+  -- >   anchor _ = Just "globalConfig"+  anchor :: a -> Maybe Anchor+  default anchor :: a -> Maybe Anchor+  anchor _ = Nothing+++  -- | Manually control all aspects of how this is converted to a 'Node'+  toNode :: a -> Node+  default toNode :: a -> Node+  toNode a = Node (schema a) (anchor a) $ toValue a+++{- | Parse an Asdf 'Value' or 'Node' into a type. The generic instance will decode an 'Object' with field names matching record selectors++> data Example = Example+>   { name :: Text+>   , age :: Int+>   , tags :: [Text]+>   }+>   deriving (Generic, FromAsdf)+-}+class FromAsdf a where+  -- | Specify how a type is parsed from a 'Value'+  --+  -- > instance FromAsdf Integer where+  -- >   parseValue = \case+  -- >     Integer n -> pure $ fromIntegral n+  -- >     node -> expected "Integer" node+  parseValue :: (Parser :> es) => Value -> Eff es a+  default parseValue :: (Generic a, GParseObject (Rep a), Parser :> es) => Value -> Eff es a+  parseValue (Object o) = to <$> gParseObject o+  parseValue val = expected "Object" val+++instance ToAsdf Int where+  toValue n = toValue (fromIntegral @Int @Int64 n)+instance FromAsdf Int where+  parseValue = fmap (fromIntegral @Int64 @Int) <$> parseValue+++instance ToAsdf Int8 where+  toValue n = Integer $ fromIntegral n+instance FromAsdf Int8 where+  parseValue = parseInteger+++instance ToAsdf Int16 where+  toValue n = Integer $ fromIntegral n+instance FromAsdf Int16 where+  parseValue = parseInteger+++instance ToAsdf Int32 where+  toValue n = Integer $ fromIntegral n+instance FromAsdf Int32 where+  parseValue = parseInteger+++instance ToAsdf Int64 where+  toValue n = Integer $ fromIntegral n+instance FromAsdf Int64 where+  parseValue = parseInteger+++instance ToAsdf Integer where+  toValue n = Integer $ fromIntegral n+instance FromAsdf Integer where+  parseValue = parseInteger+++instance ToAsdf Double where+  toValue n = Number $ fromFloatDigits n+instance FromAsdf Double where+  parseValue = \case+    Number n -> pure $ toRealFloat n+    node -> expected "Double" node+++instance ToAsdf Float where+  toValue n = Number $ fromFloatDigits n+instance FromAsdf Float where+  parseValue = \case+    Number n -> pure $ toRealFloat n+    node -> expected "Float" node+++parseInteger :: (Integral a, Parser :> es) => Value -> Eff es a+parseInteger = \case+  Integer n -> pure $ fromIntegral n+  node -> expected "Integer" node+++instance {-# OVERLAPPABLE #-} (FromAsdf a) => FromAsdf [a] where+  parseValue = \case+    Array ns -> mapM (parseNode @a) ns+    node -> expected "Array" node+instance {-# OVERLAPPABLE #-} (ToAsdf a) => ToAsdf [a] where+  toValue as = Array $ fmap toNode as+instance {-# OVERLAPPABLE #-} (FromAsdf a) => FromAsdf (NonEmpty a) where+  parseValue val = do+    as <- parseValue @[a] val+    case as of+      [] -> expected "NonEmpty List" val+      (a : rest) -> pure (a :| rest)+instance {-# OVERLAPPABLE #-} (ToAsdf a) => ToAsdf (NonEmpty a) where+  toValue as = toValue $ NE.toList as+++instance (ToAsdf a, ToAsdf b) => ToAsdf (a, b) where+  toValue (a, b) = Array [toNode a, toNode b]+instance (FromAsdf a, FromAsdf b) => FromAsdf (a, b) where+  parseValue = \case+    Array [n1, n2] -> do+      a <- parseValue n1.value+      b <- parseValue n2.value+      pure (a, b)+    node -> expected "[a, b]" node+++instance (ToAsdf a, ToAsdf b, ToAsdf c) => ToAsdf (a, b, c) where+  toValue (a, b, c) = Array [toNode a, toNode b, toNode c]+instance (FromAsdf a, FromAsdf b, FromAsdf c) => FromAsdf (a, b, c) where+  parseValue = \case+    Array [na, nb, nc] -> do+      a <- parseValue na.value+      b <- parseValue nb.value+      c <- parseValue nc.value+      pure (a, b, c)+    node -> expected "[a, b, c]" node+++instance (ToAsdf a, ToAsdf b, ToAsdf c, ToAsdf d) => ToAsdf (a, b, c, d) where+  toValue (a, b, c, d) = Array [toNode a, toNode b, toNode c, toNode d]+instance (FromAsdf a, FromAsdf b, FromAsdf c, FromAsdf d) => FromAsdf (a, b, c, d) where+  parseValue = \case+    Array [na, nb, nc, nd] -> do+      a <- parseValue na.value+      b <- parseValue nb.value+      c <- parseValue nc.value+      d <- parseValue nd.value+      pure (a, b, c, d)+    node -> expected "[a, b, c, d]" node+++-- they will always serialize to Array+instance FromAsdf [Text] where+  parseValue = parseAnyList+instance FromAsdf [Int] where+  parseValue = parseAnyList+instance FromAsdf [Int8] where+  parseValue = parseAnyList+instance FromAsdf [Int16] where+  parseValue = parseAnyList+instance FromAsdf [Int32] where+  parseValue = parseAnyList+instance FromAsdf [Int64] where+  parseValue = parseAnyList+instance FromAsdf [Double] where+  parseValue = parseAnyList+++-- | Flexibly parse lists from either Array or NDArray+parseAnyList :: (FromAsdf a, FromNDArray [a], Parser :> es) => Value -> Eff es [a]+parseAnyList = \case+  Array ns -> mapM parseNode ns+  NDArray dat -> fromNDArray dat+  node -> expected "[Double]" node+++instance (FromAsdf a) => FromAsdf (Maybe a) where+  parseValue = \case+    Null -> pure Nothing+    val -> Just <$> parseValue @a val+instance (ToAsdf a) => ToAsdf (Maybe a) where+  schema = maybe mempty schema+  anchor = maybe Nothing anchor+  toValue Nothing = Null+  toValue (Just a) = toValue a+++instance (BinaryValue a, Prim a, AxesIndex ix) => FromAsdf (Array M.D ix a) where+  parseValue = \case+    NDArray a -> fromNDArray a+    node -> expected "NDArray" node+instance (BinaryValue a, IsDataType a, Prim a, AxesIndex ix, PutArray ix) => ToAsdf (Array M.D ix a) where+  toValue as = NDArray $ ndArrayMassiv as+++instance ToAsdf Text where+  toValue = String+instance FromAsdf Text where+  parseValue = \case+    String t -> pure t+    node -> expected "Text" node+++instance ToAsdf String where+  toValue = String . pack+instance FromAsdf String where+  parseValue = \case+    String t -> pure $ unpack t+    node -> expected "Text" node+++instance ToAsdf Bool where+  toValue = Bool+instance FromAsdf Bool where+  parseValue = \case+    Bool b -> pure b+    node -> expected "Bool" node+++instance ToAsdf Value where+  toValue = id+instance FromAsdf Value where+  parseValue = pure+++instance ToAsdf Node where+  toValue (Node _ _ val) = val+instance FromAsdf Node where+  parseValue val = pure $ Node mempty Nothing val+++instance ToAsdf Tree where+  toValue (Tree o) = Object o+instance FromAsdf Tree where+  parseValue = \case+    Object o -> pure $ Tree o+    val -> expected "Object" val+++instance ToAsdf NDArrayData where+  toValue = NDArray+instance FromAsdf NDArrayData where+  parseValue = \case+    NDArray nda -> pure nda+    node -> expected "NDArray" node+++instance ToAsdf DataType where+  toValue Float64 = "float64"+  toValue Float32 = "float32"+  toValue Int64 = "int64"+  toValue Int32 = "int32"+  toValue Int16 = "int16"+  toValue Int8 = "int8"+  toValue Bool8 = "bool8"+  toValue (Ucs4 n) = Array ["ucs4", fromValue $ Integer $ fromIntegral n]+instance FromAsdf DataType where+  parseValue = \case+    String "float64" -> pure Float64+    String "float32" -> pure Float32+    String "int64" -> pure Int64+    String "int32" -> pure Int32+    String "int16" -> pure Int16+    String "int8" -> pure Int8+    String "bool8" -> pure Bool8+    Array ["ucs4", Node _ _ (Integer n)] -> pure $ Ucs4 $ fromIntegral n+    val -> expected "DataType" val+++instance ToAsdf ByteOrder where+  toValue = \case+    BigEndian -> "big"+    LittleEndian -> "little"+instance FromAsdf ByteOrder where+  parseValue = \case+    String "big" -> pure BigEndian+    String "little" -> pure LittleEndian+    node -> expected "ByteOrder" node+++instance ToAsdf (Axes Row) where+  toValue (Axes as) = toValue as+++instance ToAsdf BlockSource where+  toValue (BlockSource s) = toValue s+++instance ToAsdf UTCTime where+  toValue t = String $ pack $ iso8601Show t+instance FromAsdf UTCTime where+  parseValue v = do+    ts <- parseValue @String v+    res <- runFail $ iso8601ParseM ts+    case res of+      Left e -> parseFail e+      Right a -> pure a+++-- | Parse a node, ignoring the schema tag+parseNode :: (FromAsdf a, Parser :> es) => Node -> Eff es a+parseNode (Node _ _ v) = parseValue v+++{- | Parse a key from an 'Object'++> instance FromAsdf User where+>   parseValue = \case+>     Object o -> do+>       name <- o .: "name"+>       age <- o .: "age"+>       pure $ User{name, age}+-}+(.:) :: (FromAsdf a, Parser :> es) => Object -> Key -> Eff es a+o .: k = do+  case lookup k o of+    Nothing -> parseFail $ "key " ++ show k ++ " not found"+    Just node ->+      parseAt (Child k) $ parseNode node+++-- | Parse an optional key from an 'Object'+(.:?) :: (FromAsdf a, Parser :> es) => Object -> Key -> Eff es (Maybe a)+o .:? k = do+  case lookup k o of+    Nothing -> pure Nothing+    Just a ->+      Just <$> do+        parseAt (Child k) $ parseNode a+++{- | Parse a child at the given array index+ -+> instance FromAsdf Friends where+>   parseValue = \case+>     Array ns -> do+>       best <- ns ! 0+>       second <- ns ! 1+>       other <- mapM parseNode ns+>       pure $ Friends{best, second, other}+-}+(!) :: (FromAsdf a, Parser :> es) => [Node] -> Int -> Eff es a+ns ! n = do+  case ns !? n of+    Nothing -> parseFail $ "Index " ++ show n ++ " not found"+    Just node ->+      parseAt (Index n) $ parseNode node+++-- | Generically serialize records to an 'Object'+class GToObject f where+  gToObject :: f p -> Object+++instance (GToObject f) => GToObject (M1 D c f) where+  gToObject (M1 f) = gToObject f+++instance (GToObject f) => GToObject (M1 C c f) where+  gToObject (M1 f) = gToObject f+++instance (GToObject f, GToObject g) => GToObject (f :*: g) where+  gToObject (f :*: g) = gToObject f <> gToObject g+++instance (GToNode f, Selector s) => GToObject (M1 S s f) where+  gToObject (M1 f) =+    let s = selName (undefined :: M1 S s f p)+     in [(pack s, gToNode f)]+++-- | Generically serialize record values to a 'Node'+class GToNode f where+  gToNode :: f p -> Node+++instance {-# OVERLAPPABLE #-} (ToAsdf a) => GToNode (K1 R a) where+  gToNode (K1 a) = toNode a+++instance {-# OVERLAPPING #-} (ToAsdf a) => GToNode (K1 R (Maybe a)) where+  gToNode (K1 a) = toNode a+++-- | Generically parse 'Object's into records+class GParseObject f where+  gParseObject :: (Parser :> es) => Object -> Eff es (f p)+++instance (GParseObject f) => GParseObject (M1 D c f) where+  gParseObject o = M1 <$> gParseObject o+++instance (GParseObject f) => GParseObject (M1 C c f) where+  gParseObject o = M1 <$> gParseObject o+++instance (GParseObject f, GParseObject g) => GParseObject (f :*: g) where+  gParseObject o = do+    f <- gParseObject o+    g <- gParseObject o+    pure $ f :*: g+++instance (GParseKey f, Selector s) => GParseObject (M1 S s f) where+  gParseObject o = do+    let k = pack $ selName (undefined :: M1 S s f p)+    M1 <$> gParseKey o k+++-- | Generically parse a key from an 'Object' into a record value+class GParseKey f where+  gParseKey :: (Parser :> es) => Object -> Key -> Eff es (f p)+++instance {-# OVERLAPPABLE #-} (FromAsdf a) => GParseKey (K1 R a) where+  gParseKey o k = K1 <$> o .: k+++instance {-# OVERLAPPABLE #-} (FromAsdf a) => GParseKey (K1 R (Maybe a)) where+  gParseKey o k = K1 <$> o .:? k
+ src/Telescope/Asdf/Core.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedLists #-}++module Telescope.Asdf.Core where++import Data.String (fromString)+import Data.Text (Text)+import Data.Version (showVersion)+import Effectful+import Effectful.Error.Static+import GHC.Generics (Generic)+import Paths_telescope (version)+import Telescope.Asdf.Class+import Telescope.Asdf.Error (AsdfError (..))+import Telescope.Asdf.Node+import Telescope.Data.Parser (expected)+++{- | VOUnit: https://www.ivoa.net/documents/VOUnits/20231215/REC-VOUnits-1.1.html+ -+Unrecognised units should be accepted by parsers, as long as they are parsed giving preference to the syntaxes and prefixes described here.+-}+data Unit+  = Count+  | Pixel+  | Degrees+  | Nanometers+  | Unit Text+  deriving (Eq)+++instance ToAsdf Unit where+  schema _ = "!unit/unit-1.0.0"+  toValue = \case+    Count -> "count"+    Pixel -> "pixel"+    Degrees -> "deg"+    Nanometers -> "nm"+    (Unit t) -> String t+instance FromAsdf Unit where+  parseValue = \case+    String "count" -> pure Count+    String "deg" -> pure Degrees+    String "pixel" -> pure Pixel+    String "pix" -> pure Pixel+    String "nm" -> pure Nanometers+    String t -> pure $ Unit t+    val -> expected "String" val+++-- | Tag a value with a 'Unit'+data Quantity = Quantity+  { unit :: Unit+  , value :: Value+  }+  deriving (Generic)+++instance ToAsdf Quantity where+  schema _ = "!unit/quantity-1.1.0"+instance FromAsdf Quantity+++--+-- -- TEST: this is probably index dependent+-- data BoundingBox = BoundingBox Double Double+--+--+-- instance ToAsdf BoundingBox where+--   toValue (BoundingBox a b) =+--     Array+--       [ toNode $ Quantity Pixel (toValue a)+--       , toNode $ Quantity Pixel (toValue b)+--       ]+--+--+-- instance FromAsdf BoundingBox where+--   parseValue = \case+--     Array [n1, n2] -> do+--       BoundingBox <$> parseNode n1 <*> parseNode n2+--     node -> expected "BoundingBox" node++-- | Required Software node at the top-level+data Software = Software+  { author :: Maybe Text+  , homepage :: Maybe Text+  , name :: Text+  , version :: Text+  }+  deriving (Show, Eq, Generic, FromAsdf)+++instance ToAsdf Software where+  schema _ = "!core/software-1.0.0"+++-- | Root ASDF node+data Asdf = Asdf+  { history :: History+  , library :: Software+  , tree :: Tree+  }+++instance ToAsdf Asdf where+  schema _ = "!core/asdf-1.1.0"+  toValue a =+    let Tree tree = a.tree+     in -- these two required fields are first, then merge keys from the tree+        Object $+          [ ("asdf_library", toNode a.library)+          , ("history", toNode a.history)+          ]+            <> tree+instance FromAsdf Asdf where+  parseValue = \case+    Object o -> do+      library <- o .: "asdf_library"+      history <- o .: "history"+      let tree = Tree $ filter (not . isLibraryField) o+      pure $ Asdf{history, library, tree}+    val -> expected "Asdf" val+   where+    isLibraryField ("asdf_library", _) = True+    isLibraryField ("history", _) = True+    isLibraryField _ = False+++-- | Convert any ToAsdf into a raw Asdf document+toAsdfDoc :: (ToAsdf a, Error AsdfError :> es) => a -> Eff es Asdf+toAsdfDoc a =+  case toValue a of+    Object o -> do+      let history = History []+      let library = telescopeLibrary+      pure $ Asdf{history, library, tree = Tree o}+    value -> throwError $ EncodeError $ "Expected Top-level Tree Object, but got: " ++ show value+ where+  telescopeLibrary :: Software+  telescopeLibrary =+    Software+      { author = Just "DKIST Data Center"+      , homepage = Just "https://github.com/dkistdc/telescope.hs"+      , name = "telescope.hs"+      , version = fromString $ showVersion version+      }+++data History = History+  { extensions :: [ExtensionMetadata]+  }+  deriving (Show, Generic, FromAsdf, ToAsdf)+++data ExtensionMetadata = ExtensionMetadata+  { extension_class :: Text+  , software :: Software+  }+  deriving (Show, Generic, FromAsdf)+instance ToAsdf ExtensionMetadata where+  schema _ = "!core/extension_metadata-1.0.0"
+ src/Telescope/Asdf/Encoding.hs view
@@ -0,0 +1,122 @@+module Telescope.Asdf.Encoding where++import Conduit+import Data.Binary.Get+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BL+import Data.Function ((&))+import Effectful+import Effectful.Error.Static+import Effectful.Reader.Dynamic+import Effectful.Resource+import Effectful.State.Static.Local+import Telescope.Asdf.Class+import Telescope.Asdf.Core+import Telescope.Asdf.Encoding.File+import Telescope.Asdf.Encoding.Stream+import Telescope.Asdf.Error+import Telescope.Asdf.Node+import Telescope.Data.Parser (ParseError, runParser)+import Text.Libyaml qualified as Yaml+++-- | Encode a 'ToAsdf' to a 'ByteString'+encodeM :: (ToAsdf a, MonadIO m, MonadThrow m) => a -> m ByteString+encodeM a = runAsdfM $ encode a+++-- | Encode a 'ToAsdf' to a 'ByteString'+encode :: (ToAsdf a, IOE :> es, Error AsdfError :> es) => a -> Eff es ByteString+encode a = do+  asdf <- toAsdfDoc a+  file <- encodeAsdf asdf+  pure $ concatAsdfFile file+++-- | Encode an 'Asdf' document to a 'ByteString'+encodeAsdf :: (IOE :> es, Error AsdfError :> es) => Asdf -> Eff es AsdfFile+encodeAsdf a = do+  (doc, bds) <- encodeNode (toNode a)+  let tree = encodeTree doc+  let blocks = fmap encodeBlock bds+  let index = encodeIndex $ blockIndex tree blocks+  pure $ AsdfFile{tree, blocks, index}+++-- | Low-level encoding of a node to a Yaml tree, without required headers, etc+encodeNode :: (IOE :> es, Error AsdfError :> es) => Node -> Eff es (ByteString, [BlockData])+encodeNode node = do+  runYamlError $ encodeStream (yieldDocumentStream $ yieldNode node)+++-- | Create a stream of yaml events+encodeStream :: (IOE :> es, Error AsdfError :> es) => ConduitT () Yaml.Event (Eff (State Anchors : State [BlockData] : Resource : es)) () -> Eff es (ByteString, [BlockData])+encodeStream con = do+  runStream $ con .| Yaml.encodeWith format+ where+  format =+    Yaml.defaultFormatOptions+      & Yaml.setTagRendering Yaml.renderUriTags+      & Yaml.setWidth (Just 100)+++-- | Decode a 'ByteString' to a 'FromAsdf'+decodeM :: (FromAsdf a, MonadIO m, MonadThrow m) => ByteString -> m a+decodeM bs = runAsdfM $ decode bs+++-- | Decode a 'ByteString' to a 'FromAsdf'+decodeEither :: forall a m. (FromAsdf a, MonadIO m) => ByteString -> m (Either String a)+decodeEither bs = do+  res <- liftIO $ runEff $ runErrorNoCallStack @AsdfError $ decode @a bs+  pure $ either (Left . show) Right res+++-- | Decode a 'ByteString' to a 'FromAsdf'+decode :: (FromAsdf a, IOE :> es, Error AsdfError :> es) => ByteString -> Eff es a+decode bs = do+  f <- splitAsdfFile bs+  tree <- parseAsdfTree f.tree f.blocks+  decodeFromTree tree+++-- | Decode a 'Tree' to a 'FromAsdf'+decodeFromTree :: forall a es. (Error AsdfError :> es) => (FromAsdf a) => Tree -> Eff es a+decodeFromTree (Tree o) = do+  runParseError $ runParser $ parseValue @a (Object o)+++-- | Parse the asdf file parts into a 'Tree'+parseAsdfTree :: (Error AsdfError :> es, IOE :> es) => Encoded Tree -> [Encoded Block] -> Eff es Tree+parseAsdfTree etree eblks = do+  (root, _) <- streamAsdfFile etree eblks+  pure $ Tree root+++streamAsdfFile :: (Error AsdfError :> es, IOE :> es) => Encoded Tree -> [Encoded Block] -> Eff es (Object, Anchors)+streamAsdfFile (Encoded inp) ebks = do+  blocks <- mapM decodeBlock ebks+  runParseError . runYamlError $ do+    runReader blocks . runState @Anchors mempty . runResource . runConduit $ Yaml.decode inp .| sinkTree+++decodeBlock :: (Error AsdfError :> es) => Encoded Block -> Eff es BlockData+decodeBlock (Encoded blk) = do+  case runGetOrFail getBlock (BL.fromStrict blk) of+    Left (_, num, err) -> throwError $ BlockError $ "at " ++ show num ++ ": " ++ err+    Right ("", _, b) -> pure b+    Right (rest, _, _) -> throwError $ BlockError $ "Unused bytes: " ++ show rest+++-- | Decode the BlockIndex+decodeBlockIndex :: (Error AsdfError :> es, IOE :> es) => ByteString -> Eff es BlockIndex+decodeBlockIndex inp =+  runYamlError . runResource . runConduit $ Yaml.decode inp .| sinkIndex+++runYamlError :: (Error AsdfError :> es) => Eff (Error YamlError : es) a -> Eff es a+runYamlError = runErrorNoCallStackWith @YamlError (throwError . YamlError . show)+++runParseError :: (Error AsdfError :> es) => Eff (Error ParseError : es) a -> Eff es a+runParseError = runErrorNoCallStackWith @ParseError (throwError . ParseError . show)
+ src/Telescope/Asdf/Encoding/File.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE RecordWildCards #-}++module Telescope.Asdf.Encoding.File where++import Control.Monad (replicateM_)+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BC+import Data.ByteString.Lazy qualified as BL+import Data.String (IsString)+import Data.Word+import Effectful+import Effectful.Error.Static+import Effectful.Fail+import Effectful.NonDet+import Effectful.State.Static.Local+import Telescope.Asdf.Error+import Telescope.Asdf.Node (Tree)+++-- | Split an encoded 'ByteString' into a 'Tree', '[Encoded Block]' and 'Encoded Index'+splitAsdfFile :: (Error AsdfError :> es) => ByteString -> Eff es AsdfFile+splitAsdfFile dat = do+  res <- runFail $ evalState dat parseAsdfFile+  case res of+    Left e -> throwError $ ParseError e+    Right a -> pure a+++-- | Lightweight first-pass parsing using 'State ByteString' instead of Parsec or similar+parseAsdfFile :: (State ByteString :> es, Fail :> es) => Eff es AsdfFile+parseAsdfFile = do+  -- if it's empty, then give an error+  tree <- onEmpty "tree" parseTree+  blocks <- onEmpty "blocks" parseBlocks+  index <- parseIndex+  pure $ AsdfFile{tree, blocks, index}+ where+  onEmpty ex eff = do+    res <- runNonDet OnEmptyKeep eff+    case res of+      Left _ -> do+        inp <- get @ByteString+        fail $ "Expected " ++ ex ++ " at " ++ show (BS.take 100 inp)+      Right a -> pure a+++parseTree :: (State ByteString :> es, NonDet :> es) => Eff es (Encoded Tree)+parseTree = do+  t <- parseUntil blockMagicToken <|> parseUntil blockIndexHeader <|> remainingBytes+  pure $ Encoded t+++parseIndex :: (State ByteString :> es) => Eff es (Encoded Index)+parseIndex =+  Encoded <$> get+++parseBlocks :: (State ByteString :> es, NonDet :> es) => Eff es [Encoded Block]+parseBlocks = many parseBlock+++parseBlock :: (State ByteString :> es, NonDet :> es) => Eff es (Encoded Block)+parseBlock = do+  exactly blockMagicToken+  b <- parseUntil blockMagicToken <|> parseUntil blockIndexHeader <|> nonEmpty+  case b of+    "" -> empty+    _ -> pure $ Encoded $ blockMagicToken <> b+++exactly :: (State ByteString :> es, NonDet :> es) => ByteString -> Eff es ()+exactly val = do+  inp <- get @ByteString+  if val `BS.isPrefixOf` inp+    then do+      put $ BS.drop (BS.length val) inp+      pure ()+    else empty+++parseUntil :: (State ByteString :> es, NonDet :> es) => ByteString -> Eff es ByteString+parseUntil val = do+  inp <- get @ByteString+  let (before, rest) = BS.breakSubstring val inp+  case rest of+    "" -> empty+    _ -> do+      put rest+      pure before+++nonEmpty :: (NonDet :> es, State ByteString :> es) => Eff es ByteString+nonEmpty = do+  b <- remainingBytes+  case b of+    "" -> empty+    _ -> pure b+++remainingBytes :: (NonDet :> es, State ByteString :> es) => Eff es ByteString+remainingBytes = do+  inp <- get+  put @ByteString ""+  pure inp+++breakIndex :: (State ByteString :> es) => Eff es (Encoded Index)+breakIndex = Encoded <$> get+++concatAsdfFile :: AsdfFile -> ByteString+concatAsdfFile a =+  mconcat [a.tree.bytes, blocks a.blocks, index a.index]+ where+  blocks :: [Encoded Block] -> ByteString+  blocks ebks = mconcat $ fmap (.bytes) ebks+  -- case mconcat $ fmap (.bytes) ebks of+  --   "" -> ""+  --   s -> s <> "\n"+  index ix = ix.bytes+++encodeTree :: ByteString -> Encoded Tree+encodeTree tr =+  Encoded $ BS.intercalate "\n" (headers <> formatDoc tr) <> "\n" -- has a trailing newline+ where+  formatDoc doc = ["--- " <> doc, "..."]+  headers = ["#ASDF 1.0.0", "#ASDF_STANDARD 1.5.0", "%YAML 1.1", tagDirective]+  tagDirective = "%TAG ! tag:stsci.edu:asdf/"+++encodeBlocks :: [BlockData] -> [Encoded Block]+encodeBlocks = fmap encodeBlock+++encodeBlock :: BlockData -> Encoded Block+encodeBlock b =+  Encoded $ BL.toStrict $ runPut $ putBlock b+++encodeIndex :: BlockIndex -> Encoded Index+encodeIndex (BlockIndex ns) =+  Encoded $ BS.intercalate "\n" $ ["#ASDF BLOCK INDEX", "%YAML 1.1", "---"] <> fmap indexEntry ns <> ["..."]+ where+  indexEntry n = "- " <> BC.pack (show n)+++data Index+data Block+++-- | values that have been encoded to the file format: padding, etc+newtype Encoded a = Encoded {bytes :: ByteString}+  deriving (Show, Eq)+  deriving newtype (IsString)+++-- | Decompressed block data+newtype BlockData = BlockData {bytes :: ByteString}+  deriving (Eq)+++newtype BlockSource = BlockSource Int+  deriving (Eq)+++instance Show BlockData where+  show (BlockData bs) = "BlockData " <> show (BS.length bs)+++data BlockHeader = BlockHeader+  { headerSize :: Word16+  , flags :: Word32+  , compression :: Compression+  , allocatedSize :: Word64+  , usedSize :: Word64+  , dataSize :: Word64+  , checksum :: Checksum+  }+  deriving (Show, Eq)+++newtype BlockIndex = BlockIndex [Int]+  deriving (Eq)+++data Compression+  = NoCompression -- "\0\0\0\0"+  | ZLib -- "zlib"+  | BZip2 -- "bzp2"+  deriving (Show, Eq)+++newtype Checksum = Checksum ByteString+  deriving (Show, Eq)+++noChecksum :: Checksum+noChecksum = Checksum $ BC.replicate 16 '0'+++data AsdfFile = AsdfFile+  { tree :: Encoded Tree+  , blocks :: [Encoded Block]+  , index :: Encoded Index+  }+  deriving (Show, Eq)+++getBlock :: Get BlockData+getBlock = do+  h <- getBlockHeader+  getBlockData h+++-- | Skip along blocks and create a list of all of them+getBlocks :: Get [BlockData]+getBlocks = do+  isBlock <- checkMagicToken+  if not isBlock+    then pure []+    else do+      b <- getBlock+      bs <- getBlocks+      pure (b : bs)+++getBlockHeader :: Get BlockHeader+getBlockHeader = do+  expectMagicToken+  headerSize <- label "header_size" getWord16be+  start <- bytesRead++  -- the remainder is inside the headerSize+  flags <- label "flags" getWord32be -- 4+  compression <- label "compression" getCompression -- 4+  allocatedSize <- label "allocated_size" getWord64be -- 8+  usedSize <- label "used_size" getWord64be -- 8+  dataSize <- label "data_size" getWord64be -- 8+  checksum <- label "checksum" getChecksum -- 2+  end <- bytesRead++  -- skip until the end of headerSize+  let usedHead = fromIntegral $ end - start+  skip $ fromIntegral headerSize - usedHead++  pure $ BlockHeader{..}+ where+  getCompression = do+    val <- getByteString 4+    case val of+      "\0\0\0\0" -> pure NoCompression+      -- "zlib" -> pure ZLib+      -- "bzp2" -> pure BZip2+      _ -> fail $ "BlockHeader compression invalid, found " <> show val++  getChecksum = Checksum <$> getByteString 16++  expectMagicToken = do+    m <- getMagicToken+    case m of+      Right a -> pure a+      Left str -> fail $ "BlockHeader magic token invalid: " ++ show str+++putBlockHeader :: BlockHeader -> Put+putBlockHeader h = do+  putByteString blockMagicToken+  putWord16be h.headerSize+  size <- putHeaderContent+  let emptyBytes = fromIntegral h.headerSize - size :: Int+  replicateM_ emptyBytes $ putWord8 0x0+ where+  putCompression _ = putByteString "\0\0\0\0"+  putChecksum (Checksum cs) = putByteString cs+  putHeaderContent = do+    let bs = runPut $ do+          putWord32be 0 -- flags+          putCompression NoCompression+          putWord64be h.allocatedSize+          putWord64be h.usedSize+          putWord64be h.dataSize+          putChecksum h.checksum+    putLazyByteString bs+    pure $ fromIntegral $ BL.length bs+++blockIndex :: Encoded Tree -> [Encoded Block] -> BlockIndex+blockIndex (Encoded bytes) ebs =+  let ns = scanl go (BS.length bytes) ebs+   in BlockIndex $ take (length ns - 1) ns+ where+  go :: Int -> Encoded Block -> Int+  go n eb = n + BS.length eb.bytes+++putBlock :: BlockData -> Put+putBlock bd@(BlockData bs) = do+  putBlockHeader $ blockHeader bd+  putByteString bs+++blockHeader :: BlockData -> BlockHeader+blockHeader (BlockData bs) =+  let bytes = fromIntegral $ BS.length bs+   in BlockHeader+        { headerSize = 48 -- minimum allowed size. Our encoding uses fewer bytes than this+        , compression = NoCompression+        , allocatedSize = bytes+        , usedSize = bytes+        , dataSize = bytes+        , checksum = noChecksum+        , flags = 0+        }+++getBlockData :: BlockHeader -> Get BlockData+getBlockData h = do+  -- LATER: handle compression+  bytes <- getByteString $ fromIntegral h.usedSize+  _empty <- getByteString $ fromIntegral $ h.allocatedSize - h.usedSize+  pure $ BlockData bytes+++blockMagicToken :: ByteString+blockMagicToken = BS.pack [0xd3, 0x42, 0x4c, 0x4b]+++blockIndexHeader :: ByteString+blockIndexHeader = "#ASDF BLOCK INDEX"+++-- | Verify that the magic token is next without consuming any input+checkMagicToken :: Get Bool+checkMagicToken = do+  emp <- isEmpty+  if emp+    then pure False+    else do+      eb <- lookAhead getMagicToken+      pure $ either (const False) (const True) eb+++-- | consume the magic token if available+getMagicToken :: Get (Either ByteString ())+getMagicToken = do+  -- this still fails if it is empty+  str <- getByteString 4+  pure $+    if str == blockMagicToken+      then Right ()+      else Left str
+ src/Telescope/Asdf/Encoding/Stream.hs view
@@ -0,0 +1,409 @@+module Telescope.Asdf.Encoding.Stream where++import Conduit+import Data.ByteString (ByteString)+import Data.Conduit.Combinators (peek)+import Data.Conduit.Combinators qualified as C+import Data.List ((!?))+import Data.String (fromString)+import Data.Text (pack, unpack)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8)+import Data.Text.Encoding qualified as T+import Effectful+import Effectful.Error.Static+import Effectful.NonDet+import Effectful.Reader.Dynamic+import Effectful.Resource+import Effectful.State.Static.Local+import Telescope.Asdf.Class hiding (anchor)+import Telescope.Asdf.Encoding.File+import Telescope.Asdf.NDArray (NDArrayData (..))+import Telescope.Asdf.Node+import Telescope.Data.Axes+import Telescope.Data.Parser (runPureParser)+import Text.Libyaml (Event (..), MappingStyle (..), SequenceStyle (..), Style (..), Tag (..))+import Text.Libyaml qualified as Yaml+import Text.Read (readMaybe)+++runStream :: (IOE :> es) => ConduitT () Void (Eff (State Anchors : State [BlockData] : Resource : es)) a -> Eff es (a, [BlockData])+runStream con = do+  runResource . runState @[BlockData] [] . evalState @Anchors mempty . runConduit $ con+++runStreamList :: (IOE :> es) => ConduitT () Event (Eff (State Anchors : State [BlockData] : Resource : es)) () -> Eff es [Event]+runStreamList con = do+  (res, _) <- runStream $ con .| sinkList+  pure res+++yieldDocumentStream :: (State [BlockData] :> es, IOE :> es) => ConduitT a Event (Eff es) () -> ConduitT a Event (Eff es) ()+yieldDocumentStream content = do+  yield EventStreamStart+  yield EventDocumentStart+  content+  yield EventDocumentEnd+  yield EventStreamEnd+++yieldNode :: forall es a. (IOE :> es, State [BlockData] :> es, State Anchors :> es, Error YamlError :> es) => Node -> ConduitT a Event (Eff es) ()+yieldNode node@(Node st anc val) = do+  lift $ addNodeAnchor node+  yieldValue val+ where+  yieldValue = \case+    Object o -> yieldObject o+    Array a -> yieldArray a+    String "" -> yieldEmptyString+    String s -> yieldScalar (T.encodeUtf8 s)+    Integer n -> yieldNum n+    NDArray nd -> yieldNDArray nd+    Bool b -> yieldBool b+    Number n -> yieldNum n+    Null -> yieldScalar "~"+    Reference r -> yieldObject [("$ref", toNode $ String (pack $ show r))]+    Alias a -> yieldAlias a++  anchor :: Yaml.Anchor+  anchor =+    case anc of+      Nothing -> Nothing+      (Just (Anchor a)) -> pure (unpack a)++  tag = case st of+    SchemaTag Nothing -> NoTag+    SchemaTag (Just s) -> UriTag (unpack s)++  yieldScalar s = yield $ EventScalar s tag Plain anchor+  yieldEmptyString = yield $ EventScalar "" tag SingleQuoted anchor++  yieldAlias (Anchor a) = do+    _ <- lift $ resolveAnchor (Anchor a)+    yield $ EventAlias (unpack a)++  yieldNum :: (Num n, Show n) => n -> ConduitT a Event (Eff es) ()+  yieldNum n = yieldScalar (T.encodeUtf8 $ pack $ show n)++  yieldBool = \case+    True -> yieldScalar "true"+    False -> yieldScalar "false"++  yieldObject :: [(Key, Node)] -> ConduitT a Event (Eff es) ()+  yieldObject o = do+    yield $ EventMappingStart tag blockStyle anchor+    mapM_ yieldMapping o+    yield EventMappingEnd+   where+    blockStyle+      | any (isComplexNode . snd) o = BlockMapping+      | otherwise = FlowMapping++  yieldMapping :: (Key, Node) -> ConduitT a Event (Eff es) ()+  yieldMapping (key, nd) = do+    yield $ EventScalar (T.encodeUtf8 key) NoTag Plain Nothing+    yieldNode nd++  yieldArray :: [Node] -> ConduitT a Event (Eff es) ()+  yieldArray ns = do+    yield $ EventSequenceStart tag seqStyle anchor+    mapM_ yieldNode ns+    yield EventSequenceEnd+   where+    seqStyle+      | any isComplexNode ns = BlockSequence+      | otherwise = FlowSequence++  yieldNDArray :: NDArrayData -> ConduitT a Event (Eff es) ()+  yieldNDArray nd = do+    src <- lift $ addBlock nd.bytes+    yield $ EventMappingStart (UriTag "!core/ndarray-1.0.0") FlowMapping anchor+    yieldMapping ("source", toNode src)+    yieldMapping ("datatype", toNode nd.datatype)+    yieldMapping ("shape", toNode nd.shape)+    yieldMapping ("byteorder", toNode nd.byteorder)+    yield EventMappingEnd+++addBlock :: (State [BlockData] :> es) => ByteString -> Eff es BlockSource+addBlock bytes = do+  blocks <- get @[BlockData]+  put $ blocks <> [BlockData bytes]+  pure $ BlockSource $ length blocks+++isComplexNode :: Node -> Bool+isComplexNode (Node _ _ val) = isComplex val+ where+  isComplex = \case+    Array _ -> True+    Object _ -> True+    NDArray _ -> True+    _ -> False+++sinkTree :: (Error YamlError :> es, State Anchors :> es, Reader [BlockData] :> es) => ConduitT Yaml.Event o (Eff es) Object+sinkTree = do+  expect EventStreamStart+  expect EventDocumentStart+  Node _ _ v <- sinkNode+  case v of+    Object o -> pure o+    _ -> lift $ throwError $ InvalidTree "Expected Object" v+++sinkNode :: (Error YamlError :> es, State Anchors :> es, Reader [BlockData] :> es) => ConduitT Yaml.Event o (Eff es) Node+sinkNode = do+  e <- event+  node <- sinkByEvent e+  lift $ addNodeAnchor node+  pure node+ where+  sinkByEvent = \case+    EventScalar s t _ a ->+      lift $ parseScalar (fromString <$> a) s t+    EventMappingStart tg _ a -> do+      let stag = parseSchemaTag tg+      maps <- sinkMappings+      val <- lift $ fromMappings stag maps+      pure $ Node stag (fromString <$> a) val+    EventSequenceStart tg _ a -> do+      ns <- sinkSequence+      pure $ Node (parseSchemaTag tg) (fromString <$> a) $ Array ns+    EventAlias a -> do+      val <- lift $ resolveAnchor (Anchor $ pack a)+      pure $ Node mempty Nothing val+    ev -> lift $ throwError $ ExpectedEvent "Not Handled" ev++  fromMappings :: forall es. (Error YamlError :> es, Reader [BlockData] :> es) => SchemaTag -> [(Key, Node)] -> Eff es Value+  fromMappings stag maps = do+    res <- runNonDet OnEmptyKeep (tryNDArray stag maps <|> tryReference maps) :: Eff es (Either CallStack Value)+    case res of+      Left _ -> pure $ Object maps+      Right val -> pure val++  tryNDArray :: (NonDet :> es, Error YamlError :> es, Reader [BlockData] :> es) => SchemaTag -> [(Key, Node)] -> Eff es Value+  tryNDArray stag maps+    | isNDArray stag = NDArray <$> ndArrayDataFromMaps maps+    | otherwise = empty++  tryReference :: (NonDet :> es, Error YamlError :> es) => [(Key, Node)] -> Eff es Value+  tryReference maps = do+    case lookup "$ref" maps of+      Nothing -> empty+      Just (Node _ _ (String s)) -> pure $ Reference $ jsonReference s+      Just (Node _ _ value) -> throwError $ InvalidReference value+++resolveAnchor :: (State Anchors :> es, Error YamlError :> es) => Anchor -> Eff es Value+resolveAnchor anc = do+  Anchors anchors <- get @Anchors+  case lookup anc anchors of+    Nothing -> throwError $ AnchorUndefined anc (fmap fst anchors)+    Just v -> pure v+++ndArrayDataFromMaps :: forall es. (Error YamlError :> es, Reader [BlockData] :> es) => [(Key, Node)] -> Eff es NDArrayData+ndArrayDataFromMaps maps = do+  bytes <- require "source" >>= findSource+  datatype <- require "datatype" >>= parseDatatype+  byteorder <- require "byteorder" >>= parseByteorder+  shape <- require "shape" >>= parseShape+  pure $ NDArrayData{bytes, datatype, byteorder, shape}+ where+  require key =+    case lookup key maps of+      Nothing -> throwError $ NDArrayMissingKey (unpack key)+      Just (Node _ _ val) -> pure val++  parseDatatype = parseLocal "DataType"+  parseByteorder = parseLocal "ByteOrder"+  parseShape val =+    case val of+      Array ns -> axesRowMajor <$> mapM (parseAxis . (.value)) ns+      _ -> throwError $ NDArrayExpected "Shape" val++  parseAxis val =+    case val of+      Integer n -> pure $ fromIntegral n+      _ -> throwError $ NDArrayExpected "Shape Axis" val++  findSource val =+    case val of+      Integer s -> do+        blocks <- ask+        case blocks !? fromIntegral s of+          Nothing -> throwError $ NDArrayMissingBlock s+          Just (BlockData b) -> pure b+      _ -> throwError $ NDArrayExpected "Source" val++  parseLocal :: (FromAsdf a, Error YamlError :> es) => String -> Value -> Eff es a+  parseLocal expected val =+    case runPureParser . runReader @Anchors mempty $ parseValue val of+      Left _ -> throwError $ NDArrayExpected expected val+      Right a -> pure a+++sinkMapping :: (Error YamlError :> es, Reader [BlockData] :> es, State Anchors :> es) => ConduitT Event o (Eff es) (Key, Node)+sinkMapping = do+  k <- sinkMapKey+  v <- sinkNode+  pure (k, v)+ where+  sinkMapKey =+    event >>= \case+      EventScalar s _ _ _ -> pure $ decodeUtf8 s+      ev -> lift $ throwError $ ExpectedEvent "Scalar Key" ev+++-- we don't have to parse this into an object...+sinkMappings :: (Error YamlError :> es, State Anchors :> es, Reader [BlockData] :> es) => ConduitT Event o (Eff es) [(Key, Node)]+sinkMappings = do+  sinkWhile (/= EventMappingEnd) sinkMapping+++-- oh, the event mapping ends aren't being consumed!+sinkWhile :: (Event -> Bool) -> ConduitT Event o (Eff es) a -> ConduitT Event o (Eff es) [a]+sinkWhile p parse = do+  e <- peek+  if maybe False p e+    then do+      a <- parse+      as <- sinkWhile p parse+      pure $ a : as+    else do+      -- consume the one we matched+      C.drop 1+      pure []+++sinkSequence :: (Error YamlError :> es, State Anchors :> es, Reader [BlockData] :> es) => ConduitT Event o (Eff es) [Node]+sinkSequence = do+  sinkWhile (/= EventSequenceEnd) sinkNode+++parseScalar :: (Error YamlError :> es) => Maybe Anchor -> ByteString -> Yaml.Tag -> Eff es Node+parseScalar ma inp tg = byTag tg+ where+  byTag :: (Error YamlError :> es) => Yaml.Tag -> Eff es Node+  byTag = \case+    UriTag s -> throwEmpty "Any" $ Node (schemaTag s) ma <$> parseMulti inp+    other -> do+      val <- nonUriTagValue other+      pure $ Node mempty ma val++  nonUriTagValue :: (Error YamlError :> es) => Yaml.Tag -> Eff es Value+  nonUriTagValue = \case+    StrTag -> parseStr inp -- always succeeds+    FloatTag -> throwEmpty "Float" $ parseFloat inp+    IntTag -> throwEmpty "Int" $ parseInt inp+    NullTag -> pure Null+    BoolTag -> throwEmpty "Bool" $ parseBool inp+    NoTag -> throwEmpty "Any" $ parseMulti inp+    _ -> throwError $ InvalidScalarTag tg inp++  parseBool "true" = pure $ Bool True+  parseBool "false" = pure $ Bool False+  parseBool _ = empty++  parseStr s = pure $ String (decodeUtf8 s)++  parseInt s = Integer <$> parseRead s++  parseFloat s = Number <$> parseRead s++  parseMulti s =+    parseInt s <|> parseFloat s <|> parseBool s <|> parseStr s++  throwEmpty :: (Error YamlError :> es) => String -> Eff (NonDet : es) a -> Eff es a+  throwEmpty expt eff = do+    ec <- runNonDet OnEmptyKeep eff+    case ec of+      Left _ -> throwError $ InvalidScalar expt tg inp+      Right a -> pure a++  parseRead :: (Read a, NonDet :> es) => ByteString -> Eff es a+  parseRead s = do+    maybe empty pure $ readMaybe (unpack $ decodeUtf8 s)+++-- | Await an event. Throw if out of input+event :: (Error YamlError :> es) => ConduitT i o (Eff es) i+event = do+  e <- await+  case e of+    Nothing -> lift $ throwError NoInput+    Just a -> pure a+++parseSchemaTag :: Tag -> SchemaTag+parseSchemaTag (UriTag s) =+  let t = pack s+      mt = T.stripPrefix "tag:stsci.edu:asdf/" t+   in SchemaTag (maybe (pure t) pure mt)+parseSchemaTag _ = mempty+++isNDArray :: SchemaTag -> Bool+isNDArray (SchemaTag Nothing) = False+isNDArray (SchemaTag (Just t)) =+  "core/ndarray" `T.isPrefixOf` t+++expect :: (Error YamlError :> es) => Event -> ConduitT Event o (Eff es) ()+expect ex = expect' ("Exactly " ++ show ex) (== ex)+++expect' :: (Error YamlError :> es) => String -> (Event -> Bool) -> ConduitT Event o (Eff es) ()+expect' ex p = do+  e <- event+  if p e+    then pure ()+    else lift $ throwError $ ExpectedEvent ex e+++data YamlError+  = NoInput+  | ExpectedEvent String Event+  | InvalidScalar String Tag ByteString+  | InvalidScalarTag Tag ByteString+  | InvalidTree String Value+  | NDArrayMissingKey String+  | NDArrayMissingBlock Integer+  | NDArrayExpected String Value+  | InvalidReference Value+  | AnchorUndefined Anchor [Anchor]+  deriving (Show)+++sinkIndex :: (Error YamlError :> es) => ConduitT Event o (Eff es) BlockIndex+sinkIndex = do+  expect EventStreamStart+  expect EventDocumentStart+  expect' "EventSequenceStart" isSequence+  ns <- sinkWhile (/= EventSequenceEnd) sinkIndexEntry+  expect EventSequenceEnd+  expect EventDocumentEnd+  expect EventStreamEnd+  pure $ BlockIndex ns+ where+  isSequence :: Event -> Bool+  isSequence EventSequenceStart{} = True+  isSequence _ = False++  sinkIndexEntry :: (Error YamlError :> es) => ConduitT Event o (Eff es) Int+  sinkIndexEntry = do+    e <- event+    case e of+      EventScalar s t _ _ -> do+        case readMaybe (unpack $ decodeUtf8 s) of+          Just n -> pure n+          Nothing -> lift $ throwError $ InvalidScalar "Int Index Entry" t s+      _ -> lift $ throwError $ ExpectedEvent "Scalar Int" e+++addNodeAnchor :: (State Anchors :> es) => Node -> Eff es ()+addNodeAnchor n =+  case n.anchor of+    Nothing -> pure ()+    Just a -> modify (Anchors [(a, n.value)] <>)
+ src/Telescope/Asdf/Error.hs view
@@ -0,0 +1,24 @@+module Telescope.Asdf.Error where++import Control.Monad.Catch (Exception, MonadThrow, throwM)+import Effectful+import Effectful.Error.Static+++data AsdfError+  = YamlError String+  | BlockError String+  | ParseError String+  | EncodeError String+  deriving (Exception, Eq)+++instance Show AsdfError where+  show (YamlError s) = "YamlError " ++ s+  show (BlockError s) = "BlockError " ++ s+  show (ParseError s) = "ParseError " ++ s+  show (EncodeError s) = "EncodeError " ++ s+++runAsdfM :: (MonadIO m, MonadThrow m) => Eff [Error AsdfError, IOE] a -> m a+runAsdfM = liftIO . runEff . runErrorNoCallStackWith @AsdfError throwM
+ src/Telescope/Asdf/GWCS.hs view
@@ -0,0 +1,431 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DefaultSignatures #-}++module Telescope.Asdf.GWCS where++import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Massiv.Array (Array, Ix2)+import Data.Massiv.Array qualified as M+import Data.String (IsString)+import Data.Text (Text, pack)+import Data.Text qualified as T+import GHC.Generics+import Telescope.Asdf+import Telescope.Asdf.Core+import Telescope.Data.WCS (WCSAxis (..))+++-- | GWCS pipelines consist of an input and output 'GWCSStep'+data GWCS inp out = GWCS (GWCSStep inp) (GWCSStep out)+++instance (ToAsdf inp, ToAsdf out) => ToAsdf (GWCS inp out) where+  schema _ = "tag:stsci.edu:gwcs/wcs-1.2.0"+  toValue (GWCS inp out) =+    Object+      [ ("name", toNode $ String "")+      , ("steps", toNode $ Array [toNode inp, toNode out])+      ]+++-- | A step contains a frame (like 'CelestialFrame') and a 'Transform a b'+data GWCSStep frame = GWCSStep+  { frame :: frame+  , transform :: Maybe Transformation+  }+  deriving (Generic)+++instance (ToAsdf frame) => ToAsdf (GWCSStep frame) where+  schema _ = "tag:stsci.edu:gwcs/step-1.1.0"+++newtype AxisName = AxisName Text+  deriving newtype (IsString, ToAsdf, Show, Semigroup, Eq)+++newtype AxisType = AxisType Text+  deriving newtype (IsString)+instance ToAsdf AxisType where+  toValue (AxisType t) = String t+++data Pix a+data Rot a+++instance (ToAxes a) => ToAxes (Pix a) where+  toAxes = toAxes @a+instance (ToAxes a) => ToAxes (Scale a) where+  toAxes = fmap ("*" <>) (toAxes @a)+instance (ToAxes a) => ToAxes (Shift a) where+  toAxes = fmap ("+" <>) (toAxes @a)+instance (ToAxes a) => ToAxes (Rot a) where+  toAxes = fmap ("rot_" <>) (toAxes @a)+instance (ToAxes a) => ToAxes (Linear a) where+  toAxes = fmap ("lin_" <>) (toAxes @a)+++newtype Lon = Lon Float+  deriving newtype (ToAsdf)+newtype Lat = Lat Float+  deriving newtype (ToAsdf)+newtype LonPole = LonPole Float+  deriving newtype (ToAsdf)+++-- | A 'Tranform' with the types stripped, and the axes recorded+data Transformation = Transformation+  { inputs :: [AxisName]+  , outputs :: [AxisName]+  , forward :: Forward+  }+  deriving (Show, Eq)+++instance ToAsdf Transformation where+  schema t =+    case t.forward of+      Compose _ _ -> "!transform/compose-1.2.0"+      Concat _ _ -> "!transform/concatenate-1.2.0"+      Direct{schemaTag} -> schemaTag+++  toValue t =+    inputFields <> case t.forward of+      Compose a b -> Object [("forward", toNode [a, b])]+      Concat a b -> Object [("forward", toNode [a, b])]+      Direct{fields} -> fields+   where+    inputFields =+      Object+        [ ("inputs", toNode t.inputs)+        , ("outputs", toNode t.outputs)+        ]+++data Forward+  = Compose Transformation Transformation+  | Concat Transformation Transformation+  | Direct {schemaTag :: SchemaTag, fields :: Value}+  deriving (Show, Eq)+++{- | A Transform specifies how we manipulate a type in a pipeline++> spatialTransform :: WCSAxis s X -> WCSAxis s Y -> Transform (Pix X, PixY) (Scale X, Scale Y)+> spatialTransform wcsx wcsy =+>   let dx = shift wcsx.crpix :: Transform (Pix X) (Shift X)+>       dy = shift wcsy.crpix :: Transform (Pix Y) (Shift Y)+>       xx = scale wcsx.cdelt :: Transform (Shift X) (Scale X)+>       xy = scale wcsy.cdelt :: Transform (Shift Y) (Scale Y)+>   in dx |> xx <&> dy |> xy+-}+data Transform b c = Transform+  { transformation :: Transformation+  }+  deriving (Show)+++-- | Convert a type into a 'Transform' via 'ToAsdf' and 'ToAxes'+transform :: forall a bs cs. (ToAsdf a, ToAxes bs, ToAxes cs) => a -> Transform bs cs+transform a =+  Transform+    $ Transformation+      (toAxes @bs)+      (toAxes @cs)+    $ Direct (schema a) (toValue a)+++-- | Compose two transforms+(|>) :: forall b c d. (ToAxes b, ToAxes d) => Transform b c -> Transform c d -> Transform b d+(Transform s) |> (Transform t) =+  Transform+    $ Transformation+      (toAxes @b)+      (toAxes @d)+    $ Compose s t+++infixr 5 |>+++-- | Concatent two transforms+(<&>)+  :: forall (a :: Type) (b :: Type) (cs :: Type) (ds :: Type)+   . (ToAxes (TConcat a cs), ToAxes (TConcat b ds))+  => Transform a b+  -> Transform cs ds+  -> Transform (TConcat a cs) (TConcat b ds)+Transform s <&> Transform t =+  Transform+    $ Transformation+      (toAxes @(TConcat a cs))+      (toAxes @(TConcat b ds))+    $ Concat s t+++infixr 4 <&>+++data Direction+  = Pix2Sky+  | Native2Celestial+  deriving (Show)+++instance ToAsdf Direction where+  toValue = String . T.toLower . pack . show+++data Shift a = Shift Float deriving (Show, Eq)+data Scale a = Scale Float 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 Projection = Projection Direction+data Rotate3d = Rotate3d {direction :: Direction, phi :: Lon, theta :: Lat, psi :: LonPole}+  deriving (Generic)+data Linear a = Linear1d {intercept :: Float, slope :: Float}+  deriving (Generic)+++instance ToAsdf Identity where+  schema _ = "!transform/identity-1.2.0"+  toValue _ = Object []+++instance ToAsdf (Linear a) where+  schema _ = "!transform/linear1d-1.0.0"+++instance ToAsdf (Shift a) where+  schema _ = "!transform/shift-1.2.0"+  toValue (Shift d) =+    Object [("offset", toNode d)]+++instance ToAsdf (Scale a) where+  schema _ = "!transform/scale-1.2.0"+  toValue (Scale d) =+    Object [("factor", toNode d)]+++instance ToAsdf Projection where+  schema _ = "!transform/gnomonic-1.2.0"+  toValue (Projection d) =+    Object [("direction", toNode d)]+++instance ToAsdf Rotate3d where+  schema _ = "!transform/rotate3d-1.3.0"+++instance ToAsdf Affine where+  schema _ = "!transform/affine-1.3.0"+  toValue a =+    let (tx, ty) = a.translation+     in Object+          [ ("matrix", toNode $ M.toLists a.matrix)+          , ("translation", toNode [tx, ty])+          ]+++-- Frames -----------------------------------------------++data CoordinateFrame = CoordinateFrame+  { name :: Text+  , axes :: NonEmpty FrameAxis+  }+instance ToAsdf CoordinateFrame where+  schema _ = "tag:stsci.edu:gwcs/frame-1.0.0"+  toValue f =+    Object $+      [ ("name", toNode f.name)+      , ("axes_type", toNode $ fmap (.axisType) f.axes)+      ]+        <> frameAxesObject f.axes+++data StokesFrame = StokesFrame+  { name :: Text+  , axisOrder :: Int+  }+instance ToAsdf StokesFrame where+  schema _ = "tag:stsci.edu:gwcs/stokes_frame-1.0.0"+  toValue f =+    Object+      [ ("name", toNode f.name)+      , ("axes_order", toNode [f.axisOrder])+      ]+++data SpectralFrame = SpectralFrame+  { name :: Text+  , axisOrder :: Int+  }+instance ToAsdf SpectralFrame where+  schema _ = "tag:stsci.edu:gwcs/spectral_frame-1.0.0"+  toValue f =+    Object+      [ ("name", toNode f.name)+      , ("axes_names", toNode [String "wavelength"])+      , ("axes_order", toNode [f.axisOrder])+      , ("axis_physical_types", toNode [String "em.wl"])+      , ("unit", toNode [Nanometers])+      ]+++data CelestialFrame = CelestialFrame+  { name :: Text+  , axes :: NonEmpty FrameAxis+  , referenceFrame :: ICRSFrame+  }+instance ToAsdf CelestialFrame where+  schema _ = "tag:stsci.edu:gwcs/celestial_frame-1.0.0"+  toValue f =+    Object $+      [ ("name", toNode f.name)+      , ("reference_frame", toNode f.referenceFrame)+      ]+        <> frameAxesObject f.axes+++frameAxesObject :: NonEmpty FrameAxis -> Object+frameAxesObject as =+  -- doesn't include axes_type, only on CoorindateFrame+  [ ("naxes", toNode $ NE.length as)+  , ("axes_names", toNode axesNames)+  , ("axes_order", toNode axesOrders)+  , ("axes_physical_types", toNode axesPhysicalTypes)+  , ("unit", toNode units)+  ]+ where+  axesNames = fmap (.axisName) as+  axesOrders = fmap (.axisOrder) as+  axesPhysicalTypes = fmap (physicalType . (.axisType)) as+  units = fmap (.unit) as+  physicalType t = String "custom:" <> toValue t+++-- numAxes = NE.length as++data ICRSFrame = ICRSFrame+instance ToAsdf ICRSFrame where+  schema _ = "tag:astropy.org:astropy/coordinates/frames/icrs-1.1.0"+  toValue _ = Object [("frame_attributes", toNode $ Object mempty)]+++data FrameAxis = FrameAxis+  { axisOrder :: Int+  , axisName :: AxisName+  , axisType :: AxisType+  , unit :: Unit+  }+++data CompositeFrame as = CompositeFrame as+instance (ToAsdf as) => ToAsdf (CompositeFrame as) where+  schema _ = "tag:stsci.edu:gwcs/composite_frame-1.0.0"+  toValue (CompositeFrame as) =+    Object+      [ ("name", toNode $ String "CompositeFrame")+      , ("frames", toNode as)+      ]+++-- ToAxes -----------------------------------------------++{- | Convert a type to named axes++> data X deriving (Generic, ToAxes)+> data Y+> instance ToAxes Y where+>   toAxes = ["y"]+-}+class ToAxes (as :: Type) where+  toAxes :: [AxisName]+  default toAxes :: (Generic as, GTypeName (Rep as)) => [AxisName]+  toAxes = [AxisName $ pack $ gtypeName (from (undefined :: as))]+++instance ToAxes () where+  toAxes = []+instance (ToAxes a, ToAxes b) => ToAxes (a, b) where+  toAxes = mconcat [toAxes @a, toAxes @b]+instance (ToAxes a, ToAxes b, ToAxes c) => ToAxes (a, b, c) where+  toAxes = mconcat [toAxes @a, toAxes @b, toAxes @c]+instance (ToAxes a, ToAxes b, ToAxes c, ToAxes d) => ToAxes (a, b, c, d) where+  toAxes = mconcat [toAxes @a, toAxes @b, toAxes @c, toAxes @d]+++-- Transforms -----------------------------------------------++shift :: forall a f. (ToAxes (f a), ToAxes (Shift a)) => Float -> 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 d = transform $ Scale d+++linear :: forall a. (ToAxes a) => Intercept -> Scale a -> Transform (Pix a) (Linear a)+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 arr =+  transform $ Affine arr (0, 0)+++project :: (ToAxes x, ToAxes y) => Direction -> Transform (Rot (x, y)) (Phi, Theta)+project dir =+  transform $ Projection dir+++celestial :: Lat -> Lon -> LonPole -> Transform (Phi, Theta) (Alpha, Delta)+celestial lat lon pole =+  transform $ Rotate3d{direction = Native2Celestial, theta = lat, phi = lon, psi = pole}+++data Phi deriving (Generic, ToAxes)+data Theta deriving (Generic, ToAxes)+data Alpha deriving (Generic, ToAxes)+data Delta deriving (Generic, ToAxes)+++identity :: (ToAxes bs, ToAxes cs) => Transform bs cs+identity = transform Identity+++-- WCS Transforms ---------------------------------------------------------++wcsLinear :: (ToAxes axis) => WCSAxis alt axis -> Transform (Pix axis) (Linear axis)+wcsLinear wcs = linear (wcsIntercept wcs) (Scale wcs.cdelt)+++-- the Y intercept+wcsIntercept :: WCSAxis alt axis -> Intercept+wcsIntercept w =+  -- crpix is 1-indexed, need to switch to zero+  Intercept $ w.crval - w.cdelt * (w.crpix - 1)+++-- | Generic NodeName+class GTypeName f where+  gtypeName :: f p -> String+++instance (Datatype d) => GTypeName (D1 d f) where+  gtypeName = datatypeName+++type family TConcat a b where+  TConcat (a, b, c) d = (a, b, c, d)+  TConcat a (b, c, d) = (a, b, c, d)+  TConcat (a, b) (c, d) = (a, b, c, d)+  TConcat (a, b) c = (a, b, c)+  TConcat a (b, c) = (a, b, c)+  TConcat a b = (a, b)
+ src/Telescope/Asdf/NDArray.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Asdf.NDArray+  ( NDArrayData (..)+  , FromNDArray (..)+  , ToNDArray (..)+  , DataType (..)+  , IsDataType (..)+  , parseGet+  , ndArrayPut+  , ndArrayMassiv+  , parseMassiv+  , parseNDArray+  , ByteOrder (..)+  , getUcs4+  , putUcs4+  , Parser+  )+where++import Control.Monad (replicateM)+import Control.Monad.Catch (try)+import Data.Binary.Get hiding (getBytes)+import Data.Binary.Put+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.Massiv.Array (Array, D, Prim, Sz (..))+import Data.Massiv.Array qualified as M+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Effectful+import Telescope.Asdf.NDArray.Types+import Telescope.Asdf.Node+import Telescope.Data.Array+import Telescope.Data.Axes+import Telescope.Data.Binary+import Telescope.Data.Parser+++-- import Telescope.Asdf.Node++{- | Convert an 'NDArrayData' into a type+https://asdf-standard.readthedocs.io/en/latest/generated/stsci.edu/asdf/core/ndarray-1.1.0.html+-}+class FromNDArray a where+  fromNDArray :: (Parser :> es) => NDArrayData -> Eff es a+++{- | Convert a type to an 'NDArrayData'+https://asdf-standard.readthedocs.io/en/latest/generated/stsci.edu/asdf/core/ndarray-1.1.0.html+-}+class ToNDArray a where+  toNDArray :: a -> NDArrayData+++instance {-# OVERLAPPABLE #-} (BinaryValue a, IsDataType a) => ToNDArray [a] where+  toNDArray = ndArrayPut shape putBytes+   where+    putBytes = mapM_ (put BigEndian)+    shape as = axesRowMajor [length as]+++instance {-# OVERLAPPING #-} (BinaryValue a, IsDataType a) => ToNDArray [[a]] where+  toNDArray = ndArrayPut shape putBytes+   where+    putBytes = mapM_ (mapM_ (put BigEndian))+    shape = axesRowMajor . dimensions+    dimensions [] = []+    dimensions (r1 : rs) =+      [length rs + 1, length r1]+++instance {-# OVERLAPPABLE #-} (BinaryValue a) => FromNDArray [a] where+  fromNDArray arr = parseGet (getBytes arr.byteorder arr.shape) arr.bytes+   where+    getBytes bo axes = do+      let num = totalItems axes+      replicateM num (get bo)+++instance FromNDArray [Text] where+  fromNDArray arr = do+    n <- fromIntegral <$> ucs4Size arr.datatype+    parseGet (replicateM (totalItems arr.shape) (getUcs4 arr.byteorder n)) arr.bytes+   where+    ucs4Size = \case+      Ucs4 n -> pure n+      dt -> expected "Ucs4" dt+++-- decode LittleEndian = T.decodeUtf32LE+-- decode BigEndian = T.decodeUtf32BE++instance {-# OVERLAPPING #-} (BinaryValue a) => FromNDArray [[a]] where+  fromNDArray arr = parseGet (getBytes arr.shape) arr.bytes+   where+    getBytes (Axes rows) = mapM getRow rows+    getRow n = replicateM n (get arr.byteorder)+++instance (BinaryValue a, Prim a, AxesIndex ix) => FromNDArray (Array D ix a) where+  fromNDArray = parseMassiv+++instance (BinaryValue a, IsDataType a, Prim a, AxesIndex ix, PutArray ix) => ToNDArray (Array D ix a) where+  toNDArray = ndArrayMassiv+++parseGet :: (Parser :> es) => Get a -> ByteString -> Eff es a+parseGet gt bytes =+  case runGetOrFail gt (BL.fromStrict bytes) of+    Left (rest, nused, err) ->+      parseFail $ "could not decode binary data at (" ++ show nused ++ ") (rest " ++ show (BL.length rest) ++ "): " ++ err+    Right (_, _, a) -> pure a+++ndArrayPut :: forall a. (IsDataType a) => (a -> Axes Row) -> (a -> Put) -> a -> NDArrayData+ndArrayPut toShape putA a =+  let bytes = BL.toStrict $ runPut (putA a)+   in NDArrayData{bytes, byteorder = BigEndian, datatype = dataType @a, shape = toShape a}+++ndArrayMassiv :: forall a ix. (IsDataType a, BinaryValue a, Prim a, AxesIndex ix, PutArray ix) => Array D ix a -> NDArrayData+ndArrayMassiv arr =+  let bytes = encodeArray arr+      Sz ix = M.size arr+      shape = indexAxes ix+      datatype = dataType @a+   in NDArrayData{bytes, shape, byteorder = BigEndian, datatype}+++parseMassiv :: (BinaryValue a, AxesIndex ix, Parser :> es) => NDArrayData -> Eff es (Array D ix a)+parseMassiv nda = do+  ea <- try $ decodeArrayOrder nda.byteorder nda.shape nda.bytes+  case ea of+    Left (e :: ArrayError) -> parseFail $ show e+    Right a -> pure a+++putUcs4 :: Int -> Text -> Put+putUcs4 n t = putByteString $ justifyUcs4 n $ T.encodeUtf32BE t+++getUcs4 :: ByteOrder -> Int -> Get Text+getUcs4 bo n =+  decodeUcs4 <$> getByteString (n * 4)+ where+  decodeUcs4 bs =+    case bo of+      BigEndian -> T.decodeUtf32BE . BS.dropWhileEnd (== 0x0) $ bs+      LittleEndian -> T.decodeUtf32LE . BS.dropWhile (== 0x0) $ bs+++justifyUcs4 :: Int -> BS.ByteString -> BS.ByteString+justifyUcs4 len bs =+  let nulls = len * 4 - BS.length bs+   in bs <> BS.replicate nulls 0x0+++parseNDArray :: (FromNDArray a, Parser :> es) => Value -> Eff es a+parseNDArray val = do+  dat <- ndarray val+  fromNDArray dat+ where+  ndarray (NDArray a) = pure a+  ndarray v = expected "NDArray" v
+ src/Telescope/Asdf/NDArray/Types.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Asdf.NDArray.Types where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import GHC.Int (Int16, Int32, Int64)+import Telescope.Data.Axes+import Telescope.Data.Binary+++-- import Telescope.Asdf.Node++{- | In-tree representation of an NDArray. You can parse a file as this and get it back. Not really what we want though+but in haskell we can't easily just parse a multi-dimensional array+we could do a simpler representation. Using an ADT+-}+data NDArrayData = NDArrayData+  { bytes :: ByteString+  , byteorder :: ByteOrder+  , datatype :: DataType+  , shape :: Axes Row+  }+  deriving (Eq)+++instance Show NDArrayData where+  show nd = unwords ["NDArrayData", show (BS.length nd.bytes), show nd.byteorder, show nd.shape]+++data DataType+  = Float64+  | Float32+  | Int64+  | Int32+  | Int16+  | Int8+  | Bool8+  | Ucs4 Int+  deriving (Show, Eq)+++class IsDataType a where+  dataType :: DataType+++instance IsDataType Double where+  dataType = Float64+instance IsDataType Float where+  dataType = Float32+instance IsDataType Int64 where+  dataType = Int64+instance IsDataType Int32 where+  dataType = Int32+instance IsDataType Int16 where+  dataType = Int16+instance IsDataType Int8 where+  dataType = Int8+instance (IsDataType a) => IsDataType [a] where+  dataType = dataType @a
+ src/Telescope/Asdf/Node.hs view
@@ -0,0 +1,129 @@+module Telescope.Asdf.Node where++import Data.Maybe (fromMaybe)+import Data.Scientific (Scientific)+import Data.String (IsString (..))+import Data.Text (Text, pack, unpack)+import Data.Text qualified as T+import Telescope.Asdf.NDArray.Types+import Telescope.Data.Parser+import Text.Read (readMaybe)+++-- | Specify a schema using 'schema' from 'ToAsdf'+newtype SchemaTag = SchemaTag (Maybe Text)+  deriving newtype (Monoid, Semigroup, Eq)+++instance Show SchemaTag where+  show (SchemaTag Nothing) = ""+  show (SchemaTag (Just t)) = unpack t ++ ":"+++schemaTag :: String -> SchemaTag+schemaTag = SchemaTag . Just . pack+++instance IsString SchemaTag where+  fromString s = SchemaTag (Just $ pack s)+++-- | A Node is a 'Value' with an optional 'SchemaTag' and 'Anchor'+data Node = Node+  { schema :: SchemaTag+  , anchor :: Maybe Anchor+  , value :: Value+  }+  deriving (Eq)+++instance Show Node where+  show (Node st _ v) = show st ++ show v+instance IsString Node where+  fromString s = Node mempty Nothing $ String $ pack s+++-- | All allowed node values. We can't use Aeson's Value, because it doesn't support tags, binary data, or references+data Value+  = Bool !Bool+  | Number !Scientific+  | Integer !Integer+  | String !Text+  | -- | RawBinary !ByteString+    NDArray !NDArrayData+  | Array ![Node]+  | Object !Object+  | Reference !JSONReference+  | Alias !Anchor+  | Null+  deriving (Show, Eq)+++instance IsString Value where+  fromString = String . pack+instance Semigroup Value where+  String a <> String b = String $ a <> b+  Array as <> Array bs = Array $ as <> bs+  Object as <> Object bs = Object $ as <> bs+  Null <> b = b+  a <> Null = a+  a <> _ = a+instance Monoid Value where+  mempty = Null+++type Key = Text+type Object = [(Key, Node)]+++-- | Makes a node from a value+fromValue :: Value -> Node+fromValue = Node mempty Nothing+++-- | Root Object with all anchors resolved+newtype Tree = Tree Object+  deriving newtype (Semigroup, Monoid, Show)+++-- always $ref: uri#path+data JSONReference = JSONReference+  { uri :: Text+  , pointer :: JSONPointer+  }+  deriving (Eq)+instance Show JSONReference where+  show ref = unpack ref.uri ++ show ref.pointer+++jsonReference :: Text -> JSONReference+jsonReference t =+  let (uri, rest) = T.breakOn "#" t+   in JSONReference uri (jsonPointer rest)+++jsonPointer :: Text -> JSONPointer+jsonPointer t =+  let segs = filter (not . T.null) $ T.splitOn "/" $ T.dropWhile (== '#') t+   in JSONPointer $ Path (fmap ref segs)+ where+  ref :: Text -> Ref+  ref s = fromMaybe (Child s) $ do+    n <- readMaybe (unpack s)+    pure $ Index n+++newtype JSONPointer = JSONPointer Path+  deriving (Eq)+instance Show JSONPointer where+  show (JSONPointer ps) = "#/" ++ show ps+++newtype Anchor = Anchor {anchor :: Text}+  deriving (Eq)+  deriving newtype (IsString, Show)+++newtype Anchors = Anchors [(Anchor, Value)]+  deriving (Show, Eq)+  deriving newtype (Monoid, Semigroup)
+ src/Telescope/Asdf/Reference.hs view
@@ -0,0 +1,46 @@+module Telescope.Asdf.Reference where++import Data.List ((!?))+import Data.Text (Text)+import Effectful+import Telescope.Asdf.NDArray+import Telescope.Asdf.Node+import Telescope.Data.Parser+++-- resolveInternalPointer :: forall a es. (FromAsdf a, Reader Tree :> es, Parser :> es) => JSONPointer -> Eff es a+-- resolveInternalPointer point = do+--   Node _ value <- findPointer point+--   parseValue value++-- | Parse a 'JSONPointer' from a 'Tree'+findPointer :: forall es. (Parser :> es) => JSONPointer -> Tree -> Eff es Node+findPointer (JSONPointer path) (Tree tree) = do+  parseNext path (Node mempty Nothing (Object tree))+ where+  parseNext :: Path -> Node -> Eff es Node+  parseNext (Path []) node = pure node+  parseNext (Path (p : ps)) (Node _ _ val) = do+    child <- parseSegment p val+    parseNext (Path ps) child++  parseSegment :: Ref -> Value -> Eff es Node+  parseSegment (Child n) (Object o) = parseChild n o+  parseSegment (Child n) node = missingPointer (Child n) node+  parseSegment (Index n) (Array a) = parseIndex n a+  parseSegment (Index n) node = missingPointer (Index n) node++  parseChild :: Text -> Object -> Eff es Node+  parseChild name o =+    case lookup name o of+      Nothing -> missingPointer (Child name) o+      Just c -> pure c++  parseIndex :: Int -> [Node] -> Eff es Node+  parseIndex n a =+    case a !? n of+      Nothing -> missingPointer (Index n) a+      Just c -> pure c++  missingPointer :: (Show ex, Show at) => ex -> at -> Eff es Node+  missingPointer expect at = parseFail $ "Could not locate pointer: " ++ show path ++ ". Expected " ++ show expect ++ " at " ++ show at
+ src/Telescope/Data/Array.hs view
@@ -0,0 +1,194 @@+module Telescope.Data.Array where++import Control.Exception (throw)+import Control.Monad.Catch+import Data.Binary.Get (ByteOffset, runGetOrFail)+import Data.Binary.Put (Put, runPut)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.Massiv.Array (Array, Comp (..), D, Index, Ix1, Ix2 (..), Ix3, Ix4, Ix5, IxN (..), Lower, Prim, Source, Stream, Sz (..), Vector)+import Data.Massiv.Array qualified as M+import Data.Word (Word8)+import Telescope.Data.Axes+import Telescope.Data.Binary+++{- | Decode Big Endian encoded binary data into an Array of arbitrary dimensions 'ix' by specifying the 'Axes' 'Row'++>>> decodeArray @Ix2 @Float [3, 2] input+Array P Seq (Sz (2 :. 3))+  [ [ 1.0, 2.0, 3.0 ]+  , [ 4.0, 5.0, 6.0 ]+  ]+-}+decodeArray+  :: forall ix a m+   . (AxesIndex ix, Prim a, BinaryValue a, MonadThrow m, MonadCatch m)+  => Axes Row+  -> BS.ByteString+  -> m (Array D ix a)+decodeArray = decodeArrayOrder BigEndian+++{- | Encode an Array as a Lazy ByteString based on the type of the element 'a'++>>> myArray = decodeArray @Ix2 @Float BPFloat [3, 2] input+>>> output = encodeArray myArray+-}+encodeArray+  :: (Source r a, Stream r Ix1 a, PutArray ix, BinaryValue a, Prim a)+  => Array r ix a+  -> BS.ByteString+encodeArray = BL.toStrict . runPut . putArray BigEndian+++{- | Decode binary data into an Array of arbitrary dimensions 'ix' by specifying the 'Axes' 'Row' and the 'ByteOrder'++>>> decodeArrayOrder @Ix2 @Float BigEndian [3, 2] input+Array P Seq (Sz (2 :. 3))+  [ [ 1.0, 2.0, 3.0 ]+  , [ 4.0, 5.0, 6.0 ]+  ]+-}+decodeArrayOrder+  :: forall ix a m+   . (AxesIndex ix, BinaryValue a, MonadThrow m, MonadCatch m)+  => ByteOrder+  -> Axes Row+  -> BS.ByteString+  -> m (Array D ix a)+decodeArrayOrder bo as inp = do+  fromVector as $ decodeVector @a Par bo inp+++-- | Decode binary data into as a 1d Array+decodeVector+  :: forall a+   . (BinaryValue a)+  => Comp+  -> ByteOrder+  -> BS.ByteString+  -> Vector D a+decodeVector c bo inp =+  let v = parseWordVector inp+   in M.makeArray c (arraySize v) (valueAt v)+ where+  numBytes = byteSize @a++  arraySize v =+    let Sz s = M.size v+     in Sz $ s `div` numBytes++  valueAt :: Vector D Word8 -> Ix1 -> a+  valueAt v ix =+    fromWords $ wordsAt v ix++  wordsAt :: Vector D Word8 -> Ix1 -> [Word8]+  wordsAt v ix =+    M.toList $ M.slice (ix * numBytes) (Sz numBytes) v++  parseWordVector :: BS.ByteString -> Vector D Word8+  parseWordVector = M.fromByteString c++  -- this should never actually fail+  fromWords :: [Word8] -> a+  fromWords ws =+    case runGetOrFail (get bo) (BL.pack ws) of+      Left (ip, byts, e) -> throw $ BinaryParseError byts (e <> " " <> show ip <> show ws)+      Right (_, _, a) -> a+++-- | Resize a Vector into an Array+fromVector+  :: forall ix a m+   . (AxesIndex ix, MonadThrow m, MonadCatch m)+  => Axes Row+  -> Vector D a+  -> m (Array D ix a)+fromVector as v = do+  ix <- axesIndex as+  ea <- try $ M.resizeM (Sz ix) v+  case ea of+    Left (e :: M.SizeException) -> throwM $ ResizeMismatch (show e)+    Right a -> pure a+++data ArrayError+  = BinaryParseError !ByteOffset String+  | AxesMismatch !(Axes Row)+  | ResizeMismatch String+  deriving (Show, Exception)+++-- | Convert between an 'Index' and 'Axes' 'Row'+class (Index ix) => AxesIndex ix where+  axesIndex :: (MonadThrow m) => Axes Row -> m ix+  indexAxes :: ix -> Axes Row+++instance AxesIndex Ix1 where+  axesIndex (Axes [i]) = pure i+  axesIndex as = throwM $ AxesMismatch as+  indexAxes n = Axes [n]+++instance AxesIndex Ix2 where+  axesIndex (Axes [c, r]) = do+    ix1 <- axesIndex $ Axes [r]+    pure $ c :. ix1+  axesIndex as = throwM $ AxesMismatch as+  indexAxes (c :. r) = Axes [c, r]+++instance AxesIndex Ix3 where+  axesIndex = axesIndexN+  indexAxes = indexAxesN+++instance AxesIndex Ix4 where+  axesIndex = axesIndexN+  indexAxes = indexAxesN+++instance AxesIndex Ix5 where+  axesIndex = axesIndexN+  indexAxes = indexAxesN+++-- | Encode an 'Array' of dimensions up to 'Ix5'+class PutArray ix where+  putArray+    :: (BinaryValue a, Source r a, Stream r Ix1 a, Prim a)+    => ByteOrder+    -> Array r ix a+    -> Put+++instance PutArray Ix1 where+  putArray bo = M.sfoldl (\b a -> b <> put bo a) mempty+instance PutArray Ix2 where+  putArray = M.foldOuterSlice . putArray+instance PutArray Ix3 where+  putArray = M.foldOuterSlice . putArray+instance PutArray Ix4 where+  putArray = M.foldOuterSlice . putArray+instance PutArray Ix5 where+  putArray = M.foldOuterSlice . putArray+++axesIndexN :: (AxesIndex (Lower (IxN n))) => (MonadThrow m) => Axes Row -> m (IxN n)+axesIndexN (Axes (a : as)) = do+  ixl <- axesIndex (Axes as)+  pure $ a :> ixl+axesIndexN as = throwM $ AxesMismatch as+++indexAxesN :: (AxesIndex (Lower (IxN n))) => IxN n -> Axes Row+indexAxesN (d :> ix) =+  let Axes ax = indexAxes ix+   in Axes $ d : ax+++-- | Get the Axes for a given array size+sizeAxes :: (AxesIndex ix, Index ix) => Sz ix -> Axes Column+sizeAxes (Sz ix) = toColumnMajor $ indexAxes ix
+ src/Telescope/Data/Axes.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Data.Axes where++import GHC.IsList (IsList (..))+import GHC.TypeLits+++type Axis = Int+++newtype Axes (a :: Major) = Axes {axes :: [Axis]}+  deriving (Show, Eq)+++data Major = Row | Column+++axesRowMajor :: [Axis] -> Axes Row+axesRowMajor = Axes+++axesColumnMajor :: [Axis] -> Axes Column+axesColumnMajor = Axes+++toRowMajor :: Axes Column -> Axes Row+toRowMajor (Axes as) = Axes (reverse as)+++toColumnMajor :: Axes Row -> Axes Column+toColumnMajor (Axes as) = Axes (reverse as)+++totalItems :: Axes a -> Int+totalItems (Axes as) = product as+++instance IsList (Axes Row) where+  type Item (Axes Row) = Axis+  fromList = Axes+  toList (Axes ax) = ax+++{- | Specify which numbered axis a type represents++> data X+> instance AxisOrder X where+>   axisN = 1+>+> data Y+> instance AxisOrder Y where+>   axisN = 2+-}+class AxisOrder ax where+  axisN :: Natural
+ src/Telescope/Data/Binary.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Data.Binary+  ( BinaryValue (..)+  , ByteOrder (..)+  ) where++import Data.Binary.Get+import Data.Binary.Put+import GHC.Int+import System.ByteOrder (ByteOrder (..))+++-- | Primitive types that can be serialized as Big or Little Endian+class BinaryValue a where+  byteSize :: Int+  put :: ByteOrder -> a -> Put+  get :: ByteOrder -> Get a+++instance BinaryValue Int8 where+  byteSize = 1+  put _ = putInt8+  get _ = getInt8+++instance BinaryValue Int16 where+  byteSize = 2+  put BigEndian = putInt16be+  put LittleEndian = putInt16le+  get BigEndian = getInt16be+  get LittleEndian = getInt16le+++instance BinaryValue Int32 where+  byteSize = 4+  put BigEndian = putInt32be+  put LittleEndian = putInt32le+  get BigEndian = getInt32be+  get LittleEndian = getInt32le+++instance BinaryValue Int64 where+  byteSize = 8+  put BigEndian = putInt64be+  put LittleEndian = putInt64le+  get BigEndian = getInt64be+  get LittleEndian = getInt64le+++instance BinaryValue Int where+  byteSize = byteSize @Int64+  put bo a = put @Int64 bo (fromIntegral a)+  get bo = fromIntegral <$> get @Int64 bo+++instance BinaryValue Float where+  byteSize = 4+  put BigEndian = putFloatbe+  put LittleEndian = putFloatle+  get BigEndian = getFloatbe+  get LittleEndian = getFloatle+++instance BinaryValue Double where+  byteSize = 8+  put BigEndian = putDoublebe+  put LittleEndian = putDoublele+  get BigEndian = getDoublebe+  get LittleEndian = getDoublele
+ src/Telescope/Data/KnownText.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Data.KnownText where++import Data.Proxy (Proxy (..))+import Data.Text+import GHC.TypeLits+++-- | Types that have a textual representation, like 'KnownSymbol', but for any 'Type'+class KnownText a where+  knownText :: Text+++instance (KnownSymbol s) => KnownText s where+  knownText = pack $ symbolVal @s Proxy
+ src/Telescope/Data/Parser.hs view
@@ -0,0 +1,88 @@+module Telescope.Data.Parser where++import Control.Monad.Catch (Exception)+import Data.List (intercalate)+import Data.Text (Text, unpack)+import Effectful+import Effectful.Dispatch.Dynamic+import Effectful.Error.Static+import Effectful.Reader.Static+++data Parser :: Effect where+  ParseFail :: String -> Parser m a+  PathAdd :: Ref -> m a -> Parser m a+++type instance DispatchOf Parser = 'Dynamic+++runParser+  :: (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+  PathAdd p m -> do+    -- copied from Effectful.Reader.Dynamic+    localSeqUnlift env $ \unlift -> local (<> Path [p]) (unlift m)+++runPureParser :: Eff '[Parser, Error ParseError] a -> Either ParseError a+runPureParser eff = runPureEff . runErrorNoCallStack @ParseError $ runParser eff+++data ParseError+  = ParseFailure Path String+  deriving (Exception, Eq)+++instance Show ParseError where+  show (ParseFailure path s) =+    "at " ++ show path ++ "\n ! " ++ s+++-- | Tracks the location of the parser in the document for error messages+newtype Path = Path [Ref]+  deriving (Eq)+  deriving newtype (Semigroup, Monoid)+++instance Show Path where+  show (Path ps) =+    intercalate "/" (fmap show ps)+++data Ref+  = Child Text+  | Index Int+  deriving (Eq)+++instance Show Ref where+  show (Child c) = unpack c+  show (Index n) = show n+++{- | Easy error message when we expect a particular type:++> instance FromKeyword Int where+>   parseKeywordValue = \case+>     Integer n -> pure n+>     v -> expected "Integer" v+-}+expected :: (Show value, Parser :> es) => String -> value -> Eff es a+expected ex n =+  parseFail $ "Expected " ++ ex ++ ", but got: " ++ show n+++parseFail :: (Parser :> es) => String -> Eff es a+parseFail e = send $ ParseFail e+++-- | Add a child to the parsing 'Path'+parseAt :: (Parser :> es) => Ref -> Eff es a -> Eff es a+parseAt p parse = do+  send $ PathAdd p parse
+ src/Telescope/Data/WCS.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Data.WCS where++import Data.Text+import GHC.Generics (Generic)+import Telescope.Data.Axes (AxisOrder (..))+import Telescope.Data.KnownText+++newtype CUnit = CUnit Text deriving (Eq, Show)+newtype CType = CType Text deriving (Eq, Show)+++{- | Typed WCS Axes++> data X+> data Y+>+> myFunction :: WCSAxis 'WCSMain X -> WCSAxis 'WCSMain Y -> Header+> myFunction wcsx wcsy =+>   toHeader wcsx <> toHeader wcsy+-}+data WCSAxis (alt :: WCSAlt) axis = WCSAxis+  { ctype :: CType+  , cunit :: CUnit+  , crpix :: Float+  , crval :: Float+  , cdelt :: Float+  }+  deriving (Generic, Eq, Show)+++-- | WCSAlt options+data WCSAlt+  = WCSMain+  | A+  | B+++instance KnownText WCSMain where+  knownText = ""+instance KnownText A where+  knownText = "A"+instance KnownText B where+  knownText = "B"+++-- | Converts a wcs keyword like "ctype" to "CTYPE1A" for header parsing+toWCSAxisKey :: forall alt ax. (KnownText alt, AxisOrder ax) => Text -> Text+toWCSAxisKey = addAlt . addAxisN+ where+  addAxisN k = k <> pack (show (axisN @ax))+  addAlt k = k <> (knownText @alt)
+ src/Telescope/Fits.hs view
@@ -0,0 +1,90 @@+{- |+Module:      Telescope.Fits+Copyright:   (c) 2024 Sean Hess+License:     BSD3+Maintainer:  Sean Hess <shess@nso.edu>+Stability:   experimental+Portability: portable++Read, Generate, and Write FITS (Flexible Image Transport System) files++@+import Data.ByteString qualified as BS+import Telescope.Fits++test :: IO ()+test = do+  inp <- BS.readFile "samples/simple2x3.fits"+  f <- decode inp+  print f.primaryHDU.dataArray.axes+  print f.primaryHDU.dataArray.bitpix+  print $ lookupKeyword \"BTYPE\" f.primaryHDU.header++  a <- decodeArray @Ix2 @Int f.primaryHDU.dataArray+  print $ size a+  print $ a !> 0+@+-}+module Telescope.Fits+  ( decode+  , encode+  , decodeDataArray+  , encodeDataArray++    -- * Headers+  , lookupKeyword+  , Header+  , Value (..)+  , LogicalConstant (..)++    -- * Parsing Headers+  , FromHeader (..)+  , FromKeyword (..)++    -- * Creating Headers+  , ToKeyword (..)+  , ToHeader (..)+  , Parser++    -- * Types+  , Fits (..)+  , PrimaryHDU (..)+  , ImageHDU (..)+  , BinTableHDU (..)+  , DataArray (..)+  , Extension (..)+  , Axis+  , Axes+  , Major (..)+  , BitPix (..)++    -- * Generate+  , addComment+  , keyword+  , dataArray+  , emptyDataArray++    -- * Exports from Data.Massiv.Array+  , Array+  , Ix1+  , Ix2+  , Ix3+  , Ix4+  , Ix5+  , size+  , (!>)+  , (!?>)+  , (<!)+  , (<!?)+  , (<!>)+  , Dim (..)+  -- , test+  ) where++import Data.Massiv.Array (Array, Dim (..), Ix1, Ix2, Ix3, Ix4, Ix5, size, (!>), (!?>), (<!), (<!>), (<!?))+import Telescope.Data.Parser (Parser)+import Telescope.Fits.DataArray+import Telescope.Fits.Encoding+import Telescope.Fits.Header (FromHeader (..), FromKeyword (..), ToHeader (..), ToKeyword (..), addComment, keyword, lookupKeyword)+import Telescope.Fits.Types+
+ src/Telescope/Fits/Checksum.hs view
@@ -0,0 +1,66 @@+module Telescope.Fits.Checksum where++import Data.Bits (complement, shiftR, (.&.))+import Data.ByteString.Internal+import Data.Fits (Value (..))+import Data.Text (Text, pack)+import Data.Word+import Foreign.C.String+import Foreign.C.Types+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr+import GHC.IO+++-- | Generate the Checksum per the FITS spec+checksum :: ByteString -> Checksum+checksum bs = unsafePerformIO $ do+  let (fptr, offset, len) = toForeignPtr bs+  withForeignPtr fptr $ \ptr -> do+    ci <- c_checksum (ptr `plusPtr` offset) (fromIntegral len)+    pure $ Checksum $ fromIntegral ci+++-- | Encode the Checksum as ASCII chars per FITS spec+encodeChecksum :: Checksum -> Text+encodeChecksum (Checksum csum) =+  unsafePerformIO $ do+    let comp = complement csum+    let str = replicate 16 ' '+    out <- withCString str $ \cs -> do+      c_char_encode (fromIntegral comp) cs+      peekCString cs+    pure $ pack out+++foreign import ccall "checksum" c_checksum :: Ptr CChar -> CInt -> IO CUInt+++newtype Checksum = Checksum Word32+  deriving (Eq, Show)+++instance Semigroup Checksum where+  Checksum w1 <> Checksum w2 = Checksum (add1s w1 w2)+++checksumValue :: Checksum -> Value+checksumValue (Checksum s) = String (pack (show s))+++foreign import ccall "char_encode" c_char_encode :: CUInt -> CString -> IO ()+++add1s :: Word32 -> Word32 -> Word32+add1s x y =+  let+    sum64 = (+) @Word64 (fromIntegral x) (fromIntegral y)+    result =+      if sum64 > maxWord32+        then (sum64 .&. maxWord32) + (sum64 `shiftR` 32)+        else sum64+   in+    fromIntegral result+ where+  maxWord32 :: Word64+  maxWord32 = 0xFFFFFFFF
+ src/Telescope/Fits/DataArray.hs view
@@ -0,0 +1,85 @@+module Telescope.Fits.DataArray+  ( DataArray (..)+  , dataArray+  , decodeDataArray+  , encodeDataArray+  )+where++import Control.Monad.Catch (MonadCatch)+import Data.ByteString (ByteString)+import Data.Fits qualified as Fits+import Data.Massiv.Array as M hiding (isEmpty, product)+import System.ByteOrder+import Telescope.Data.Array+import Telescope.Data.Axes+import Telescope.Data.Binary+import Telescope.Fits.Types+++-- > {-# LANGUAGE TypeApplications #-}+-- > import Data.Massiv.Array+-- > import Data.Fits.Image+-- > import Data.Fits+-- >+-- > decodeExample :: BL.ByteString -> Either String Int+-- > decodeExample bs = do+-- >  hdu <- readPrimaryHDU bs+-- >  arr <- decodeImage @Ix2 $ hdu.dataArray+-- >  pure $ arr !> 1 ! 2++{- | Decode a 'DataArray' of arbitrary dimensions 'ix' and type 'a'. Consider inspecting the DataArray's (.bitpix) and (.axes) if these are unknown.++>>> decodeDataArray @Ix2 @Float hdu.dataArray+Array D Seq (Sz (2 :. 3))+  [ [ 1.0, 2.0, 3.0 ]+  , [ 4.0, 5.0, 6.0 ]+  ]++This creates a delayed (D) array, which will postpone evaluation of cells until needed+-}+decodeDataArray :: forall ix a m. (MonadThrow m, MonadCatch m) => (Index ix, AxesIndex ix, Prim a, BinaryValue a) => DataArray -> m (Array D ix a)+decodeDataArray DataArray{axes, rawData} = do+  decodeArrayOrder BigEndian (toRowMajor axes) rawData+++{- | Encode an 'Array' to a 'DataArray'++>>> encodeImage array+DataArray:+  data: 48 bytes+  dimensions:+    format: Int64+    axes: [3,2]+-}+encodeDataArray+  :: forall r ix a+   . (Source r a, Stream r Ix1 a, Size r, PutArray ix, Index ix, AxesIndex ix, BinaryValue a, Prim a, IsBitPix a)+  => Array r ix a+  -> DataArray+encodeDataArray arr =+  let axes = sizeAxes $ size arr+      bitpix = bitPix @a+      rawData = encodeArray arr -- O(n)+   in DataArray{bitpix, axes, rawData}+++-- | Create a DataArray from raw Fits info+dataArray :: Fits.Dimensions -> ByteString -> DataArray+dataArray dim dat =+  DataArray+    { bitpix = bitpix dim._bitpix+    , axes = axes dim._axes+    , rawData = dat+    }+ where+  bitpix :: Fits.BitPixFormat -> BitPix+  bitpix Fits.EightBitInt = BPInt8+  bitpix Fits.SixteenBitInt = BPInt16+  bitpix Fits.ThirtyTwoBitInt = BPInt32+  bitpix Fits.SixtyFourBitInt = BPInt64+  bitpix Fits.ThirtyTwoBitFloat = BPFloat+  bitpix Fits.SixtyFourBitFloat = BPDouble++  axes :: Fits.Axes -> Axes Column+  axes = Axes
+ src/Telescope/Fits/Encoding.hs view
@@ -0,0 +1,198 @@+module Telescope.Fits.Encoding+  ( -- * Decoding+    decode++    -- * Encoding+  , encode+  , encodePrimaryHDU+  , encodeImageHDU+  , encodeExtension+  , encodeHDU+  , replaceKeywordLine++    -- * Parser+  , nextParser+  , parseFits+  , parseMainData+  , HDUError (..)+  )+where++import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow, throwM)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Fits qualified as Fits+import Data.Fits.MegaParser qualified as Fits+import Data.Fits.Read (FitsError (..))+import Data.Text (Text)+import Data.Text.Encoding qualified as TE+import Effectful+import Effectful.Error.Static+import Effectful.State.Static.Local+import Telescope.Fits.Checksum+import Telescope.Fits.DataArray (dataArray)+import Telescope.Fits.Encoding.Render+import Telescope.Fits.Types+import Text.Megaparsec qualified as M+import Text.Megaparsec.State qualified as M+++{- | Decode a FITS file read as a strict 'ByteString'++>  decode =<< BS.readFile "samples/simple2x3.fits"+-}+decode :: forall m. (MonadThrow m) => ByteString -> m Fits+decode inp = do+  let res = runPureEff $ runErrorNoCallStack @HDUError $ evalState inp parseFits+  case res of+    Left e -> throwM e+    Right a -> pure a+++{- | Encode a FITS file to a strict 'ByteString'++> BS.writeFile $ encdoe fits+-}+encode :: Fits -> ByteString+encode f =+  let primary = encodePrimaryHDU f.primaryHDU+      exts = fmap encodeExtension f.extensions+   in mconcat $ primary : exts+++encodePrimaryHDU :: PrimaryHDU -> ByteString+encodePrimaryHDU p =+  encodeHDU (renderPrimaryHeader p.header p.dataArray) p.dataArray.rawData+++encodeImageHDU :: ImageHDU -> ByteString+encodeImageHDU p =+  encodeHDU (renderImageHeader p.header p.dataArray) p.dataArray.rawData+++encodeExtension :: Extension -> ByteString+encodeExtension (Image hdu) = encodeImageHDU hdu+encodeExtension (BinTable _) = error "BinTableHDU rendering not supported"+++-- | Encode an HDU, properly handling datasum and checksum+encodeHDU :: (Checksum -> BuilderBlock) -> ByteString -> ByteString+encodeHDU buildHead rawData =+  let dsum = checksum rawData+   in encodeHeader dsum <> renderDataArray rawData+ where+  encodeHeader :: Checksum -> ByteString+  encodeHeader dsum =+    let h = BS.toStrict $ runRender (buildHead dsum)+        hsum = checksum h -- calculate the checksum of only the header+        csum = hsum <> dsum -- 1s complement add to the datasum+     in replaceChecksum csum h++  replaceChecksum :: Checksum -> ByteString -> ByteString+  replaceChecksum csum = replaceKeywordLine "CHECKSUM" (String $ encodeChecksum csum) Nothing+++-- | Fast replace a single keyword in a raw header bytestring+replaceKeywordLine :: ByteString -> Value -> Maybe Text -> ByteString -> ByteString+replaceKeywordLine key val mc header =+  let (start, rest) = BS.breakSubstring key header+      newKeyLine = BS.toStrict $ runRender $ renderKeywordLine (TE.decodeUtf8 key) val mc+   in start <> newKeyLine <> BS.drop 80 rest+++parseFits :: forall es. (State ByteString :> es, Error HDUError :> es) => Eff es Fits+parseFits = do+  p <- primary+  es <- extensions+  pure $ Fits p es+ where+  primary :: Eff es PrimaryHDU+  primary = do+    (dm, hd) <- nextParser "Primary Header" $ do+      dm <- Fits.parsePrimaryKeywords+      hd <- Fits.parseHeader+      pure (dm, hd)++    darr <- parseMainData dm+    pure $ PrimaryHDU hd darr++  extensions :: Eff es [Extension]+  extensions = do+    inp <- get @ByteString+    case inp of+      "" -> pure []+      _ -> do+        e <- extension+        es <- extensions+        pure (e : es)++  extension :: Eff es Extension+  extension = do+    -- this consumes input!+    resImg <- tryError @HDUError image+    resTbl <- tryError @HDUError binTable+    case (resImg, resTbl) of+      (Right i, _) -> pure $ Image i+      (_, Right b) -> pure $ BinTable b+      (Left (_, FormatError ie), Left (_, FormatError be)) -> throwM $ InvalidHDU [ie, be]+      (Left _, Left (_, be)) -> throwM be++  image :: Eff es ImageHDU+  image = do+    (dm, hd) <- imageHeader+    darr <- parseMainData dm+    pure $ ImageHDU hd darr++  imageHeader :: Eff es (Fits.Dimensions, Header)+  imageHeader = do+    nextParser "Image Header" $ do+      dm <- Fits.parseImageKeywords+      hd <- Fits.parseHeader+      pure (dm, hd)++  binTable :: Eff es BinTableHDU+  binTable = do+    (dm, pcount, hd) <- binTableHeader+    darr <- parseMainData dm+    rest <- get+    let heap = BS.take pcount rest+    put $ BS.dropWhile (== 0) $ BS.drop pcount rest+    pure $ BinTableHDU hd pcount heap darr++  binTableHeader :: Eff es (Fits.Dimensions, Int, Header)+  binTableHeader = do+    nextParser "BinTable Header" $ do+      (dm, pcount) <- Fits.parseBinTableKeywords+      hd <- Fits.parseHeader+      pure (dm, pcount, hd)+++parseMainData :: (State ByteString :> es) => Fits.Dimensions -> Eff es DataArray+parseMainData dm = do+  rest <- get+  let len = Fits.dataSize dm+  let dat = dataArray dm (BS.take len rest)+  put $ BS.dropWhile (== 0) $ BS.drop len rest+  pure dat+++-- | Parse HDUs by running MegaParsec parsers one at a time, tracking how much of the ByteString we've consumed+nextParser :: (Error HDUError :> es, State ByteString :> es) => String -> Fits.Parser a -> Eff es a+nextParser src parse = do+  bs <- get+  let st1 = M.initialState src bs+  case M.runParser' parse st1 of+    (st2, Right a) -> do+      -- only consumes input if it succeeds+      put $ BS.drop st2.stateOffset bs+      pure a+    (_, Left err) -> throwError $ FormatError $ ParseError err+++data HDUError+  = InvalidExtension String+  | MissingPrimary+  | FormatError FitsError+  | InvalidHDU [FitsError]+  deriving (Show, Exception)
+ src/Telescope/Fits/Encoding/Render.hs view
@@ -0,0 +1,205 @@+module Telescope.Fits.Encoding.Render where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Builder+import Data.ByteString.Lazy qualified as BL+import Data.Char (toUpper)+import Data.String (IsString (..))+import Data.Text (Text, isPrefixOf, pack, unpack)+import Data.Text qualified as T+import Telescope.Fits.Checksum+import Telescope.Fits.Types+++renderDataArray :: ByteString -> ByteString+renderDataArray dat = BS.toStrict $ runRender $ renderData dat+++renderData :: ByteString -> BuilderBlock+renderData s = fillBlock zeros $ BuilderBlock (BS.length s) $ byteString s+++renderImageHeader :: Header -> DataArray -> Checksum -> BuilderBlock+renderImageHeader h d dsum =+  fillBlock spaces $+    mconcat+      [ renderKeywordLine "XTENSION" (String "IMAGE   ") (Just "Image Extension")+      , renderDataKeywords d.bitpix d.axes+      , renderKeywordLine "PCOUNT" (Integer 0) Nothing+      , renderKeywordLine "GCOUNT" (Integer 1) Nothing+      , renderDatasum dsum+      , renderOtherKeywords h+      , renderEnd+      ]+++renderPrimaryHeader :: Header -> DataArray -> Checksum -> BuilderBlock+renderPrimaryHeader h d dsum =+  fillBlock spaces $+    mconcat+      [ renderKeywordLine "SIMPLE" (Logic T) (Just "Conforms to the FITS standard")+      , renderDataKeywords d.bitpix d.axes+      , renderKeywordLine "EXTEND" (Logic T) Nothing+      , renderDatasum dsum+      , renderOtherKeywords h+      , renderEnd+      ]+++renderDatasum :: Checksum -> BuilderBlock+renderDatasum dsum =+  mconcat+    [ renderKeywordLine "DATASUM" (checksumValue dsum) Nothing+    , -- encode the CHECKSUM as zeros, replace later in 'runRenderHDU'+      renderKeywordLine "CHECKSUM" (String (T.replicate 16 "0")) Nothing+    ]+++renderEnd :: BuilderBlock+renderEnd = pad 80 "END"+++-- | Render required keywords for a data array+renderDataKeywords :: BitPix -> Axes Column -> BuilderBlock+renderDataKeywords bp (Axes as) =+  mconcat+    [ bitpix+    , naxis_+    , naxes+    ]+ where+  bitpix = renderKeywordLine "BITPIX" (Integer $ bitPixCode bp) (Just $ "(" <> bitPixType bp <> ") array data type")+  naxis_ = renderKeywordLine "NAXIS" (Integer $ length as) (Just "number of axes in data array")+  naxes = mconcat $ zipWith @Int naxisN [1 ..] as+  naxisN n a =+    let nt = pack (show n)+     in renderKeywordLine ("NAXIS" <> nt) (Integer a) (Just $ "axis " <> nt <> " length")+  bitPixType = pack . drop 2 . show+  bitPixCode :: BitPix -> Int+  bitPixCode = \case+    BPInt8 -> 8+    BPInt16 -> 16+    BPInt32 -> 32+    BPInt64 -> 64+    BPFloat -> -32+    BPDouble -> -64+++-- | 'Header' contains all other keywords. Filter out any that match system keywords so they aren't rendered twice+renderOtherKeywords :: Header -> BuilderBlock+renderOtherKeywords (Header ks) =+  mconcat $ map toLine $ filter (not . isSystemKeyword) ks+ where+  toLine (Keyword kr) = renderKeywordLine kr._keyword kr._value kr._comment+  toLine (Comment c) = pad 80 $ string $ "COMMENT " <> unpack c+  toLine BlankLine = pad 80 ""+  isSystemKeyword (Keyword kr) =+    let k = kr._keyword+     in k == "BITPIX"+          || k == "EXTEND"+          || k == "DATASUM"+          || k == "CHECKSUM"+          || "NAXIS" `isPrefixOf` k+  isSystemKeyword _ = False+++-- | Fill out the header or data block to the nearest 2880 bytes+fillBlock :: (Int -> BuilderBlock) -> BuilderBlock -> BuilderBlock+fillBlock fill b =+  let rm = hduBlockSize - b.length `mod` hduBlockSize+   in b <> extraSpaces rm+ where+  extraSpaces n+    | n == hduBlockSize = mempty+    | otherwise = fill n+++-- Keyword Lines -----------------------------------------------------++renderKeywordLine :: Text -> Value -> Maybe Text -> BuilderBlock+renderKeywordLine k v mc =+  let kv = renderKeywordValue k v+   in pad 80 $ addComment kv mc+ where+  addComment kv Nothing = kv+  addComment kv (Just c) =+    let mx = 80 - kv.length+     in kv <> renderComment mx c+++renderKeywordValue :: Text -> Value -> BuilderBlock+renderKeywordValue k v =+  mconcat+    [ renderKeyword k+    , string "= "+    , pad 20 $ renderValue v+    ]+++renderKeyword :: Text -> BuilderBlock+renderKeyword k = pad 8 $ string $ map toUpper $ take 8 $ unpack k+++renderComment :: Int -> Text -> BuilderBlock+renderComment mx c = string $ take mx $ " / " <> unpack c+++renderValue :: Value -> BuilderBlock+renderValue (Logic T) = justify 20 "T"+renderValue (Logic F) = justify 20 "F"+renderValue (Float f) = justify 20 $ string $ map toUpper $ show f+renderValue (Integer n) = justify 20 $ string $ show n+renderValue (String s) = string $ "'" <> unpack s <> "'"+++-- Builder Block ---------------------------------------------------------++-- | A builder that keeps track of its length so we can pad and justify things+data BuilderBlock = BuilderBlock {length :: Int, builder :: Builder}+++-- | Smart constructor, don't allow negative lengths+builderBlock :: Int -> Builder -> BuilderBlock+builderBlock n = BuilderBlock (max n 0)+++-- | Execute a BuilderBlock and create a bytestring+runRender :: BuilderBlock -> BL.ByteString+runRender bb = toLazyByteString bb.builder+++instance IsString BuilderBlock where+  fromString = string+++instance Semigroup BuilderBlock where+  BuilderBlock l b <> BuilderBlock l2 b2 = BuilderBlock (l + l2) (b <> b2)+++instance Monoid BuilderBlock where+  mempty = BuilderBlock 0 mempty+++justify :: Int -> BuilderBlock -> BuilderBlock+justify n b = spaces (n - b.length) <> b+++pad :: Int -> BuilderBlock -> BuilderBlock+pad n b = b <> spaces (n - b.length)+++spaces :: Int -> BuilderBlock+spaces = padding (charUtf8 ' ')+++zeros :: Int -> BuilderBlock+zeros = padding (word8 0)+++padding :: Builder -> Int -> BuilderBlock+padding b n = builderBlock n . mconcat . replicate n $ b+++string :: String -> BuilderBlock+string s = builderBlock (length s) (stringUtf8 s)
+ src/Telescope/Fits/Header.hs view
@@ -0,0 +1,43 @@+module Telescope.Fits.Header+  ( Header (..)+  , Value (..)+  , keyword+  , addComment++    -- * Parsing Headers+  , FromHeader (..)+  , FromKeyword (..)++    -- * Creating Headers+  , ToHeader (..)+  , ToKeyword (..)+  , parseKeyword++    -- * Keyword Lookup+  , lookupKeyword+  , findKeyword+  , isKeyword+  , HeaderFor (..)++    -- * Re-exports+  , LogicalConstant (..)+  , getKeywords+  , HeaderRecord (..)+  , KeywordRecord (..)+  ) where++import Data.Fits hiding (isKeyword, lookup)+import Data.Text (Text)+import Telescope.Fits.Header.Class+import Telescope.Fits.Header.Keyword (findKeyword, isKeyword, lookupKeyword)+import Prelude hiding (lookup)+++-- | Construct a keyword HeaderRecord+keyword :: Text -> Value -> Maybe Text -> HeaderRecord+keyword k v mc = Keyword $ KeywordRecord k v mc+++-- | Set the comment of a KeywordRecrod+addComment :: Text -> KeywordRecord -> KeywordRecord+addComment c kr = kr{_comment = Just c}
+ src/Telescope/Fits/Header/Class.hs view
@@ -0,0 +1,213 @@+module Telescope.Fits.Header.Class where++import Data.Fits as Fits hiding (isKeyword)+import Data.Text (Text, pack)+import Data.Text qualified as T+import Effectful+import GHC.Generics+import Telescope.Data.Axes (AxisOrder (..))+import Telescope.Data.KnownText+import Telescope.Data.Parser+import Telescope.Data.WCS (CType (..), CUnit (..), WCSAxis (..), toWCSAxisKey)+import Telescope.Fits.Header.Keyword (lookupKeyword)+import Text.Casing (fromHumps, toSnake)+++class ToKeyword a where+  toKeywordValue :: a -> Value+++  -- Can ignore the selector name, modify it, etc+  toKeywordRecord :: Text -> a -> KeywordRecord+  default toKeywordRecord :: Text -> a -> KeywordRecord+  toKeywordRecord key a =+    KeywordRecord key (toKeywordValue a) Nothing+++instance ToKeyword Int where+  toKeywordValue = Integer+instance FromKeyword Int where+  parseKeywordValue = \case+    Integer n -> pure n+    v -> expected "Integer" v+++instance ToKeyword Float where+  toKeywordValue = Float+instance FromKeyword Float where+  parseKeywordValue = \case+    Float n -> pure n+    v -> expected "Float" v+++instance ToKeyword Text where+  toKeywordValue = String+instance FromKeyword Text where+  parseKeywordValue = \case+    String n -> pure n+    v -> expected "String" v+++instance ToKeyword Bool where+  toKeywordValue True = Logic T+  toKeywordValue False = Logic F+instance FromKeyword Bool where+  parseKeywordValue = \case+    Logic c -> pure $ c == T+    v -> expected "Logic" v+++instance ToKeyword CUnit where+  toKeywordValue (CUnit t) = toKeywordValue t+instance FromKeyword CUnit where+  parseKeywordValue = \case+    String t -> pure $ CUnit t+    v -> expected "CUnit" v+++instance ToKeyword CType where+  toKeywordValue (CType t) = toKeywordValue t+instance FromKeyword CType where+  parseKeywordValue = \case+    String t -> pure $ CType t+    v -> expected "CType" v+++class FromKeyword a where+  parseKeywordValue :: (Parser :> es) => Value -> Eff es a+++class ToHeader a where+  toHeader :: a -> Header+  default toHeader :: (Generic a, GToHeader (Rep a)) => a -> Header+  toHeader = gToHeader . from+++instance (ToHeader a) => ToHeader (Maybe a) where+  toHeader Nothing = mempty+  toHeader (Just a) = toHeader a+++instance (ToHeader a) => ToHeader [a] where+  toHeader = mconcat . fmap toHeader+++instance (AxisOrder ax, KnownText alt) => ToHeader (WCSAxis alt ax) where+  toHeader axis =+    mconcat+      [ axisKey "ctype" axis.ctype+      , axisKey "cunit" axis.cunit+      , axisKey "crpix" axis.crpix+      , axisKey "crval" axis.crval+      , axisKey "cdelt" axis.cdelt+      ]+   where+    axisKey :: (ToKeyword a) => String -> a -> Header+    axisKey s a =+      Header [Keyword $ toKeywordRecord (keyword s) a]++    keyword s = toWCSAxisKey @alt @ax $ cleanKeyword s+++class FromHeader a where+  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 (AxisOrder ax, KnownText alt) => FromHeader (WCSAxis alt ax) where+  parseHeader h = do+    ctype <- parseAxisKey "ctype" h+    cunit <- parseAxisKey "cunit" h+    crpix <- parseAxisKey "crpix" h+    crval <- parseAxisKey "crval" h+    cdelt <- parseAxisKey "cdelt" h+    pure $ WCSAxis{ctype, cunit, crpix, crval, cdelt}+   where+    parseAxisKey :: (FromKeyword a, Parser :> es) => String -> Header -> Eff es a+    parseAxisKey k = do+      parseKeyword (toWCSAxisKey @alt @ax $ cleanKeyword k)+++parseKeyword :: (FromKeyword a, Parser :> es) => Text -> Header -> Eff es a+parseKeyword k h =+  case Fits.lookup k h of+    Nothing -> parseFail $ "Missing key: " ++ show k+    Just v -> parseAt (Child k) $ parseKeywordValue v+++class GToHeader f where+  gToHeader :: f p -> Header+++instance (GToHeader f) => GToHeader (M1 D c f) where+  gToHeader (M1 f) = gToHeader f+++instance (GToHeader f) => GToHeader (M1 C c f) where+  gToHeader (M1 f) = gToHeader f+++instance (GToHeader f, GToHeader g) => GToHeader (f :*: g) where+  gToHeader (f :*: g) = gToHeader f <> gToHeader g+++instance {-# OVERLAPPABLE #-} (ToKeyword a, Selector s) => GToHeader (M1 S s (K1 R a)) where+  gToHeader (M1 (K1 a)) = keywordForField (selName (undefined :: M1 S s f p)) a+++instance {-# OVERLAPS #-} (ToKeyword a, Selector s) => GToHeader (M1 S s (K1 R (Maybe a))) where+  gToHeader (M1 (K1 Nothing)) = Header []+  gToHeader (M1 (K1 (Just a))) = keywordForField (selName (undefined :: M1 S s f p)) a+++instance {-# OVERLAPS #-} (ToHeader a, Selector s) => GToHeader (M1 S s (K1 R (HeaderFor a))) where+  gToHeader (M1 (K1 (HeaderFor a))) = toHeader a+++class GFromHeader f where+  gParseHeader :: (Parser :> es) => Header -> Eff es (f p)+++instance (GFromHeader f) => GFromHeader (M1 D c f) where+  gParseHeader h = M1 <$> gParseHeader h+++instance (GFromHeader f) => GFromHeader (M1 C c f) where+  gParseHeader h = M1 <$> gParseHeader h+++instance (GFromHeader f, GFromHeader g) => GFromHeader (f :*: g) where+  gParseHeader h = do+    f <- gParseHeader h+    g <- gParseHeader h+    pure $ f :*: g+++instance {-# OVERLAPPABLE #-} (FromKeyword a, Selector s) => GFromHeader (M1 S s (K1 R a)) where+  gParseHeader h = do+    let k = cleanKeyword $ selName (undefined :: M1 S s f p)+    M1 . K1 <$> parseKeyword k h+++instance {-# OVERLAPS #-} (FromKeyword a, Selector s) => GFromHeader (M1 S s (K1 R (Maybe a))) where+  gParseHeader h = do+    let k = cleanKeyword $ selName (undefined :: M1 S s f p)+    let mval = lookupKeyword k h :: Maybe Value+    M1 . K1 <$> case mval of+      Nothing -> pure Nothing+      Just v -> do+        a <- parseAt (Child k) $ parseKeywordValue v+        pure $ Just a+++cleanKeyword :: String -> Text+cleanKeyword = T.toUpper . pack . toSnake . fromHumps+++newtype HeaderFor a = HeaderFor a+++keywordForField :: (ToKeyword a) => String -> a -> Header+keywordForField selector a =+  Header [Keyword $ toKeywordRecord (cleanKeyword selector) a]
+ src/Telescope/Fits/Header/Keyword.hs view
@@ -0,0 +1,21 @@+module Telescope.Fits.Header.Keyword where++import Data.Fits as Fits hiding (isKeyword)+import Data.List qualified as L+import Data.Text (Text)+import Data.Text qualified as T+++-- | Manually look up a keyword from the header+lookupKeyword :: Text -> Header -> Maybe Value+lookupKeyword k = findKeyword (isKeyword k)+++findKeyword :: (KeywordRecord -> Bool) -> Header -> Maybe Value+findKeyword p h = do+  kr <- L.find p (getKeywords h)+  pure kr._value+++isKeyword :: Text -> KeywordRecord -> Bool+isKeyword k (KeywordRecord k2 _ _) = T.toLower k == T.toLower k2
+ src/Telescope/Fits/Types.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Telescope.Fits.Types+  ( Fits (..)+  , PrimaryHDU (..)+  , ImageHDU (..)+  , BinTableHDU (..)+  , DataArray (..)+  , Extension (..)+  , Axis+  , Axes (..)+  , Major (..)+  , BitPix (..)+  , bitPixBits+  , Header (..)+  , getKeywords+  , HeaderRecord (..)+  , KeywordRecord (..)+  , Value (..)+  , LogicalConstant (..)+  , hduBlockSize+  , emptyDataArray+  , IsBitPix (..)+  ) where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Fits (Header (..), HeaderRecord (..), KeywordRecord (..), LogicalConstant (..), Value (..), getKeywords, hduBlockSize)+import Data.List qualified as L+import GHC.Int+import Telescope.Data.Axes+++data PrimaryHDU = PrimaryHDU+  { header :: Header+  , dataArray :: DataArray+  }+++instance Show PrimaryHDU where+  show p = showHDU "PrimaryHDU" p.header p.dataArray+++data ImageHDU = ImageHDU+  { header :: Header+  , dataArray :: DataArray+  }+++instance Show ImageHDU where+  show p = showHDU "ImageHDU" p.header p.dataArray+++data BinTableHDU = BinTableHDU+  { header :: Header+  , pCount :: Int+  , heap :: ByteString+  , dataArray :: DataArray+  }+++instance Show BinTableHDU where+  show p = showHDU "BinTableHDU" p.header p.dataArray+++-- | Raw HDU Data. See 'Telescope.Fits.DataArray'+data DataArray = DataArray+  { bitpix :: BitPix+  , axes :: Axes Column+  , rawData :: BS.ByteString+  }+++instance Show DataArray where+  show d =+    L.intercalate+      "\n"+      [ "  data: " <> show (BS.length d.rawData) <> " bytes"+      , "  dimensions: "+      , "    format: " <> L.drop 2 (show d.bitpix)+      , "    axes: " <> show d.axes.axes+      ]+++showHDU :: String -> Header -> DataArray -> String+showHDU name h d =+  L.intercalate+    "\n"+    [ name+    , showHeader h+    , show d+    ]+++showHeader :: Header -> String+showHeader h =+  "  Header: " <> show (length $ getKeywords h)+++emptyDataArray :: DataArray+emptyDataArray = DataArray BPInt8 (Axes []) ""+++-- data BinaryTable = BinaryTable+--   { pCount :: Int+--   , heap :: ByteString+--   }++data Extension+  = Image ImageHDU+  | BinTable BinTableHDU+++instance Show Extension where+  show (Image i) = show i+  show (BinTable b) = show b+++data Fits = Fits+  { primaryHDU :: PrimaryHDU+  , extensions :: [Extension]+  }+++instance Show Fits where+  show f =+    show f.primaryHDU+      <> "\n"+      <> L.intercalate "\n" (fmap show f.extensions)+++data BitPix+  = BPInt8+  | BPInt16+  | BPInt32+  | BPInt64+  | BPFloat+  | BPDouble+  deriving (Show, Eq)+++bitPixBits :: BitPix -> Int+bitPixBits BPInt8 = 8+bitPixBits BPInt16 = 16+bitPixBits BPInt32 = 32+bitPixBits BPInt64 = 64+bitPixBits BPFloat = 32+bitPixBits BPDouble = 64+++class IsBitPix a where+  bitPix :: BitPix+++instance IsBitPix Int8 where+  bitPix = BPInt8+instance IsBitPix Int16 where+  bitPix = BPInt16+instance IsBitPix Int32 where+  bitPix = BPInt32+instance IsBitPix Int64 where+  bitPix = BPInt64+instance IsBitPix Float where+  bitPix = BPFloat+instance IsBitPix Double where+  bitPix = BPDouble
+ src/checksum.c view
@@ -0,0 +1,98 @@+#include "checksum.h"+#include <stdio.h>++// From FITS standard 4.0++int sum(int* array, int size) {+    int total = 0;+    for (int i = 0; i < size; i++) {+      total += array[i];+    }+    return total;+}++// J.5. Example C code for accumulating the checksum+// --------------------------------------------------++unsigned int checksum (+  unsigned char *buf,+  int length)+{++  unsigned int sum32 = 0;+  unsigned int hi, lo, hicarry, locarry, i;++  // Accumulate the sum of the high-order 16 bits and the */+  // low-order 16 bits of each 32-bit word, separately. */+  // The first byte in each pair is the most significant. */+  // This algorithm works on both big and little endian machines.+  hi = (sum32 >> 16);+  lo = sum32 & 0xFFFF;+  for (i=0; i < length; i+=4) {+    hi += ((buf[i] << 8) + buf[i+1]);+    lo += ((buf[i+2] << 8) + buf[i+3]);+  }++  // fold carry bits from each 16 bit sum into the other sum+  hicarry = hi >> 16;+  locarry = lo >> 16;++  while (hicarry || locarry) {+    hi = (hi & 0xFFFF) + locarry;+    lo = (lo & 0xFFFF) + hicarry;+    hicarry = hi >> 16;+    locarry = lo >> 16;+  }++  // Concatenate the high and low parts to form the full 32-bit checksum+  return (hi << 16) + lo;+}++++// J.6. Example C code for ASCII encoding+// --------------------------------------------------++unsigned int exclude[13] = {0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, 0x40, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, 0x60 };++int offset = 0x30; /* ASCII 0 (zero) */+unsigned long mask[4] = { 0xff000000, 0xff0000, 0xff00, 0xff };++void char_encode (+    unsigned int value, // 1's complement of the checksum value to be encoded+    char *ascii)        // Output 16-character encoded string+{+  int byte, quotient, remainder, ch[4], check, i, j, k; char asc[32];++  for (i=0; i < 4; i++) {+    /* each byte becomes four */+    byte = (value & mask[i]) >> ((3 - i) * 8);+    quotient = byte / 4 + offset;+    remainder = byte % 4;+    for (j=0; j < 4; j++)+      ch[j] = quotient;++    ch[0] += remainder;++    // avoid ASCII punctuation+    for (check=1; check;)+      for (check=0, k=0; k < 13; k++)+        for (j=0; j < 4; j+=2)+          if (ch[j]==exclude[k] || ch[j+1]==exclude[k]) {+            ch[j]++;+            ch[j+1]--;+            check++;+          }++    // assign the bytes+    for (j=0; j < 4; j++)+      asc[4*j+i] = ch[j];+  }++  // Permute the bytes for FITS+  for (i=0; i < 16; i++)+    ascii[i] = asc[(i+15)%16];++  // terminate the string+  ascii[16] = 0;+}
+ src/checksum.h view
@@ -0,0 +1,9 @@+#ifndef CHECKSUM_H+#define CHECKSUM_H++unsigned int checksum ( unsigned char *buf, int length);++void char_encode ( unsigned int value, char *ascii);++#endif+
+ telescope.cabal view
@@ -0,0 +1,148 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name:               telescope+version:            0.2.0+synopsis:           Astronomical Observations (FITS, ASDF, WCS, etc)+description:        Work with astronomical observations from modern telescopes+license:            BSD3+license-file:       LICENSE+author:             Sean Hess+maintainer:         Sean Hess <shess@nso.edu>+copyright:          (c) 2024 Sean Hess+category:           Science, Astronomy+homepage:           https://github.com/dkistdc/telescope.hs+build-type:         Simple+extra-source-files:+    README.md+    src/checksum.c+    src/checksum.h++library+    exposed-modules:+        Telescope.Asdf+        Telescope.Asdf.Class+        Telescope.Asdf.Core+        Telescope.Asdf.Encoding+        Telescope.Asdf.Encoding.File+        Telescope.Asdf.Encoding.Stream+        Telescope.Asdf.Error+        Telescope.Asdf.GWCS+        Telescope.Asdf.NDArray+        Telescope.Asdf.NDArray.Types+        Telescope.Asdf.Node+        Telescope.Asdf.Reference+        Telescope.Data.Array+        Telescope.Data.Axes+        Telescope.Data.Binary+        Telescope.Data.KnownText+        Telescope.Data.Parser+        Telescope.Data.WCS+        Telescope.Fits+        Telescope.Fits.Checksum+        Telescope.Fits.DataArray+        Telescope.Fits.Encoding+        Telescope.Fits.Encoding.Render+        Telescope.Fits.Header+        Telescope.Fits.Header.Class+        Telescope.Fits.Header.Keyword+        Telescope.Fits.Types+    other-modules:+        Paths_telescope+    build-depends:+        base >=4.7 && <5,+        binary >=0.8.9 && <0.9,+        byte-order >=0.1.3 && <0.2,+        bytestring >=0.11 && <0.13,+        casing >=0.1.4 && <0.2,+        conduit ==1.3.*,+        effectful >=2.3 && <3,+        exceptions ==0.10.*,+        fits-parse >=0.4.2 && <0.5,+        libyaml >=0.1.4 && <0.2,+        massiv ==1.0.*,+        megaparsec ==9.6.*,+        resourcet-effectful >=1.0.1 && <1.1,+        scientific ==0.3.*,+        text >=2.0 && <3,+        time >=1.12 && <2+    hs-source-dirs:+        src+    default-extensions:+        DataKinds+        DefaultSignatures+        DeriveAnyClass+        DerivingStrategies+        DuplicateRecordFields+        LambdaCase+        NoFieldSelectors+        OverloadedRecordDot+        OverloadedStrings+        QuasiQuotes+        StrictData+        TypeApplications+        TypeFamilies+    ghc-options: -Wall -fdefer-typed-holes+    c-sources:+        src/checksum.c+    default-language: GHC2021++test-suite spec+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    other-modules:+        Test.ArraySpec+        Test.Asdf.ClassSpec+        Test.Asdf.DecodeSpec+        Test.Asdf.EncodeSpec+        Test.Asdf.FileSpec+        Test.Asdf.GWCSSpec+        Test.Asdf.NDArraySpec+        Test.BinarySpec+        Test.Fits.ChecksumSpec+        Test.Fits.ClassSpec+        Test.Fits.EncodingSpec+        Paths_telescope+    hs-source-dirs:+        test/+    default-extensions:+        DataKinds+        DefaultSignatures+        DeriveAnyClass+        DerivingStrategies+        DuplicateRecordFields+        LambdaCase+        NoFieldSelectors+        OverloadedRecordDot+        OverloadedStrings+        QuasiQuotes+        StrictData+        TypeApplications+        TypeFamilies+    ghc-options: -Wall -fdefer-typed-holes -threaded -rtsopts -with-rtsopts=-N -F -pgmF=skeletest-preprocessor+    build-tool-depends:+        skeletest:skeletest-preprocessor+    build-depends:+        base >=4.7 && <5,+        binary,+        byte-order >=0.1.3 && <0.2,+        bytestring >=0.11 && <0.13,+        casing >=0.1.4 && <0.2,+        conduit ==1.3.*,+        containers,+        effectful >=2.3 && <3,+        exceptions ==0.10.*,+        fits-parse >=0.4.2 && <0.5,+        libyaml >=0.1.4 && <0.2,+        massiv ==1.0.*,+        megaparsec ==9.6.*,+        resourcet-effectful >=1.0.1 && <1.1,+        scientific ==0.3.*,+        skeletest,+        telescope,+        text >=2.0 && <3,+        time >=1.12 && <2+    default-language: GHC2021
+ test/Spec.hs view
@@ -0,0 +1,3 @@+import Skeletest.Main++
+ test/Test/ArraySpec.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedLists #-}++module Test.ArraySpec where++import Data.ByteString qualified as BS+import Data.Massiv.Array as M+import Data.Word (Word8)+import GHC.Int+import Skeletest+import System.ByteOrder+import Telescope.Data.Array+import Telescope.Data.Axes+import Telescope.Fits.DataArray+++spec :: Spec+spec = do+  describe "indices" testIndices+  describe "decode" $ do+    -- describe "vector" testDecode+    describe "array" testDecodeArray+    describe "image" testDecodeImage++  describe "encode" $ do+    describe "array/image" testEncode+++testIndices :: Spec+testIndices = do+  describe "axesIndex" $ do+    it "Ix1" $ do+      ix <- axesIndex $ toRowMajor $ Axes [10]+      ix `shouldBe` Ix1 10++    it "Ix2 in reverse order" $ do+      ix <- axesIndex $ toRowMajor $ Axes [3, 2]+      ix `shouldBe` 2 :. 3++    it "Ix3 in reverse order" $ do+      ix <- axesIndex $ toRowMajor $ Axes [3, 2, 1]+      ix `shouldBe` 1 :> 2 :. 3++  describe "indexAxes" $ do+    -- indexAxes produces row major+    it "Ix1" $ do+      indexAxes @Ix1 2 `shouldBe` Axes [2]++    it "Ix2 Row Major" $ do+      indexAxes (2 :. 3) `shouldBe` Axes [2, 3]++    it "Ix3 Row Major" $ do+      indexAxes (1 :> 2 :. 3) `shouldBe` Axes [1, 2, 3]++    it "Ix3 Column Major" $ do+      sizeAxes (Sz (1 :> 2 :. 3)) `shouldBe` Axes [3, 2, 1]+++-- generate a series of Word8+genInput :: Word8 -> BS.ByteString+genInput start = BS.pack [start .. start + 100]+++testDecodeArray :: Spec+testDecodeArray = do+  let input = genInput 0++  it "should parse int8 vector" $ do+    let v = decodeVector @Int8 Par BigEndian input+    computeAs P (M.take 6 v) `shouldBe` [0, 1, 2, 3, 4, 5]++  it "should decode Ix1 from vector" $ do+    let v = decodeVector @Int8 Par BigEndian input+    a <- fromVector @Ix1 (Axes [3]) $ M.take 3 v+    computeAs P a `shouldBe` [0, 1, 2]++  it "should decode Ix2" $ do+    a <- decodeArray @Ix2 @Int8 [2, 3] $ BS.take 6 input+    computeAs P a `shouldBe` [[0, 1, 2], [3, 4, 5]]++  it "should decode Ix3" $ do+    a <- decodeArray @Ix3 @Int8 [2, 2, 2] $ BS.take 8 input+    computeAs P a `shouldBe` [[[0, 1], [2, 3]], [[4, 5], [6, 7]]]+++testDecodeImage :: Spec+testDecodeImage = do+  let input = genInput 0+  it "should decode image" $ do+    a <- decodeArray @Ix2 @Int8 [2, 3] $ BS.take 6 input+    computeAs P a `shouldBe` [[0, 1, 2], [3, 4, 5]]+++testEncode :: Spec+testEncode = do+  let array = delay @Ix2 @P $ M.fromLists' Seq [[1, 2, 3], [4, 5, 6]] :: Array D Ix2 Int8++  it "should encode to 6 items" $ do+    BS.length (encodeArray array) `shouldBe` 6++  it "int8 should round-trip to original array" $ do+    let enc = encodeArray array :: BS.ByteString+    arr <- decodeArray @Ix2 @Int8 [2, 3] enc+    arr `shouldBe` array++  let arrayFloat = delay @Ix2 @P $ M.fromLists' Seq [[1, 2, 3], [4, 5, 6]] :: Array D Ix2 Float+  it "float should round-trip to original array" $ do+    let enc = encodeArray arrayFloat :: BS.ByteString+    arr <- decodeArray [2, 3] enc+    arr `shouldBe` arrayFloat++  let arrayInt = delay @Ix2 @P $ M.fromLists' Seq [[1, 2, 3], [4, 5, 6]] :: Array D Ix2 Int+  it "int should round-trip to original array" $ do+    let enc = encodeArray arrayInt :: BS.ByteString+    arr <- decodeArray [2, 3] enc+    arr `shouldBe` arrayInt++  it "should encode naxes in correct order" $ do+    size array `shouldBe` Sz (2 :. 3)+    sizeAxes (size array) `shouldBe` Axes [3, 2]
+ test/Test/Asdf/ClassSpec.hs view
@@ -0,0 +1,206 @@+module Test.Asdf.ClassSpec where++import Conduit+import Data.ByteString (ByteString)+import Data.Massiv.Array (Array, Comp (..), D, Ix1, P)+import Data.Massiv.Array qualified as M+import Data.Text (Text)+import Effectful.Resource+import GHC.Generics (Generic, from)+import GHC.Int (Int32, Int64)+import Skeletest+import System.ByteOrder+import Telescope.Asdf.Class+import Telescope.Asdf.Encoding+import Telescope.Asdf.Encoding.File+import Telescope.Asdf.Error+import Telescope.Asdf.NDArray+import Telescope.Asdf.Node+import Telescope.Data.Axes+import Telescope.Data.Parser+import Test.Asdf.DecodeSpec (ExampleTreeFix (..), parseIO)+import Text.Libyaml qualified as Yaml+++spec :: Spec+spec = do+  describe "FromAsdf" fromAsdfSpec+  describe "ToAsdf" toAsdfSpec+  describe "GObject" gObjectSpec+++fromAsdfSpec :: Spec+fromAsdfSpec = do+  it "parses object" $ do+    let (tree :: Object) =+          [ ("foo", fromValue $ Integer 42)+          , ("name", fromValue $ String "Monty")+          , ("sequence", fromValue $ Array $ fmap (fromValue . Integer) [0 .. 99])+          , ("random", fromValue $ NDArray $ NDArrayData "" BigEndian Float64 (axesRowMajor [0]))+          ]+    ex <- parseIO $ parseValue @Example (Object tree)+    ex.foo `shouldBe` 42+    ex.name `shouldBe` "Monty"+    ex.sequence `shouldBe` [0 .. 99]++  it "parses sequence from example.asdf as an NDArray" $ do+    ExampleTreeFix (Tree tree) <- getFixture+    (Sequence s) <- parseIO $ parseValue @Sequence (Object tree)+    s `shouldBe` M.delay (M.fromLists' @P Seq [0 .. 99])++  it "resolves anchors" $ do+    let ex = AnchorExample "world" "asdf"+    out <- runAsdfM $ encode ex+    ex2 <- runAsdfM $ decode @AnchorExample out+    ex2.message `shouldBe` "world"+    ex2.alias `shouldBe` "world"+++toAsdfSpec :: Spec+toAsdfSpec = do+  it "should serialize Example" $ do+    let ex = Example{foo = 40, name = "Marty", sequence = [], powers = Nothing, random = M.empty}+    let Node s anc val = toNode ex+    s `shouldBe` schema ex+    anc `shouldBe` Just "example"+    o <- expectObject val+    lookup "foo" o `shouldBe` Just (Node mempty Nothing (Integer 40))+    lookup "name" o `shouldBe` Just (Node mempty Nothing (String "Marty"))++  it "should serialize Example sequence as list" $ do+    let val = toValue $ Example{foo = 40, name = "Marty", sequence = [0 .. 99], powers = Nothing, random = M.empty}+    o <- expectObject val+    ns <- expectArray $ lookup "sequence" o+    ns `shouldBe` fmap (fromValue . Integer) [0 .. 99]++  it "should serialize list to Array" $ do+    let nums = [0 .. 99] :: [Int]+    toValue nums `shouldBe` Array (fmap (Node mempty Nothing . Integer) [0 .. 99])++  it "should forward schema to maybes" $ do+    schema @(Maybe Example) Nothing `shouldBe` mempty+    schema @(Maybe Example) (Just undefined) `shouldBe` schema @Example undefined++++-- it "should produce similar example.asdf" $ do+--   ExampleFileFix inp _ <- getFixture+--   e <- decodeM @Example inp+--   -- o <- encodeM e+--   -- BS.writeFile "dump/test.asdf" o+--   -- print e+--   fail ":NOPE"++gObjectSpec :: Spec+gObjectSpec = do+  it "should gen object" $ do+    gToObject (from (TinyGen "world")) `shouldBe` [("hello", fromValue (String "world"))]++  it "should gen tiny type" $ do+    toValue (TinyGen "world") `shouldBe` Object [("hello", fromValue (String "world"))]++  it "should gen maybe type" $ do+    toValue (MaybeGen (Just "world")) `shouldBe` Object [("hello", fromValue (String "world"))]+    toValue (MaybeGen Nothing) `shouldBe` Object [("hello", fromValue Null)]++  it "should allow maybes" $ do+    let val = Object [("hello", fromValue (String "world"))]+    m1 <- parseIO (parseValue val)+    m1 `shouldBe` MaybeGen (Just "world")++    m2 <- parseIO (parseValue $ Object [])+    m2 `shouldBe` MaybeGen Nothing+++-- newtype ExampleAsdfFix = ExampleAsdfFix Asdf+-- instance Fixture ExampleAsdfFix where+--   fixtureAction = do+--     ExampleFileFix _ f <- getFixture+--     a <- runAsdfM $ fromAsdfFile f.tree f.blocks+--     pure $ noCleanup $ ExampleAsdfFix a++dumpEvents :: ByteString -> IO ()+dumpEvents inp = do+  runAsdfM $ do+    a <- splitAsdfFile inp+    runResource $ runConduit $ Yaml.decode a.tree.bytes .| takeC 100 .| mapM_C (liftIO . print)+++data TinyGen = TinyGen+  { hello :: Text+  }+  deriving (Generic, FromAsdf, ToAsdf)+++data MaybeGen = MaybeGen+  { hello :: Maybe Text+  }+  deriving (Generic, FromAsdf, ToAsdf, Eq)+++data Example = Example+  { foo :: Int32+  , name :: Text+  , powers :: Maybe Powers+  , sequence :: [Int64]+  , random :: Array D Ix1 Double+  }+  deriving (Generic, Show)+instance ToAsdf Example where+  schema _ = "example/woot-1.0"+  anchor _ = Just "example"+instance FromAsdf Example where+  parseValue = \case+    Object o -> do+      foo <- o .: "foo"+      name <- o .: "name"+      sq <- o .: "sequence" >>= parseSequence+      powers <- o .:? "powers"+      random <- o .: "random"+      pure $ Example{foo, name, sequence = sq, powers, random}+    val -> expected "Example" val+   where+    parseSequence = \case+      Array ns -> mapM parseNode ns+      NDArray nd -> fromNDArray nd+      val -> expected "Array or NDArray" val+++data Powers = Powers+  {squares :: Array D Ix1 Int64}+  deriving (Generic, Show, ToAsdf, FromAsdf)+++data Sequence = Sequence (Array D Ix1 Int64)+  deriving (Eq)+instance FromAsdf Sequence where+  parseValue = \case+    Object o -> do+      sql <- o .: "sequence"+      pure $ Sequence sql+    node -> expected "Example Sequence" node+++data AnchorExample = AnchorExample+  { message :: Text+  , alias :: Text+  }+  deriving (Generic, FromAsdf)+instance ToAsdf AnchorExample where+  toValue ae =+    Object+      [ ("message", Node mempty (Just "message") $ String ae.message)+      , ("alias", toNode $ Alias "message")+      ]+++expectArray :: Maybe Node -> IO [Node]+expectArray = \case+  Just (Node _ _ (Array ns)) -> pure ns+  n -> fail $ "Expected Array, but got: " ++ show n+++expectObject :: Value -> IO Object+expectObject = \case+  Object o -> pure o+  n -> fail $ "Expected Object, but got: " ++ show n
+ test/Test/Asdf/DecodeSpec.hs view
@@ -0,0 +1,270 @@+module Test.Asdf.DecodeSpec where++import Control.Monad.Catch (throwM)+import Data.ByteString qualified as BS+import Data.List (find)+import Data.Massiv.Array (Array, D, Ix1)+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+import Skeletest.Predicate qualified as P+import Telescope.Asdf.Class+import Telescope.Asdf.Core+import Telescope.Asdf.Encoding+import Telescope.Asdf.Encoding.File+import Telescope.Asdf.Error+import Telescope.Asdf.Node+import Telescope.Asdf.Reference+import Telescope.Data.Parser+import Test.Asdf.FileSpec (ExampleFileFix (..))+++spec :: Spec+spec = do+  describe "basic" basicSpec+  describe "example" exampleSpec+  describe "dkist" dkistSpec+  describe "references" referenceSpec+  describe "anchors" anchorSpec+++basicSpec :: Spec+basicSpec = do+  describe "basic" $ do+    it "should parse asdf" $ do+      ExampleTreeFix tree <- getFixture+      a :: Asdf <- runAsdfM $ decodeFromTree tree+      a.library.name `shouldBe` "asdf"+      length a.history.extensions `shouldBe` 1++    it "should parse tree" $ do+      ExampleTreeFix (Tree tree) <- getFixture+      lookup "foo" tree `shouldBe` Just (Node mempty Nothing (Integer 42))+      lookup "name" tree `shouldBe` Just (Node mempty Nothing (String "Monty"))+++exampleSpec :: Spec+exampleSpec = do+  it "should parse example.asdf" $ do+    inp <- BS.readFile "samples/example.asdf"+    e <- decodeM @Example inp+    e.name `shouldBe` "Monty"+    e.foo `shouldBe` 42+    e.items `shouldBe` ["one", "two", "three", "four", "five"]+++data Example = Example+  { foo :: Int+  , name :: Text+  , items :: [Text]+  }+  deriving (Generic, FromAsdf, ToAsdf)+++anchorSpec :: Spec+anchorSpec = do+  it "should create anchors" $ do+    let Encoded out = encodeTree "{hello: &hello world}"+    f <- runAsdfM $ splitAsdfFile out+    (_, ancs) <- runAsdfM $ streamAsdfFile f.tree f.blocks+    ancs `shouldBe` Anchors [("hello", String "world")]++  it "should throw missing anchors" $ do+    f <- runAsdfM $ do+      let tree = encodeTree "{message: *somealias}"+      pure $ AsdfFile tree mempty ""+    runAsdfM (streamAsdfFile f.tree f.blocks) `shouldSatisfy` P.throws @AsdfError P.anything++  it "should throw if alias before anchor" $ do+    let Encoded out = encodeTree "{message: *hello, hello: &hello world}"+    decodeM @Tree out `shouldSatisfy` P.throws @AsdfError P.anything++  it "should succeed if anchor before alias" $ do+    let Encoded out = encodeTree "{hello: &hello world, message: *hello}"+    Tree tree <- decodeM @Tree out+    lookup "message" tree `shouldBe` Just "world"++  it "should decode anchors roundtrip" $ do+    let root = [("hello", Node mempty (Just "hello") (String "world")), ("message", toNode $ Alias "hello")] :: Object+    out <- runAsdfM $ encode (Object root)+    Tree tree <- decodeM @Tree out+    lookup "message" tree `shouldBe` Just "world"+++referenceSpec :: Spec+referenceSpec = do+  it "should parse pointers" $ do+    jsonPointer "/users/1/name" `shouldBe` JSONPointer (Path [Child "users", Index 1, Child "name"])+    jsonPointer "" `shouldBe` JSONPointer (Path [])+    jsonPointer "#" `shouldBe` JSONPointer (Path [])+    jsonPointer "/" `shouldBe` JSONPointer (Path [])+    jsonPointer "users" `shouldBe` JSONPointer (Path [Child "users"])+    jsonPointer "/users" `shouldBe` JSONPointer (Path [Child "users"])+    jsonPointer "#users" `shouldBe` JSONPointer (Path [Child "users"])++  it "should parse an internal pointer as a reference" $ do+    jsonReference "#/users/1/name" `shouldBe` JSONReference mempty (jsonPointer "#/users/1/name")++  it "should parse an external reference" $ do+    let url = "https://woot.com/asdf"+    let point = "#/users/1/name"+    jsonReference (url <> point) `shouldBe` JSONReference url (jsonPointer point)++  it "should show pointers" $ do+    let point = JSONPointer (Path [Child "users", Index 0, Child "name"])+    show point `shouldBe` "#/users/0/name"++  it "should show references" $ do+    let point = JSONPointer (Path [Child "users", Index 0, Child "name"])+    let uri = "https://example.com/document.asdf/"+    show (JSONReference uri point) `shouldBe` "https://example.com/document.asdf/#/users/0/name"++  it "should locate pointer" $ do+    RefTreeFix tree <- getFixture+    n0 <- parseIO $ findPointer (jsonPointer "#/users/0/name") tree+    n0 `shouldBe` "Monty"++    n1 <- parseIO $ findPointer (jsonPointer "/users/1/name") tree+    n1 `shouldBe` "Harold"+++-- I don't think we should automatically resolve any internal references. Assume all references are external+-- it "parses Internal Ref to CurrentUsername with tree" $ do+--   RefTreeFix (Tree tree) <- getFixture+--   cu <- runParse $ runAsdfParser (Tree tree) $ parseValue @CurrentUsername (InternalRef $ pointer "#/users/2/name")+--   cu `shouldBe` CurrentUsername "Sandra"+--+-- it "parses Internal Ref to RefResolved with tree" $ do+--   RefTreeFix (Tree tree) <- getFixture+--   r <- runParse $ runAsdfParser (Tree tree) $ parseValue @RefResolved (Object tree)+--   length r.users `shouldBe` 3+--   r.currentUsername `shouldBe` CurrentUsername "Harold"+--+-- it "should parse internal references from sample file" $ do+--   inp <- BS.readFile "./samples/reference.asdf"+--   r <- decodeM @RefResolved inp+--   length r.users `shouldBe` 3+--   fmap (.name) r.users `shouldBe` ["Monty", "Harold", "Sandra"]+--   r.currentUsername `shouldBe` CurrentUsername "Harold"++-- data RefResolved = RefResolved+--   { currentUsername :: CurrentUsername+--   , users :: [RefUser]+--   }+--   deriving (Generic, FromAsdf, Show)+--+--+-- data RefUser = RefUser+--   { name :: Text+--   }+--   deriving (Generic, FromAsdf, Show)++-- newtype CurrentUsername = CurrentUsername Text+--   deriving (Show, Eq)+-- instance FromAsdf CurrentUsername where+--   parseValue = \case+--     String s -> pure $ CurrentUsername s+--     -- TODO: this should be automagic+--     InternalRef p -> parsePointer p+--     val -> expected "UsernameRef" val+-- instance ToAsdf CurrentUsername where+--   toValue (CurrentUsername _) = InternalRef $ pointer "/users/2/name"++dkistSpec :: Spec+dkistSpec = do+  it "should parse dkist asdf" $ do+    inp <- BS.readFile "samples/dkist.asdf"+    d <- decodeM @DKISTAsdf inp+    d.dataset.unit `shouldBe` Count+    d.dataset.meta.inventory.datasetId `shouldBe` "AVORO"++    let us = d.dataset.meta.headers.bunit+    take 3 us `shouldBe` ["ct", "ct", "ct"]++    take 3 (M.toLists d.dataset.meta.headers.naxis2) `shouldBe` [998, 998, 998]+++data DKISTAsdf = DKISTAsdf+  { dataset :: Dataset+  }+  deriving (Generic, FromAsdf)+++data Dataset = Dataset+  { unit :: Unit+  , meta :: Meta+  }+  deriving (Generic, FromAsdf)+++data Meta = Meta+  { headers :: MetaHeaders+  , inventory :: MetaInventory+  }+  deriving (Generic, FromAsdf)+++data MetaInventory = MetaInventory+  { bucket :: Text+  , datasetId :: Text+  }+  deriving (Generic, FromAsdf)+++-- can we make this work with a generic?+data MetaHeaders = MetaHeaders+  { naxis :: Array D Ix1 Int64+  , naxis2 :: Array D Ix1 Int64+  , bitpix :: [Int64]+  , bunit :: [Text]+  }+++instance FromAsdf MetaHeaders where+  parseValue = \case+    Object o -> do+      ns <- o .: "columns"+      naxis <- parseColumn "NAXIS" ns+      naxis2 <- parseColumn "NAXIS2" ns+      bitpix <- parseColumn "BITPIX" ns+      bunit <- parseColumn "BUNIT" ns+      pure MetaHeaders{naxis, naxis2, bitpix, bunit}+    val -> expected "Columns" val+   where+    parseColumn :: forall a es. (FromAsdf a, Parser :> es) => Text -> [Node] -> Eff es a+    parseColumn name ns = do+      case find (isColumnName name) ns of+        Just (Node _ _ (Object o)) ->+          o .: "data"+        _ -> parseFail $ "Column " ++ unpack name ++ " not found"++    isColumnName n = \case+      Node _ _ (Object o) -> do+        lookup "name" o == Just (Node mempty Nothing (String n))+      _ -> False+++newtype ExampleTreeFix = ExampleTreeFix Tree+instance Fixture ExampleTreeFix where+  fixtureAction = do+    ExampleFileFix _ f <- getFixture+    tree <- runAsdfM $ parseAsdfTree f.tree f.blocks+    pure $ noCleanup $ ExampleTreeFix tree+++newtype RefTreeFix = RefTreeFix Tree+instance Fixture RefTreeFix where+  fixtureAction = do+    let user n = toNode $ Object [("name", toNode (String n))]+    let users = toNode $ Array [user "Monty", user "Harold", user "Sandra"]+    let curr = toNode $ Reference $ JSONReference mempty (jsonPointer "#/users/1/name")+    let tree = Tree [("users", users), ("currentUsername", toNode curr)]+    pure $ noCleanup $ RefTreeFix tree+++parseIO :: Eff '[Parser, Error ParseError, IOE] a -> IO a+parseIO p = runEff $ runErrorNoCallStackWith @ParseError throwM $ runParser p
+ test/Test/Asdf/EncodeSpec.hs view
@@ -0,0 +1,285 @@+module Test.Asdf.EncodeSpec where++import Control.Monad (forM_)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BC+import Data.Massiv.Array (Array, Comp (Seq), D, Ix2, P)+import Data.Massiv.Array qualified as M+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import GHC.Generics (Generic)+import GHC.Int (Int16, Int64)+import Skeletest+import Skeletest.Predicate qualified as P+import Telescope.Asdf.Class+import Telescope.Asdf.Core+import Telescope.Asdf.Encoding+import Telescope.Asdf.Encoding.File+import Telescope.Asdf.Error+import Telescope.Asdf.NDArray+import Telescope.Asdf.Node+import Telescope.Data.Parser (expected)+import Test.Asdf.ClassSpec (expectObject)+++spec :: Spec+spec = do+  describe "basic" basicSpec+  describe "document" documentSpec+  describe "blocks" blocksSpec+  describe "roundtrip" roundSpec+  describe "stream" streamSpec+  describe "external verification" externalSpec+  describe "references" referenceSpec+  describe "anchors" anchorSpec+++anchorSpec :: Spec+anchorSpec = do+  it "should encode an anchor" $ do+    (out, _) <- runAsdfM . encodeNode $ Node mempty (Just "woot") "hello"+    out `shouldBe` "&woot 'hello'\n"++  it "should encode an alias" $ do+    let alias = toNode $ Alias $ Anchor "something" :: Node+    let anc = Node mempty (Just "something") "something"+    (out, _) <- runAsdfM . encodeNode $ toNode $ Array [anc, alias]+    out `shouldBe` "[&something 'something', *something]\n"++  it "should not encode anchors to mappings" $ do+    (out, _) <- runAsdfM . encodeNode $ Node mempty (Just "thing") (Object [("hello", "world")])+    let outt = T.decodeUtf8 out+    length (T.splitOn "&thing" outt) `shouldBe` 2+    out `shouldBe` "&thing {hello: world}\n"++  it "should not encode anchors to array members" $ do+    (out, _) <- runAsdfM . encodeNode $ Node mempty (Just "thing") (Array ["one", "two"])+    let outt = T.decodeUtf8 out+    length (T.splitOn "&thing" outt) `shouldBe` 2+    out `shouldBe` "&thing [one, two]\n"++  it "should throw if alias before anchor" $ do+    let vals = [toNode $ Alias "two", Node mempty (Just "two") "two"]+    runAsdfM (encodeNode $ toNode (Array vals)) `shouldSatisfy` P.throws @AsdfError P.anything+++referenceSpec :: Spec+referenceSpec = do+  it "should encode a pointer" $ do+    let ref = JSONReference mempty (jsonPointer "#/users/1/name")+    (out, _) <- runAsdfM . encodeNode $ toNode $ Reference ref+    out `shouldBe` "{$ref: '#/users/1/name'}\n"++  it "should encode a reference" $ do+    let ref = JSONReference "https://woot.com/" (jsonPointer "#/users/1/name")+    (out, _) <- runAsdfM . encodeNode $ toNode $ Reference ref+    out `shouldBe` "{$ref: 'https://woot.com/#/users/1/name'}\n"++  it "should roundtrip reference" $ do+    let ref = Reference $ JSONReference mempty (jsonPointer "#/users/1/name")+    let tree = Object [("username", toNode ref)]+    out <- encodeM tree+    obj <- decodeM @Value out >>= expectObject+    lookup "username" obj `shouldBe` Just (Node mempty Nothing ref)+++-- it "should rountrip and resolve references" $ do+--   let pn = PointyName "pip"+--   toValue pn `shouldBe` InternalRef (pointer "/names/2")+--+--   let pd = PointyData pn ["bob", "pip", "will"]+--   out <- encodeM pd+--   pd2 <- decodeM @PointyData out+--+--   pd2.other `shouldBe` PointyName "will"++basicSpec :: Spec+basicSpec = do+  it "starts with required header lines" $ do+    out <- encodeM (Object [])+    (l1 : l2 : l3 : l4 : doc1 : _) <- pure $ BC.lines out+    l1 `shouldBe` "#ASDF 1.0.0"+    l2 `shouldBe` "#ASDF_STANDARD 1.5.0"+    l3 `shouldBe` "%YAML 1.1"+    l4 `shouldBe` "%TAG ! tag:stsci.edu:asdf/"+    BS.take 4 doc1 `shouldBe` "--- "++  it "should include history" $ do+    out <- encodeM (Object [])+    let (_, restL) = BS.breakSubstring "asdf_library:" out+    BS.length restL `shouldNotBe` 0+    let (_, restH) = BS.breakSubstring "history:" out+    BS.length restH `shouldNotBe` 0++  it "should throw if not an object" $ do+    encodeM (Integer 100) `shouldSatisfy` P.throws @AsdfError P.anything+++streamSpec :: Spec+streamSpec = do+  it "should encode an empty string as empty single quotes" $ do+    let unit = fromValue $ String ""+    let obj = Object [("unit", unit)]+    (out, _) <- runAsdfM . encodeNode $ toNode obj+    out `shouldBe` "{unit: ''}\n"+++documentSpec :: Spec+documentSpec = do+  it "converts to document" $ do+    asdf <- runAsdfM $ toAsdfDoc $ BasicData "henry"+    asdf.library.name `shouldBe` "telescope.hs"+    let Tree tree = asdf.tree+    lookup "username" tree `shouldBe` Just "henry"+++blocksSpec :: Spec+blocksSpec = do+  it "includes blocks" $ do+    let ns = [1 .. 100]+    out <- encodeM (BasicArray ns)+    af <- runAsdfM $ splitAsdfFile out+    length af.blocks `shouldBe` 1++    [BlockData bd] <- runAsdfM $ mapM decodeBlock af.blocks+    bd `shouldBe` (toNDArray ns).bytes++  describe "index" $ do+    it "increeasing" $ do+      let nd1 = toNDArray ([1 .. 10] :: [Int64])+      let nd2 = toNDArray $ matrix @Int64 [[1, 2, 3], [4, 5, 6], [7, 8, 9]]+      let blks = fmap (encodeBlock . BlockData) [nd1.bytes, nd2.bytes, nd1.bytes]+      let tree = "1234567890"+      let BlockIndex ix = blockIndex tree blks+      length ix `shouldBe` 3+      [i1, i2, i3] <- pure ix+      let start = BS.length tree.bytes+      i1 `shouldBe` start+      i2 `shouldSatisfy` P.gt (start + (10 * 8))+      i3 `shouldSatisfy` P.gt i2++    it "equivalent to example.asdf" $ do+      inp <- BS.readFile "samples/example.asdf"+      e <- decodeM @Value inp+      e `shouldSatisfy` P.con (Object P.anything)+      af <- runAsdfM $ toAsdfDoc e >>= encodeAsdf+      length af.blocks `shouldBe` 3++      let BlockIndex ix = blockIndex af.tree af.blocks+      length ix `shouldBe` 3+      (i1 : _) <- pure ix++      i1 `shouldBe` BS.length af.tree.bytes+      fmap (subtract i1) ix `shouldBe` fmap (subtract 897) [897, 1751, 2605]++    it "addresses blocks" $ do+      inp <- BS.readFile "samples/example.asdf"+      e <- decodeM @Value inp+      o <- encodeM e+      BlockIndex ix <- runAsdfM $ do+        a <- toAsdfDoc e+        af <- encodeAsdf a+        pure $ blockIndex af.tree af.blocks+      forM_ ix $ \n -> do+        BS.take 4 (BS.drop n o) `shouldBe` blockMagicToken+++roundSpec :: Spec+roundSpec = do+  it "decodes encoded file" $ do+    out <- encodeM (Object [("hello", "world")])+    tree <- decodeM @Value out >>= expectObject+    lookup "hello" tree `shouldSatisfy` P.just (P.eq "world")++  it "encodes data type fields" $ do+    out <- encodeM $ BasicData "hello"+    let (_, nameRest) = BS.breakSubstring "username: hello" out+    nameRest `shouldNotBe` ""++  it "encodes simple ndarray" $ do+    out <- encodeM $ BasicArray [1 .. 100]+    BasicArray ns <- decodeM out+    ns `shouldBe` [1 .. 100]++  it "encodes massiv array" $ do+    let mx = matrix [[1.0 .. 5.0], [2.0 .. 6.0]]+    out <- encodeM $ Matrix mx++    -- TEST: throws an error if NDArrayData.shape doesn't match+    Matrix ns <- decodeM out+    ns `shouldBe` mx++  it "decodes encoded data type" $ do+    let sd = SomeData 24 ["one", "two"] $ matrix [[1, 2, 3], [4, 5, 6]]+    out <- encodeM sd+    sd2 <- decodeM @SomeData out+    sd2.number `shouldBe` sd.number+    sd2.tags `shouldBe` sd.tags+    sd2.matrix `shouldBe` sd.matrix+++externalSpec :: Spec+externalSpec = do+  it "saves encoded document to an asdf for external verification in python" $ do+    let sd = SomeData 24 ["one", "two"] $ matrix [[1, 2, 3], [4, 5, 6]]+    out <- encodeM sd+    BS.writeFile "samples/generated.asdf" out+++matrix :: (M.Prim n) => [[n]] -> Array D Ix2 n+matrix ns = M.delay @Ix2 @P $ M.fromLists' Seq ns+++newtype BasicArray = BasicArray [Int64]+instance ToAsdf BasicArray where+  toValue (BasicArray ns) =+    Object+      [("values", fromValue $ NDArray $ toNDArray ns)]+instance FromAsdf BasicArray where+  parseValue = \case+    Object o -> do+      nd <- o .: "values"+      ns <- fromNDArray nd+      pure $ BasicArray ns+    val -> expected "BasicArray.values" val+++data Matrix = Matrix+  { values :: Array D Ix2 Double+  }+  deriving (Generic, ToAsdf, FromAsdf)+++data BasicData = BasicData+  { username :: Text+  }+  deriving (Generic, ToAsdf, FromAsdf)+++data SomeData = SomeData+  { number :: Int+  , tags :: [Text]+  , matrix :: Array D Ix2 Int16+  }+  deriving (Generic, ToAsdf, FromAsdf)++-- TEST: round trip file parts+-- TEST: round trip is the only good way++-- data PointyData = PointyData+--   { other :: PointyName+--   , names :: [Text]+--   }+--   deriving (Generic, FromAsdf, ToAsdf, Show, Eq)+--+--+-- newtype PointyName = PointyName Text+--   deriving (Show, Eq)+-- instance ToAsdf PointyName where+--   toValue (PointyName _) = InternalRef (pointer "/names/2")+-- instance FromAsdf PointyName where+--   parseValue = \case+--     String s -> pure $ PointyName s+--     InternalRef p -> parsePointer p+--     other -> expected "PointyName Ref" other
+ test/Test/Asdf/FileSpec.hs view
@@ -0,0 +1,235 @@+module Test.Asdf.FileSpec where++import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Effectful+import Effectful.NonDet+import Effectful.State.Static.Local+import Skeletest+import Skeletest.Predicate ((>>>))+import Skeletest.Predicate qualified as P+import Telescope.Asdf.Encoding.File+import Telescope.Asdf.Error+++spec :: Spec+spec = do+  describe "blocks" testBlocks+  describe "split-file" testSplit+++testBlocks :: Spec+testBlocks = do+  let blockHeadZero = BlockHeader 1 0 NoCompression 0 0 0 noChecksum++  describe "BlockHeader" $ do+    it "should parse zero" $ do+      let bh = runPut (putBlockHeader blockHeadZero)+      goGet getBlockHeader bh `shouldBe` Right blockHeadZero++    it "should create from data" $ do+      let block = BlockData "hello"+      let bh = blockHeader block++      bh.allocatedSize `shouldBe` 5+      bh.usedSize `shouldBe` 5+      bh.allocatedSize `shouldBe` 5+      bh.usedSize `shouldBe` 5+      bh.dataSize `shouldBe` 5+      bh.headerSize `shouldSatisfy` P.gte 48++  describe "putBlock" $ do+    it "puts a header" $ do+      runPut (putBlockHeader blockHeadZero) `shouldSatisfy` (BL.length >>> P.gt 10)++    it "puts a block" $ do+      runPut (putBlock $ BlockData "hello") `shouldSatisfy` (BL.length >>> P.gt 10)++  describe "getBlock" $ do+    it "fails on empty data" $ do+      goGet getBlock "" `shouldSatisfy` P.left P.anything++    it "fails if missing magic byte" $ do+      goGet getBlock "asdf" `shouldSatisfy` P.left P.anything++    it "puts an empty block" $ do+      let out = runPut (putBlock $ BlockData "")+      goGet getBlock out `shouldBe` Right (BlockData "")++  describe "getBlocks" $ do+    it "looks ahead without failing" $ do+      goGet checkMagicToken "asdf" `shouldBe` Right False++    it "gets a single block" $ do+      let out = runPut (putBlock $ BlockData "")+      goGet getBlocks out `shouldBe` Right [BlockData ""]++    it "gets empty array" $ do+      goGet getBlocks "" `shouldBe` Right []+ where+  goGet a bs =+    case runGetOrFail a bs of+      Left e -> Left e+      Right (_, _, x) -> Right x+++testSplit :: Spec+testSplit = do+  describe "parse tree" $ do+    it "empty" $ do+      t <- runParse "" parseTree+      t `shouldBe` Encoded ""++    it "tree only" $ do+      (t, rest) <- runParse "value" $ do+        t <- parseTree+        rest <- get @ByteString+        pure (t, rest)+      t `shouldBe` Encoded "value"+      rest `shouldBe` ""++    it "tree with data" $ do+      let Encoded bks = encodeBlock (BlockData "woot")+      let inp = "value\n" <> bks+      t <- runParse inp parseTree+      t `shouldBe` Encoded "value\n"++    it "tree with index" $ do+      let Encoded ix = encodeIndex (BlockIndex [4])+      let inp = "value\n" <> ix+      (t, rest) <- runParse inp $ do+        t <- parseTree+        rest <- get @ByteString+        pure (t, rest)+      t `shouldBe` Encoded "value\n"+      rest `shouldBe` ix++    it "tree with all" $ do+      let Encoded bks = encodeBlock (BlockData "woot")+      let Encoded ix = encodeIndex (BlockIndex [4])+      let inp = "value\n" <> bks <> ix+      t <- runParse inp parseTree+      t `shouldBe` Encoded "value\n"++  describe "parse blocks" $ do+    it "one block" $ do+      let Encoded blks = encodeBlock (BlockData "woot")+      n <- runParse blks parseBlock+      n `shouldBe` Encoded blks++    it "first block" $ do+      let Encoded b1 = encodeBlock (BlockData "b1")+      let Encoded b2 = encodeBlock (BlockData "b2")+      b <- runParse (b1 <> b2) parseBlock+      b `shouldBe` Encoded b1++    it "block with index" $ do+      let Encoded b1 = encodeBlock (BlockData "b1")+      let Encoded ix = encodeIndex (BlockIndex [10])+      let inp = b1 <> ix+      n <- runParse inp parseBlock+      n `shouldBe` Encoded b1++    it "blocks" $ do+      let Encoded b1 = encodeBlock (BlockData "b1")+      let Encoded b2 = encodeBlock (BlockData "b2")+      let inp = b1 <> b2+      bs <- runParse inp parseBlocks+      bs `shouldBe` [Encoded b1, Encoded b2]++    it "blocks and index" $ do+      let Encoded b1 = encodeBlock (BlockData "b1")+      let Encoded b2 = encodeBlock (BlockData "b2")+      let Encoded ix = encodeIndex (BlockIndex [10])+      let inp = b1 <> b2 <> ix+      bs <- runParse inp parseBlocks+      bs `shouldBe` [Encoded b1, Encoded b2]++  describe "basic data" $ do+    it "should parse empty" $ do+      af <- split ""+      af `shouldBe` AsdfFile "" [] ""++    it "just a tree" $ do+      af <- split "tree"+      af.tree `shouldBe` "tree"+      af.blocks `shouldBe` []+      af.index `shouldBe` ""++  describe "optionals" $ do+    it "tree + data!" $ do+      let treeData = "#hello"+      let tree = Encoded treeData+      let blocks = [encodeBlock (BlockData "data")]+      let ix = encodeIndex (blockIndex tree blocks)+      let inp = concatAsdfFile $ AsdfFile{tree = Encoded treeData, blocks, index = ix}+      af <- split inp+      af.tree `shouldBe` "#hello"+      af.blocks `shouldBe` blocks+      af.index `shouldBe` ix++    it "all parts" $ do+      let treeData = "#hello\n"+      let blocks = [encodeBlock (BlockData "data")]+      let index = encodeIndex (BlockIndex [BS.length treeData])+      let out = concatAsdfFile $ AsdfFile{tree = Encoded treeData, blocks, index}+      af <- split out+      af.tree `shouldBe` Encoded "#hello\n"+      af.blocks `shouldBe` blocks+      af.index `shouldBe` index++    it "optional blocks" $ do+      af <- split "asdf"+      af `shouldBe` AsdfFile "asdf" [] ""++    it "optional tree" $ do+      let Encoded out = encodeBlock $ BlockData "hello"+      af <- split out+      af.tree `shouldBe` Encoded ""+      af.blocks `shouldBe` [Encoded out]+      af.index `shouldBe` ""++    it "tree and index" $ do+      let out = "tree\n" <> blockIndexHeader <> "index"+      af <- split out+      af.tree `shouldBe` "tree\n"+      af.blocks `shouldBe` []+      af.index `shouldBe` Encoded (blockIndexHeader <> "index")++  describe "real asdf file" $ do+    it "tree smaller than document " $ do+      ExampleFileFix inp dp <- getFixture+      BS.length dp.tree.bytes `shouldNotBe` BS.length inp++    it "tree exists" $ do+      ExampleFileFix _ dp <- getFixture+      BS.length dp.tree.bytes `shouldSatisfy` P.gt 0++    it "blocks exist" $ do+      ExampleFileFix _ dp <- getFixture+      length dp.blocks `shouldSatisfy` P.gt 0++    it "index exists" $ do+      ExampleFileFix _ dp <- getFixture+      BS.length dp.index.bytes `shouldSatisfy` P.gt 0+ where+  split :: BS.ByteString -> IO AsdfFile+  split inp = runAsdfM $ splitAsdfFile inp++  runParse :: ByteString -> Eff [NonDet, State ByteString, IOE] a -> IO a+  runParse inp eff = do+    ret <- runEff . runState inp . runNonDet OnEmptyKeep $ eff+    case ret of+      (Left _, rest) -> fail $ "Failed parse at: " ++ show (BS.take 100 rest)+      (Right a, _) -> pure a+++data ExampleFileFix = ExampleFileFix {input :: BS.ByteString, file :: AsdfFile}+instance Fixture ExampleFileFix where+  fixtureAction = do+    inp <- BS.readFile "samples/example.asdf"+    f <- runAsdfM $ splitAsdfFile inp+    pure $ noCleanup $ ExampleFileFix inp f
+ test/Test/Asdf/GWCSSpec.hs view
@@ -0,0 +1,103 @@+module Test.Asdf.GWCSSpec where++import Data.List.NonEmpty qualified as NE+import GHC.Generics (Generic)+import Skeletest+import Skeletest.Predicate qualified as P+import Telescope.Asdf.Class+import Telescope.Asdf.Core+import Telescope.Asdf.GWCS+import Telescope.Asdf.Node+import Telescope.Data.WCS+import Test.Asdf.ClassSpec (expectObject)+++data X deriving (Generic, ToAxes)+data Y deriving (Generic, ToAxes)+data Z deriving (Generic, ToAxes)+++spec :: Spec+spec = do+  describe "toAsdf" toAsdfSpec+  describe "transforms" transformSpec+++toAsdfSpec :: Spec+toAsdfSpec = do+  describe "Coorindate Frames" $ do+    it "should auto number axes order" $ do+      o <- expectObject $ toValue frame+      lookup "axes_order" o `shouldBe` Just (toNode @[Int] [0, 1])++    it "should order composite frame" $ do+      let frame2 = CoordinateFrame "boot" (NE.fromList [FrameAxis 2 "zero" "type" Pixel])+      let comp = CompositeFrame (frame2, frame)+      o <- expectObject $ toValue comp+      case lookup "frames" o of+        Just (Node _ _ (Array ns)) -> do+          case ns of+            [Node _ _ (Object f1), Node _ _ (Object f2)] -> do+              lookup "axes_order" f1 `shouldBe` Just (toNode @[Int] [2])+              lookup "axes_order" f2 `shouldBe` Just (toNode @[Int] [0, 1])+            _ -> fail $ "Expected frame objects" ++ show ns+        f -> fail $ "Expected frames" ++ show f+ where+  axes = [FrameAxis 0 "one" "type" Pixel, FrameAxis 1 "two" "type" Pixel]+  frame = CoordinateFrame "woot" (NE.fromList axes)+++transformSpec :: Spec+transformSpec = do+  describe "linear" $ withMarkers ["focus"] $ do+    it "should calculate intercept as 0th value for crval = 0" $ do+      let wcs = WCSAxis{cunit = CUnit "cunit", ctype = CType "Ctype", crpix = 12.0, crval = 0, cdelt = 0.1}+      let Intercept int = wcsIntercept wcs+      int `shouldBe` (-1.1)++    it "should calculate intercept with crval" $ do+      let wcs = WCSAxis{cunit = CUnit "cunit", ctype = CType "Ctype", crpix = 12.0, crval = 1.0, cdelt = 0.1}+      let Intercept int = wcsIntercept wcs+      int `shouldSatisfy` P.approx P.tol (-0.1)++  describe "(<&>) concatenate" $ withMarkers ["focus"] $ do+    it "should combine two inputs" $ do+      let tx = shift 10 :: Transform (Pix X) (Shift X)+      let ty = shift 20 :: Transform (Pix Y) (Shift Y)+      let total = tx <&> ty :: Transform (Pix X, Pix Y) (Shift X, Shift Y)+      total.transformation.forward `shouldSatisfy` P.con (Concat P.anything P.anything)++    it "should nest three inputs" $ do+      let tx = shift 10 :: Transform (Pix X) (Shift X)+      let ty = shift 20 :: Transform (Pix Y) (Shift Y)+      let tz = shift 20 :: Transform (Pix Z) (Shift Z)+      let total = tx <&> ty <&> tz :: Transform (Pix X, Pix Y, Pix Z) (Shift X, Shift Y, Shift Z)+      total.transformation.forward `shouldSatisfy` P.con (Concat P.anything P.anything)+      Concat txt tnext <- pure total.transformation.forward+      txt `shouldBe` tx.transformation++      tnext.forward `shouldSatisfy` P.con (Concat P.anything P.anything)+      Concat tyt tzt <- pure tnext.forward+      tyt `shouldBe` ty.transformation+      tzt `shouldBe` tz.transformation++  describe "concat and compose" $ withMarkers ["focus"] $ do+    it "should compose with higher priority first" $ do+      let tx = shift 10 :: Transform (Pix X) (Shift X)+      let tx2 = scale 10 :: Transform (Shift X) (Scale X)+      let ty = shift 20 :: Transform (Pix Y) (Shift Y)+      let ty2 = scale 10 :: Transform (Shift Y) (Scale Y)+      let total = tx |> tx2 <&> ty |> ty2 :: Transform (Pix X, Pix Y) (Scale X, Scale Y)++      total.transformation.forward `shouldSatisfy` P.con (Concat P.anything P.anything)+      Concat txt tyt <- pure total.transformation.forward++      txt.forward `shouldSatisfy` P.con (Compose P.anything P.anything)+      Compose txt1 txt2 <- pure txt.forward+      txt1 `shouldBe` tx.transformation+      txt2 `shouldBe` tx2.transformation++      tyt.forward `shouldSatisfy` P.con (Compose P.anything P.anything)+      Compose tyt1 tyt2 <- pure tyt.forward+      tyt1 `shouldBe` ty.transformation+      tyt2 `shouldBe` ty2.transformation
+ test/Test/Asdf/NDArraySpec.hs view
@@ -0,0 +1,45 @@+module Test.Asdf.NDArraySpec where++import Control.Monad (replicateM)+import Data.Binary.Get (runGet)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import GHC.Int+import Skeletest+import System.ByteOrder+import Telescope.Asdf.NDArray (DataType (..), NDArrayData (..))+import Telescope.Asdf.Node+import Telescope.Data.Axes+import Telescope.Data.Binary+import Test.Asdf.DecodeSpec (ExampleTreeFix (..))+++spec :: Spec+spec = do+  -- can we correctly decode an array?+  describe "DataType" $ do+    -- TEST: parse bool8+    -- TEST: parse uc4+    pure ()++  it "should parse NDArrayData" $ do+    ExampleTreeFix (Tree tree) <- getFixture+    nd <- expectNDArray $ lookup "sequence" tree+    nd.byteorder `shouldBe` LittleEndian+    nd.datatype `shouldBe` Int64+    nd.shape `shouldBe` axesRowMajor [100]+    BS.length nd.bytes `shouldBe` (100 * byteSize @Int64)++  it "should contain data" $ do+    ExampleTreeFix (Tree tree) <- getFixture+    nd <- expectNDArray $ lookup "sequence" tree+    decodeNums nd.bytes `shouldBe` [0 :: Int64 .. 99]+ where+  decodeNums bytes = do+    runGet (replicateM 100 (get LittleEndian)) (BL.fromStrict bytes) :: [Int64]+++expectNDArray :: Maybe Node -> IO NDArrayData+expectNDArray = \case+  Just (Node _ _ (NDArray dat)) -> pure dat+  n -> fail $ "Expected NDArray, but got: " ++ show n
+ test/Test/BinarySpec.hs view
@@ -0,0 +1,33 @@+module Test.BinarySpec where++import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString.Lazy (ByteString)+import GHC.Int+import Skeletest+import System.ByteOrder+import Telescope.Data.Binary+++spec :: Spec+spec = do+  describe "BinaryValue" testBinaryValue+++testBinaryValue :: Spec+testBinaryValue = do+  it "should decode ints" $ do+    get' @Int8 (put' @Int8 12) `shouldBe` 12+    get' @Int16 (put' @Int16 12) `shouldBe` 12+    get' @Int32 (put' @Int32 12) `shouldBe` 12+    get' @Int64 (put' @Int64 12) `shouldBe` 12+    get' @Int (put' @Int 12) `shouldBe` 12+  it "should decode floats" $ do+    get' @Float (put' @Float 12.21) `shouldBe` 12.21+    get' @Double (put' @Double 12.21) `shouldBe` 12.21+ where+  get' :: (BinaryValue a) => ByteString -> a+  get' = runGet (get BigEndian)++  put' :: (BinaryValue a) => a -> ByteString+  put' a = runPut (put BigEndian a)
+ test/Test/Fits/ChecksumSpec.hs view
@@ -0,0 +1,68 @@+module Test.Fits.ChecksumSpec where++import Data.ByteString qualified as BS+import Data.Word+import Skeletest+import Telescope.Fits+import Telescope.Fits.Checksum+import Telescope.Fits.Encoding+import Telescope.Fits.Types+++spec :: Spec+spec = do+  describe "checksum" specChecksum+  describe "add1s" specOnesComplement+++specChecksum :: Spec+specChecksum = do+  describe "checksum" $ do+    it "should calc zeros" $ do+      let inp = BS.pack (replicate 100 0)+      checksum inp `shouldBe` Checksum 0++    it "should calc max" $ do+      let inp = BS.pack (replicate 100 (maxBound :: Word8))+      checksum inp `shouldBe` Checksum (maxBound :: Word32)++    it "should be equal with trailing zeros" $ do+      checksum (BS.pack [1, 2, 3, 4, 5]) `shouldBe` checksum (BS.pack [1, 2, 3, 4, 5, 0, 0, 0, 0, 0])++    it "should not be equal with trailing spaces" $ do+      checksum "12345" `shouldNotBe` checksum "12345     "++  describe "datasum" $ do+    it "should calc same datasum as astro.py" $ do+      inp <- BS.readFile "./samples/ones10x10.fits"+      f :: Fits <- decode inp++      let datasumHeader = lookupKeyword "DATASUM" f.primaryHDU.header+          datasumCalc = checksum f.primaryHDU.dataArray.rawData+          datasumCalcHeader = Just $ checksumValue datasumCalc+      datasumCalcHeader `shouldBe` datasumHeader++  describe "encoding" $ do+    it "checksum of empty HDU should be (-0)" $ do+      let empty = PrimaryHDU (Header []) (DataArray BPInt8 (Axes []) "")+      let out = encodePrimaryHDU empty+      checksum out `shouldBe` Checksum maxBound++    it "checksum of sample HDU should be (-0)" $ do+      inp <- BS.readFile "./samples/ones10x10.fits"+      f <- decode inp+      let out = encodePrimaryHDU f.primaryHDU+      checksum out `shouldBe` Checksum maxBound+++specOnesComplement :: Spec+specOnesComplement = do+  describe "add" $ do+    it "max + 0" $ do+      add1s maxBound 0 `shouldBe` maxBound++    it "max + 1" $ do+      add1s maxBound 1 `shouldBe` 1++    it "max + max" $ do+      add1s maxBound maxBound `shouldBe` maxBound
+ test/Test/Fits/ClassSpec.hs view
@@ -0,0 +1,118 @@+module Test.Fits.ClassSpec where++import Control.Monad.Catch (throwM)+import Data.Fits as Fits hiding (isKeyword)+import Data.Text (Text)+import Effectful+import Effectful.Error.Static+import GHC.Generics+import Skeletest+import Skeletest.Predicate qualified as P+import Telescope.Data.Axes+import Telescope.Data.Parser+import Telescope.Data.WCS+import Telescope.Fits.Header+++spec :: Spec+spec = do+  describe "class" classSpec+  describe "wcs" wcsSpec+++newtype Activity = Activity Text+  deriving newtype (FromKeyword, ToKeyword)+++data Test = Test+  { age :: Int+  , firstName :: Text+  }+  deriving (Generic, ToHeader, FromHeader)+++data Woot = Woot+  { woot :: Float+  }+  deriving (Generic, ToHeader)+++data Parent = Parent+  { test :: HeaderFor Test+  , woot :: HeaderFor Woot+  }+  deriving (Generic, ToHeader)+++classSpec :: Spec+classSpec = do+  describe "To/From KeywordValue" $ do+    it "should toKeywordValue" $ do+      toKeywordValue (23 :: Int) `shouldBe` Integer 23+      toKeywordValue ("hello" :: Text) `shouldBe` String "hello"+      toKeywordValue True `shouldBe` Logic T++    it "should parseKeywordValue" $ do+      runPureParser (parseKeywordValue @Int $ Integer 23) `shouldBe` Right 23+      runPureParser (parseKeywordValue @Text $ String "woot") `shouldBe` Right "woot"+      runPureParser (parseKeywordValue @Bool $ Logic F) `shouldBe` Right False++  describe "ToHeader" $ do+    it "should uppercase and snake keywords" $ do+      let h = toHeader (Test 40 "Alice")+      length h._records `shouldBe` 2+      [Keyword (KeywordRecord k1 _ _), Keyword (KeywordRecord k2 _ _)] <- pure h._records+      k1 `shouldBe` "AGE"+      k2 `shouldBe` "FIRST_NAME"++    it "should convert datatype" $ do+      let h = toHeader (Test 40 "Alice")+      lookupKeyword "AGE" h `shouldBe` Just (Integer 40)+      lookupKeyword "FIRST_NAME" h `shouldBe` Just (String "Alice")++  it "should mconcat fields that are members of toHeader" $ do+    let h = toHeader $ Parent (HeaderFor $ Test 40 "Alice") (HeaderFor $ Woot 123.456)+    lookupKeyword "age" h `shouldBe` Just (Integer 40)+    lookupKeyword "first_name" h `shouldBe` Just (String "Alice")+    lookupKeyword "woot" h `shouldSatisfy` P.just (P.con (Float (P.eq 123.456)))++  describe "FromHeader" $ do+    it "should convert datatype" $ do+      let h = toHeader (Test 40 "Alice")+      let et = runPureParser $ parseHeader h+      et `shouldSatisfy` P.right (P.con Test{age = P.eq 40})+      et `shouldSatisfy` P.right (P.con Test{firstName = P.eq "Alice"})+++data X+instance AxisOrder X where+  axisN = 1+++data Y+instance AxisOrder Y where+  axisN = 2+++wcsSpec :: Spec+wcsSpec = do+  describe "axis To/From Header" $ withMarkers ["focus"] $ do+    it "should incorporate axis order into keywords" $ do+      let hx = toHeader wcsX+      Fits.lookup "CRPIX1" hx `shouldBe` Just (Float 1.0)++    it "should incorporate wcsalt into keywords" $ do+      let h = toHeader wcsAY+      Fits.lookup "CRVAL2A" h `shouldBe` Just (Float 5.0)++    it "should roundtrip" $ do+      let h = toHeader wcsAY+      wcs2 <- parseIO $ parseHeader h+      wcs2 `shouldBe` wcsAY+ where+  wcsX = WCSAxis (CType "X") (CUnit "M") 1 2 3 :: WCSAxis 'WCSMain X+  wcsAY = WCSAxis (CType "Y") (CUnit "M") 4 5 6 :: WCSAxis 'A Y+++parseIO :: Eff '[Parser, Error ParseError, IOE] a -> IO a+parseIO p = runEff $ runErrorNoCallStackWith @ParseError throwM $ runParser p
+ test/Test/Fits/EncodingSpec.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE TypeApplications #-}++module Test.Fits.EncodingSpec where++import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as BL+import Data.ByteString.Lazy.Char8 qualified as C8+import Data.Massiv.Array (Ix2)+import Data.Massiv.Array qualified as M+import Data.Text (pack)+import Skeletest+import Telescope.Fits.DataArray+import Telescope.Fits.Encoding+import Telescope.Fits.Encoding.Render hiding (justify, pad, spaces)+import Telescope.Fits.Header+import Telescope.Fits.Types+++spec :: Spec+spec = do+  describe "decode fits" testDecodeFits+  describe "render header" testRenderHeader+  describe "render data" testRenderData+  describe "encode primary" testEncodePrimary+  describe "round trip" testRoundTrip+++testDecodeFits :: Spec+testDecodeFits = do+  describe "simple2x3.fits" $ do+    it "should load metadata" $ do+      f <- decode =<< BS.readFile "samples/simple2x3.fits"+      let dat = f.primaryHDU.dataArray+          hds = f.primaryHDU.header+      dat.axes `shouldBe` Axes [3, 2]+      dat.bitpix `shouldBe` BPInt64+      lookupKeyword "CUSTOM" hds `shouldBe` Just (Integer 123456)++    it "should load data array" $ do+      f <- decode =<< BS.readFile "samples/simple2x3.fits"+      arr <- decodeDataArray @Ix2 @Int f.primaryHDU.dataArray+      M.toLists arr `shouldBe` [[0, 1, 2], [3, 4, 5]]++  describe "NSO L2 Data" $ do+    it "should load" $ do+      f <- decode =<< BS.readFile "samples/dkistL2.fits"+      length f.extensions `shouldBe` 1+++-- arr <- decodeDataArray @Ix2 @Int f.primaryHDU.dataArray+-- M.toLists arr `shouldBe` [[0, 1, 2], [3, 4, 5]]++testRenderHeader :: Spec+testRenderHeader = do+  describe "renderValue" $ do+    it "int should right justify" $ do+      runValue (Integer 8) `shouldBe` justify 20 "8"++    it "float should right justify" $ do+      runValue (Float 3.2) `shouldBe` justify 20 "3.2"++    it "negative int" $ do+      runValue (Integer (-32)) `shouldBe` justify 20 "-32"++    it "negative float" $ do+      runValue (Float (-32.32)) `shouldBe` justify 20 "-32.32"++    it "float should exponent uppercase" $ do+      runValue (Float 6.0001e-16) `shouldBe` justify 20 "6.0001E-16"++    it "logic should right justify" $ do+      runValue (Logic T) `shouldBe` justify 20 "T"++    it "string" $ do+      runValue (String "Hello World") `shouldBe` "'Hello World'"++  -- TEST: does it matter if e-06 vs e-6? We output e-6.++  describe "renderKeyword" $ do+    it "should left justify" $ do+      run (renderKeyword "BITPIX") `shouldBe` "BITPIX  "++    it "should truncate" $ do+      run (renderKeyword "REALLYLONG") `shouldBe` "REALLYLO"++    it "should uppercase" $ do+      run (renderKeyword "lower") `shouldBe` "LOWER   "++  describe "renderKeywordValue" $ do+    it "should render space" $ do+      run (renderKeywordValue "SIMPLE" (Logic T)) `shouldBe` ("SIMPLE  = " <> justify 20 "T")++    it "should butt against equals" $ do+      run (renderKeywordValue "WHATEVER" (Integer 10)) `shouldBe` ("WHATEVER= " <> justify 20 "10")++    it "should string" $ do+      run (renderKeywordValue "WHATEVER" (String "dude")) `shouldBe` pad 30 "WHATEVER= 'dude'"++    it "should correctly count long values" $ do+      let render = renderKeywordValue "KEYWORD" (String "0123456789012345678901234567890123456789")+      render.length `shouldBe` length (run render)++  describe "renderComment" $ do+    it "should render comment" $ do+      run (renderComment 100 "Hello World") `shouldBe` " / Hello World"++    it "should truncate comment" $ do+      run (renderComment 10 "Hello World") `shouldBe` " / Hello W"++  describe "renderKeywordComments" $ do+    it "should render comment in line" $ do+      run (renderKeywordLine "SIMPLE" (Logic T) (Just "Comment")) `shouldBe` pad 80 ("SIMPLE  = " <> justify 20 "T" <> " / Comment")++    it "should render no comment" $ do+      run (renderKeywordLine "SIMPLE" (Logic T) Nothing) `shouldBe` pad 80 ("SIMPLE  = " <> justify 20 "T")++    it "should truncate whole line" $ do+      run (renderKeywordLine "SIMPLE" (Logic T) Nothing) `shouldBe` pad 80 ("SIMPLE  = " <> justify 20 "T")++  describe "renderKeywordLine" $ do+    it "should be 80 characters mininum" $ do+      let b = renderKeywordLine "HELLO" (Integer 1) Nothing+      b.length `shouldBe` 80++    it "should be 80 characters maximum" $ do+      let b = renderKeywordLine "HELLO" (Integer 1) (Just $ pack $ replicate 100 'a')+      b.length `shouldBe` 80++    it "should be 80 characters maximum with long strings" $ do+      let b = renderKeywordLine "HELLO" (String "this is a really long value that exceeds 20") (Just $ pack $ replicate 100 'a')+      b.length `shouldBe` 80+      length (run b) `shouldBe` 80++    it "should be padded" $ do+      run (renderKeywordLine "HELLO" (Integer 1) Nothing) `shouldBe` "HELLO   = " <> justify 20 "1" <> spaces 50++  describe "renderOtherKeywords" $ do+    it "should render comments" $ do+      let h = Header [Comment "hello world"]+      run (renderOtherKeywords h) `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"]++    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"]+ where+  runValue :: Value -> String+  runValue = run . renderValue+++run :: BuilderBlock -> String+run = C8.unpack . runRender+++headers :: [String] -> String+headers = mconcat . map (pad 80)+++justify :: Int -> String -> String+justify n s = spaces (n - length s) <> s+++pad :: Int -> String -> String+pad n s = s <> spaces (n - length s)+++spaces :: Int -> String+spaces n = replicate n ' '+++testRenderData :: Spec+testRenderData = do+  it "fill block should fill" $ do+    (fillBlock zeros "a").length `shouldBe` 2880+    (fillBlock zeros "hello world").length `shouldBe` 2880+    (fillBlock zeros "").length `shouldBe` 0++  it "should be empty" $ do+    runRender (renderData "") `shouldBe` ""++  it "should pad to nearest block" $ do+    (renderData "asdf").length `shouldBe` 2880++  it "should render some data" $ do+    runRender (renderData "12345") `shouldBe` ("12345" <> BL.replicate 2875 0)+++testEncodePrimary :: Spec+testEncodePrimary = do+  describe "encoded primary hdu" $ do+    it "encodes both a header and data hdu" $ do+      FitsEncodedFix enc <- getFixture+      BS.length enc `shouldBe` hduBlockSize * 2++    it "encodes the data" $ do+      FitsEncodedFix enc <- getFixture+      BS.take 6 (BS.drop 2880 enc) `shouldBe` rawData++    it "starts with SIMPLE" $ do+      FitsEncodedFix enc <- getFixture+      BS.take 30 enc `shouldBe` "SIMPLE  =                    T"++  describe "decoded encoded primary hdu" $ do+    it "Has custom header" $ do+      FitsDecodedFix f <- getFixture+      lookupKeyword "WOOT" f.primaryHDU.header `shouldBe` Just (Integer 123)++    it "Has required headers" $ do+      FitsDecodedFix f <- getFixture+      lookupKeyword "EXTEND" f.primaryHDU.header `shouldBe` Just (Logic T)++    it "Matches data metadata" $ do+      FitsDecodedFix f <- getFixture+      f.primaryHDU.dataArray.bitpix `shouldBe` BPInt8+      f.primaryHDU.dataArray.axes `shouldBe` Axes [3, 2]++    it "Matches raw data" $ do+      FitsDecodedFix f <- getFixture+      f.primaryHDU.dataArray.rawData `shouldBe` BS.pack [0 .. 5]+ where+  rawData = BS.pack [0 .. 5]+++testRoundTrip :: Spec+testRoundTrip = do+  describe "simple2x3.fits" $ do+    it "should match metadata" $ do+      Simple2x3Fix fs <- getFixture+      f2 <- decode $ encode fs+      f2.primaryHDU.dataArray.axes `shouldBe` Axes [3, 2]+      f2.primaryHDU.dataArray.bitpix `shouldBe` fs.primaryHDU.dataArray.bitpix++    it "should match raw data" $ do+      Simple2x3Fix fs <- getFixture+      f2 <- decode $ encode fs+      f2.primaryHDU.dataArray.rawData `shouldBe` fs.primaryHDU.dataArray.rawData++    it "should encode headers only once" $ do+      Simple2x3Fix fs <- getFixture+      f2 <- decode $ encode fs+      let hs = fs.primaryHDU.header+          h2 = f2.primaryHDU.header+      lookupKeyword "NAXIS" h2 `shouldBe` Just (Integer 2)++      let ks = getKeywords hs :: [KeywordRecord]+          k2 = getKeywords h2 :: [KeywordRecord]++      length (filter (matchKeyword "BITPIX") k2) `shouldBe` length (filter (matchKeyword "BITPIX") ks)++      length h2._records `shouldBe` length hs._records++    it "should keep naxes order preserved" $ do+      Simple2x3Fix fs <- getFixture+      f2 <- decode $ encode fs+      f2.primaryHDU.dataArray.axes `shouldBe` fs.primaryHDU.dataArray.axes++  describe "image fits" $ do+    it "should roundtrip image extensions" $ do+      let prim = PrimaryHDU mempty emptyDataArray+      let img = Image $ ImageHDU mempty emptyDataArray+      let out = encode $ Fits prim [img]+      fits2 <- decode out+      length fits2.extensions `shouldBe` 1+ where+  matchKeyword k (KeywordRecord k2 _ _) = k == k2+++newtype Simple2x3Fix = Simple2x3Fix Fits+instance Fixture Simple2x3Fix where+  fixtureAction = do+    inp <- BS.readFile "samples/simple2x3.fits"+    fits <- decode inp+    pure $ noCleanup $ Simple2x3Fix fits+++newtype FitsEncodedFix = FitsEncodedFix BS.ByteString+instance Fixture FitsEncodedFix where+  fixtureAction = do+    pure $ noCleanup $ FitsEncodedFix encoded+   where+    encoded = encode (Fits primary [])+    primary =+      let heads = Header [Keyword $ KeywordRecord "WOOT" (Integer 123) Nothing]+          dat = DataArray BPInt8 (Axes [3, 2]) $ BS.pack [0 .. 5]+       in PrimaryHDU heads dat+++newtype FitsDecodedFix = FitsDecodedFix Fits+instance Fixture FitsDecodedFix where+  fixtureAction = do+    FitsEncodedFix enc <- getFixture+    f <- decode enc+    pure $ noCleanup $ FitsDecodedFix f