diff --git a/other/anychart.svg b/other/anychart.svg new file mode 100644 --- /dev/null +++ b/other/anychart.svg @@ -0,0 +1,47 @@ +-1.0-0.8-0.6-0.4-0.2 0.0 0.2 0.4 0.6 0.8 1.00.00.10.20.30.40.50.60.70.80.91.0 diff --git a/other/digit.svg b/other/digit.svg new file mode 100644 --- /dev/null +++ b/other/digit.svg @@ -0,0 +1,42 @@ +10%20%30%40%50%60%70%80%90%30 Jun 201931 Dec 201930 Jun 202031 Dec 202030 Jun 202131 Dec 202130 Jun 202231 Dec 2022 diff --git a/other/digitsurface.svg b/other/digitsurface.svg new file mode 100644 --- /dev/null +++ b/other/digitsurface.svg @@ -0,0 +1,50 @@ +0%10%20%30%40%50%60%70%80%90%100%0%10%20%30%40%50%60%70%80%90%100%ma versus stdmastd 50100150 diff --git a/other/dlista.svg b/other/dlista.svg new file mode 100644 --- /dev/null +++ b/other/dlista.svg @@ -0,0 +1,34 @@ +1.01.81.91.10.240.0410.721.72.02.01.50.580.0100.351.32.01.80.85row 0row 1row 2row 3row 4row 5row 6row 7row 8col 1col 0 diff --git a/other/dlistb.svg b/other/dlistb.svg new file mode 100644 --- /dev/null +++ b/other/dlistb.svg @@ -0,0 +1,68 @@ +012345678910111213141516171819012345678910111213141516171819-0.5 0.0 0.5 diff --git a/other/dlistc.svg b/other/dlistc.svg new file mode 100644 --- /dev/null +++ b/other/dlistc.svg @@ -0,0 +1,25 @@ + diff --git a/other/dtuple.svg b/other/dtuple.svg new file mode 100644 --- /dev/null +++ b/other/dtuple.svg @@ -0,0 +1,47 @@ +-1.0-0.8-0.6-0.4-0.2 0.0 0.2 0.4 0.6 0.8 1.0-1.0-0.8-0.6-0.4-0.2 0.0 0.2 0.4 0.6 0.8 1.0 diff --git a/other/dtupleb.svg b/other/dtupleb.svg new file mode 100644 --- /dev/null +++ b/other/dtupleb.svg @@ -0,0 +1,247 @@ +-1.0-0.8-0.6-0.4-0.2 0.0 0.2 0.4 0.6 0.8 1.0-1.0-0.8-0.6-0.4-0.2 0.0 0.2 0.4 0.6 0.8 1.0 diff --git a/other/hist.svg b/other/hist.svg new file mode 100644 --- /dev/null +++ b/other/hist.svg @@ -0,0 +1,30 @@ +-0.04-0.02 0.00 0.02 0.04 diff --git a/other/line.svg b/other/line.svg new file mode 100644 --- /dev/null +++ b/other/line.svg @@ -0,0 +1,43 @@ +0.00.51.01.52.02.53.03.54.04.55.00.00.51.01.52.02.53.0Line ChartMade with love and chart-svgpalette1 2palette1 1palette1 0 diff --git a/other/list1a.svg b/other/list1a.svg new file mode 100644 --- /dev/null +++ b/other/list1a.svg @@ -0,0 +1,35 @@ +0.01.02.03.04.05.06.07.08.09.00123456789 diff --git a/other/list1b.svg b/other/list1b.svg new file mode 100644 --- /dev/null +++ b/other/list1b.svg @@ -0,0 +1,30 @@ +-1.0-0.5 0.0 0.5 1.0 diff --git a/other/list1c.svg b/other/list1c.svg new file mode 100644 --- /dev/null +++ b/other/list1c.svg @@ -0,0 +1,25 @@ + diff --git a/other/qhist.svg b/other/qhist.svg new file mode 100644 --- /dev/null +++ b/other/qhist.svg @@ -0,0 +1,36 @@ +1%10%20%30%40%50%60%70%80%90%99% diff --git a/other/quantile.svg b/other/quantile.svg new file mode 100644 --- /dev/null +++ b/other/quantile.svg @@ -0,0 +1,39 @@ +-15%-10% -5% 0% 5% 10%30 Jun 201931 Dec 201930 Jun 202031 Dec 202030 Jun 202131 Dec 202130 Jun 202231 Dec 202299%90%50%10%1% diff --git a/other/scatter.svg b/other/scatter.svg new file mode 100644 --- /dev/null +++ b/other/scatter.svg @@ -0,0 +1,38 @@ +0.0%0.1%0.2%0.3%0.4%0.5%-6%-4%-2% 0% 2% 4% 6%scattermastd diff --git a/other/simpleline.svg b/other/simpleline.svg new file mode 100644 --- /dev/null +++ b/other/simpleline.svg @@ -0,0 +1,44 @@ +-50% 0% 50%100%150%200%250%300%350%400%198019851990199520002005201020152020Simple Line Exampleaccumulated return diff --git a/other/tdtuple.svg b/other/tdtuple.svg new file mode 100644 --- /dev/null +++ b/other/tdtuple.svg @@ -0,0 +1,35 @@ +0.01.02.03.04.05.06.07.08.09.00123456789 diff --git a/prettychart.cabal b/prettychart.cabal new file mode 100644 --- /dev/null +++ b/prettychart.cabal @@ -0,0 +1,55 @@ +cabal-version: 2.4 +name: prettychart +version: 0.1.0 +synopsis: Pretty print charts from ghci. +description: Serve and print charts from ghci, with automatic formatting. +category: project +author: Tony Day +maintainer: tonyday567@gmail.com +copyright: Tony Day (c) 2023 +license: BSD-3-Clause +homepage: https://github.com/tonyday567/prettycharts#readme +bug-reports: https://github.com/tonyday567/prettycharts/issues +build-type: Simple +extra-doc-files: + other/*.svg +source-repository head + type: git + location: https://github.com/tonyday567/prettycharts + +library + hs-source-dirs: + src + default-extensions: + ghc-options: + -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + build-depends: + async, + base >=4.7 && <5, + box, + bytestring, + chart-svg >= 0.4, + containers, + flatparse, + formatn >= 0.3 && < 0.4, + lucid, + mealy, + numhask-space, + optics-core, + profunctors, + text >= 1.2 && < 2.1, + time >= 1.9, + web-rep >= 0.10.1 && < 0.11, + exposed-modules: + Prettychart + Prettychart.Any + Prettychart.Charts + Prettychart.Server + Prettychart.ExampleData + other-modules: + default-language: Haskell2010 + diff --git a/src/Prettychart.hs b/src/Prettychart.hs new file mode 100644 --- /dev/null +++ b/src/Prettychart.hs @@ -0,0 +1,74 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK prune #-} + +-- | A haskell library to serve charts via ghci. +module Prettychart + ( -- * Usage + + -- + -- $usage + + -- * Re-exports + module Prettychart.Server, + module Prettychart.Any, + module Prettychart.Charts, + ) +where + +import Prettychart.Any +import Prettychart.Charts +import Prettychart.Server + +-- $usage +-- +-- >> -- :set -package prettychart +-- >> import Prettychart +-- >> (sendChart, quitChartServer) <- startChartServer +-- +-- An example from chart-svg ... +-- +-- >> import Chart.Examples +-- >> sendChart lineExample +-- +-- ... point your browser at localhost:9160 and you should see this: +-- +-- ![line Example](other/line.svg) +-- +-- Utilising -interactive-print, we can turn these protocols into a pretty printer for collections of numbers: +-- +-- >> printc = printChart False sendChart +-- >> :t printc +-- >> (Show a) => a -> IO () +-- >> :set -interactive-print printc +-- >> [0..9] +-- +-- A bar chart representing this list will be rendered in the browser, and should look like this: +-- +-- ![list Example](other/list1a.svg) +-- +-- ... stop the server, and go back to normal. +-- +-- >> quitChartServer +-- >> :set -interactive-print print +-- +-- All of this can be automated by dropping the code below into a ghci.conf +-- +-- > -- :set -package prettychart +-- > :{ +-- > :def! prettychart \_ -> pure $ unlines [ +-- > "import Prettychart", +-- > "(sendChart, quitChartServer) <- startChartServer", +-- > "printc=printChart False sendChart", +-- > ":set -interactive-print printc" +-- > ] +-- > :} +-- > +-- > :{ +-- > :def! noprettychart \_ -> pure $ unlines [ +-- > "quitChartServer", +-- > ":set -interactive-print print" +-- > ] +-- > :} +-- > +-- > :prettychart +-- > diff --git a/src/Prettychart/Any.hs b/src/Prettychart/Any.hs new file mode 100644 --- /dev/null +++ b/src/Prettychart/Any.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Read some text and attempt to make a chart. +module Prettychart.Any + ( anyChart, + anyWrite, + tryChart, + anyList1, + anyList2, + anyTuple2, + anySingleNamedBarChart, + anyBar2, + anyLineChart, + anySurfaceChart, + ) +where + +import Chart +import Data.Either (rights) +import Data.Maybe +import Data.Text (Text, pack, unpack) +import Optics.Core +import Prettychart.Charts +import Text.Read (readEither) + +-- $setup +-- +-- >>> :set -Wno-type-defaults +-- >>> import Chart +-- >>> import Prettychart.Any +-- >>> import Data.Text (unpack) + +-- | Attempt to read some text and interpret it as data suitable for charting. +-- +-- In the example below, 'anyChart' determines that the input text is of type [(Double, Double)] and renders a scatter chart of the data. +-- +-- >>> unknownData = (,) <$> (((\x -> sin (pi * x/40)) . fromIntegral <$> ([1..40] :: [Int]))) <*> (((\x -> cos (pi * x/40)) . fromIntegral <$> ([1..40] :: [Int]))) +-- >>> let c = anyChart $ show $ unknownData +-- >>> writeFile "other/anychart.svg" $ either id (unpack . renderChartOptions) c +-- +-- ![anyChart Example](other/anychart.svg) +anyChart :: String -> Either String ChartOptions +anyChart t = + maybe (Left "bad read") Right . listToMaybe . rights $ + [ -- single list + tryChart t anyList1, + -- double list + tryChart t anyList2, + -- single tuple list + tryChart t (\x -> anyTuple2 [x]), + -- double tuple list + tryChart t anyTuple2, + -- (Text,Double) single list + tryChart t anySingleNamedBarChart + ] + +-- | Attempt to read chart data and write to file. +anyWrite :: FilePath -> String -> IO () +anyWrite f t = writeFile f $ either id (unpack . renderChartOptions) $ anyChart t + +-- | Read a String and try a chart with a particular shape. +tryChart :: (Read a) => String -> (a -> ChartOptions) -> Either String ChartOptions +tryChart t c = c <$> readEither t + +-- | Default chart for a single list. +anyList1 :: [Double] -> ChartOptions +anyList1 xs + | length xs > 1000 = histChart (unsafeSpace1 xs) 20 xs + | length xs > 10 = anyLineChart [xs] + | otherwise = barChart defaultBarOptions (BarData [xs] [] []) + +-- | Default chart for a double list. +anyList2 :: [[Double]] -> ChartOptions +anyList2 xss + | (length xss < 4) && (length (head xss) < 10) = anyBar2 xss + -- square + | all (length xss ==) (length <$> xss) = + anySurfaceChart xss + | otherwise = anyLineChart xss + +-- | Bar chart for a labelled list. +anySingleNamedBarChart :: [(Text, Double)] -> ChartOptions +anySingleNamedBarChart xs = + barChart + defaultBarOptions + ( BarData + [snd <$> xs] + (fst <$> xs) + [] + ) + +-- | Bar chart for a double list. +anyBar2 :: [[Double]] -> ChartOptions +anyBar2 xss = + barChart + defaultBarOptions + ( BarData + xss + (pack . ("row " <>) . show <$> take nrows [(0 :: Int) ..]) + (pack . ("col " <>) . show <$> take ncols [(0 :: Int) ..]) + ) + where + ncols = length xss + nrows = maximum (length <$> xss) + +-- | Multiple line chart. +anyLineChart :: [[Double]] -> ChartOptions +anyLineChart xss = + mempty + & #hudOptions .~ defaultHudOptions + & #charts .~ unnamed (zipWith (\c xs -> simpleLineChart 0.02 (palette1 c) xs) [0 ..] xss) + +-- | Default scatter chart for paired data +anyTuple2 :: [[(Double, Double)]] -> ChartOptions +anyTuple2 xss = + mempty + & #hudOptions .~ defaultHudOptions + & #charts .~ unnamed (scatterChart (fmap (fmap (uncurry Point)) xss)) + +-- | Default pixel chart for double list. +anySurfaceChart :: [[Double]] -> ChartOptions +anySurfaceChart xss = mempty & #charts .~ ct + where + ct = runHud (aspect 1) (h0 <> h1) (unnamed c) + (h0, _) = toHuds (anySurfaceHud nrows ncols) gr + gr = Rect 0 (fromIntegral nrows :: Double) 0 (fromIntegral ncols) + (c, h1) = + surfacefl + (\(Point x y) -> (xss' !! floor x) !! floor y) + (SurfaceOptions defaultSurfaceStyle (Point nrows ncols) gr) + (defaultSurfaceLegendOptions dark "") + nrows = rows xss + ncols = length xss + xss' = appendZeros xss + +-- | Number of rows +rows :: [[Double]] -> Int +rows xs = maximum $ (0 :) $ length <$> xs + +appendZeros :: [[Double]] -> [[Double]] +appendZeros xs = + ( \x -> + take + (rows xs) + (x <> repeat 0) + ) + <$> xs + +anySurfaceHud :: Int -> Int -> HudOptions +anySurfaceHud nx ny = + defaultHudOptions + & #axes + .~ [ ( 5, + defaultAxisOptions + & #ticks % #style .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labelsy) + & #place .~ PlaceLeft + ), + ( 5, + defaultAxisOptions + & #ticks % #style .~ TickPlaced (zip ((0.5 +) <$> [0 ..]) labelsx) + & #place .~ PlaceBottom + ) + ] + where + labelsx = pack . show <$> [0 .. (nx - 1)] + labelsy = pack . show <$> [0 .. (ny - 1)] diff --git a/src/Prettychart/Charts.hs b/src/Prettychart/Charts.hs new file mode 100644 --- /dev/null +++ b/src/Prettychart/Charts.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# HLINT ignore "Eta reduce" #-} +{-# HLINT ignore "Use ?~" #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- | Various common chart patterns. +module Prettychart.Charts + ( simpleLineChart, + xify, + yify, + timeXAxis, + titles3, + histChart, + gpalette, + scatterChart, + blendMidLineStyles, + quantileNames, + quantileChart, + digitChart, + quantileHistChart, + digitSurfaceChart, + ) +where + +import Chart hiding (abs) +import Data.Bifunctor +import Data.Foldable +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Text (Text) +import Data.Time (UTCTime (..)) +import NumHask.Space +import Optics.Core + +-- $setup +-- +-- >>> :set -Wno-type-defaults +-- >>> import Chart +-- >>> import Prettychart.Charts +-- >>> import Data.Text (pack, Text) +-- >>> import qualified Data.Text as Text +-- >>> import qualified Data.Text.IO as Text + +-- | convert from [a] to [Point a], by adding the index as the x axis +-- +-- >>> xify [1..3] +-- [Point 0.0 1.0,Point 1.0 2.0,Point 2.0 3.0] +xify :: [Double] -> [Point Double] +xify ys = + zipWith Point [0 ..] ys + +-- | convert from [a] to [Point a], by adding the index as the y axis +-- +-- >>> yify [1..3] +-- [Point 1.0 0.0,Point 2.0 1.0,Point 3.0 2.0] +yify :: [Double] -> [Point Double] +yify xs = + zipWith Point xs [0 ..] + +-- | interpret a [Double] as a line with x coordinates of [0..] +-- +-- ![simpleLineChart example](other/simpleline.svg) +simpleLineChart :: Double -> Colour -> [Double] -> Chart +simpleLineChart w c xs = + LineChart + (defaultLineStyle & #color .~ c & #size .~ w) + [xify xs] + +-- | Create a hud that has time as the x-axis, based on supplied UTCTime list. +timeXAxis :: Int -> [UTCTime] -> AxisOptions +timeXAxis nticks ds = + defaultAxisOptions + & #ticks % #style + .~ TickPlaced + ( first (* fromIntegral (length ds)) <$> placedTimeLabelContinuous PosInnerOnly Nothing nticks (unsafeSpace1 ds) + ) + +-- | common pattern of chart title, x-axis title and y-axis title +titles3 :: Priority -> (Text, Text, Text) -> [(Priority, Title)] +titles3 p (t, x, y) = + [ (p, defaultTitle t & #style % #size .~ 0.08), + (p, defaultTitle x & #place .~ PlaceBottom & #style % #size .~ 0.05), + (p, defaultTitle y & #place .~ PlaceLeft & #style % #size .~ 0.05) + ] + +-- | histogram chart +-- +-- ![histChart example](other/hist.svg) +histChart :: + Range Double -> + Int -> + [Double] -> + ChartOptions +histChart r g xs = + mempty + & #charts .~ named "histogram" [RectChart defaultRectStyle rects] + & #hudOptions % #axes .~ [(5, defaultAxisOptions & #ticks % #ltick .~ Nothing & #ticks % #style .~ TickRound (FormatN FSCommaPrec (Just 2) 4 True True) 5 NoTickExtend)] + & #hudOptions % #frames .~ [(20, defaultFrameOptions & #buffer .~ 0.05)] + where + hcuts = gridSensible OuterPos False r (fromIntegral g) + h = fill hcuts xs + rects = + filter (\(Rect _ _ _ y') -> y' /= 0) $ + makeRects (IncludeOvers (NumHask.Space.width r / fromIntegral g)) h + +-- | scatter chart +-- +-- ![scatterChart example](other/scatter.svg) +scatterChart :: + [[Point Double]] -> + [Chart] +scatterChart xss = zipWith GlyphChart (gpaletteStyle 0.04 0.01) xss + +-- | GlyphStyle palette +gpaletteStyle :: Double -> Double -> [GlyphStyle] +gpaletteStyle s bs = zipWith (\c g -> defaultGlyphStyle & #size .~ s & #color .~ palette1 c & #shape .~ g & #borderSize .~ bs) [0 ..] gpalette + +-- | Glyph palette +gpalette :: [GlyphShape] +gpalette = + [ CircleGlyph, + SquareGlyph, + RectSharpGlyph 0.75, + RectRoundedGlyph 0.75 0.01 0.01, + EllipseGlyph 0.75, + VLineGlyph, + HLineGlyph, + TriangleGlyph (Point 0.0 0.0) (Point 1 1) (Point 1 0), + PathGlyph "M0.05,-0.03660254037844387 A0.1 0.1 0.0 0 1 0.0,0.05 0.1 0.1 0.0 0 1 -0.05,-0.03660254037844387 0.1 0.1 0.0 0 1 0.05,-0.03660254037844387 Z" ScaleBorder + ] + +-- | Chart template for quantiles. +-- +-- ![quantileChart example](other/quantile.svg) +quantileChart :: + [Text] -> + [LineStyle] -> + [[Double]] -> + ChartOptions +quantileChart names ls xs = mempty & #hudOptions .~ h & #charts .~ unnamed c + where + h = + defaultHudOptions + & ( #legends + .~ [ ( 10, + defaultLegendOptions + & #textStyle % #size .~ 0.1 + & #vgap .~ 0.05 + & #innerPad .~ 0.2 + & #place .~ PlaceRight + & #content .~ zip names ((: []) <$> c) + ) + ] + ) + c = + zipWith + (\l x -> LineChart l [x]) + ls + (zipWith Point [0 ..] <$> xs) + +-- | Format quantile-style numbers +-- +-- >>> quantileNames [0.01, 0.5, 0.99] +-- ["1%","50%","99%"] +quantileNames :: (Functor f) => f Double -> f Text +quantileNames qs = percent commaSF Nothing <$> qs + +-- | /blendMidLineStyle n w/ produces n lines of width w interpolated between two colors. +blendMidLineStyles :: Int -> Double -> (Colour, Colour) -> [LineStyle] +blendMidLineStyles l w (c1, c2) = lo + where + m = (fromIntegral l - 1) / 2 :: Double + cs = (\x -> 1 - abs (fromIntegral x - m) / m) <$> [0 .. (l - 1)] + bs = (\x -> mix x c1 c2) <$> cs + lo = (\c -> defaultLineStyle & #size .~ w & #color .~ c) <$> bs + +-- | A histogram based on quantile information +-- +-- ![quantileHistChart example](other/qhist.svg) +quantileHistChart :: + -- | quantile names + Maybe [Text] -> + -- | quantiles + [Double] -> + -- | quantile values + [Double] -> + ChartOptions +quantileHistChart names qs vs = mempty & #charts .~ unnamed [chart'] & #hudOptions .~ hudOptions + where + hudOptions = + defaultHudOptions + & #axes + .~ [ ( 5, + maybe + ( axis0 + & #ticks % #style + .~ TickRound (FormatN FSDecimal (Just 3) 4 True True) 6 TickExtend + ) + ( \x -> + axis0 + & #ticks % #style + .~ TickPlaced (zip vs x) + ) + names + ) + ] + axis0 = defaultAxisOptions & #ticks % #ltick .~ Nothing & (#ticks % #ttick) %~ fmap (first (#size .~ 0.03)) + chart' = RectChart defaultRectStyle hr + hr = + zipWith + (\(y, w) (x, z) -> Rect x z 0 ((w - y) / (z - x))) + (zip qs (drop 1 qs)) + (zip vs (drop 1 vs)) + +-- | A chart drawing quantiles of a time series +-- +-- ![digitChart example](other/digit.svg) +digitChart :: + [UTCTime] -> + [Double] -> + [Text] -> + ChartOptions +digitChart utcs xs labels = + mempty & #charts .~ unnamed [c] & #hudOptions .~ hudOptions + where + hudOptions = + defaultHudOptions + & #axes .~ [(5, timeXAxis 8 utcs), (5, decileYAxis labels)] + c = + GlyphChart + ( defaultGlyphStyle + & #color .~ Colour 0 0 1 1 + & #shape .~ CircleGlyph + & #size .~ 0.01 + ) + (xify xs) + +decileYAxis :: [Text] -> AxisOptions +decileYAxis labels = + defaultAxisOptions + & #ticks % #style .~ TickPlaced (zip ((+ 0.5) <$> [0 ..]) labels) + & #ticks % #ltick .~ Nothing + & #ticks % #ttick %~ fmap (first (#size .~ 0.03)) + & #place .~ PlaceLeft + +-- | Surface chart of quantile vs quantile counts +-- +-- ![digitSurfaceChart example](other/digitsurface.svg) +digitSurfaceChart :: + SurfaceStyle -> + SurfaceLegendOptions -> + (Text, Text, Text) -> + [Text] -> + [(Int, Int)] -> + ChartTree +digitSurfaceChart pixelStyle plo ts names ps = + runHud (aspect 1) (hs0 <> hs1) (unnamed cs1) + where + l = length names - 1 + pts = Point l l + gr :: Rect Double + gr = fromIntegral <$> Rect 0 l 0 l + mapCount = foldl' (\m x -> Map.insertWith (+) x 1.0 m) Map.empty ps + f :: Point Double -> Double + f (Point x y) = fromMaybe 0 $ Map.lookup (floor (1 + x), floor (1 + y)) mapCount + (hs0, _) = toHuds (qvqHud ts names) gr + (cs1, hs1) = + surfacefl + f + (SurfaceOptions pixelStyle pts gr) + plo + +qvqHud :: (Text, Text, Text) -> [Text] -> HudOptions +qvqHud ts labels = + defaultHudOptions + & #titles .~ titles3 5 ts + & #axes + .~ ( (3,) + <$> [ defaultAxisOptions + & #ticks % #style .~ TickPlaced (zip [0 ..] labels) + & #ticks % #ltick .~ Nothing + & #ticks % #ttick %~ fmap (first (#size .~ 0.03)) + & #place .~ PlaceLeft, + defaultAxisOptions + & #ticks % #style .~ TickPlaced (zip [0 ..] labels) + & #ticks % #ltick .~ Nothing + & #ticks % #ttick %~ fmap (first (#size .~ 0.03)) + & #place .~ PlaceBottom + ] + ) diff --git a/src/Prettychart/ExampleData.hs b/src/Prettychart/ExampleData.hs new file mode 100644 --- /dev/null +++ b/src/Prettychart/ExampleData.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | Data for testing prettychart. +module Prettychart.ExampleData + ( getReturns, + taker, + ) +where + +import Chart.FlatParse +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C +import Data.Time.Calendar +import FlatParse.Basic (Parser, Result (OK), char, runParser) + +dayP :: Parser e Day +dayP = do + y <- int + _ <- $(char '-') + m <- int + _ <- $(char '-') + d <- int + pure $ fromGregorian (fromIntegral y) m d + +runParserError :: Parser e a -> BS.ByteString -> a +runParserError p bs = case runParser p bs of + OK r _ -> r + _ -> error "uncaught flatparse error" + +dayReturnP :: Parser e (Day, Double) +dayReturnP = (,) <$> dayP <*> ($(char ',') *> signed double) + +-- | Read and parse example data, which is daily stock market returns since 1980. +getReturns :: IO [(Day, Double)] +getReturns = do + bs <- BS.readFile "other/returns.csv" + pure $ runParserError dayReturnP <$> C.lines bs + +-- | Take the last n of a list. +taker :: Int -> [a] -> [a] +taker n = reverse . take n . reverse diff --git a/src/Prettychart/Server.hs b/src/Prettychart/Server.hs new file mode 100644 --- /dev/null +++ b/src/Prettychart/Server.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Serve a chart web page with a web socket in it, that accepts 'ChartOptions'. +module Prettychart.Server + ( startChartServer, + startChartServerWith, + printChart, + chartSocketPage, + ) +where + +import Box +import Chart +import Control.Concurrent.Async +import Control.Monad (when) +import Lucid as L +import Optics.Core +import Prettychart.Any +import Web.Rep + +-- | 'Page' containing a web socket and javascript needed to run it. +chartSocketPage :: Page +chartSocketPage = + bootstrap5Page + & #jsOnLoad + .~ mconcat + [ webSocket, + runScriptJs, + refreshJsbJs + ] + & #htmlBody + .~ divClass_ + "container" + ( mconcat + [ divClass_ "row" $ divClass_ "col" (h4_ "prettychart" <> L.with div_ [id_ "prettychart"] mempty) + ] + ) + +-- | Print a chart supplying a 'ChartOptions' consumer, and a showable thing that may be chartable. The first argument flags whether to also print the item to stdout. +printChart :: (Show a) => Bool -> (ChartOptions -> IO Bool) -> a -> IO () +printChart reprint send s = case anyChart (show s) of + Left _ -> print s + Right co -> do + b <- send co + when (not b || reprint) (print s) + +-- | Start the chart server. Returns the chart consumer, and a server quit signal effect. +-- +-- An iconic ghci session transcript: +-- +-- >> import Chart.Examples +-- >> (sendChart, quitChartServer) <- startChartServer +-- >> sendChart unitExample +-- +-- ... point browser to localhost:9160 ... +-- +-- >> quitChartServer +startChartServer :: IO (ChartOptions -> IO Bool, IO ()) +startChartServer = startChartServerWith defaultSocketConfig chartSocketPage + +-- | Start the chart server protocol with bespoke 'SocketConfig' and 'Page' configurations. +-- +-- > startChartServerWith (defaultSocketConfig & #port .~ 4567) (defaultSocketPage & #htmlBody %~ divClass_ "row" "bespoke footnote") +startChartServerWith :: SocketConfig -> Page -> IO (ChartOptions -> IO Bool, IO ()) +startChartServerWith scfg page = do + (Box c e, q) <- toBoxM Single + x <- async $ serveSocketBox scfg page (Box toStdout (replace "prettychart" . renderChartOptions <$> e)) + pure (commit c, cancel x >> q)