diff --git a/src/Telescope/Asdf/Class.hs b/src/Telescope/Asdf/Class.hs --- a/src/Telescope/Asdf/Class.hs +++ b/src/Telescope/Asdf/Class.hs @@ -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 diff --git a/src/Telescope/Asdf/Core.hs b/src/Telescope/Asdf/Core.hs --- a/src/Telescope/Asdf/Core.hs +++ b/src/Telescope/Asdf/Core.hs @@ -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 diff --git a/src/Telescope/Asdf/Encoding.hs b/src/Telescope/Asdf/Encoding.hs --- a/src/Telescope/Asdf/Encoding.hs +++ b/src/Telescope/Asdf/Encoding.hs @@ -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' diff --git a/src/Telescope/Asdf/Encoding/Stream.hs b/src/Telescope/Asdf/Encoding/Stream.hs --- a/src/Telescope/Asdf/Encoding/Stream.hs +++ b/src/Telescope/Asdf/Encoding/Stream.hs @@ -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) () diff --git a/src/Telescope/Asdf/GWCS.hs b/src/Telescope/Asdf/GWCS.hs --- a/src/Telescope/Asdf/GWCS.hs +++ b/src/Telescope/Asdf/GWCS.hs @@ -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: ! @@ -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) diff --git a/src/Telescope/Asdf/Node.hs b/src/Telescope/Asdf/Node.hs --- a/src/Telescope/Asdf/Node.hs +++ b/src/Telescope/Asdf/Node.hs @@ -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 diff --git a/src/Telescope/Data/Parser.hs b/src/Telescope/Data/Parser.hs --- a/src/Telescope/Data/Parser.hs +++ b/src/Telescope/Data/Parser.hs @@ -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 diff --git a/src/Telescope/Fits/Header/Class.hs b/src/Telescope/Fits/Header/Class.hs --- a/src/Telescope/Fits/Header/Class.hs +++ b/src/Telescope/Fits/Header/Class.hs @@ -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 diff --git a/telescope.cabal b/telescope.cabal --- a/telescope.cabal +++ b/telescope.cabal @@ -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/ diff --git a/test/Test/Asdf/ClassSpec.hs b/test/Test/Asdf/ClassSpec.hs --- a/test/Test/Asdf/ClassSpec.hs +++ b/test/Test/Asdf/ClassSpec.hs @@ -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 diff --git a/test/Test/Asdf/DecodeSpec.hs b/test/Test/Asdf/DecodeSpec.hs --- a/test/Test/Asdf/DecodeSpec.hs +++ b/test/Test/Asdf/DecodeSpec.hs @@ -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 diff --git a/test/Test/Asdf/EncodeSpec.hs b/test/Test/Asdf/EncodeSpec.hs --- a/test/Test/Asdf/EncodeSpec.hs +++ b/test/Test/Asdf/EncodeSpec.hs @@ -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 diff --git a/test/Test/Asdf/GWCSSpec.hs b/test/Test/Asdf/GWCSSpec.hs --- a/test/Test/Asdf/GWCSSpec.hs +++ b/test/Test/Asdf/GWCSSpec.hs @@ -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" + [ "!" + , "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) diff --git a/test/Test/Fits/MegaHeaderSpec.hs b/test/Test/Fits/MegaHeaderSpec.hs --- a/test/Test/Fits/MegaHeaderSpec.hs +++ b/test/Test/Fits/MegaHeaderSpec.hs @@ -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 diff --git a/test/Test/ParserSpec.hs b/test/Test/ParserSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/ParserSpec.hs @@ -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