diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ For the latest version of this document, please see [https://github.com/DougBurke/hvega/blob/master/hvega/CHANGELOG.md](https://github.com/DougBurke/hvega/blob/master/hvega/CHANGELOG.md). +## 0.12.0.0 + +Support aeson version 2.0. There is currently no significant change to +the API but it is expected that in a future release there will be when +we wil require a minimum version of 2.0 for aeson. + +At the time of release of 0.12.0.0 the tests will fail when using +aeson >= 2.0 because `aeson-pretty` has not yet been updated (see +https://github.com/informatikr/aeson-pretty/issues/36). + ## 0.11.0.1 There is no change in the code, only the tests, which should now diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -1,13 +1,9 @@ -# Looks like release-20.03 doesn't have haskell-language-server so stick -# with nixpkgs-unstable -{ nixpkgs ? import {}, compiler ? "ghc8104" }: +{ sources ? import ../nix/sources.nix +, pkgs ? import sources.nixpkgs {} +, compiler ? "ghc8104" +}: let - # sources = import ../nix/sources.nix; - # pkgs = import sources.nixpkgs {}; - - inherit (nixpkgs) pkgs; - # since we are in a sub-directory # gitignore = pkgs.nix-gitignore.gitignoreSourcePure [ ./.gitignore ]; gitignore = pkgs.nix-gitignore.gitignoreSourcePure [ ../.gitignore ]; @@ -32,7 +28,7 @@ withHoogle = true; }; - # exe = pkgs.haskell.lib.justStaticExecutables (myHaskellPackages."{{cookiecutter.project_name}}"); + # exe = pkgs.haskell.lib.justStaticExecutables (myHaskellPackages."hvega"); # docker = pkgs.dockerTools.buildImage { # name = "{{cookiecutter.project_name}}"; diff --git a/hvega.cabal b/hvega.cabal --- a/hvega.cabal +++ b/hvega.cabal @@ -1,5 +1,5 @@ name: hvega -version: 0.11.0.1 +version: 0.12.0.0 synopsis: Create Vega-Lite visualizations (version 4) in Haskell. description: This is based on the elm-vegalite package () @@ -159,7 +159,7 @@ Graphics.Vega.VegaLite.Time Graphics.Vega.VegaLite.Transform build-depends: base >= 4.9 && < 5 - , aeson >= 0.11 && < 1.6 + , aeson >= 0.11 && < 2.1 , text == 1.2.* , unordered-containers == 0.2.* @@ -215,7 +215,7 @@ Gallery.Scatter Gallery.Table - build-depends: aeson >= 1.4.2 && < 1.6 + build-depends: aeson >= 1.4.2 && < 2.1 , aeson-pretty == 0.8.* , base >= 4 && < 5 , bytestring == 0.10.* diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -1,2 +1,1 @@ -{ nixpkgs ? import {}, compiler ? "ghc8104" }: -(import ./default.nix { inherit nixpkgs compiler; }).shell +(import ./default.nix {}).shell diff --git a/src/Graphics/Vega/Tutorials/VegaLite.hs b/src/Graphics/Vega/Tutorials/VegaLite.hs --- a/src/Graphics/Vega/Tutorials/VegaLite.hs +++ b/src/Graphics/Vega/Tutorials/VegaLite.hs @@ -3,7 +3,7 @@ {-| Module : Graphics.Vega.Tutorials.VegaLite -Copyright : (c) Douglas Burke, 2019-2020 +Copyright : (c) Douglas Burke, 2019-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -19,7 +19,7 @@ . The tutorial targets version 4 of the Vega-Lite specification and -the functionality provided in version @0.11.0.0@ of hvega (although +the functionality provided in version @0.12.0.0@ of hvega (although a number of examples could be simplified by removing the now-optional type information as of Vega-Lite 4.14). @@ -361,7 +361,8 @@ -- example, @elm-vegalite@ provides @pQuant n@ which in @hvega@ is the -- combination of @'PName' n@ and @'PmType' 'Quantitative'@ in @hvega@. -- The top-level functions - such as 'dataFromUrl', 'encoding', and --- 'filter' - are generally the same. +-- 'filter' - are generally the same. As the VegaLite schema has expanded +-- over time the differences between the two approaches has also grown. -- -- Version @0.5.0.0@ does introduce more-significant changes, in that -- there are now separate types for a number of functions - such as @@ -472,7 +473,7 @@ <> - + @ 'toVegaLite' @@ -546,7 +547,7 @@ <> - + @ let enc = encoding @@ -589,7 +590,7 @@ <> - + @ let enc = encoding @@ -664,7 +665,7 @@ <> - + @ let enc = encoding @@ -758,7 +759,7 @@ <> - + @ let enc = encoding @@ -4015,7 +4016,7 @@ <> - + The image was captured after panning and zooming in the \"parallax-RA_ICRS\" plot. diff --git a/src/Graphics/Vega/VegaLite.hs b/src/Graphics/Vega/VegaLite.hs --- a/src/Graphics/Vega/VegaLite.hs +++ b/src/Graphics/Vega/VegaLite.hs @@ -14,14 +14,10 @@ it has been updated to match later versions. This module allows users to create a Vega-Lite specification, targeting __version 4__ of the . -Version 0.11 of @hvega@ supports version 4.15 of the Vega-Lite specification. +Version 0.12 of @hvega@ supports version 4.15 of the Vega-Lite specification. -Although this is based on the Elm module, there are differences, such -as using type constructors rather than functions for many properties - -such as @'VL.PName' \"HorsePower\"@ rather than @pName \"HorsePower\"@ - -and the return value of 'VL.toVegaLite'. The intention is to keep close -to the Elm module, but it is more a guide than an absolute -requirement! +Although this was based on the Elm module, there have been a number of +changes - on both sides. Please see "Graphics.Vega.Tutorials.VegaLite" for an introduction to using @hvega@ to create visualizations. The @@ -857,6 +853,10 @@ -- -- $update + -- ** Version 0.12 + -- + -- $update01200 + -- ** Version 0.11 -- -- $update01101 @@ -1267,6 +1267,17 @@ -- $update -- The following section describes how to update code that used -- an older version of @hvega@. + +-- $update01200 +-- The @0.12.0.0@ release allows @hvega@ to be built with version 2.0 of the +-- [aeson package](https://hackage.haskell.org/package/aeson). There are +-- no changes to the API of @hvega@, but it does mean that you may need +-- to update code that directly creates JSON, such as 'VL.dataFromJson'. +-- It is likely that 'VL.LabelledSpec' type and the related +-- @toXXXSpec/fromXXXSpec@ functions, such as 'VL.fromSelectSpec' and +-- 'VL.toSelectSpec', will be updated once we can drop +-- support for versions of @aeson@ prior to 2.0. +-- -- $update01101 -- The @0.11.0.1@ release is purely to support testing with @hashable@ 0.3.1.0. diff --git a/src/Graphics/Vega/VegaLite/Configuration.hs b/src/Graphics/Vega/VegaLite/Configuration.hs --- a/src/Graphics/Vega/VegaLite/Configuration.hs +++ b/src/Graphics/Vega/VegaLite/Configuration.hs @@ -3,12 +3,12 @@ {-| Module : Graphics.Vega.VegaLite.Configuration -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com Stability : unstable -Portability : OverloadedStrings +Portability : CPP, OverloadedStrings Top-level configuration options. As this can configure most of a visualization, it needs to import most of the other @@ -38,9 +38,11 @@ import qualified Data.Aeson as A + import qualified Data.Text as T import Data.Aeson ((.=), object) +import Data.Aeson.Types (Pair) #if !(MIN_VERSION_base(4, 12, 0)) import Data.Monoid ((<>)) @@ -97,6 +99,7 @@ , autosizeProperty , viewBackgroundSpec , cursorLabel + , (.=~), toObject ) import Graphics.Vega.VegaLite.Geometry ( ProjectionProperty @@ -110,7 +113,7 @@ ) import Graphics.Vega.VegaLite.Mark ( MarkProperty - , mprops_ + , oldMprops_ ) import Graphics.Vega.VegaLite.Scale ( ScaleNice @@ -530,7 +533,7 @@ toAxis :: T.Text -> [AxisConfig] -> LabelledSpec -toAxis lbl acs = ("axis" <> lbl) .= object (map axisConfigProperty acs) +toAxis lbl acs = ("axis" <> lbl) .=~ object (map axisConfigProperty acs) toAxisChoice :: AxisChoice -> T.Text -> [AxisConfig] -> LabelledSpec toAxisChoice AxXY lbl = toAxis lbl @@ -538,14 +541,14 @@ toAxisChoice AxY lbl = toAxis ("Y" <> lbl) aprops_ :: T.Text -> [AxisProperty] -> LabelledSpec -aprops_ f mps = f .= object (map axisProperty mps) +aprops_ f mps = f .=~ object (map axisProperty mps) -- easier to turn into a ConfigSpec in config than here configProperty :: ConfigurationProperty -> LabelledSpec -configProperty (ArcStyle mps) = mprops_ "arc" mps -configProperty (AreaStyle mps) = mprops_ "area" mps -configProperty (AriaStyle b) = "aria" .= b -configProperty (AutosizeStyle aus) = "autosize" .= object (map autosizeProperty aus) +configProperty (ArcStyle mps) = oldMprops_ "arc" mps +configProperty (AreaStyle mps) = oldMprops_ "area" mps +configProperty (AriaStyle b) = "aria" .=~ b +configProperty (AutosizeStyle aus) = "autosize" .=~ object (map autosizeProperty aus) configProperty (Axis acs) = toAxis "" acs configProperty (AxisBand c acs) = toAxisChoice c "Band" acs configProperty (AxisBottom acs) = toAxis "Bottom" acs @@ -559,78 +562,78 @@ configProperty (AxisX acs) = toAxis "X" acs configProperty (AxisY acs) = toAxis "Y" acs --- configProperty (AxisNamedStyles [(nme, mps)]) = "style" .= object [aprops_ nme mps] +-- configProperty (AxisNamedStyles [(nme, mps)]) = "style" .=~ object [aprops_ nme mps] configProperty (AxisNamedStyles styles) = let toStyle = uncurry aprops_ - in "style" .= object (map toStyle styles) + in "style" .=~ toObject (map toStyle styles) -configProperty (BackgroundStyle bg) = "background" .= bg -configProperty (BarStyle mps) = mprops_ "bar" mps -configProperty (BoxplotStyle mps) = mprops_ "boxplot" mps -configProperty (CircleStyle mps) = mprops_ "circle" mps -configProperty (ConcatStyle cps) = "concat" .= object (map compConfigProperty cps) -configProperty (CountTitleStyle ttl) = "countTitle" .= ttl -configProperty (CustomFormatStyle b) = "customFormatTypes" .= b -configProperty (ErrorBandStyle mps) = mprops_ "errorband" mps -configProperty (ErrorBarStyle mps) = mprops_ "errorbar" mps -configProperty (FacetStyle cps) = "facet" .= object (map compConfigProperty cps) -configProperty (FieldTitleStyle ftp) = "fieldTitle" .= fieldTitleLabel ftp -configProperty (FontStyle font) = "font" .= font -configProperty (GeoshapeStyle mps) = mprops_ "geoshape" mps +configProperty (BackgroundStyle bg) = "background" .=~ bg +configProperty (BarStyle mps) = oldMprops_ "bar" mps +configProperty (BoxplotStyle mps) = oldMprops_ "boxplot" mps +configProperty (CircleStyle mps) = oldMprops_ "circle" mps +configProperty (ConcatStyle cps) = "concat" .=~ object (map compConfigProperty cps) +configProperty (CountTitleStyle ttl) = "countTitle" .=~ ttl +configProperty (CustomFormatStyle b) = "customFormatTypes" .=~ b +configProperty (ErrorBandStyle mps) = oldMprops_ "errorband" mps +configProperty (ErrorBarStyle mps) = oldMprops_ "errorbar" mps +configProperty (FacetStyle cps) = "facet" .=~ object (map compConfigProperty cps) +configProperty (FieldTitleStyle ftp) = "fieldTitle" .=~ fieldTitleLabel ftp +configProperty (FontStyle font) = "font" .=~ font +configProperty (GeoshapeStyle mps) = oldMprops_ "geoshape" mps configProperty (HeaderStyle hps) = header_ "" hps configProperty (HeaderColumnStyle hps) = header_ "Column" hps configProperty (HeaderFacetStyle hps) = header_ "Facet" hps configProperty (HeaderRowStyle hps) = header_ "Row" hps -configProperty (ImageStyle mps) = mprops_ "image" mps -configProperty (LegendStyle lcs) = "legend" .= object (map legendConfigProperty lcs) -configProperty (LineStyle mps) = mprops_ "line" mps +configProperty (ImageStyle mps) = oldMprops_ "image" mps +configProperty (LegendStyle lcs) = "legend" .=~ object (map legendConfigProperty lcs) +configProperty (LineStyle mps) = oldMprops_ "line" mps -configProperty (LineBreakStyle s) = "lineBreak" .= s +configProperty (LineBreakStyle s) = "lineBreak" .=~ s -configProperty (MarkStyle mps) = mprops_ "mark" mps --- configProperty (MarkNamedStyles [(nme, mps)]) = "style" .= object [mprops_ nme mps] +configProperty (MarkStyle mps) = oldMprops_ "mark" mps +-- configProperty (MarkNamedStyles [(nme, mps)]) = "style" .=~ object [mprops_ nme mps] configProperty (MarkNamedStyles styles) = - let toStyle = uncurry mprops_ - in "style" .= object (map toStyle styles) + let toStyle = uncurry oldMprops_ + in "style" .=~ toObject (map toStyle styles) -configProperty (NumberFormatStyle fmt) = "numberFormat" .= fmt -configProperty (PaddingStyle pad) = "padding" .= paddingSpec pad -configProperty (PointStyle mps) = mprops_ "point" mps -configProperty (ProjectionStyle pps) = "projection" .= object (map projectionProperty pps) -configProperty (RangeStyle rcs) = "range" .= object (map rangeConfigProperty rcs) -configProperty (RectStyle mps) = mprops_ "rect" mps -configProperty (RepeatStyle cps) = "repeat" .= object (map compConfigProperty cps) -configProperty (RuleStyle mps) = mprops_ "rule" mps +configProperty (NumberFormatStyle fmt) = "numberFormat" .=~ fmt +configProperty (PaddingStyle pad) = "padding" .=~ paddingSpec pad +configProperty (PointStyle mps) = oldMprops_ "point" mps +configProperty (ProjectionStyle pps) = "projection" .=~ object (map projectionProperty pps) +configProperty (RangeStyle rcs) = "range" .=~ object (map rangeConfigProperty rcs) +configProperty (RectStyle mps) = oldMprops_ "rect" mps +configProperty (RepeatStyle cps) = "repeat" .=~ object (map compConfigProperty cps) +configProperty (RuleStyle mps) = oldMprops_ "rule" mps configProperty (ScaleStyle scs) = scaleConfig_ scs configProperty (SelectionStyle selConfig) = - let selProp (sel, sps) = selectionLabel sel .= object (concatMap selectionProperties sps) - in "selection" .= object (map selProp selConfig) -configProperty (SquareStyle mps) = mprops_ "square" mps -configProperty (TextStyle mps) = mprops_ "text" mps -configProperty (TickStyle mps) = mprops_ "tick" mps -configProperty (TimeFormatStyle fmt) = "timeFormat" .= fmt -configProperty (TitleStyle tcs) = "title" .= object (map titleConfigSpec tcs) -configProperty (TrailStyle mps) = mprops_ "trail" mps -configProperty (ViewStyle vcs) = "view" .= object (concatMap viewConfigProperties vcs) + let selProp (sel, sps) = selectionLabel sel .=~ object (concatMap selectionProperties sps) + in "selection" .=~ toObject (map selProp selConfig) +configProperty (SquareStyle mps) = oldMprops_ "square" mps +configProperty (TextStyle mps) = oldMprops_ "text" mps +configProperty (TickStyle mps) = oldMprops_ "tick" mps +configProperty (TimeFormatStyle fmt) = "timeFormat" .=~ fmt +configProperty (TitleStyle tcs) = "title" .=~ object (map titleConfigSpec tcs) +configProperty (TrailStyle mps) = oldMprops_ "trail" mps +configProperty (ViewStyle vcs) = "view" .=~ object (concatMap viewConfigProperties vcs) -- deprecated aliases -configProperty (Autosize aus) = "autosize" .= object (map autosizeProperty aus) -configProperty (Background bg) = "background" .= bg -configProperty (CountTitle ttl) = "countTitle" .= ttl -configProperty (FieldTitle ftp) = "fieldTitle" .= fieldTitleLabel ftp -configProperty (Legend lcs) = "legend" .= object (map legendConfigProperty lcs) -configProperty (NumberFormat fmt) = "numberFormat" .= fmt -configProperty (Padding pad) = "padding" .= paddingSpec pad -configProperty (Projection pps) = "projection" .= object (map projectionProperty pps) -configProperty (Range rcs) = "range" .= object (map rangeConfigProperty rcs) +configProperty (Autosize aus) = "autosize" .=~ object (map autosizeProperty aus) +configProperty (Background bg) = "background" .=~ bg +configProperty (CountTitle ttl) = "countTitle" .=~ ttl +configProperty (FieldTitle ftp) = "fieldTitle" .=~ fieldTitleLabel ftp +configProperty (Legend lcs) = "legend" .=~ object (map legendConfigProperty lcs) +configProperty (NumberFormat fmt) = "numberFormat" .=~ fmt +configProperty (Padding pad) = "padding" .=~ paddingSpec pad +configProperty (Projection pps) = "projection" .=~ object (map projectionProperty pps) +configProperty (Range rcs) = "range" .=~ object (map rangeConfigProperty rcs) configProperty (Scale scs) = scaleConfig_ scs -configProperty (TimeFormat fmt) = "timeFormat" .= fmt -configProperty (View vcs) = "view" .= object (concatMap viewConfigProperties vcs) +configProperty (TimeFormat fmt) = "timeFormat" .=~ fmt +configProperty (View vcs) = "view" .=~ object (concatMap viewConfigProperties vcs) -configProperty (NamedStyle nme mps) = "style" .= object [mprops_ nme mps] +configProperty (NamedStyle nme mps) = "style" .=~ toObject [oldMprops_ nme mps] configProperty (NamedStyles styles) = - let toStyle = uncurry mprops_ - in "style" .= object (map toStyle styles) + let toStyle = uncurry oldMprops_ + in "style" .=~ toObject (map toStyle styles) {-| @@ -705,7 +708,7 @@ scaleConfig_ :: [ScaleConfig] -> LabelledSpec -- scaleConfig_ [] = "scale" .= A.Null -- not sure here -scaleConfig_ scs = "scale" .= object (map scaleConfigProperty scs) +scaleConfig_ scs = "scale" .=~ object (map scaleConfigProperty scs) -- | Indicates the style in which field names are displayed. @@ -1043,7 +1046,7 @@ -- -- @since 0.9.0.0 -legendConfigProperty :: LegendConfig -> LabelledSpec +legendConfigProperty :: LegendConfig -> Pair legendConfigProperty (LeAria b) = "bool" .= b legendConfigProperty (LeAriaDescription t) = "description" .= t legendConfigProperty (LeClipHeight x) = "clipHeight" .= x @@ -1140,7 +1143,7 @@ | RSymbol T.Text -rangeConfigProperty :: RangeConfig -> LabelledSpec +rangeConfigProperty :: RangeConfig -> Pair rangeConfigProperty rangeCfg = let (l, n) = case rangeCfg of RCategory nme -> ("category", nme) @@ -1153,7 +1156,7 @@ in l .= object [schemeProperty n []] -scaleConfigProperty :: ScaleConfig -> LabelledSpec +scaleConfigProperty :: ScaleConfig -> Pair scaleConfigProperty (SCBandPaddingInner x) = "bandPaddingInner" .= x scaleConfigProperty (SCBandPaddingOuter x) = "bandPaddingOuter" .= x scaleConfigProperty (SCBarBandPaddingInner x) = "barBandPaddingInner" .= x @@ -1306,7 +1309,7 @@ -- be used instead. -viewConfigProperties :: ViewConfig -> [LabelledSpec] +viewConfigProperties :: ViewConfig -> [Pair] viewConfigProperties (ViewBackgroundStyle bs) = map viewBackgroundSpec bs viewConfigProperties (ViewClip b) = ["clip" .= b] viewConfigProperties (ViewWidth x) = ["continuousWidth" .= x] @@ -1674,7 +1677,7 @@ -- @since 0.5.0.0 -axisConfigProperty :: AxisConfig -> LabelledSpec +axisConfigProperty :: AxisConfig -> Pair axisConfigProperty (AStyle [s]) = "style" .= s axisConfigProperty (AStyle s) = "style" .= s @@ -1899,7 +1902,7 @@ -- @since 0.4.0.0 -titleConfigSpec :: TitleConfig -> LabelledSpec +titleConfigSpec :: TitleConfig -> Pair titleConfigSpec (TAlign ha) = "align" .= hAlignLabel ha titleConfigSpec (TAnchor an) = "anchor" .= anchorLabel an titleConfigSpec (TAngle x) = "angle" .= x @@ -1954,7 +1957,7 @@ -- Prior to @0.6.0.0@ this was either @ConcatSpacing@ or @FSpacing@. -compConfigProperty :: CompositionConfig -> LabelledSpec +compConfigProperty :: CompositionConfig -> Pair compConfigProperty (CompColumns n) = "columns" .= n compConfigProperty (CompSpacing x) = "spacing" .= x diff --git a/src/Graphics/Vega/VegaLite/Core.hs b/src/Graphics/Vega/VegaLite/Core.hs --- a/src/Graphics/Vega/VegaLite/Core.hs +++ b/src/Graphics/Vega/VegaLite/Core.hs @@ -4,7 +4,7 @@ {-| Module : Graphics.Vega.VegaLite.Core -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -174,9 +174,15 @@ import Prelude hiding (filter, lookup, repeat) import qualified Data.Aeson as A + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#endif + import qualified Data.Text as T import Data.Aeson (object, toJSON, (.=)) +import Data.Aeson.Types (Pair) import Data.Maybe (mapMaybe) #if !(MIN_VERSION_base(4, 12, 0)) @@ -259,6 +265,7 @@ , cInterpolateSpec , viewBackgroundSpec , symbolLabel + , (.=~), toObject, toKey ) import Graphics.Vega.VegaLite.Input ( Data @@ -286,7 +293,6 @@ ( VLProperty(..) , VLSpec , PropertySpec - , LabelledSpec , EncodingSpec(..) , BuildEncodingSpecs , TransformSpec(..) @@ -320,6 +326,7 @@ , imputeTS ) + --- helpers -- This could be extended to any Ord type but specialize for now to Double @@ -334,40 +341,40 @@ clamped xmin xmax x = max xmin (min xmax x) -repeat_ :: Arrangement -> LabelledSpec +repeat_ :: Arrangement -> Pair repeat_ arr = "repeat" .= arrangementLabel arr -sort_ :: [SortProperty] -> LabelledSpec +sort_ :: [SortProperty] -> Pair sort_ ops = "sort" .= sortPropertySpec ops mchan_ :: T.Text -> [MarkChannel] -> EncodingSpec -mchan_ f ms = ES (f .= object (concatMap markChannelProperty ms)) +mchan_ f ms = ES (f .=~ object (concatMap markChannelProperty ms)) -mtype_ :: Measurement -> LabelledSpec +mtype_ :: Measurement -> Pair mtype_ m = "type" .= measurementLabel m -timeUnit_ :: TimeUnit -> LabelledSpec +timeUnit_ :: TimeUnit -> Pair timeUnit_ tu = "timeUnit" .= timeUnitSpec tu -- The assumption at the moment is that it's always correct to -- replace the empty list by null. -- -scaleProp_ :: [ScaleProperty] -> LabelledSpec +scaleProp_ :: [ScaleProperty] -> Pair scaleProp_ [] = "scale" .= A.Null scaleProp_ sps = "scale" .= object (map scaleProperty sps) -value_ :: T.Text -> LabelledSpec +value_ :: T.Text -> Pair value_ v = "value" .= v -selCond_ :: (a -> [LabelledSpec]) -> BooleanOp -> [a] -> [a] -> [LabelledSpec] +selCond_ :: (a -> [Pair]) -> BooleanOp -> [a] -> [a] -> [Pair] selCond_ getProps selName ifClause elseClause = let h = ("condition", hkey) toProps = concatMap getProps - hkey = object (("selection", booleanOpSpec selName) : toProps ifClause) + hkey = object (toKey ("selection", booleanOpSpec selName) : toProps ifClause) hs = toProps elseClause - in h : hs + in (h : hs) -- Special case the single-condition check, so that I don't get false -- positives when comparing against the Vega-Lite specification. There @@ -380,7 +387,7 @@ -- selection: xxx -- which happens for the Selection operator. -- -dataCond_ :: (a -> [LabelledSpec]) -> [(BooleanOp, [a])] -> [a] -> [LabelledSpec] +dataCond_ :: (a -> [Pair]) -> [(BooleanOp, [a])] -> [a] -> [Pair] dataCond_ getProps tests elseClause = let h = ("condition", condClause) condClause = case conds of @@ -390,10 +397,10 @@ testClause (Selection sel, ifClause) = object (("selection" .= sel) : toProps ifClause) testClause (predicate, ifClause) = - object (("test", booleanOpSpec predicate) : toProps ifClause) + object (toKey ("test", booleanOpSpec predicate) : toProps ifClause) toProps = concatMap getProps hs = toProps elseClause - in h : hs + in (h : hs) @@ -577,8 +584,8 @@ -- -- @since 0.6.0.0 -markChannelProperty :: MarkChannel -> [LabelledSpec] -markChannelProperty (MName s) = [field_ s] +markChannelProperty :: MarkChannel -> [Pair] +markChannelProperty (MName s) = ["field" .= s] markChannelProperty (MRepeat arr) = ["field" .= object [repeat_ arr]] markChannelProperty (MRepeatDatum arr) = ["datum" .= object [repeat_ arr]] markChannelProperty (MmType t) = [mtype_ t] @@ -636,7 +643,7 @@ -- -- Prior to @0.5.0.0@ this argument was @['LabelledSpec']@. -> PropertySpec -encoding channels = (VLEncoding, object (map unES channels)) +encoding channels = (VLEncoding, toObject (map unES channels)) {-| @@ -823,7 +830,7 @@ -- channel. -scaleProperty :: ScaleProperty -> LabelledSpec +scaleProperty :: ScaleProperty -> Pair scaleProperty (SType sType) = "type" .= scaleLabel sType scaleProperty (SAlign c) = "align" .= clamped 0 1 c scaleProperty (SBase x) = "base" .= x @@ -859,7 +866,7 @@ -- -- based on schema 3.3.0 #/definitions/SchemeParams -schemeProperty :: T.Text -> [Double] -> LabelledSpec +schemeProperty :: T.Text -> [Double] -> Pair schemeProperty nme [n] = "scheme" .= object ["name" .= nme, "count" .= n] schemeProperty nme [mn, mx] = "scheme" .= object ["name" .= nme, "extent" .= [mn, mx]] schemeProperty nme [n, mn, mx] = "scheme" .= object ["name" .= nme, "count" .= n, "extent" .= [mn, mx]] @@ -919,11 +926,11 @@ -- @since 0.4.0.0 -sortProperty :: SortProperty -> [LabelledSpec] +sortProperty :: SortProperty -> [Pair] sortProperty Ascending = [order_ "ascending"] sortProperty Descending = [order_ "descending"] sortProperty (ByChannel ch) = ["encoding" .= channelLabel ch] -sortProperty (ByFieldOp field op) = [field_ field, op_ op] +sortProperty (ByFieldOp field op) = ["field" .= field, op_ op] sortProperty (ByRepeatOp arr op) = ["field" .= object [repeat_ arr], op_ op] sortProperty (CustomSort _) = [] @@ -1103,8 +1110,8 @@ -- -- @since 0.5.0.0 -positionChannelProperty :: PositionChannel -> LabelledSpec -positionChannelProperty (PName s) = field_ s +positionChannelProperty :: PositionChannel -> Pair +positionChannelProperty (PName s) = "field" .= s positionChannelProperty (PmType m) = mtype_ m positionChannelProperty (PBin b) = bin b positionChannelProperty PBinned = binned_ @@ -1636,7 +1643,7 @@ -- ^ The z-index of the axis, relative to the chart marks. -axisProperty :: AxisProperty -> LabelledSpec +axisProperty :: AxisProperty -> Pair axisProperty (AxStyle [s]) = "style" .= s axisProperty (AxStyle s) = "style" .= s @@ -2036,10 +2043,15 @@ -- @since 0.4.0.0 -fop_ :: FieldName -> T.Text -> DataValue -> [LabelledSpec] -fop_ field label val = [field_ field, label .= dataValueSpec val] +#if MIN_VERSION_aeson(2, 0, 0) +fop_ :: FieldName -> Key.Key -> DataValue -> [Pair] +#else +fop_ :: FieldName -> T.Text -> DataValue -> [Pair] +#endif +fop_ field label val = ["field" .= field, + label .= dataValueSpec val] -filterProperty :: Filter -> [LabelledSpec] +filterProperty :: Filter -> [Pair] filterProperty (FEqual field val) = fop_ field "equal" val filterProperty (FLessThan field val) = fop_ field "lt" val @@ -2059,7 +2071,7 @@ process [] = A.Null process dts = dateTimeSpec dts - in [field_ field, "range" .= ans] + in ["field" .= field, "range" .= ans] filterProperty (FOneOf field vals) = let ans = case vals of @@ -2068,9 +2080,9 @@ Strings ss -> map toJSON ss Booleans bs -> map toJSON bs - in [field_ field, "oneOf" .= ans] + in ["field" .= field, "oneOf" .= ans] -filterProperty (FValid field) = [field_ field, "valid" .= True] +filterProperty (FValid field) = ["field" .= field, "valid" .= True] filterProperty _ = [] -- ignore FExpr and FCompose @@ -2189,8 +2201,8 @@ -- -- @since 0.9.0.0 -hyperlinkChannelProperty :: HyperlinkChannel -> [LabelledSpec] -hyperlinkChannelProperty (HName s) = [field_ s] +hyperlinkChannelProperty :: HyperlinkChannel -> [Pair] +hyperlinkChannelProperty (HName s) = ["field" .= s] hyperlinkChannelProperty (HRepeat arr) = ["field" .= object [repeat_ arr]] hyperlinkChannelProperty (HmType t) = [mtype_ t] hyperlinkChannelProperty (HAggregate op) = [aggregate_ op] @@ -2271,8 +2283,8 @@ -- ^ Display no title. -ariaDescriptionChannelProperty :: AriaDescriptionChannel -> [LabelledSpec] -ariaDescriptionChannelProperty (ADName s) = [field_ s] +ariaDescriptionChannelProperty :: AriaDescriptionChannel -> [Pair] +ariaDescriptionChannelProperty (ADName s) = ["field" .= s] ariaDescriptionChannelProperty (ADRepeat arr) = ["field" .= object [repeat_ arr]] ariaDescriptionChannelProperty (ADmType t) = [mtype_ t] ariaDescriptionChannelProperty (ADAggregate op) = [aggregate_ op] @@ -2406,14 +2418,14 @@ -- -- @since 0.4.0.0 -facetChannelProperty :: FacetChannel -> LabelledSpec -facetChannelProperty (FName s) = field_ s +facetChannelProperty :: FacetChannel -> Pair +facetChannelProperty (FName s) = "field" .= s facetChannelProperty (FmType measure) = mtype_ measure facetChannelProperty (FAlign algn) = "align" .= compositionAlignmentSpec algn facetChannelProperty (FAggregate op) = aggregate_ op facetChannelProperty (FBin bps) = bin bps facetChannelProperty (FCenter b) = "center" .= b -facetChannelProperty (FHeader hps) = header_ "" hps +facetChannelProperty (FHeader hps) = toKey (header_ "" hps) facetChannelProperty (FSort sps) = sort_ sps facetChannelProperty (FSpacing x) = "spacing" .= x facetChannelProperty (FTitle s) = "title" .= s @@ -2527,8 +2539,8 @@ -- -- @since 0.4.0.0 -textChannelProperty :: TextChannel -> [LabelledSpec] -textChannelProperty (TName s) = [field_ s] +textChannelProperty :: TextChannel -> [Pair] +textChannelProperty (TName s) = ["field" .= s] textChannelProperty (TRepeat arr) = ["field" .= object [repeat_ arr]] textChannelProperty (TRepeatDatum arr) = ["datum" .= object [repeat_ arr]] textChannelProperty (TmType measure) = [mtype_ measure] @@ -2625,11 +2637,11 @@ -- -- @since 0.11.0.0 -orderChannelProperty :: OrderChannel -> [LabelledSpec] +orderChannelProperty :: OrderChannel -> [Pair] orderChannelProperty (OAggregate op) = [aggregate_ op] orderChannelProperty (OBand x) = ["band" .= x] orderChannelProperty (OBin bps) = [bin bps] -orderChannelProperty (OName s) = [field_ s] +orderChannelProperty (OName s) = ["field" .= s] orderChannelProperty (ORepeat arr) = ["field" .= object [repeat_ arr]] orderChannelProperty (OSort ops) = [sort_ ops] orderChannelProperty (OTimeUnit tu) = [timeUnit_ tu] @@ -2658,8 +2670,8 @@ -- ^ How should the detail field be aggregated? -detailChannelProperty :: DetailChannel -> LabelledSpec -detailChannelProperty (DName s) = field_ s +detailChannelProperty :: DetailChannel -> Pair +detailChannelProperty (DName s) = "field" .= s -- field_ s detailChannelProperty (DmType t) = mtype_ t detailChannelProperty (DBin bps) = bin bps detailChannelProperty (DTimeUnit tu) = timeUnit_ tu @@ -2677,7 +2689,7 @@ | RowBy [FacetChannel] -facetMappingProperty :: FacetMapping -> LabelledSpec +facetMappingProperty :: FacetMapping -> Pair facetMappingProperty (RowBy fFields) = "row" .= object (map facetChannelProperty fFields) facetMappingProperty (ColumnBy fFields) = @@ -2708,9 +2720,9 @@ [ConfigureSpec] -- ^ The configuration options, created with 'Graphics.Vega.VegaLite.configuration'. -- - -- Prior to version @0.5.0.0@ this was @[LabelledSpec]@. + -- Prior to version @0.5.0.0@ this was @['LabelledSpec']@. -> PropertySpec -configure configs = (VLConfig, object (map unCS configs)) +configure configs = (VLConfig, toObject (map unCS configs)) -- | Alignment to apply to grid rows and columns generated by a composition @@ -3149,7 +3161,7 @@ -- -- Prior to @0.5.0.0@ this argument was @['LabelledSpec']@. -> PropertySpec -resolve res = (VLResolve, object (map unRS res)) +resolve res = (VLResolve, toObject (map unRS res)) {-| @@ -5088,4 +5100,4 @@ -- ^ A separate list of properties for each channel. -> BuildEncodingSpecs tooltips tDefs ols = - ES ("tooltip" .= map (object . concatMap textChannelProperty) tDefs) : ols + ES ("tooltip" .=~ map (object . concatMap textChannelProperty) tDefs) : ols diff --git a/src/Graphics/Vega/VegaLite/Foundation.hs b/src/Graphics/Vega/VegaLite/Foundation.hs --- a/src/Graphics/Vega/VegaLite/Foundation.hs +++ b/src/Graphics/Vega/VegaLite/Foundation.hs @@ -3,7 +3,7 @@ {-| Module : Graphics.Vega.VegaLite.Foundation -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -112,13 +112,29 @@ , header_ , order_ , allowNull + + -- aeson 2.0 support + , (.=~) + , toKey + , toKeys + , toObject ) where import qualified Data.Aeson as A + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#endif + import qualified Data.Text as T +#if MIN_VERSION_aeson(2, 0, 0) +import Control.Arrow (first) +#endif + import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair, ToJSON) #if !(MIN_VERSION_base(4, 12, 0)) import Data.Monoid ((<>)) @@ -135,14 +151,45 @@ ) -field_ :: FieldName -> LabelledSpec +{- +Similar to the Aeson .= version, but retains the Text,Value pairing as +this matches LabelledSpec. Ideally we'd change LabelledSpec to match +Pair (aka Key,Value) but then we'd have different types depending on +the version of aeson in use, which is less-than-ideal. The current +thinking is that we can bump the minimum aeson value to 2.0 at some +point and make the change then. + +It does leave a number of "internal" routines in place that return +LabelledSpec rather than Pair, since they have been made available for +use, which means a confusing set of "this function can use .= and this +one has to use .=~". +-} + +(.=~) :: ToJSON a => T.Text -> a -> (T.Text, A.Value) +a .=~ b = (a, toJSON b) + +toKey :: LabelledSpec -> Pair +#if MIN_VERSION_aeson(2, 0, 0) +toKey = first Key.fromText +#else +toKey = id +#endif + +toKeys :: [LabelledSpec] -> [Pair] +toKeys = map toKey + +toObject :: [LabelledSpec] -> VLSpec +toObject = object . toKeys + + +field_ :: FieldName -> Pair field_ f = "field" .= f header_ :: T.Text -> [HeaderProperty] -> LabelledSpec -header_ extra hps = ("header" <> extra) .= object (map headerProperty hps) +header_ extra hps = ("header" <> extra, object (map headerProperty hps)) -- could restrict to ascending/descending -order_ :: T.Text -> LabelledSpec +order_ :: T.Text -> Pair order_ o = "order" .= o @@ -1066,10 +1113,9 @@ stackOffsetSpec StCenter = "center" stackOffsetSpec NoStack = A.Null -stackOffset :: StackOffset -> LabelledSpec +stackOffset :: StackOffset -> Pair stackOffset so = "stack" .= stackOffsetSpec so - stackPropertySpecOffset , stackPropertySpecSort:: StackProperty -> Maybe VLSpec stackPropertySpecOffset (StOffset op) = Just (stackOffsetSpec op) stackPropertySpecOffset _ = Nothing @@ -1247,8 +1293,8 @@ RLegend chRules -> ("legend", chRules) RScale chRules -> ("scale", chRules) - ans = map (\(ch, rule) -> channelLabel ch .= resolutionLabel rule) rls - in RS (nme, object ans) + ans = map (\(ch, rule) -> channelLabel ch .=~ resolutionLabel rule) rls + in RS (nme, toObject ans) -- | This is used with 'Graphics.Vega.VegaLite.bounds' to define the extent of a sub plot. @@ -1350,7 +1396,7 @@ -- ^ Recalculate autosizing on every view update. -autosizeProperty :: Autosize -> LabelledSpec +autosizeProperty :: Autosize -> Pair autosizeProperty APad = "type" .= fromT "pad" autosizeProperty AFit = "type" .= fromT "fit" autosizeProperty AFitX = "type" .= fromT "fit-x" @@ -1374,12 +1420,11 @@ | LayerFields [FieldName] -- ^ @since 0.9.0.0 -repeatFieldsProperty :: RepeatFields -> LabelledSpec +repeatFieldsProperty :: RepeatFields -> Pair repeatFieldsProperty (RowFields fs) = "row" .= fs repeatFieldsProperty (ColumnFields fs) = "column" .= fs repeatFieldsProperty (LayerFields fs) = "layer" .= fs - {-| Indicates the type of color interpolation to apply, when mapping a data field @@ -1414,8 +1459,13 @@ -- Need to tie down some types as things are too polymorphic, -- particularly in the presence of OverloadedStrings. -- -pairT :: T.Text -> T.Text -> (T.Text, A.Value) +#if MIN_VERSION_aeson(2, 0, 0) +pairT :: Key.Key -> T.Text -> Pair pairT a b = a .= b +#else +pairT :: T.Text -> T.Text -> Pair +pairT a b = a .= b +#endif cInterpolateSpec :: CInterpolate -> VLSpec @@ -1489,7 +1539,7 @@ -- ^ The mitre limit at which to bevel the line around the background, if drawn. -viewBackgroundSpec :: ViewBackground -> LabelledSpec +viewBackgroundSpec :: ViewBackground -> Pair viewBackgroundSpec (VBStyle [style]) = "style" .= style -- special case singleton viewBackgroundSpec (VBStyle styles) = "style" .= styles viewBackgroundSpec (VBCornerRadius r) = "cornerRadius" .= r @@ -1693,7 +1743,7 @@ -- @since 0.4.0.0 -headerProperty :: HeaderProperty -> LabelledSpec +headerProperty :: HeaderProperty -> Pair headerProperty (HFormat fmt) = "format" .= fmt headerProperty HFormatAsNum = "formatType" .= fromT "number" headerProperty HFormatAsTemporal = "formatType" .= fromT "time" diff --git a/src/Graphics/Vega/VegaLite/Geometry.hs b/src/Graphics/Vega/VegaLite/Geometry.hs --- a/src/Graphics/Vega/VegaLite/Geometry.hs +++ b/src/Graphics/Vega/VegaLite/Geometry.hs @@ -3,7 +3,7 @@ {-| Module : Graphics.Vega.VegaLite.Geometry -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -35,10 +35,13 @@ ) where import qualified Data.Aeson as A + import qualified Data.Text as T import Control.Arrow (second) + import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair) #if !(MIN_VERSION_base(4, 12, 0)) import Data.Monoid ((<>)) @@ -49,11 +52,13 @@ ( DataValue , dataValueSpec ) -import Graphics.Vega.VegaLite.Foundation (fromT) +import Graphics.Vega.VegaLite.Foundation + ( fromT + , toObject + ) import Graphics.Vega.VegaLite.Specification ( VLProperty(VLData, VLProjection) , VLSpec - , LabelledSpec , PropertySpec ) import Graphics.Vega.VegaLite.Input @@ -61,7 +66,7 @@ ) -type_ :: T.Text -> LabelledSpec +type_ :: T.Text -> Pair type_ t = "type" .= t @@ -285,7 +290,7 @@ -- ^ @Satellite@ map projection tilt. -projectionProperty :: ProjectionProperty -> LabelledSpec +projectionProperty :: ProjectionProperty -> Pair projectionProperty (PrType proj) = "type" .= projectionLabel proj projectionProperty (PrClipAngle numOrNull) = "clipAngle" .= maybe A.Null toJSON numOrNull projectionProperty (PrClipExtent rClip) = @@ -366,7 +371,7 @@ <> if null properties then [] else [("properties", - object (map (second dataValueSpec) properties))] + toObject (map (second dataValueSpec) properties))] ) @@ -477,7 +482,7 @@ -- The default is @2.5@. -graticuleProperty :: GraticuleProperty -> LabelledSpec +graticuleProperty :: GraticuleProperty -> Pair graticuleProperty (GrExtent (lng1, lat1) (lng2, lat2)) = "extent" .= [[lng1, lat1], [lng2, lat2]] graticuleProperty (GrExtentMajor (lng1, lat1) (lng2, lat2)) = diff --git a/src/Graphics/Vega/VegaLite/Input.hs b/src/Graphics/Vega/VegaLite/Input.hs --- a/src/Graphics/Vega/VegaLite/Input.hs +++ b/src/Graphics/Vega/VegaLite/Input.hs @@ -4,7 +4,7 @@ {-| Module : Graphics.Vega.VegaLite.Input -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -40,12 +40,14 @@ ) where import qualified Data.Aeson as A + import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Control.Arrow (second) import Data.Aeson ((.=), Value, decode, encode, object, toJSON) +import Data.Aeson.Types (Pair) import Data.Maybe (fromMaybe, mapMaybe) #if !(MIN_VERSION_base(4, 12, 0)) @@ -59,6 +61,7 @@ ) import Graphics.Vega.VegaLite.Foundation ( FieldName + , toObject ) import Graphics.Vega.VegaLite.Specification ( VLProperty(VLData, VLDatasets) @@ -177,7 +180,7 @@ type Data = (VLProperty, VLSpec) -formatProperty :: Format -> [LabelledSpec] +formatProperty :: Format -> [Pair] formatProperty (JSON js) = let ps = [("type", "json")] <> if T.null (T.strip js) then [] else [("property", js)] @@ -194,7 +197,7 @@ , "mesh" .= os ] formatProperty (Parse fmts) = - let pObj = object (map (second dataTypeSpec) fmts) + let pObj = toObject (map (second dataTypeSpec) fmts) in [("parse", pObj)] @@ -222,7 +225,7 @@ @ -} dataRow :: [(FieldName, DataValue)] -> [DataRow] -> [DataRow] -dataRow rw = (object (map (second dataValueSpec) rw) :) +dataRow rw = (toObject (map (second dataValueSpec) rw) :) {-| @@ -271,7 +274,7 @@ in fromMaybe din (convert din >>= extract') - in (VLDatasets, object specs) + in (VLDatasets, toObject specs) -- | This is for composed specifications, and it tells the visualization to @@ -317,7 +320,7 @@ -- a relatively easy conversion. The type annotation isn't needed -- but left in for reference. -- - convert :: Maybe [(T.Text, Value)] + convert :: Maybe [Pair] convert = HM.toList <$> decode (encode dataSpec) extract [v] = Just v @@ -359,7 +362,7 @@ -- calls to 'dataColumn'. -> Data dataFromColumns fmts cols = - let dataArray = map object (transpose cols) + let dataArray = map toObject (transpose cols) vals = [("values", toJSON dataArray)] <> if null fmts diff --git a/src/Graphics/Vega/VegaLite/Legend.hs b/src/Graphics/Vega/VegaLite/Legend.hs --- a/src/Graphics/Vega/VegaLite/Legend.hs +++ b/src/Graphics/Vega/VegaLite/Legend.hs @@ -32,7 +32,9 @@ import qualified Data.Text as T import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair) + import Graphics.Vega.VegaLite.Foundation ( APosition , Bounds @@ -70,7 +72,7 @@ ( ScaleNice , scaleNiceSpec ) -import Graphics.Vega.VegaLite.Specification (VLSpec, LabelledSpec) +import Graphics.Vega.VegaLite.Specification (VLSpec) import Graphics.Vega.VegaLite.Time ( DateTime , dateTimeSpec @@ -165,7 +167,7 @@ | LeLTopRight [BaseLegendLayout] -legendLayoutSpec :: LegendLayout -> LabelledSpec +legendLayoutSpec :: LegendLayout -> Pair legendLayoutSpec (LeLAnchor anc) = "anchor" .= anchorLabel anc legendLayoutSpec (LeLBottom bl) = "bottom" .= toBLSpec bl legendLayoutSpec (LeLBottomLeft bl) = "bottom-left" .= toBLSpec bl @@ -210,7 +212,7 @@ toBLSpec :: [BaseLegendLayout] -> VLSpec toBLSpec = object . map baseLegendLayoutSpec -baseLegendLayoutSpec :: BaseLegendLayout -> LabelledSpec +baseLegendLayoutSpec :: BaseLegendLayout -> Pair baseLegendLayoutSpec (BLeLAnchor anc) = "anchor" .= anchorLabel anc baseLegendLayoutSpec (BLeLBounds bnds) = "bounds" .= boundsSpec bnds baseLegendLayoutSpec (BLeLCenter b) = "center" .= b @@ -490,7 +492,7 @@ | LZIndex ZIndex -- ^ The z-index at which to draw the legend. -legendProperty :: LegendProperty -> LabelledSpec +legendProperty :: LegendProperty -> Pair legendProperty (LAria b) = "aria" .= b legendProperty (LAriaDescription t) = "description" .= t legendProperty (LClipHeight x) = "clipHeight" .= x @@ -569,7 +571,7 @@ legendProperty (LZIndex z) = "zindex" .= z -legendProp_ :: [LegendProperty] -> LabelledSpec +legendProp_ :: [LegendProperty] -> Pair legendProp_ [] = "legend" .= A.Null legendProp_ lps = "legend" .= object (map legendProperty lps) diff --git a/src/Graphics/Vega/VegaLite/Mark.hs b/src/Graphics/Vega/VegaLite/Mark.hs --- a/src/Graphics/Vega/VegaLite/Mark.hs +++ b/src/Graphics/Vega/VegaLite/Mark.hs @@ -1,13 +1,14 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-| Module : Graphics.Vega.VegaLite.Mark -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com Stability : unstable -Portability : OverloadedStrings +Portability : CPP, OverloadedStrings This provides the functionality of the VegaLite module but is not directly exported to the user. @@ -29,7 +30,7 @@ , BlendMode(..) -- not for external export - , mprops_ + , oldMprops_ , markLabel , markProperty @@ -37,9 +38,15 @@ ) where import qualified Data.Aeson as A + +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#endif + import qualified Data.Text as T import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair) import Data.List (sortOn) @@ -71,6 +78,7 @@ , ttContentLabel , hAlignLabel , vAlignLabel + , (.=~) ) import Graphics.Vega.VegaLite.Specification ( VLSpec @@ -79,11 +87,20 @@ -- As of version 0.6.0.0, an empty list is mapped to True -mprops_ :: T.Text -> [MarkProperty] -> LabelledSpec +#if MIN_VERSION_aeson(2, 0, 0) +mprops_ :: Key.Key -> [MarkProperty] -> Pair +#else +mprops_ :: T.Text -> [MarkProperty] -> Pair +#endif mprops_ f [] = f .= True mprops_ f mps = f .= object (map markProperty mps) +-- Used by Configuration to create top-level data +oldMprops_ :: T.Text -> [MarkProperty] -> LabelledSpec +oldMprops_ f [] = f .=~ True +oldMprops_ f mps = f .=~ object (map markProperty mps) + -- | Type of visual mark used to represent data in the visualization. -- -- The properties of the mark can be changed with the 'MarkProperty' @@ -713,7 +730,7 @@ -- @since 0.9.0.0 -markProperty :: MarkProperty -> LabelledSpec +markProperty :: MarkProperty -> Pair -- special case the gradients markProperty (MColorGradient dir stops opts) = @@ -868,7 +885,7 @@ let sortedStops = sortOn fst stops in object ([ "gradient" .= colorGradientLabel dir , "stops" .= map stopSpec sortedStops ] - ++ map gradientProperty props) + ++ map gradientProperty props) {-| @@ -1024,10 +1041,10 @@ -- This is a little different from the other calls since I wanted to -- make sure the scale factor was encoded as a number not a string. -- -extent_ :: T.Text -> LabelledSpec +extent_ :: T.Text -> Pair extent_ v = "extent" .= v -markErrorExtentLSpec :: MarkErrorExtent -> LabelledSpec +markErrorExtentLSpec :: MarkErrorExtent -> Pair markErrorExtentLSpec ConfidenceInterval = extent_ "ci" markErrorExtentLSpec StdErr = extent_ "stderr" markErrorExtentLSpec StdDev = extent_ "stdev" @@ -1129,7 +1146,7 @@ -- only). The default is 0.5. -gradientProperty :: GradientProperty -> LabelledSpec +gradientProperty :: GradientProperty -> Pair gradientProperty (GrX1 x) = "x1" .= x gradientProperty (GrX2 x) = "x2" .= x gradientProperty (GrY1 x) = "y1" .= x diff --git a/src/Graphics/Vega/VegaLite/Scale.hs b/src/Graphics/Vega/VegaLite/Scale.hs --- a/src/Graphics/Vega/VegaLite/Scale.hs +++ b/src/Graphics/Vega/VegaLite/Scale.hs @@ -2,7 +2,7 @@ {-| Module : Graphics.Vega.VegaLite.Scale -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -29,6 +29,7 @@ import qualified Data.Text as T import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair) import Graphics.Vega.VegaLite.Foundation @@ -39,7 +40,6 @@ ) import Graphics.Vega.VegaLite.Specification ( VLSpec - , LabelledSpec , SelectionLabel ) import Graphics.Vega.VegaLite.Time @@ -151,7 +151,7 @@ -- ^ Date-time values that define a scale domain. -scaleDomainProperty :: ScaleDomain -> LabelledSpec +scaleDomainProperty :: ScaleDomain -> Pair scaleDomainProperty (DMax x) = "domainMax" .= x scaleDomainProperty (DMaxTime dts) = "domainMax" .= dateTimeSpec dts diff --git a/src/Graphics/Vega/VegaLite/Selection.hs b/src/Graphics/Vega/VegaLite/Selection.hs --- a/src/Graphics/Vega/VegaLite/Selection.hs +++ b/src/Graphics/Vega/VegaLite/Selection.hs @@ -35,6 +35,7 @@ import Control.Arrow (second) import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair) import Data.Maybe (mapMaybe) @@ -55,11 +56,11 @@ , fromColor , fromDS , cursorLabel + , (.=~), toKey, toObject ) import Graphics.Vega.VegaLite.Specification ( VLProperty(VLSelection) , PropertySpec - , LabelledSpec , SelectSpec(..) , BuildSelectSpecs , SelectionLabel @@ -238,10 +239,10 @@ -- [Vega-Lite toggle documentation](https://vega.github.io/vega-lite/docs/toggle.html). -selectionProperties :: SelectionProperty -> [LabelledSpec] +selectionProperties :: SelectionProperty -> [Pair] selectionProperties (Fields fNames) = ["fields" .= fNames] selectionProperties (Encodings channels) = ["encodings" .= map channelLabel channels] -selectionProperties (SInit iVals) = ["init" .= object (map (second dataValueSpec) iVals)] +selectionProperties (SInit iVals) = ["init" .= toObject (map (second dataValueSpec) iVals)] selectionProperties (SInitInterval Nothing Nothing) = [] selectionProperties (SInitInterval mx my) = let conv (_, Nothing) = Nothing @@ -321,7 +322,7 @@ -- ^ The offset at which to start the dash pattern. -selectionMarkProperty :: SelectionMarkProperty -> LabelledSpec +selectionMarkProperty :: SelectionMarkProperty -> Pair selectionMarkProperty (SMCursor c) = "cursor" .= cursorLabel c selectionMarkProperty (SMFill colour) = "fill" .= fromColor colour selectionMarkProperty (SMFillOpacity x) = "fillOpacity" .= x @@ -373,10 +374,10 @@ -- ^ The initial text for input elements such as text fields. -inputProperty :: InputProperty -> LabelledSpec +inputProperty :: InputProperty -> Pair inputProperty (Debounce x) = "debounce" .= x inputProperty (Element el) = "element" .= el -- #/definitions/Element -inputProperty (InOptions opts) = "options" .= map toJSON opts +inputProperty (InOptions opts) = "options" .= map toJSON opts -- don't need the map inputProperty (InMin x) = "min" .= x inputProperty (InMax x) = "max" .= x inputProperty (InName s) = "name" .= s @@ -421,7 +422,7 @@ -- ^ Color input element that can bound to a named field value. -bindingSpec :: Binding -> LabelledSpec +bindingSpec :: Binding -> Pair bindingSpec bnd = let (lbl, input, ps) = case bnd of IRange label props -> (label, fromT "range", props) @@ -438,7 +439,7 @@ ITel label props -> (label, "tel", props) IColor label props -> (label, "color", props) - in (lbl, object (("input" .= input) : map inputProperty ps)) + in toKey (lbl, object (("input" .= input) : map inputProperty ps)) {-| @@ -465,7 +466,7 @@ -- that should trigger the selection. -bindLegendProperty :: BindLegendProperty -> [LabelledSpec] +bindLegendProperty :: BindLegendProperty -> [Pair] bindLegendProperty (BLField f) = [ toLBind Nothing , "fields" .= [f] ] @@ -479,7 +480,7 @@ , "encodings" .= [channelLabel ch] ] -toLBind :: Maybe T.Text -> LabelledSpec +toLBind :: Maybe T.Text -> Pair toLBind Nothing = "bind" .= fromT "legend" toLBind (Just es) = "bind" .= object ["legend" .= es] @@ -506,7 +507,7 @@ -- -- Prior to @0.5.0.0@ this argument was @['LabelledSpec']@. -> PropertySpec -selection sels = (VLSelection, object (map unS sels)) +selection sels = (VLSelection, toObject (map unS sels)) {-| @@ -535,4 +536,4 @@ select nme sType options ols = -- TODO: elm filters out those properties that are set to A.Null let selProps = ("type" .= selectionLabel sType) : concatMap selectionProperties options - in S (nme .= object selProps) : ols + in S (nme .=~ object selProps) : ols diff --git a/src/Graphics/Vega/VegaLite/Specification.hs b/src/Graphics/Vega/VegaLite/Specification.hs --- a/src/Graphics/Vega/VegaLite/Specification.hs +++ b/src/Graphics/Vega/VegaLite/Specification.hs @@ -3,7 +3,7 @@ {-| Module : Graphics.Vega.VegaLite.Specification -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -50,6 +50,10 @@ ) where +#if MIN_VERSION_aeson(2, 0, 0) +import qualified Data.Aeson.Key as Key +#endif + -- VegaLite uses these symbols. import Prelude hiding (filter, lookup, repeat) @@ -58,7 +62,12 @@ import Control.Arrow (first) -- Aeson's Value type conflicts with the Number type +#if MIN_VERSION_aeson(2, 0, 0) +import Data.Aeson (Value, object, toJSON) +#else import Data.Aeson (Value, object, (.=)) +#endif + import Data.Maybe (catMaybes, fromMaybe) #if !(MIN_VERSION_base(4, 12, 0)) @@ -232,7 +241,11 @@ -- JSON representation of the visualization (noting that @VLSpec@ is -- an alias for @Value@). fromVL (VL (schema, specs)) = +#if MIN_VERSION_aeson(2, 0, 0) + let kvals = map (first Key.fromText) (("$schema", toJSON schema) : specs) +#else let kvals = ("$schema" .= schema) : specs +#endif in object kvals @@ -249,8 +262,11 @@ @ -} asSpec :: [PropertySpec] -> VLSpec +#if MIN_VERSION_aeson(2, 0, 0) +asSpec = object . map (first Key.fromText) . unProperty +#else asSpec = object . unProperty - +#endif {-| diff --git a/src/Graphics/Vega/VegaLite/Time.hs b/src/Graphics/Vega/VegaLite/Time.hs --- a/src/Graphics/Vega/VegaLite/Time.hs +++ b/src/Graphics/Vega/VegaLite/Time.hs @@ -3,7 +3,7 @@ {-| Module : Graphics.Vega.VegaLite.Time -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -30,6 +30,7 @@ import qualified Data.Text as T import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair) #if !(MIN_VERSION_base(4, 12, 0)) import Data.Monoid ((<>)) @@ -38,7 +39,7 @@ -- added in base 4.8.0.0 / ghc 7.10.1 import Numeric.Natural (Natural) -import Graphics.Vega.VegaLite.Specification (LabelledSpec, VLSpec) +import Graphics.Vega.VegaLite.Specification (VLSpec) {-| @@ -364,7 +365,7 @@ baseTimeUnitLabel SecondsMilliseconds = "secondsmilliseconds" -dateTimeProperty :: DateTime -> LabelledSpec +dateTimeProperty :: DateTime -> Pair dateTimeProperty (DTYear y) = "year" .= y dateTimeProperty (DTQuarter q) = "quarter" .= q dateTimeProperty (DTMonth mon) = "month" .= monthNameLabel mon @@ -382,7 +383,6 @@ dateTimeSpec :: [DateTime] -> VLSpec dateTimeSpec = object . map dateTimeProperty - dayLabel :: DayName -> T.Text dayLabel Mon = "Mon" diff --git a/src/Graphics/Vega/VegaLite/Transform.hs b/src/Graphics/Vega/VegaLite/Transform.hs --- a/src/Graphics/Vega/VegaLite/Transform.hs +++ b/src/Graphics/Vega/VegaLite/Transform.hs @@ -3,7 +3,7 @@ {-| Module : Graphics.Vega.VegaLite.Transform -Copyright : (c) Douglas Burke, 2018-2020 +Copyright : (c) Douglas Burke, 2018-2021 License : BSD3 Maintainer : dburke.gw@gmail.com @@ -46,6 +46,7 @@ import qualified Data.Text as T import Data.Aeson ((.=), object, toJSON) +import Data.Aeson.Types (Pair) import Data.Maybe (mapMaybe) #if !(MIN_VERSION_base(4, 12, 0)) @@ -62,13 +63,12 @@ ( FieldName , SortField , sortFieldSpec - , field_ + -- , field_ , fromT , allowNull ) import Graphics.Vega.VegaLite.Specification ( VLSpec - , LabelledSpec , TransformSpec(..) , SelectionLabel ) @@ -195,10 +195,10 @@ operationSpec VarianceP = "variancep" -aggregate_ :: Operation -> LabelledSpec +aggregate_ :: Operation -> Pair aggregate_ op = "aggregate" .= operationSpec op -op_ :: Operation -> LabelledSpec +op_ :: Operation -> Pair op_ op = "op" .= operationSpec op @@ -219,11 +219,11 @@ -- that do not apply to fields such as 'Count', 'Rank', and 'DenseRank'. -windowFieldProperty :: Window -> LabelledSpec +windowFieldProperty :: Window -> Pair windowFieldProperty (WAggregateOp op) = "op" .= operationSpec op windowFieldProperty (WOp op) = "op" .= wOperationLabel op windowFieldProperty (WParam n) = "param" .= n -windowFieldProperty (WField f) = field_ f +windowFieldProperty (WField f) = "field" .= f -- was "field_ f" -- | Window-specific operation for transformations (for use with 'WOp'). @@ -340,7 +340,7 @@ -- ^ Pick the step size from this list. -binProperty :: BinProperty -> LabelledSpec +binProperty :: BinProperty -> Pair binProperty (AlreadyBinned b) = "binned" .= b binProperty (BinAnchor x) = "anchor" .= x binProperty (Base x) = "base" .= x @@ -354,11 +354,11 @@ binProperty (Steps xs) = "steps" .= xs -bin :: [BinProperty] -> LabelledSpec +bin :: [BinProperty] -> Pair bin [] = "bin" .= True bin xs = "bin" .= object (map binProperty xs) -binned_ :: LabelledSpec +binned_ :: Pair binned_ = "bin" .= fromT "binned" @@ -462,7 +462,7 @@ -- ^ The replacement value (when using @ImMethod 'ImValue'@). -imputeProperty :: ImputeProperty -> LabelledSpec +imputeProperty :: ImputeProperty -> Pair imputeProperty (ImFrame m1 m2) = "frame" .= map allowNull [m1, m2] imputeProperty (ImKeyVals dVals) = "keyvals" .= dataValuesSpecs dVals imputeProperty (ImKeyValSequence start stop step) = @@ -497,7 +497,7 @@ imputePropertySpecValue _ = Nothing -impute_ :: [ImputeProperty] -> LabelledSpec +impute_ :: [ImputeProperty] -> Pair impute_ ips = "impute" .= object (map imputeProperty ips) diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -3,6 +3,12 @@ packages: - . -extra-deps: [] +extra-deps: +- aeson-2.0.1.0 +- semialign-1.2 +- time-compat-1.9.6.1 +- hashable-1.3.4.1 +- git: https://github.com/hasufell/aeson-pretty + commit: e902ab866bb41d990b66af3644aeb352ff7aaf6f -resolver: lts-17.2 +resolver: lts-18.7 diff --git a/tests/Gallery/Label.hs b/tests/Gallery/Label.hs --- a/tests/Gallery/Label.hs +++ b/tests/Gallery/Label.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} @@ -9,7 +10,11 @@ import Data.Aeson (Value(Object)) import Data.Aeson.QQ.Simple (aesonQQ) +#if MIN_VERSION_aeson(2, 0, 0) +import Data.Aeson.KeyMap (empty) +#else import Data.HashMap.Strict (empty) +#endif import Graphics.Vega.VegaLite diff --git a/tests/ViewCompositionTests.hs b/tests/ViewCompositionTests.hs --- a/tests/ViewCompositionTests.hs +++ b/tests/ViewCompositionTests.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -- @@ -13,7 +14,11 @@ import Prelude hiding (filter, repeat) import Data.Aeson (Value(Object)) +#if MIN_VERSION_aeson(2, 0, 0) +import Data.Aeson.KeyMap (empty) +#else import Data.HashMap.Strict (empty) +#endif testSpecs :: [(String, VegaLite)] diff --git a/tools/PlayTutorial.hs b/tools/PlayTutorial.hs --- a/tools/PlayTutorial.hs +++ b/tools/PlayTutorial.hs @@ -44,7 +44,6 @@ import qualified Data.Aeson.Encode.Pretty as AP import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.Text as T import qualified Graphics.Vega.Tutorials.VegaLite as VL @@ -252,7 +251,7 @@ specFile = prefix <> ".vg.json" prefix = outdir name - opts = object [T.pack "downloadFileName" .= name] + opts = object ["downloadFileName" .= name] toHtmlFileWith (Just opts) htmlFile spec BL.writeFile specFile (AP.encodePretty (fromVL spec))