diff --git a/chart-svg.cabal b/chart-svg.cabal --- a/chart-svg.cabal +++ b/chart-svg.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: chart-svg -version: 0.3.2 +version: 0.3.3 synopsis: Charting library targetting SVGs. description: This package provides a charting library targetting SVG as the rendered output. @@ -31,7 +31,8 @@ license-file: LICENSE build-type: Simple extra-doc-files: other/*.svg -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.4 +tested-with: + GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.2.5 || ==9.4.4 source-repository head type: git @@ -63,7 +64,7 @@ , foldl ^>=1.4 , formatn ^>=0.2 , lucid >=2.9 && <3 - , mtl ^>=2.2.2 + , mtl >=2.2.2 && <2.4 , neat-interpolation ^>=0.5.1 , numhask ^>=0.10 , numhask-array ^>=0.10 @@ -72,13 +73,12 @@ , random ^>=1.2.1 , scientific ^>=0.3 , tagsoup ^>=0.14 - , text ^>=1.2 + , text >=1.2 && <2.1 , time >=1.9 && <2 - , transformers ^>=0.5 + , transformers >=0.5 && <0.7 default-language: Haskell2010 default-extensions: StrictData ghc-options: -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info - -hiedir=.hie + -Wincomplete-uni-patterns -Wredundant-constraints diff --git a/src/Chart.hs b/src/Chart.hs --- a/src/Chart.hs +++ b/src/Chart.hs @@ -125,7 +125,6 @@ -- This process is reified in 'runHudWith'. The most common Hud concepts, such as axes and titles, have been collected into the 'HudOptions' type. -- -- An important quality of 'runHud' (and conversion of charts to svg in general) is that this is the point at which chart data is converted from the data domain to the page domain. --- -- $optics -- diff --git a/src/Chart/Bar.hs b/src/Chart/Bar.hs --- a/src/Chart/Bar.hs +++ b/src/Chart/Bar.hs @@ -86,12 +86,12 @@ barHudOptions bo bd = mempty & #axes - .~ [ (1, axis1), - (1, axis2) - ] + .~ [ (1, axis1), + (1, axis2) + ] & #legends - .~ [ (10, o & #content .~ barLegendContent bo bd) - ] + .~ [ (10, o & #content .~ barLegendContent bo bd) + ] where o = view #barLegendOptions bo axis1 = bool id flipAxis (barOrientation bo == Vert) (defaultAxisOptions & #ticks % #ltick .~ Nothing & #ticks % #style .~ barTicks bd) @@ -117,7 +117,6 @@ ts = (\x -> defaultTextStyle & #color .~ palette1 x & #size .~ 0.24) <$> [1, 2, 6, 7, 5, 3, 4, 0] -- | Two dimensional data, maybe with row and column labels. --- data BarData = BarData { barData :: [[Double]], barRowLabels :: [Text], @@ -171,7 +170,7 @@ barDataLowerUpper stacked bs = case stacked of NonStacked -> fmap (fmap (0,)) bs - Stacked -> drop 1 $ scanl' (\acc xs -> zip (fmap snd acc) xs) (repeat (0,0)) (accRows bs) + Stacked -> drop 1 $ scanl' (\acc xs -> zip (fmap snd acc) xs) (repeat (0, 0)) (accRows bs) -- | Calculate the Rect range of a bar data set. -- @@ -219,11 +218,11 @@ barTicks bd | null (bd ^. #barData) = TickNone | null (bd ^. #barRowLabels) = - TickLabels $ pack . show <$> [0 .. (maxRows (bd ^. #barData) - 1)] + TickLabels $ pack . show <$> [0 .. (maxRows (bd ^. #barData) - 1)] | otherwise = - TickLabels $ - take (maxRows (bd ^. #barData)) $ - (bd ^. #barRowLabels) <> repeat "" + TickLabels $ + take (maxRows (bd ^. #barData)) $ + (bd ^. #barRowLabels) <> repeat "" -- | A bar legend barLegendContent :: BarOptions -> BarData -> [(Text, Chart)] @@ -231,9 +230,9 @@ | null (bd ^. #barData) = [] | null (bd ^. #barColumnLabels) = [] | otherwise = - zip - (view #barColumnLabels bd <> repeat "") - ((\s -> RectChart s [one]) <$> take (length (view #barData bd)) (bo ^. #barRectStyles)) + zip + (view #barColumnLabels bd <> repeat "") + ((\s -> RectChart s [one]) <$> take (length (view #barData bd)) (bo ^. #barRectStyles)) barDataTP :: Stacked -> FormatN -> Double -> Double -> [[Double]] -> [[(Text, Double)]] barDataTP stacked fn d negd bs = diff --git a/src/Chart/Data.hs b/src/Chart/Data.hs --- a/src/Chart/Data.hs +++ b/src/Chart/Data.hs @@ -7,7 +7,6 @@ -- Whilst the library makes use of , it does not re-export, to avoid clashes with Prelude, with the exception of 'zero', 'one', 'angle', 'norm' & 'abs'. -- -- 'Rect' and 'Point', from , make up the base elements of many chart primitives, and all of numhask-space is re-exported. --- module Chart.Data ( -- * Data Primitives Rect (..), @@ -18,7 +17,9 @@ addp, -- * NumHask Exports + -- + -- | Note that (+) and (*) from numhask are not actually re-exported. Multiplicative (one), Additive (zero), diff --git a/src/Chart/Examples.hs b/src/Chart/Examples.hs --- a/src/Chart/Examples.hs +++ b/src/Chart/Examples.hs @@ -6,8 +6,7 @@ -- | Examples of chart construction. module Chart.Examples - ( - -- * Unit & Hud + ( -- * Unit & Hud unitExample, hudOptionsExample, @@ -629,10 +628,12 @@ mempty & #charts .~ blank (Rect 0 1 0 1) & #hudOptions - .~ ( mempty & #chartAspect .~ FixedAspect 1.5 & #axes - .~ [ (1, defaultAxisOptions & #place .~ PlaceLeft & #ticks % #style .~ TickPlaced tsTime), - (1, defaultAxisOptions & #ticks % #style .~ TickPlaced tsDate) - ] + .~ ( mempty + & #chartAspect .~ FixedAspect 1.5 + & #axes + .~ [ (1, defaultAxisOptions & #place .~ PlaceLeft & #ticks % #style .~ TickPlaced tsTime), + (1, defaultAxisOptions & #ticks % #style .~ TickPlaced tsDate) + ] ) where tsTime = placedTimeLabelContinuous PosIncludeBoundaries Nothing 12 (Range (UTCTime (fromGregorian 2021 12 6) (toDiffTime 0)) (UTCTime (fromGregorian 2021 12 7) (toDiffTime 0))) @@ -663,16 +664,16 @@ gradient marker h fa grain ok0 ok1 = mempty & #svgOptions % #svgHeight - .~ h + .~ h & #svgOptions % #cssOptions % #shapeRendering - .~ UseCssCrisp + .~ UseCssCrisp & #hudOptions - .~ ( mempty - & #chartAspect .~ FixedAspect fa - & #frames .~ [(20, FrameOptions (Just (border 0.004 white)) 0.1)] - ) + .~ ( mempty + & #chartAspect .~ FixedAspect fa + & #frames .~ [(20, FrameOptions (Just (border 0.004 white)) 0.1)] + ) & #charts - .~ named "gradient" (gradientChart_ grain ok0 ok1) <> strip + .~ named "gradient" (gradientChart_ grain ok0 ok1) <> strip where strip = case marker of Nothing -> mempty @@ -697,22 +698,22 @@ dotMap s grain l maxchroma cs = mempty & #hudOptions - .~ defaultHudOptions + .~ defaultHudOptions & #charts - .~ named "dots" (dot_ <$> cs) - <> named - "wheel" - ( ( \(p, c) -> - GlyphChart - ( defaultGlyphStyle - & #size .~ s - & #color .~ c - & #borderSize .~ 0 - ) - [p] - ) - <$> filter (validColour . snd) (wheelPoints grain l maxchroma) - ) + .~ named "dots" (dot_ <$> cs) + <> named + "wheel" + ( ( \(p, c) -> + GlyphChart + ( defaultGlyphStyle + & #size .~ s + & #color .~ c + & #borderSize .~ 0 + ) + [p] + ) + <$> filter (validColour . snd) (wheelPoints grain l maxchroma) + ) dot_ :: Colour -> Chart dot_ x = (\(p, c) -> GlyphChart (defaultGlyphStyle & #size .~ 0.08 & #color .~ c & #borderColor .~ Colour 0.5 0.5 0.5 1 & #shape .~ CircleGlyph) [p]) (colour2Point x, x) @@ -765,20 +766,18 @@ -- | Run this to refresh example SVG's. writeAllExamples :: IO () writeAllExamples = do - sequence_ $ uncurry writeChartSvg <$> pathChartSvg + mapM_ (uncurry writeChartSvg) pathChartSvg putStrLn "ok" -- | Version of charts with a dark-friendly hud writeAllExamplesDark :: IO () writeAllExamplesDark = do - sequence_ $ - uncurry writeChartSvg + mapM_ (uncurry writeChartSvg . bimap ((<> "d.svg") . reverse . drop 4 . reverse) ( \x -> x & #hudOptions %~ colourHudOptions (rgb light) & #svgOptions % #cssOptions % #preferColorScheme .~ PreferDark - ) - <$> pathChartSvg + )) pathChartSvg putStrLn "dark version, ok" diff --git a/src/Chart/Hud.hs b/src/Chart/Hud.hs --- a/src/Chart/Hud.hs +++ b/src/Chart/Hud.hs @@ -8,7 +8,6 @@ -- | A hud stands for , and is a collective noun used to name chart elements that assist in data interpretation or otherwise annotate and decorate data. -- -- This includes axes, titles, borders, frames, background canvaii, tick marks and tick value labels. --- module Chart.Hud ( -- * Hud Hud (..), @@ -586,7 +585,6 @@ -- -- >>> defaultLegendOptions -- LegendOptions {size = 0.3, buffer = 0.1, vgap = 0.2, hgap = 0.1, textStyle = TextStyle {size = 0.18, color = Colour 0.05 0.05 0.05 1.00, anchor = AnchorMiddle, hsize = 0.45, vsize = 1.1, vshift = -0.25, rotation = Nothing, scalex = ScaleX, frame = Nothing}, innerPad = 0.1, outerPad = 2.0e-2, frame = Just (RectStyle {borderSize = 1.0e-2, borderColor = Colour 0.05 0.05 0.05 1.00, color = Colour 0.05 0.05 0.05 0.00}), place = PlaceRight, overallScale = 0.25, content = []} --- data LegendOptions = LegendOptions { size :: Double, buffer :: Double, @@ -709,9 +707,9 @@ where style' | t ^. #anchor == AnchorStart = - #anchor .~ AnchorStart $ t ^. #style + #anchor .~ AnchorStart $ t ^. #style | t ^. #anchor == AnchorEnd = - #anchor .~ AnchorEnd $ t ^. #style + #anchor .~ AnchorEnd $ t ^. #style | otherwise = t ^. #style rot' = fromMaybe 0 (t ^. #style % #rotation) rot @@ -734,22 +732,22 @@ alignPosTitle t (Rect x z y w) | t ^. #anchor == AnchorStart && (t ^. #place == PlaceTop || t ^. #place == PlaceBottom) = - Point ((x - z) / 2.0) 0.0 + Point ((x - z) / 2.0) 0.0 | t ^. #anchor == AnchorStart && t ^. #place == PlaceLeft = - Point 0.0 ((y - w) / 2.0) + Point 0.0 ((y - w) / 2.0) | t ^. #anchor == AnchorStart && t ^. #place == PlaceRight = - Point 0.0 ((y - w) / 2.0) + Point 0.0 ((y - w) / 2.0) | t ^. #anchor == AnchorEnd && (t ^. #place == PlaceTop || t ^. #place == PlaceBottom) = - Point ((-x + z) / 2.0) 0.0 + Point ((-x + z) / 2.0) 0.0 | t ^. #anchor == AnchorEnd && t ^. #place == PlaceLeft = - Point 0.0 ((-y + w) / 2.0) + Point 0.0 ((-y + w) / 2.0) | t ^. #anchor == AnchorEnd && t ^. #place == PlaceRight = - Point 0.0 ((-y + w) / 2.0) + Point 0.0 ((-y + w) / 2.0) | otherwise = Point 0.0 0.0 -- | title append transformation. @@ -911,23 +909,23 @@ Ticks adjustTicks (Adjustments mrx ma mry ad) vb cs pl t | pl == PlaceBottom || pl == PlaceTop = - if ad - then - ( case adjustSizeX > 1 of - True -> - ( case pl of - PlaceBottom -> #ttick % _Just % _1 % #anchor .~ AnchorEnd - PlaceTop -> #ttick % _Just % _1 % #anchor .~ AnchorStart - _ -> #ttick % _Just % _1 % #anchor .~ AnchorEnd - ) - . (#ttick % _Just % _1 % #size %~ (/ adjustSizeA)) - $ (#ttick % _Just % _1 % #rotation ?~ pi / 4) t - False -> (#ttick % _Just % _1 % #size %~ (/ adjustSizeA)) t - ) - else t & #ttick % _Just % _1 % #size %~ (/ adjustSizeX) + if ad + then + ( case adjustSizeX > 1 of + True -> + ( case pl of + PlaceBottom -> #ttick % _Just % _1 % #anchor .~ AnchorEnd + PlaceTop -> #ttick % _Just % _1 % #anchor .~ AnchorStart + _ -> #ttick % _Just % _1 % #anchor .~ AnchorEnd + ) + . (#ttick % _Just % _1 % #size %~ (/ adjustSizeA)) + $ (#ttick % _Just % _1 % #rotation ?~ pi / 4) t + False -> (#ttick % _Just % _1 % #size %~ (/ adjustSizeA)) t + ) + else t & #ttick % _Just % _1 % #size %~ (/ adjustSizeX) | otherwise -- pl `elem` [PlaceLeft, PlaceRight] = - (#ttick % _Just % _1 % #size %~ (/ adjustSizeY)) t + (#ttick % _Just % _1 % #size %~ (/ adjustSizeY)) t where max' [] = 1 max' xs = maximum xs diff --git a/src/Chart/Primitive.hs b/src/Chart/Primitive.hs --- a/src/Chart/Primitive.hs +++ b/src/Chart/Primitive.hs @@ -9,7 +9,6 @@ -- | Base 'Chart' and 'ChartTree' types and support module Chart.Primitive ( -- * Charts - Chart (..), ChartTree (..), tree', @@ -26,7 +25,6 @@ ChartAspect (..), -- * Boxes - -- $boxes box, sbox, @@ -52,7 +50,8 @@ rectangularize, glyphize, overText, - renamed) + renamed, + ) where import Chart.Data @@ -117,7 +116,7 @@ -- | Apply a filter to ChartTree filterChartTree :: (Chart -> Bool) -> ChartTree -> ChartTree filterChartTree p (ChartTree (Node (a, cs) xs)) = - ChartTree (Node (a, catMaybes (rem' <$> cs)) (tree . filterChartTree p . ChartTree <$> xs)) + ChartTree (Node (a, mapMaybe rem' cs) (tree . filterChartTree p . ChartTree <$> xs)) where rem' x = bool Nothing (Just x) (p x) diff --git a/src/Chart/Style.hs b/src/Chart/Style.hs --- a/src/Chart/Style.hs +++ b/src/Chart/Style.hs @@ -5,7 +5,6 @@ {-# OPTIONS_GHC -Wall #-} -- | Stylistic or syntactical options for chart elements. --- module Chart.Style ( -- * RectStyle RectStyle (..), diff --git a/src/Chart/Surface.hs b/src/Chart/Surface.hs --- a/src/Chart/Surface.hs +++ b/src/Chart/Surface.hs @@ -6,7 +6,6 @@ -- | Surface chart combinators. -- -- A common chart is to present a set of rectangles on the XY plane with colour representing values of the underlying data. This library uses the term /surface/ chart but it is often referred to as a heatmap. --- module Chart.Surface ( SurfaceData (..), SurfaceOptions (..), @@ -178,7 +177,7 @@ pchart | l ^. #sloLegendOptions % #place == PlaceBottom || l ^. #sloLegendOptions % #place == PlaceTop = - vertGlyph + vertGlyph | otherwise = horiGlyph t = TextChart (l ^. #sloLegendOptions % #textStyle & #anchor .~ AnchorStart) [(l ^. #sloTitle, zero)] hs = vert (l ^. #sloLegendOptions % #vgap) [a, unnamed [t]] diff --git a/src/Chart/Svg.hs b/src/Chart/Svg.hs --- a/src/Chart/Svg.hs +++ b/src/Chart/Svg.hs @@ -7,7 +7,6 @@ {-# OPTIONS_GHC -Wall #-} -- | Conversion from a chart to SVG. --- module Chart.Svg ( -- * ChartSvg ChartSvg (..), @@ -113,7 +112,7 @@ -- * rendering -- | @svg@ element + svg 2 attributes -svg2Tag :: Term [Attribute] (s -> t) => s -> t +svg2Tag :: (Term [Attribute] (s -> t)) => s -> t svg2Tag m = svg_ [ makeAttribute "xmlns" "http://www.w3.org/2000/svg", diff --git a/src/Data/Colour.hs b/src/Data/Colour.hs --- a/src/Data/Colour.hs +++ b/src/Data/Colour.hs @@ -11,7 +11,6 @@ {-# OPTIONS_GHC -Wall #-} -- | Colour representations and combinations. --- module Data.Colour ( -- * Colour Colour, @@ -105,7 +104,6 @@ -- >>> import Optics.Core -- | Colour type for the library, wrapping 'Color'. --- newtype Colour = Colour' { color' :: Color (Alpha RGB) Double } @@ -114,7 +112,6 @@ -- | Constructor pattern. -- -- > Colour red green blue alpha --- pattern Colour :: Double -> Double -> Double -> Double -> Colour pattern Colour r g b a = Colour' (ColorRGBA r g b a) @@ -219,7 +216,6 @@ where (ColorRGBA r g b _) = fromIntegral . toWord8 <$> color' c --- | hex' :: Int -> Text hex' i | i < 0 = "-" <> go (-i) @@ -229,13 +225,11 @@ | n < 16 = hexDigit n | otherwise = go (n `quot` 16) <> hexDigit (n `rem` 16) --- | hexDigit :: Int -> Text hexDigit n | n <= 9 = Text.singleton $! i2d n | otherwise = Text.singleton $! toEnum (n + 87) --- | i2d :: Int -> Char i2d i = chr (ord '0' + i) @@ -701,7 +695,7 @@ go g = let (x, g') = runStateGen g rvSensible in x : go g' -- | A random Colour generator that provides a (hopefully) pleasant colour not too light, dark, over-saturated or dull. -rvSensible :: StatefulGen g m => g -> m Colour +rvSensible :: (StatefulGen g m) => g -> m Colour rvSensible gen = do l <- uniformRM (0.3, 0.75) gen c <- uniformRM (0.05, 0.24) gen diff --git a/src/Data/Path.hs b/src/Data/Path.hs --- a/src/Data/Path.hs +++ b/src/Data/Path.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RebindableSyntax #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} @@ -111,14 +110,12 @@ projectPaths :: Rect Double -> Rect Double -> [PathData Double] -> [PathData Double] projectPaths new old ps = flip evalState zero $ - sequence $ - ( \p -> do + mapM ( \p -> do x <- get let d = projectPath new old x p put (pointPath d) pure d - ) - <$> ps + ) ps -- | Project a PathData from one Rect (XY plave) to a new one. projectPath :: diff --git a/src/Data/Path/Parser.hs b/src/Data/Path/Parser.hs --- a/src/Data/Path/Parser.hs +++ b/src/Data/Path/Parser.hs @@ -24,7 +24,7 @@ import Data.Either import Data.FormatN import Data.Functor -import Data.Path ( PathData(..), ArcInfo(ArcInfo) ) +import Data.Path (ArcInfo (ArcInfo), PathData (..)) import Data.Scientific (toRealFloat) import Data.Text (Text, pack) import qualified Data.Text as Text @@ -49,7 +49,6 @@ -- >>> let outerseg1 = "M-1.0,0.5 A0.5 0.5 0.0 1 1 0.0,-1.2320508075688774 1.0 1.0 0.0 0 0 -0.5,-0.3660254037844387 1.0 1.0 0.0 0 0 -1.0,0.5 Z" -- >>> parsePath outerseg1 -- Right [MoveTo OriginAbsolute [Point -1.0 0.5],EllipticalArc OriginAbsolute [(0.5,0.5,0.0,True,True,Point 0.0 -1.2320508075688774),(1.0,1.0,0.0,False,False,Point -0.5 -0.3660254037844387),(1.0,1.0,0.0,False,False,Point -1.0 0.5)],EndPath] --- parsePath :: Text -> Either String [PathCommand] parsePath = A.parseOnly pathParser @@ -115,7 +114,8 @@ <|> EndPath <$ A.string "z" <* commaWsp where curveToArgs = - (,,) <$> (point <* commaWsp) + (,,) + <$> (point <* commaWsp) <*> (point <* commaWsp) <*> point manyComma a = fromList <$> a `A.sepBy1` commaWsp @@ -123,7 +123,8 @@ numComma = num <* commaWsp flagComma = flag <* commaWsp ellipticalArgs = - (,,,,,) <$> numComma + (,,,,,) + <$> numComma <*> numComma <*> numComma <*> flagComma @@ -231,7 +232,8 @@ -- | Render a point (including conversion to SVG Coordinates). pp :: Point Double -> Text pp (Point x y) = - formatOrShow (FixedStyle 4) Nothing x <> "," + formatOrShow (FixedStyle 4) Nothing x + <> "," <> formatOrShow (FixedStyle 4) Nothing (bool (-y) y (y == zero)) data PathCursor = PathCursor @@ -257,7 +259,7 @@ -- | Convert from a path command list to a PathA specification toPathDatas :: [PathCommand] -> [PathData Double] -toPathDatas xs = fmap svgCoords $ mconcat $ flip evalState stateCur0 $ sequence $ toPathData <$> xs +toPathDatas xs = fmap svgCoords $ mconcat $ flip evalState stateCur0 $ mapM toPathData xs -- | Convert relative points to absolute points relToAbs :: (Additive a) => a -> [a] -> [a] @@ -292,7 +294,7 @@ pure $ (\(c1, c2, x2) -> CubicP c1 c2 x2) <$> xs -- | Convert relative points to absolute points -relToAbs3 :: Additive a => a -> [(a, a, a)] -> [(a, a, a)] +relToAbs3 :: (Additive a) => a -> [(a, a, a)] -> [(a, a, a)] relToAbs3 p xs = xs' where x1 = (\(x, _, _) -> x) <$> xs @@ -318,10 +320,10 @@ smoothCurveTo :: [(Point Double, Point Double)] -> State PathCursor [PathData Double] smoothCurveTo xs = - sequence (smoothCurveToStep <$> xs) + mapM smoothCurveToStep xs -- | Convert relative points to absolute points -relToAbs2 :: Additive a => a -> [(a, a)] -> [(a, a)] +relToAbs2 :: (Additive a) => a -> [(a, a)] -> [(a, a)] relToAbs2 p xs = xs' where x1 = fst <$> xs @@ -346,7 +348,7 @@ smoothQuad :: [Point Double] -> State PathCursor [PathData Double] smoothQuad xs = - sequence (smoothQuadStep <$> xs) + mapM smoothQuadStep xs arcTo :: [(Double, Double, Double, Bool, Bool, Point Double)] -> State PathCursor [PathData Double] arcTo xs = do @@ -357,7 +359,7 @@ fromPathEllipticalArc (x, y, r, l, s, p) = ArcP (ArcInfo (Point x y) r l s) p -- | Convert relative points to absolute points -relToAbsArc :: Additive a => Point a -> [(a, a, a, Bool, Bool, Point a)] -> [(a, a, a, Bool, Bool, Point a)] +relToAbsArc :: (Additive a) => Point a -> [(a, a, a, Bool, Bool, Point a)] -> [(a, a, a, Bool, Bool, Point a)] relToAbsArc p xs = xs' where ps = (\(_, _, _, _, _, pt) -> pt) <$> xs