diff --git a/app/prettychart-watch.hs b/app/prettychart-watch.hs
new file mode 100644
--- /dev/null
+++ b/app/prettychart-watch.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Watch a file or directory for svg to serve
+module Main where
+
+import Box
+import Control.Concurrent.Async
+import GHC.Generics
+import Optics.Core
+import Options.Applicative
+import Prettychart
+import Web.Rep.Socket
+import Prelude
+
+data Run = RunWatch deriving (Eq, Show)
+
+data AppConfig = AppConfig
+ { appSocketConfig :: SocketConfig,
+ appRun :: Run,
+ appFilePath :: FilePath
+ }
+ deriving (Eq, Show, Generic)
+
+defaultAppConfig :: AppConfig
+defaultAppConfig = AppConfig defaultSocketConfig RunWatch "."
+
+parseRun :: Parser Run
+parseRun =
+ flag' RunWatch (long "watch" <> help "watch for svg chart files")
+ <|> pure RunWatch
+
+parseSocketConfig :: SocketConfig -> Parser SocketConfig
+parseSocketConfig def =
+ SocketConfig
+ <$> option auto (value (view #host def) <> long "host" <> help "socket host")
+ <*> option auto (value (view #port def) <> long "port" <> help "socket port")
+ <*> option auto (value (view #path def) <> long "path" <> help "socket path")
+
+appParser :: AppConfig -> Parser AppConfig
+appParser def =
+ AppConfig
+ <$> parseSocketConfig (view #appSocketConfig def)
+ <*> parseRun
+ <*> option str (value (view #appFilePath def) <> long "filepath" <> short 'f' <> help "file path to watch")
+
+appConfig :: AppConfig -> ParserInfo AppConfig
+appConfig def =
+ info
+ (appParser def <**> helper)
+ (fullDesc <> progDesc "SVG file server")
+
+startWatcher :: IO ()
+startWatcher = pure ()
+
+startServer :: IO ()
+startServer = pure ()
+
+main :: IO ()
+main = do
+ o <- execParser (appConfig defaultAppConfig)
+ let sc = appSocketConfig o
+ let r = appRun o
+ let fp = appFilePath o
+
+ case r of
+ RunWatch -> do
+ (c, stop) <- displayFile sc (chartSocketPage Nothing)
+ a <- async $ glue' c <$|> watchSvg fp
+ putStrLn ("listening to" <> fp)
+ print =<< wait a
+ stop
diff --git a/other/anychart.svg b/other/anychart.svg
--- a/other/anychart.svg
+++ b/other/anychart.svg
@@ -1,4 +1,4 @@
-
+0.00.20.40.60.81.0-1.0-0.5 0.0 0.5 1.0
diff --git a/prettychart.cabal b/prettychart.cabal
--- a/prettychart.cabal
+++ b/prettychart.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.0
name: prettychart
-version: 0.2.2.0
+version: 0.3.0.0
license: BSD-3-Clause
license-file: LICENSE
copyright: Tony Day (c) 2023
@@ -11,12 +11,12 @@
bug-reports: https://github.com/tonyday567/prettychart/issues
synopsis: Pretty print charts from ghci.
description:
- Serve and print charts from ghci, with automatic formatting.
+ Serve and print charts from ghci or from an svg file, with automatic formatting.
build-type: Simple
tested-with:
, GHC == 9.10.1
- , GHC == 9.8.2
, GHC == 9.6.5
+ , GHC == 9.8.2
extra-doc-files:
ChangeLog.md
other/*.svg
@@ -26,6 +26,14 @@
type: git
location: https://github.com/tonyday567/prettychart
+common ghc-options-exe-stanza
+ ghc-options:
+ -fforce-recomp
+ -funbox-strict-fields
+ -rtsopts
+ -threaded
+ -with-rtsopts=-N
+
common ghc-options-stanza
ghc-options:
-Wall
@@ -45,22 +53,40 @@
hs-source-dirs: src
build-depends:
, async >=2.2.4 && <2.3
- , base >=4.7 && <5
+ , base >=4.14 && <5
, box >=0.9 && <0.10
, bytestring >=0.11.3 && <0.13
- , chart-svg >=0.6 && <0.8
+ , chart-svg >=0.8 && <0.9
, containers >=0.6 && <0.8
+ , filepath >=1.4 && <1.6
+ , fsnotify >=0.4.1 && <0.5
, markup-parse >=0.1 && <0.2
- , numhask-space >=0.10 && <0.12
+ , numhask-space >=0.10 && <0.13
, optics-core >=0.4 && <0.5
, text >=1.2 && <2.2
, time >=1.9 && <1.15
- , web-rep >=0.12.1 && <0.13
+ , web-rep >=0.12.1 && <0.14
exposed-modules:
Prettychart
Prettychart.Any
Prettychart.Charts
Prettychart.Server
+
+executable prettychart-watch
+ import: ghc-options-exe-stanza
+ import: ghc-options-stanza
+ import: ghc2021-stanza
+ main-is: prettychart-watch.hs
+ hs-source-dirs: app
+ build-depends:
+ , async >=2.2.4 && <2.3
+ , base >=4.14 && <5
+ , box >=0.9.3 && <0.10
+ , optics-core >=0.4.1 && <0.5
+ , optparse-applicative >=0.17 && <0.19
+ , prettychart
+ , web-rep >=0.12.1 && <0.14
+ ghc-options: -O2
test-suite doctests
import: ghc2021-stanza
diff --git a/readme.md b/readme.md
--- a/readme.md
+++ b/readme.md
@@ -1,63 +1,38 @@
-# Table of Contents
-
-1. [prettychart](#org52eda08)
-2. [Usage](#orgf05409a)
- 1. [live coding](#org062de09)
- 2. [ghci integration](#orgfcd7bd6)
-3. [Development](#orgf489981)
- 1. [live](#org2deed6a)
-4. [Prettychart.Any Examples](#orgca9d9d6)
- 1. [single list](#org9b83b20)
- 1. [10 or less elements => bar chart](#orgc860033)
- 2. [>1000 elements => histogram](#org7abe64c)
- 3. [< 1000 && > 10 => line chart](#orga634aff)
- 2. [double list](#org493d2b1)
- 1. [< 4 lists && < 10 values per list => bar chart](#org6e7fcb7)
- 2. [square => surface chart](#org5e9ba1b)
- 3. [tuple list [(Double, Double)] => scatter](#orgfc9b845)
- 4. [double tuple list [(Double, Double)] => scatter](#orgcd245d1)
- 5. [(Text, Double) tuple list](#org5cb6f57)
-
-
-
-
# prettychart
-[](https://hackage.haskell.org/package/prettychart) [](https://github.com/tonyday567/chart-svg/actions?query=workflow%3Ahaskell-ci)
+[](https://hackage.haskell.org/package/prettychart) [](https://github.com/tonyday567/prettychart/actions)
This library contains:
-- A chart server, for use in conjunction with ghci, or other live coding situations. (See Chartpretty.Server)
+- A chart server, for use in conjunction with ghci, or other live coding situations. (See Chartpretty.Server & prettychart-watch)
- anyChart, which attempts to convert text (of numbers) to a chart. (See Chartpretty.Any)
- Some useful chart patterns that didn’t make the cut in chart-svg (See Chartpretty.Charts)
-
-
# Usage
-
-
-## live coding
+## live
The server can be used to view and develop chart-svg charts.
- > (display, quit) <- startChartServer (Just "prettychart")
- Setting phaser>s to stun... (port 9160) (ctrl-c to quit)
-
- -- open localhost:9160
- -- developing and sending a chart to the server
-
- > import Chart.Examples
- > display lineExample
-
- > quit
+ (display, quit) <- startChartServer Nothing
+ display lineExample
+ Setting phasers to stun... (port 9160) g(hcctir>l -c to Tqruuiet
+ )
-
+## file serving
+
+prettychart-watch can watch a directory and serve new or modified charts.
+
+ prettychart-watch --watch --filepath other --port 3566
+
+ writeChartOptions "other/test.svg" (lineExample)
+
+
## ghci integration
Add this to your .ghci.conf file to automatically go into :prettychart mode.
@@ -90,23 +65,19 @@
:noprettychart
-
-
# Development
:r
- :set prompt "> "
:set -Wno-type-defaults
:set -Wno-name-shadowing
:set -XOverloadedStrings
:set -XTupleSections
:set -XOverloadedLabels
- import Chart hiding (quantiles)
+ import Chart
import Chart.Examples
import Optics.Core
import Prettychart.Charts
import Prettychart.Any
- import Prettychart.ExampleData
import Prettychart.Server
import Data.Time.Calendar
import qualified Data.Map as Map
@@ -117,37 +88,20 @@
import qualified Data.List as List
import Control.Category ((>>>))
print "ok"
-
- [3 of 5] Compiling Prettychart.ExampleData ( src/Prettychart/ExampleData.hs, interpreted ) [Flags changed]
- [5 of 5] Compiling Prettychart ( src/Prettychart.hs, interpreted ) [Flags changed]
- Ok, five modules loaded.
- >
- ok
-
-
-
-
-## live
-
(display, quit) <- startChartServer Nothing
-
- display $ debugExample quadExample
+ display lineExample
- True
+ [4 of 4] Compiling Prettychart ( src/Prettychart.hs, interpreted ) [Flags changed]
+ Ok, four modules reloaded.
+ "ok"
-
-
# Prettychart.Any Examples
-
-
## single list
-
-
### 10 or less elements => bar chart
xs = [0..9]
@@ -159,8 +113,6 @@
either Text.putStrLn (writeChartOptions "other/list1a.svg") $ anyChart (pack . show $ xs)
-
-
### >1000 elements => histogram
xs = sin <$> [0..2000]
@@ -170,8 +122,6 @@
-
-
### < 1000 && > 10 => line chart
In between goes for a line chartIn between goes for a line chart.
@@ -183,13 +133,9 @@
-
-
## double list
-
-
### < 4 lists && < 10 values per list => bar chart
xs = [(1+) . sin <$> [0..8], (1+) . cos <$> [0..8]]
@@ -202,8 +148,6 @@
-
-
### square => surface chart
iter2 f xs ys = f <$> xs <&> flip fmap ys -- or (\a -> f a <$> ys) <$> xs
@@ -221,8 +165,6 @@
-
-
## tuple list [(Double, Double)] => scatter
xs = zip (fmap (sin . (0.06*)) [1..100]) (fmap (cos . (0.06*)) [1..100])
@@ -238,8 +180,6 @@
-
-
## double tuple list [(Double, Double)] => scatter
iter2 f xs ys = f <$> xs <&> flip fmap ys -- or (\a -> f a <$> ys) <$> xs
@@ -255,8 +195,6 @@
-
-
## (Text, Double) tuple list
diff --git a/src/Prettychart/Charts.hs b/src/Prettychart/Charts.hs
--- a/src/Prettychart/Charts.hs
+++ b/src/Prettychart/Charts.hs
@@ -1,32 +1,55 @@
+{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
--- | Various common chart patterns.
+-- | Various common (& pretty) chart patterns.
module Prettychart.Charts
- ( simpleLineChart,
+ ( UtcAxisStyle (..),
+ defaultUtcAxisStyle,
+ utcAxis,
+ DecileAxisStyle (..),
+ defaultDecileAxisStyle,
+ qsAxisStyle,
+ decileAxis,
+ DigitChartStyle (..),
+ defaultDigitChartStyle,
+ digitChart,
+ UtcLineChartStyle (..),
+ defaultUtcLineChartStyle,
+ utcLineChart,
+ CountChartStyle (..),
+ defaultCountChartStyle,
+ countChart,
+ simpleRectChart,
+ simpleLineChart,
+ simpleScatterChart,
xify,
yify,
- timeXAxis,
titles3,
histChart,
+ hhistChart,
+ hhistCharts,
scatterChart,
blendMidLineStyles,
quantileNames,
quantileChart,
- digitChart,
quantileHistChart,
digitSurfaceChart,
)
where
import Chart hiding (abs)
+import Control.Category ((>>>))
import Data.Bifunctor
+import Data.Bool
import Data.Foldable
+import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Text (Text)
import Data.Time (UTCTime (..))
+import GHC.Generics
import NumHask.Space
import Optics.Core
@@ -39,6 +62,147 @@
-- >>> import qualified Data.Text as Text
-- >>> import qualified Data.Text.IO as Text
+-- | UTC (time) axis style
+data UtcAxisStyle
+ = UtcAxisStyle
+ { cont :: Bool,
+ posd :: PosDiscontinuous,
+ utcFormat :: Maybe Text,
+ nTicks :: Int
+ }
+ deriving (Generic)
+
+-- | default UTC (time) axis style
+defaultUtcAxisStyle :: UtcAxisStyle
+defaultUtcAxisStyle = UtcAxisStyle True PosInnerOnly (Just "%b %y") 8
+
+-- | Create a hud that has time as the x-axis based on supplied UTCTime list.
+utcAxis :: UtcAxisStyle -> [UTCTime] -> AxisOptions
+utcAxis s ds =
+ defaultXAxisOptions
+ & #ticks
+ % #tick
+ .~ TickPlaced
+ ( bool
+ (fmap (first fromIntegral) $ fst $ placedTimeLabelDiscontinuous posd utcFormat nTicks ds)
+ (first (* fromIntegral (length ds - 1)) <$> placedTimeLabelContinuous posd utcFormat nTicks (unsafeSpace1 ds))
+ cont
+ )
+ where
+ cont = view #cont s
+ posd = view #posd s
+ utcFormat = view #utcFormat s
+ nTicks = view #nTicks s
+
+-- | Decile (quantile) axis style
+data DecileAxisStyle
+ = DecileAxisStyle
+ { size :: Double,
+ labels :: [Text]
+ }
+ deriving (Generic)
+
+-- | Default decile (quantile) axis style
+defaultDecileAxisStyle :: DecileAxisStyle
+defaultDecileAxisStyle = DecileAxisStyle 0.04 []
+
+-- | Convert a list of quantiles to 'DecileAxisStyle'
+qsAxisStyle :: [Double] -> DecileAxisStyle
+qsAxisStyle qs = defaultDecileAxisStyle & set #labels (quantileNames qs)
+
+-- | Create an axis from a style.
+decileAxis :: DecileAxisStyle -> AxisOptions
+decileAxis s =
+ defaultYAxisOptions
+ & set (#ticks % #tick) (TickPlaced (zip ((+ 0.5) <$> [0 ..]) (view #labels s)))
+ & set (#ticks % #lineTick) Nothing
+ & set (#ticks % #textTick %? #style % #size) (view #size s)
+
+-- | Chart style for a digit chart
+data DigitChartStyle
+ = DigitChartStyle
+ { utcAxisStyle :: Maybe UtcAxisStyle,
+ decileAxisStyle :: Maybe DecileAxisStyle,
+ glyphStyle :: Style,
+ hasLegend :: Bool
+ }
+ deriving (Generic)
+
+-- | Default chart style for a digit chart
+defaultDigitChartStyle :: DigitChartStyle
+defaultDigitChartStyle = DigitChartStyle (Just defaultUtcAxisStyle) Nothing (defaultGlyphStyle & set #size 0.01) True
+
+-- | A chart drawing a (quantiled or digitized) time series
+digitChart ::
+ DigitChartStyle ->
+ [UTCTime] ->
+ [Int] ->
+ ChartOptions
+digitChart s utcs xs =
+ mempty & #chartTree .~ unnamed [c] & #hudOptions .~ hudOptions
+ where
+ xaxis = view #utcAxisStyle s & fmap (\c -> utcAxis c utcs) & maybeToList
+ yaxis = view #decileAxisStyle s & fmap decileAxis & maybeToList
+ hudOptions =
+ defaultHudOptions
+ & set #axes (fmap (Priority 5) (xaxis <> yaxis))
+ c = GlyphChart (view #glyphStyle s) (xify (fromIntegral <$> xs))
+
+-- | Style of a UTC line chart.
+data UtcLineChartStyle = UtcLineChartStyle
+ { lineStyle :: Style,
+ utcAxisStyle :: Maybe UtcAxisStyle,
+ yAxisStyle :: Maybe AxisOptions,
+ legendStyle :: Maybe LegendOptions
+ }
+ deriving (Generic)
+
+-- | Default style of a UTC line chart.
+defaultUtcLineChartStyle :: UtcLineChartStyle
+defaultUtcLineChartStyle = UtcLineChartStyle (defaultLineStyle & set #size 0.005) (Just defaultUtcAxisStyle) (Just $ defaultYAxisOptions & set #place PlaceLeft & set (#ticks % #tick) (TickRound (FormatN FSPercent (Just 2) 4 True True) 6 TickExtend)) (Just (defaultLegendOptions & set #place PlaceBottom & set #frame (Just $ border 0.01 light) & set (#textStyle % #size) 0.2 & set #anchorTo HudStyleSection))
+
+-- | Line chart for a UTC time series.
+utcLineChart :: UtcLineChartStyle -> [Text] -> [(UTCTime, [Double])] -> ChartOptions
+utcLineChart s labels xs = mempty & #chartTree .~ named "day" cs & #hudOptions .~ h
+ where
+ cs = zipWith (\c xs' -> LineChart (view #lineStyle s & set #color c) [xify xs']) ((\x -> paletteO x 0.7) <$> [1, 2, 6, 7, 5, 3, 4, 0]) (List.transpose $ snd <$> xs)
+ xaxis = view #utcAxisStyle s & fmap (\c -> utcAxis c (fmap fst xs)) & maybeToList
+ yaxis = view #yAxisStyle s & maybeToList
+ leg = view #legendStyle s & fmap (set #legendCharts (zipWith (\t c -> (t, [c])) labels cs) >>> Priority 12) & maybeToList
+ h = defaultHudOptions & set #axes (fmap (Priority 5) (xaxis <> yaxis)) & set #legends leg
+
+-- | Chart template for quantiles.
+quantileChart ::
+ [Text] ->
+ [Style] ->
+ [[Double]] ->
+ ChartOptions
+quantileChart names ls xs = mempty & #hudOptions .~ h & #chartTree .~ unnamed c
+ where
+ h =
+ defaultHudOptions
+ & ( #legends
+ .~ [ Priority 10 $
+ defaultLegendOptions
+ & #textStyle
+ % #size
+ .~ 0.1
+ & #vgap
+ .~ 0.05
+ & #innerPad
+ .~ 0.2
+ & #place
+ .~ PlaceRight
+ & #legendCharts
+ .~ zip names ((: []) <$> c)
+ ]
+ )
+ c =
+ zipWith
+ (\l x -> LineChart l [x])
+ ls
+ (zipWith Point [0 ..] <$> xs)
+
-- | convert from [a] to [Point a], by adding the index as the x axis
--
-- >>> xify [1..3]
@@ -62,14 +226,12 @@
(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 =
- defaultXAxisOptions
- & #ticks
- % #tick
- .~ TickPlaced
- (first (* fromIntegral (length ds)) <$> placedTimeLabelContinuous PosInnerOnly Nothing nticks (unsafeSpace1 ds))
+-- | interpret a [Double] as a scatter chart with x coordinates of [0..]
+simpleScatterChart :: Double -> Colour -> [Double] -> Chart
+simpleScatterChart w c xs =
+ GlyphChart
+ (defaultGlyphStyle & #color .~ c & #size .~ w)
+ (xify xs)
-- | common pattern of chart title, x-axis title and y-axis title
titles3 :: Double -> (Text, Text, Text) -> [Priority TitleOptions]
@@ -79,6 +241,39 @@
Priority p (defaultTitleOptions y & #place .~ PlaceLeft & #style % #size .~ 0.05)
]
+-- | countChart style
+data CountChartStyle = CountChartStyle
+ { title :: Maybe Text,
+ titleColour :: Colour,
+ legendStyle :: Maybe LegendOptions
+ }
+ deriving (Generic)
+
+-- | Default CountChart style
+defaultCountChartStyle :: CountChartStyle
+defaultCountChartStyle = CountChartStyle (Just "count") (paletteO 10 0.7) (Just (defaultLegendOptions & set #place PlaceRight & set #frame (Just $ border 0.01 light) & set (#textStyle % #size) 0.2 & set #anchorTo HudStyleSection))
+
+-- | Count chart
+countChart :: CountChartStyle -> [Text] -> [Int] -> ChartOptions
+countChart s ls cs =
+ barChart defaultBarOptions (BarData (List.transpose [fromIntegral <$> cs]) [] ls) & set (#hudOptions % #axes) [] & set (#chartTree % charts' % each % #chartStyle % #borderSize) 0 & set (#hudOptions % #legends % ix 0 % #item % #place) PlaceRight & set (#hudOptions % #titles) (maybeToList $ fmap (\t -> Priority 5 (defaultTitleOptions t & set (#style % #size) 0.06 & set #anchoring (-0.5) & set (#style % #color) (view #titleColour s))) (view #title s))
+
+-- | Simple Rect chart
+simpleRectChart ::
+ [Double] ->
+ Style ->
+ ChartOptions
+simpleRectChart xs s =
+ mempty
+ & set
+ #chartTree
+ (named "simpleRectChart" [RectChart s rects])
+ & set
+ (#hudOptions % #axes)
+ [Priority 5 (defaultYAxisOptions & #ticks % #lineTick .~ Nothing & #ticks % #tick .~ TickRound (FormatN FSCommaPrec (Just 2) 4 True True) 5 NoTickExtend)]
+ where
+ rects = zipWith (\x i -> Rect i (i + 1) (min 0 x) (max 0 x)) xs [0 ..]
+
-- | histogram chart
histChart ::
Range Double ->
@@ -102,6 +297,34 @@
filter (\(Rect _ _ _ y') -> y' /= 0) $
makeRects (IncludeOvers (NumHask.Space.width r / fromIntegral g)) h
+-- | horizontal histogram chart
+hhistChart ::
+ Range Double ->
+ Int ->
+ [Double] ->
+ ChartOptions
+hhistChart r g xs =
+ mempty
+ & set #chartTree (named "hhistogram" [RectChart defaultRectStyle (flipAxes <$> rects)])
+ where
+ hcuts = gridSensible OuterPos False r g
+ h = fill hcuts xs
+ rects = makeRects (IncludeOvers (NumHask.Space.width r / fromIntegral g)) h
+
+-- | horizontal histogram chart
+hhistCharts ::
+ Range Double ->
+ Int ->
+ [(Style, [Double])] ->
+ ChartOptions
+hhistCharts r g xs =
+ mempty
+ & set #chartTree (named "hhistogram" (zipWith (\r s -> RectChart s (flipAxes <$> r)) rects (fst <$> xs)))
+ where
+ hcuts = gridSensible OuterPos False r g
+ hs = fill hcuts . snd <$> xs
+ rects = makeRects (IncludeOvers (NumHask.Space.width r / fromIntegral g)) <$> hs
+
-- | scatter chart
scatterChart ::
[[Point Double]] ->
@@ -112,44 +335,12 @@
gpaletteStyle :: Double -> Double -> [(Style, GlyphShape)]
gpaletteStyle s bs = zipWith (\c g -> (defaultGlyphStyle & #size .~ s & #color .~ palette c & #glyphShape .~ g & #borderSize .~ bs, g)) [0 ..] (gpalette <$> [0 .. 8])
--- | Chart template for quantiles.
-quantileChart ::
- [Text] ->
- [Style] ->
- [[Double]] ->
- ChartOptions
-quantileChart names ls xs = mempty & #hudOptions .~ h & #chartTree .~ unnamed c
- where
- h =
- defaultHudOptions
- & ( #legends
- .~ [ Priority 10 $
- defaultLegendOptions
- & #textStyle
- % #size
- .~ 0.1
- & #vgap
- .~ 0.05
- & #innerPad
- .~ 0.2
- & #place
- .~ PlaceRight
- & #legendCharts
- .~ 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%"]
+-- ["1.0%","50%","99%"]
quantileNames :: (Functor f) => f Double -> f Text
-quantileNames qs = percent commaSF Nothing <$> qs
+quantileNames qs = percent commaSF (Just 2) <$> qs
-- | @blendMidLineStyle n w@ produces n lines of width w interpolated between two colors.
blendMidLineStyles :: Int -> Double -> (Colour, Colour) -> [Style]
@@ -197,46 +388,6 @@
(zip qs (drop 1 qs))
(zip vs (drop 1 vs))
--- | A chart drawing quantiles of a time series
-digitChart ::
- [UTCTime] ->
- [Double] ->
- [Text] ->
- ChartOptions
-digitChart utcs xs labels =
- mempty & #chartTree .~ unnamed [c] & #hudOptions .~ hudOptions
- where
- hudOptions =
- defaultHudOptions
- & #axes
- .~ [Priority 5 (timeXAxis 8 utcs), Priority 5 (decileYAxis labels)]
- c =
- GlyphChart
- ( defaultGlyphStyle
- & #color
- .~ Colour 0 0 1 1
- & #size
- .~ 0.01
- & #glyphShape
- .~ CircleGlyph
- )
- (xify xs)
-
-decileYAxis :: [Text] -> AxisOptions
-decileYAxis labels =
- defaultYAxisOptions
- & #ticks
- % #tick
- .~ TickPlaced (zip ((+ 0.5) <$> [0 ..]) labels)
- & #ticks
- % #lineTick
- .~ Nothing
- & #ticks
- % #textTick
- %? #style
- % #size
- .~ 0.03
-
-- | Surface chart of quantile vs quantile counts
digitSurfaceChart ::
SurfaceStyle ->
@@ -261,6 +412,7 @@
f
(SurfaceOptions pixelStyle pts gr)
+-- | Hud for a qvq chart.
qvqHud :: (Text, Text, Text) -> [Text] -> HudOptions
qvqHud ts labels =
defaultHudOptions
diff --git a/src/Prettychart/Server.hs b/src/Prettychart/Server.hs
--- a/src/Prettychart/Server.hs
+++ b/src/Prettychart/Server.hs
@@ -7,19 +7,31 @@
startChartServerWith,
printChart,
chartSocketPage,
+ startFileServerWith,
+ watchE,
+ watchSvg,
+ svgEvent,
+ displayFile,
)
where
import Box
import Chart
+import Control.Category ((>>>))
+import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
-import Control.Monad (when)
+import Control.Monad (forever, void, when)
+import Data.Bool
import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
import Data.ByteString.Char8 (pack)
+import Data.Maybe
import Data.Text.Encoding
import MarkupParse
import Optics.Core hiding (element)
import Prettychart.Any
+import System.FSNotify
+import System.FilePath
import Web.Rep
-- | 'Page' containing a web socket and javascript needed to run it.
@@ -67,3 +79,52 @@
(Box c e, q) <- toBoxM Single
x <- async $ serveSocketBox scfg page (Box toStdout (decodeUtf8 . replace "prettychart" . encodeChartOptions <$> e))
pure (commit c, cancel x >> q)
+
+-- | Start a file server protocol with bespoke 'SocketConfig' and 'Page' configurations.
+--
+-- > startFileServerWith (defaultSocketConfig & #port .~ 4567) (defaultSocketPage & #htmlBody %~ divClass_ "row" "bespoke footnote")
+startFileServerWith :: SocketConfig -> Page -> IO (FilePath -> IO Bool, IO ())
+startFileServerWith scfg page = do
+ (Box c e, q) <- toBoxM Single
+ x <- async $ serveSocketBox scfg page (Box toStdout (decodeUtf8 . replace "prettychart" <$> witherE (B.readFile >>> fmap Just) e))
+ pure (commit c, cancel x >> q)
+
+-- | Emit from the fsnotify watch manager.
+watchE :: [Char] -> Codensity IO (Emitter IO Event)
+watchE fp =
+ emitQ
+ New
+ ( \c -> withManager $ \mgr -> do
+ putStrLn "watchDir started"
+ _ <- watchDir mgr fp (const True) (void . commit c)
+ _ <- forever $ threadDelay 1000000
+ -- never gets to here:
+ putStrLn "watchDir stopped"
+ )
+
+-- | Emit from the fsnotify watch manager.
+-- > glue' toStdout <$|> fmap (Text.pack . show) <$> watchE "."
+watchSvg :: FilePath -> CoEmitter IO FilePath
+watchSvg fp =
+ emitQ
+ New
+ ( \c -> withManager $ \mgr -> do
+ putStrLn "watchDir started"
+ _ <- watchDir mgr fp (isJust . svgEvent) (maybe (pure ()) (void . commit c) . svgEvent)
+ _ <- forever $ threadDelay 1000000
+ -- never gets to here:
+ putStrLn "watchDir stopped"
+ )
+
+-- | Filter for svg file additions and modifications.
+svgEvent :: Event -> Maybe FilePath
+svgEvent (Added fp _ dir) = bool Nothing (Just fp) (takeExtension fp == ".svg" && dir == IsFile)
+svgEvent (Modified fp _ dir) = bool Nothing (Just fp) (takeExtension fp == ".svg" && dir == IsFile)
+svgEvent _ = Nothing
+
+-- | Create a file committer to serve an SVG file.
+displayFile :: SocketConfig -> Page -> IO (Committer IO FilePath, IO ())
+displayFile scfg page = do
+ (Box c e, q) <- toBoxM Single
+ x <- async $ serveSocketBox scfg page (Box toStdout (decodeUtf8 . replace "prettychart" <$> e))
+ pure (witherC (B.readFile >>> fmap Just) c, cancel x >> q)