telescope 0.4.0 → 0.4.1
raw patch · 15 files changed
+575/−72 lines, 15 files
Files
- src/Telescope/Asdf/Class.hs +63/−9
- src/Telescope/Asdf/Core.hs +3/−0
- src/Telescope/Asdf/Encoding.hs +1/−1
- src/Telescope/Asdf/Encoding/Stream.hs +11/−7
- src/Telescope/Asdf/GWCS.hs +190/−34
- src/Telescope/Asdf/Node.hs +4/−2
- src/Telescope/Data/Parser.hs +36/−14
- src/Telescope/Fits/Header/Class.hs +20/−0
- telescope.cabal +2/−1
- test/Test/Asdf/ClassSpec.hs +34/−1
- test/Test/Asdf/DecodeSpec.hs +44/−0
- test/Test/Asdf/EncodeSpec.hs +16/−0
- test/Test/Asdf/GWCSSpec.hs +93/−0
- test/Test/Fits/MegaHeaderSpec.hs +3/−3
- test/Test/ParserSpec.hs +55/−0
src/Telescope/Asdf/Class.hs view
@@ -10,6 +10,7 @@ import Data.Text (Text, pack, unpack) import Data.Time.Clock (UTCTime) import Data.Time.Format.ISO8601+import Data.Time.LocalTime (LocalTime) import Effectful import Effectful.Fail import GHC.Generics@@ -95,6 +96,10 @@ parseValue val = expected "Object" val + parseNode :: (Parser :> es) => Node -> Eff es a+ parseNode (Node _ _ v) = parseValue v++ instance ToAsdf Int where toValue n = toValue (fromIntegral @Int @Int64 n) instance FromAsdf Int where@@ -169,12 +174,20 @@ toValue as = toValue $ NE.toList as +instance {-# OVERLAPS #-} ToAsdf Object where+ toValue = Object instance {-# OVERLAPS #-} FromAsdf Object where parseValue = \case Object o -> pure o node -> expected "Object" node +instance ToAsdf () where+ toValue () = Null+instance FromAsdf () where+ parseValue _ = pure ()++ 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@@ -211,6 +224,35 @@ node -> expected "[a, b, c, d]" node +instance (ToAsdf a, ToAsdf b, ToAsdf c, ToAsdf d, ToAsdf e) => ToAsdf (a, b, c, d, e) where+ toValue (a, b, c, d, e) = Array [toNode a, toNode b, toNode c, toNode d, toNode e]+instance (FromAsdf a, FromAsdf b, FromAsdf c, FromAsdf d, FromAsdf e) => FromAsdf (a, b, c, d, e) 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+ e <- parseValue nd.value+ pure (a, b, c, d, e)+ node -> expected "[a, b, c, d, e]" node+++instance (ToAsdf a, ToAsdf b, ToAsdf c, ToAsdf d, ToAsdf e, ToAsdf f) => ToAsdf (a, b, c, d, e, f) where+ toValue (a, b, c, d, e, f) = Array [toNode a, toNode b, toNode c, toNode d, toNode e, toNode f]+instance (FromAsdf a, FromAsdf b, FromAsdf c, FromAsdf d, FromAsdf e, FromAsdf f) => FromAsdf (a, b, c, d, e, f) 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+ e <- parseValue nd.value+ f <- parseValue nd.value+ pure (a, b, c, d, e, f)+ node -> expected "[a, b, c, d, e, f]" node++ -- they will always serialize to Array instance FromAsdf [Text] where parseValue = parseAnyList@@ -237,6 +279,10 @@ instance (FromAsdf a) => FromAsdf (Maybe a) where+ parseNode node =+ case node.value of+ Null -> pure Nothing+ _ -> Just <$> parseNode @a node parseValue = \case Null -> pure Nothing val -> Just <$> parseValue @a val@@ -268,7 +314,7 @@ instance FromAsdf String where parseValue = \case String t -> pure $ unpack t- node -> expected "Text" node+ node -> expected "String" node instance ToAsdf Bool where@@ -286,8 +332,12 @@ instance ToAsdf Node where+ schema n = n.schema+ anchor n = n.anchor+ toNode n = n toValue (Node _ _ val) = val instance FromAsdf Node where+ parseNode = pure parseValue val = pure $ Node mempty Nothing val @@ -358,11 +408,16 @@ 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+instance ToAsdf LocalTime where+ schema _ = "!time/time-1.1.0"+ toValue t = String $ pack $ iso8601Show t+instance FromAsdf LocalTime 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 key from an 'Object'@@ -387,9 +442,8 @@ o .:? k = do case lookup k o of Nothing -> pure Nothing- Just a ->- Just <$> do- parseAt (Child k) $ parseNode a+ Just a -> do+ parseAt (Child k) $ parseNode a {- | Parse a child at the given array index
src/Telescope/Asdf/Core.hs view
@@ -27,6 +27,7 @@ | Meters | Kilometers | Arcseconds+ | Seconds | Unit Text deriving (Eq) @@ -39,6 +40,7 @@ Degrees -> "deg" Nanometers -> "nm" Kilometers -> "km"+ Seconds -> "s" Arcseconds -> "arcsec" Meters -> "m" (Unit t) -> String t@@ -51,6 +53,7 @@ String "nm" -> pure Nanometers String "km" -> pure Kilometers String "m" -> pure Meters+ String "s" -> pure Seconds String "arcsec" -> pure Arcseconds String t -> pure $ Unit t val -> expected "String" val
src/Telescope/Asdf/Encoding.hs view
@@ -57,7 +57,7 @@ format = Yaml.defaultFormatOptions & Yaml.setTagRendering Yaml.renderUriTags- & Yaml.setWidth (Just 100)+ & Yaml.setWidth Nothing -- no column limit -- | Decode a 'ByteString' to a 'FromAsdf'
src/Telescope/Asdf/Encoding/Stream.hs view
@@ -314,9 +314,16 @@ parseFloat s = Number <$> parseRead s - parseMulti s =- parseInt s <|> parseFloat s <|> parseBool s <|> parseStr s+ parseNull s = do+ case s of+ "~" -> pure Null+ "null" -> pure Null+ _ -> empty + parseMulti :: (NonDet :> es) => ByteString -> Eff es Value+ parseMulti s = do+ parseInt s <|> parseFloat s <|> parseBool s <|> parseNull s <|> parseStr s+ throwEmpty :: (Error YamlError :> es) => String -> Eff (NonDet : es) a -> Eff es a throwEmpty expt eff = do ec <- runNonDet OnEmptyKeep eff@@ -339,17 +346,14 @@ 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 (UriTag s) = schemaTag s parseSchemaTag _ = mempty isNDArray :: SchemaTag -> Bool isNDArray (SchemaTag Nothing) = False isNDArray (SchemaTag (Just t)) =- "core/ndarray" `T.isPrefixOf` t+ "!core/ndarray" `T.isPrefixOf` t expect :: (Error YamlError :> es) => Event -> ConduitT Event o (Eff es) ()
src/Telescope/Asdf/GWCS.hs view
@@ -3,6 +3,7 @@ module Telescope.Asdf.GWCS where +import Data.Foldable (toList) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE@@ -11,11 +12,14 @@ import Data.String (IsString) import Data.Text (Text, pack) import Data.Text qualified as T-import Data.Time.Clock (UTCTime)+import Data.Time.LocalTime (LocalTime)+import Effectful import GHC.Generics import Telescope.Asdf import Telescope.Asdf.Core+import Telescope.Data.Parser import Telescope.Data.WCS (WCSAxis (..))+import Text.Casing (quietSnake) -- | GWCS pipelines consist of an input and output 'GWCSStep'@@ -31,20 +35,34 @@ ] +instance (FromAsdf inp, FromAsdf out) => FromAsdf (GWCS inp out) where+ parseValue = \case+ Object o -> do+ steps :: [Value] <- o .: "steps"+ case steps of+ [inpv, outv] -> do+ inp <- parseValue inpv+ out <- parseValue outv+ pure $ GWCS inp out+ other -> expected "GWCS steps: [input,output]" other+ val -> expected "GWCS" val++ -- | A step contains a frame (like 'CelestialFrame') and a 'Transform a b' data GWCSStep frame = GWCSStep { frame :: frame , transform :: Maybe Transformation }- deriving (Generic)+ deriving (Generic, Show) instance (ToAsdf frame) => ToAsdf (GWCSStep frame) where schema _ = "tag:stsci.edu:gwcs/step-1.1.0"+instance (FromAsdf frame) => FromAsdf (GWCSStep frame) newtype AxisName = AxisName Text- deriving newtype (IsString, ToAsdf, Show, Semigroup, Eq)+ deriving newtype (IsString, ToAsdf, FromAsdf, Show, Semigroup, Eq) newtype AxisType = AxisType Text@@ -87,33 +105,90 @@ 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--+ schema t = schema t.forward 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+ toValue t.forward+ <> Object [ ("inputs", toNode t.inputs) , ("outputs", toNode t.outputs) ] +instance FromAsdf Transformation where+ parseNode (Node sch _ val) = do+ case val of+ Object o -> do+ inps <- o .: "inputs"+ outs <- o .: "outputs"+ frwd <- parseNode (Node sch Nothing (Object $ filter (not . isDirectKey) o))+ pure $ Transformation inps outs frwd+ other -> expected "Transformation" other+ where+ isDirectKey (k, _) =+ k == "inputs" || k == "outputs"+++ -- parse a direct forward transformation using the logic defined in parseNode+ parseValue val = parseNode (Node mempty Nothing val)++ data Forward = Compose Transformation Transformation | Concat Transformation Transformation- | Direct {schemaTag :: SchemaTag, fields :: Value}+ | Direct Node deriving (Show, Eq) +instance ToAsdf Forward where+ schema (Compose _ _) = "!transform/compose-1.2.0"+ schema (Concat _ _) = "!transform/concatenate-1.2.0"+ schema (Direct node) = node.schema+++ toValue = \case+ Compose a b -> Object [("forward", toNode [a, b])]+ Concat a b -> Object [("forward", toNode [a, b])]+ Direct node -> node.value+++instance FromAsdf Forward where+ parseNode (Node sch _ val) = do+ case sch of+ "!transform/compose-1.2.0" -> parseCompose val+ "!transform/concatenate-1.2.0" -> parseConcat val+ _ -> parseDirect sch val+++ parseValue v =+ -- parse it blindly: compose and concat might match the same one!+ runParserAlts (expected "Forward" v) $ do+ tryParserEmpty (parseCompose v) <|> tryParserEmpty (parseConcat v) <|> tryParserEmpty (parseDirect "..." v)+++parseCompose :: (Parser :> es) => Value -> Eff es Forward+parseCompose = \case+ Object o -> do+ res <- o .: "forward"+ case res of+ [a, b] -> pure $ Compose a b+ fwd -> expected "Compose a b" fwd+ val -> expected "Compose a b" val+++parseConcat :: (Parser :> es) => Value -> Eff es Forward+parseConcat = \case+ Object o -> do+ res <- o .: "forward"+ case res of+ [a, b] -> pure $ Concat a b+ fwd -> expected "Concat a b" fwd+ val -> expected "Concat a b" val+++parseDirect :: (Parser :> es) => SchemaTag -> Value -> Eff es Forward+parseDirect sch val = pure $ Direct $ Node sch Nothing val++ {- | 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)@@ -137,7 +212,7 @@ $ Transformation (toAxes @bs) (toAxes @cs)- $ Direct (schema a) (toValue a)+ $ Direct (toNode a) -- | Compose two transforms@@ -189,8 +264,13 @@ data Projection = Projection Direction data Rotate3d = Rotate3d {direction :: Direction, phi :: Lon, theta :: Lat, psi :: LonPole} deriving (Generic)+++-- TODO: this should be a quantity! data Linear a = Linear1d {intercept :: Double, slope :: Double} deriving (Generic)+data Mapping = Mapping {mapping :: [Int]}+data Const1D = Const1D Quantity instance ToAsdf Identity where@@ -234,6 +314,25 @@ ] +instance ToAsdf Mapping where+ schema _ = "!transform/remap_axes-1.3.0"+ toValue m =+ Object [("mapping", toNode $ toList m.mapping)]+++instance ToAsdf Const1D where+ schema _ = "!transform/constant-1.2.0"+ toValue (Const1D q) =+ Object+ [ ("dimensions", toNode $ Integer 1)+ , ("value", toNode q)+ ]+instance FromAsdf Const1D where+ parseValue val = do+ o <- parseValue @Object val+ Const1D <$> o .: "value"++ -- Frames ----------------------------------------------- data CoordinateFrame = CoordinateFrame@@ -279,6 +378,24 @@ ] +data TemporalFrame = TemporalFrame+ { name :: Text+ , time :: LocalTime+ , axisOrder :: Int+ }+instance ToAsdf TemporalFrame where+ schema _ = "tag:stsci.edu:gwcs/temporal_frame-1.0.0"+ toValue f =+ Object+ [ ("name", toNode f.name)+ , ("axis_names", toNode [String "time"])+ , ("axes_order", toNode [f.axisOrder])+ , ("axis_physical_types", toNode [String "time"])+ , ("reference_frame", toNode f.time)+ , ("unit", toNode [Seconds])+ ]++ data CelestialFrame ref = CelestialFrame { name :: Text , axes :: NonEmpty FrameAxis@@ -300,7 +417,7 @@ [ ("naxes", toNode $ NE.length as) , ("axes_names", toNode axesNames) , ("axes_order", toNode axesOrders)- , ("axes_physical_types", toNode axesPhysicalTypes)+ , ("axis_physical_types", toNode axesPhysicalTypes) , ("unit", toNode units) ] where@@ -308,7 +425,7 @@ axesOrders = fmap (.axisOrder) as axesPhysicalTypes = fmap (physicalType . (.axisType)) as units = fmap (.unit) as- physicalType t = String "custom:" <> toValue t+ physicalType = toValue -- numAxes = NE.length as@@ -321,8 +438,7 @@ data HelioprojectiveFrame = HelioprojectiveFrame { coordinates :: Cartesian3D- , obstime :: UTCTime- , rsun :: Quantity+ , observation :: HelioObservation } instance ToAsdf HelioprojectiveFrame where schema _ = "tag:sunpy.org:sunpy/coordinates/frames/helioprojective-1.0.0"@@ -330,10 +446,18 @@ Object [("frame_attributes", fromValue attributes)] where- observer = HelioObserver (CartesianRepresentation frame.coordinates) observation- observation = HelioObservation frame.obstime frame.rsun+ observer = HelioObserver (CartesianRepresentation frame.coordinates) frame.observation attributes =- Object [("observer", toNode observer)] <> toValue observation+ Object [("observer", toNode observer)] <> toValue frame.observation+instance FromAsdf HelioprojectiveFrame where+ parseValue = \case+ Object o -> do+ atts :: Object <- o .: "frame_attributes"+ observer :: HelioObserver <- atts .: "observer"+ observation <- parseValue (Object atts)+ let CartesianRepresentation coords = observer.coordinates+ pure $ HelioprojectiveFrame coords observation+ other -> expected "helioprojective frame" other -- reference_frame: !<tag:sunpy.org:sunpy/coordinates/frames/helioprojective-1.0.0>@@ -372,13 +496,20 @@ [ ("data", toNode obs.coordinates) , ("frame_attributes", toNode obs.observation) ]+instance FromAsdf HelioObserver where+ parseValue = \case+ Object o -> do+ d <- o .: "data"+ atts <- o .: "frame_attributes"+ pure $ HelioObserver d atts+ other -> expected "Helioobserver" other data HelioObservation = HelioObservation- { obstime :: UTCTime+ { obstime :: LocalTime , rsun :: Quantity }- deriving (Generic, ToAsdf)+ deriving (Generic, ToAsdf, FromAsdf) data Cartesian3D = Cartesian3D@@ -386,7 +517,7 @@ , y :: Quantity , z :: Quantity }- deriving (Generic, ToAsdf)+ deriving (Generic, ToAsdf, FromAsdf) data CartesianRepresentation dims = CartesianRepresentation dims@@ -400,6 +531,11 @@ schema _ = "tag:astropy.org:astropy/coordinates/representation-1.0.0" toValue (CartesianRepresentation dims) = Object [("components", toNode dims), ("type", "CartesianRepresentation")]+instance (FromAsdf dims) => FromAsdf (CartesianRepresentation dims) where+ parseValue = \case+ Object o -> do+ CartesianRepresentation <$> o .: "components"+ other -> expected "CartesianRepresentation" other data FrameAxis = FrameAxis@@ -410,7 +546,7 @@ } -data CompositeFrame as = CompositeFrame as+data CompositeFrame as = CompositeFrame {frames :: as} instance (ToAsdf as) => ToAsdf (CompositeFrame as) where schema _ = "tag:stsci.edu:gwcs/composite_frame-1.0.0" toValue (CompositeFrame as) =@@ -418,6 +554,11 @@ [ ("name", toNode $ String "CompositeFrame") , ("frames", toNode as) ]+instance (FromAsdf as) => FromAsdf (CompositeFrame as) where+ parseValue = \case+ Object o -> do+ CompositeFrame <$> o .: "name"+ other -> expected "CompositeFrame" other -- ToAxes -----------------------------------------------@@ -432,7 +573,7 @@ class ToAxes (as :: Type) where toAxes :: [AxisName] default toAxes :: (Generic as, GTypeName (Rep as)) => [AxisName]- toAxes = [AxisName $ pack $ gtypeName (from (undefined :: as))]+ toAxes = [AxisName $ pack $ quietSnake $ gtypeName (from (undefined :: as))] instance ToAxes () where@@ -443,6 +584,10 @@ 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]+instance (ToAxes a, ToAxes b, ToAxes c, ToAxes d, ToAxes e) => ToAxes (a, b, c, d, e) where+ toAxes = mconcat [toAxes @a, toAxes @b, toAxes @c, toAxes @d, toAxes @e]+instance (ToAxes a, ToAxes b, ToAxes c, ToAxes d, ToAxes e, ToAxes f) => ToAxes (a, b, c, d, e, f) where+ toAxes = mconcat [toAxes @a, toAxes @b, toAxes @c, toAxes @d, toAxes @e, toAxes @f] -- Transforms -----------------------------------------------@@ -480,7 +625,7 @@ data Delta deriving (Generic, ToAxes) -identity :: (ToAxes bs, ToAxes cs) => Transform bs cs+identity :: (ToAxes a) => Transform a a identity = transform Identity @@ -507,9 +652,20 @@ type family TConcat a b where- TConcat (a, b, c) d = (a, b, c, d)+ TConcat a (b, c, d, e, f) = (a, b, c, d, e, f)+ TConcat (a, b) (c, d, e, f) = (a, b, c, d, e, f)+ TConcat (a, b, c) (d, e, f) = (a, b, c, d, e, f)+ TConcat (a, b, c, d) (e, f) = (a, b, c, d, e, f)+ TConcat (a, b, c, d, e) f = (a, b, c, d, e, f)+ TConcat a (b, c, d, e) = (a, b, c, d, e)+ TConcat (a, b) (c, d, e) = (a, b, c, d, e)+ TConcat (a, b, c) (d, e) = (a, b, c, d, e)+ TConcat (a, b, c, d) e = (a, b, c, d, e) 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) d = (a, b, c, d) TConcat a (b, c) = (a, b, c)+ TConcat (a, b) c = (a, b, c)+ TConcat a () = a+ TConcat () b = b TConcat a b = (a, b)
src/Telescope/Asdf/Node.hs view
@@ -17,11 +17,13 @@ instance Show SchemaTag where show (SchemaTag Nothing) = ""- show (SchemaTag (Just t)) = unpack t ++ ":"+ show (SchemaTag (Just t)) = unpack t schemaTag :: String -> SchemaTag-schemaTag = SchemaTag . Just . pack+schemaTag "" = SchemaTag Nothing+schemaTag s =+ SchemaTag $ Just $ T.replace "tag:stsci.edu:asdf/" "!" $ pack s instance IsString SchemaTag where
src/Telescope/Data/Parser.hs view
@@ -1,13 +1,30 @@ {-# LANGUAGE UndecidableInstances #-} -module Telescope.Data.Parser where+module Telescope.Data.Parser+ ( Parser (..)+ , runParser+ , runParserPure+ , runParserAlts+ , Ref (..)+ , Path (..)+ , ParseError (..)+ , expected+ , parseFail+ , parseAt+ , Alternative (..)+ , NonDet+ , tryParserEmpty+ )+where import Control.Monad.Catch (Exception) import Data.List (intercalate)-import Data.Text (Text, unpack)+import Data.String (IsString (..))+import Data.Text (Text, pack, unpack) import Effectful import Effectful.Dispatch.Dynamic import Effectful.Error.Static+import Effectful.NonDet import Effectful.Reader.Static @@ -19,16 +36,6 @@ type instance DispatchOf Parser = 'Dynamic --- runParser--- :: Eff (Parser : es) a--- -> Eff es (Either ParseError a)--- runParser = reinterpret (runErrorNoCallStack @ParseError . runReader @Path mempty) $ \env -> \case--- ParseFail e -> do--- path <- ask @Path--- throwError $ ParseFailure path e--- PathMod mp m -> do--- localSeqUnlift env $ \unlift -> local mp (unlift m)- runParser :: (Error ParseError :> es) => Eff (Parser : es) a@@ -45,9 +52,22 @@ runParserPure = runPureEff . runErrorNoCallStack @ParseError . runParser --- copied from Effectful.Reader.Dynamic--- localSeqUnlift env $ \unlift -> local (<> Path [p]) (unlift m)+runParserAlts :: (Parser :> es) => Eff es a -> Eff (NonDet : es) a -> Eff es a+runParserAlts err eff = do+ res <- runNonDet OnEmptyKeep eff+ case res of+ Left _ -> err+ Right a -> pure a ++tryParserEmpty :: (NonDet :> es, Parser :> es) => Eff (Parser : Error ParseError : es) a -> Eff es a+tryParserEmpty eff = do+ res <- runErrorNoCallStack @ParseError $ runParser eff+ case res of+ Left _ -> empty+ Right a -> pure a++ data ParseError = ParseFailure Path String deriving (Exception, Eq)@@ -75,6 +95,8 @@ deriving (Eq) +instance IsString Ref where+ fromString = Child . pack instance Show Ref where show (Child c) = unpack c show (Index n) = show n
src/Telescope/Fits/Header/Class.hs view
@@ -4,6 +4,7 @@ import Data.Text qualified as T import Data.Time.Clock (UTCTime) import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show)+import Data.Time.LocalTime (LocalTime) import Effectful import GHC.Generics import Telescope.Data.Axes (AxisOrder (..))@@ -82,6 +83,17 @@ v -> expected "UTCTime" v +instance ToKeyword LocalTime where+ toKeywordValue utc = String $ pack $ iso8601Show utc+instance FromKeyword LocalTime where+ parseKeywordValue = \case+ String t -> do+ case iso8601ParseM $ unpack t of+ Nothing -> expected "LocalTime" t+ Just lt -> pure lt+ v -> expected "LocalTime" v++ instance ToKeyword CUnit where toKeywordValue (CUnit t) = toKeywordValue t instance FromKeyword CUnit where@@ -173,6 +185,10 @@ Just v -> parseAt (Child k) $ parseKeywordValue v +genericToHeader :: (Generic a, GToHeader (Rep a)) => a -> Header+genericToHeader = gToHeader . from++ class GToHeader f where gToHeader :: f p -> Header @@ -200,6 +216,10 @@ instance {-# OVERLAPS #-} (ToHeader a, Selector s) => GToHeader (M1 S s (K1 R (HeaderFor a))) where gToHeader (M1 (K1 (HeaderFor a))) = toHeader a+++genericParseHeader :: (Generic a, GFromHeader (Rep a), Parser :> es) => Header -> Eff es a+genericParseHeader h = to <$> gParseHeader h class GFromHeader f where
telescope.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: telescope-version: 0.4.0+version: 0.4.1 synopsis: Astronomical Observations (FITS, ASDF, WCS, etc) description: Work with astronomical observations from modern telescopes license: BSD3@@ -113,6 +113,7 @@ Test.Fits.ClassSpec Test.Fits.EncodingSpec Test.Fits.MegaHeaderSpec+ Test.ParserSpec Paths_telescope hs-source-dirs: test/
test/Test/Asdf/ClassSpec.hs view
@@ -24,6 +24,9 @@ spec :: Spec spec = do+ describe "FromAsdf" $ do+ fromAsdfSpec+ describe "nulls" nullSpec describe "FromAsdf" fromAsdfSpec describe "ToAsdf" toAsdfSpec describe "GObject" gObjectSpec@@ -56,6 +59,37 @@ ex2.alias `shouldBe` "world" +nullSpec :: Spec+nullSpec = do+ it "parses 'key: null'" $ do+ let Encoded out = encodeTree "{key: null, key2: ~, key3: value}"+ ex <- decodeM @Object out+ lookup "key" ex `shouldBe` Just (toNode Null)+ lookup "key2" ex `shouldBe` Just (toNode Null)+ lookup "key3" ex `shouldBe` Just (toNode (String "value"))++ it "parses Null as Maybe" $ do+ val <- parseIO $ parseValue @(Maybe Text) Null+ val `shouldBe` Nothing++ val2 <- parseIO $ parseNode @(Maybe Text) (Node mempty Nothing Null)+ val2 `shouldBe` Nothing++ it "parses null fields as Maybe" $ do+ let input = [("key", fromValue Null)]+ val <- parseIO $ do+ res :: Maybe Text <- input .: "key"+ pure res+ val `shouldBe` Nothing++ it "parses null fields as Maybe with (.:?)" $ do+ let input = [("key", fromValue Null)]+ val <- parseIO $ do+ res :: Maybe Text <- input .:? "key"+ pure res+ val `shouldBe` Nothing++ toAsdfSpec :: Spec toAsdfSpec = do it "should serialize Example" $ do@@ -80,7 +114,6 @@ 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
test/Test/Asdf/DecodeSpec.hs view
@@ -56,13 +56,57 @@ e.foo `shouldBe` 42 e.items `shouldBe` ["one", "two", "three", "four", "five"] + it "parses quantity and unit with expected schemas" $ do+ inp <- BS.readFile "samples/example.asdf" + Object o <- decodeM @Value inp++ case lookup "intercept" o of+ Just (Node sch _ (Object q)) -> do+ sch `shouldBe` "!unit/quantity-1.1.0"+ case lookup "unit" q of+ Just (Node schq _ u) -> do+ schq `shouldBe` "!unit/unit-1.0.0"+ u `shouldBe` String "nm"+ _ -> failTest "expected document.intercept.value"+ _ -> failTest "expected document.intercept"++ it "parses quantity schema from Generic" $ do+ inp <- BS.readFile "samples/example.asdf"+ ex2 <- decodeM @Example2 inp+ ex2.intercept.schema `shouldBe` "!unit/quantity-1.1.0"++ let q = Quantity Nanometers (Number 854.2)+ ex2.intercept.schema `shouldBe` (toNode q).schema+++-- let Encoded out = encodeTree "{key: null, key2: value}"+-- ex <- decodeM @NullFields out+-- ex.key `shouldBe` Nothing+-- ex.key2 `shouldBe` Just "value"++-- ex2 <- decodeM @ExampleNullMaybe inp+-- ex2.nullable `shouldBe` Nothing+ data Example = Example { foo :: Int , name :: Text , items :: [Text] } deriving (Generic, FromAsdf, ToAsdf)+++data Example2 = Example2+ { intercept :: Node+ }+ deriving (Generic, FromAsdf, ToAsdf)+++data NullFields = NullFields+ { key :: Maybe Text+ , key2 :: Maybe Text+ }+ deriving (Generic, FromAsdf) anchorSpec :: Spec
test/Test/Asdf/EncodeSpec.hs view
@@ -33,6 +33,22 @@ describe "external verification" externalSpec describe "references" referenceSpec describe "anchors" anchorSpec+ describe "schemas" schemaSpec+++schemaSpec :: Spec+schemaSpec = do+ it "unit nodes have correct schema" $ do+ toNode Nanometers `shouldBe` Node "!unit/unit-1.0.0" Nothing (String "nm")++ it "encoded unit has correct schema" $ do+ (out, _) <- runAsdfM $ encodeNode (toNode Nanometers)+ out `shouldBe` "!unit/unit-1.0.0 nm\n"++ it "encoded quantity has correct schema" $ do+ let q :: Quantity = Quantity Nanometers (Number 854.2)+ (out, _) <- runAsdfM $ encodeNode $ toNode q+ out `shouldBe` "!unit/quantity-1.1.0 {unit: !unit/unit-1.0.0 nm, value: 854.2}\n" anchorSpec :: Spec
test/Test/Asdf/GWCSSpec.hs view
@@ -1,15 +1,20 @@ module Test.Asdf.GWCSSpec where +import Data.ByteString.Char8 qualified as C8 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.Encoding (decodeM) import Telescope.Asdf.GWCS import Telescope.Asdf.Node+import Telescope.Data.Parser+import Data.List qualified as L import Telescope.Data.WCS import Test.Asdf.ClassSpec (expectObject)+import Test.Asdf.DecodeSpec (parseIO) data X deriving (Generic, ToAxes)@@ -20,9 +25,49 @@ spec :: Spec spec = do describe "toAsdf" toAsdfSpec+ describe "fromAsdf" fromAsdfSpec describe "transforms" transformSpec +fromAsdfSpec :: Spec+fromAsdfSpec = withMarkers ["focus"] $ do+ describe "GWCS" $ do+ it "parses Compose gwcsstep" $ do+ let input =+ C8.intercalate+ "\n"+ [ "!<tag:stsci.edu:gwcs/step-1.1.0>"+ , "frame: []"+ , "transform: !transform/compose-1.2.0"+ , " inputs: [x0, x1, x2, x3]"+ , " outputs: [x0, x1, x2, x3, x4]"+ , " forward:"+ , " - !transform/compose-1.2.0"+ , " inputs: [x, x0, x1, x1]"+ , " outputs: [y, lon, lat, y0, y1]"+ , " forward:"+ , " - !transform/woop-1.3.0"+ , " inputs: [x0, x1, x2, x3]"+ , " outputs: [x0, x1, x2, x3]"+ , " mapping: [1, 0, 2, 3]"+ , " - !transform/boop-1.2.0"+ , " inputs: [x, x0, x1, x1]"+ , " outputs: [y, lon, lat, y0, y1]"+ , " - !transform/scoop-1.2.0"+ , " inputs: [x, x0, x1, x1]"+ , " outputs: [y, lon, lat, y0, y1]"+ ]+ o <- decodeM @Object input+ t :: Maybe Transformation <- parseIO $ o .: "transform"+ case (.forward) <$> t of+ Just (Compose _ t2) -> do+ case t2.forward of+ Direct n -> do+ n.schema `shouldBe` "!transform/scoop-1.2.0"+ other -> failTest $ "Expected scoop, but got: " <> show other+ other -> failTest $ "Expected Compose but got: " <> show other++ toAsdfSpec :: Spec toAsdfSpec = do describe "Coordinate Frames" $ do@@ -42,6 +87,54 @@ lookup "axes_order" f2 `shouldBe` Just (toNode @[Int] [0, 1]) _ -> fail $ "Expected frame objects" ++ show ns f -> fail $ "Expected frames" ++ show f++ describe "Transformation" $ do+ it "encodes direct transformation" $ do+ let t = Transformation ["one", "two"] ["x", "y"] (Direct $ Node "!schema" Nothing (Object [("key", fromValue (String "hello"))]))+ let Node sch _ val = toNode t+ sch `shouldBe` "!schema"++ o <- expectObject val+ L.sort (fmap fst o) `shouldBe` L.sort ["inputs", "outputs", "key"]++ lookup "key" o `shouldBe` Just (fromValue (String "hello"))++ it "decodes direct transformation" $ do+ let t = Transformation ["one", "two"] ["x", "y"] (Direct $ Node "!schema" Nothing (Object [("key", fromValue (String "hello"))]))+ let node = toNode t+ let res :: Either ParseError Transformation = runParserPure $ parseNode node+ case res of+ Left e -> failTest (show e)+ Right a -> do+ a.inputs `shouldBe` t.inputs+ a.outputs `shouldBe` t.outputs+ a.forward `shouldBe` t.forward++ it "encodes compose" $ do+ let d = Direct $ Node "!basic" Nothing (Object [])+ toValue d `shouldBe` Object []++ let basic = Transformation ["a"] ["b"] (Direct $ Node "!basic" Nothing (Object []))+ let t = Transformation ["one"] ["x"] (Compose basic basic)+ let Node sch _ val = toNode t+ sch `shouldBe` "!transform/compose-1.2.0"++ o <- expectObject val+ lookup "inputs" o `shouldBe` Just (fromValue $ Array [fromValue $ String "one"])+ lookup "outputs" o `shouldBe` Just (fromValue $ Array [fromValue $ String "x"])++ case lookup "forward" o of+ Just (Node _ _ (Array [na, nb])) -> do+ na `shouldBe` toNode basic+ nb `shouldBe` toNode basic+ _ -> failTest ".forward == [a, b]"++ it "decodes compose" $ do+ let basic = Transformation ["a"] ["b"] (Direct $ Node "!basic" Nothing (Object []))+ let comp = Transformation ["one"] ["x"] (Compose basic basic)+ let node = toNode comp+ let res = runParserPure $ parseNode node+ res `shouldBe` Right comp where axes = [FrameAxis 0 "one" "type" Pixel, FrameAxis 1 "two" "type" Pixel] frame = CoordinateFrame "woot" (NE.fromList axes)
test/Test/Fits/MegaHeaderSpec.hs view
@@ -159,7 +159,7 @@ comments :: Spec comments = do- describe "Full-line comments" $ withMarkers ["focus"] $ do+ describe "Full-line comments" $ do it "should parse full-line comments" $ do res <- parse parseLineComment $ flattenKeywords ["COMMENT --------------------------- VISP Instrument ----------------------------"] res `shouldBe` "--------------------------- VISP Instrument ----------------------------"@@ -227,7 +227,7 @@ continue :: Spec-continue = describe "Continue Keyword" $ withMarkers ["continue"] $ do+continue = describe "Continue Keyword" $ do it "parses a normal string" $ do let input = "'normal string ' END" t <- parse parseStringContinue input@@ -406,7 +406,7 @@ sampleJWSTHeaders :: Spec sampleJWSTHeaders = do- describe "JWST Headers" $ withMarkers ["focus"] $ do+ describe "JWST Headers" $ do it "should parse jwst headers" $ do JWSTHeaders bs <- getFixture let input = mconcat $ C8.lines bs
+ test/Test/ParserSpec.hs view
@@ -0,0 +1,55 @@+module Test.ParserSpec where++import Data.List (isInfixOf)+import Effectful+import Effectful.Error.Static+import Effectful.NonDet+import Skeletest+import Skeletest.Predicate qualified as P+import Telescope.Data.Parser+++spec :: Spec+spec = do+ describe "Data.Parser" $ do+ describe "parsing" $ do+ it "parses something" $ do+ res <- runParseTest $ do+ pure "hello"+ res `shouldBe` Right ("hello" :: String)++ it "can handle alternatives" $ do+ let pa = pure ()+ res <- runParseTest pa+ res `shouldBe` Right ()++ let pb = pure ()+ res2 <- runParseTest $ runParserAlts (parseFail "Empty") empty+ res2 `shouldSatisfy` P.left P.anything++ res3 <- runParseTest $ runParserAlts (parseFail "Empty") (empty <|> pb)+ res3 `shouldBe` Right ()++ describe "location " $ do+ it "changes failure to location" $ do+ res <- runParseTest $ do+ parseAt (Child "hello") $ parseAt (Index 2) $ do+ parseFail "nope"++ case res of+ Left (ParseFailure path err) -> do+ path `shouldBe` Path [Child "hello", Index 2]+ err `shouldBe` "nope"+ Right _ -> failTest "Expected failure"++ it "gives good expected messages" $ do+ res :: Either ParseError () <- runParseTest $ do+ parseAt (Child "child") $ parseAt (Index 2) $ expected "Number" (1 :: Int)+ ("child/2" `isInfixOf` show res) `shouldBe` True+ ("1" `isInfixOf` show res) `shouldBe` True+ ("Number" `isInfixOf` show res) `shouldBe` True+++runParseTest :: Eff [Parser, Error ParseError, IOE] a -> IO (Either ParseError a)+runParseTest eff = do+ runEff . runErrorNoCallStack @ParseError . runParser $ eff