diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for charter + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,34 @@ +# Charter + +`charter` is a typed Haskell layer on top of [Google Charts](https://developers.google.com/chart) +which allows quickly and easily visualizing your Haskell data in the browser! + +It also provides **live-updates** as your data changes in Haskell-land. + +Why Google Charts? + +Google Charts provides a large amount of flexible data representations which +use a relatively consistent data format, making it easy to switch between chart types. + +## Goals + +Goals of this library include: + +* Quick to start +* Batteries Included +* Well-typed, but not at the expense of usability +* Smooth learning curve as you add more complex options to your charts +* Live chart updates! + +Non-Goals of this library include: + +* Writing charts to disk: sorry, try taking a screenshot of your browser instead! +* Performance: All your data turns into JSON and gets piped through the browser, it'll be slower than other solutions on large datasets. +* Composability with other solutions: This library is "battery included" and doesn't provide many extension points. + +## Roadmap + +* Better Date, Time, and DateTime support +* Support for Geocharts, TreeMaps, Tables, Timeline, Gauges +* Support multiple charts on a screen +* Support combo charts diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Examples/AreaChart.hs b/app/Examples/AreaChart.hs new file mode 100644 --- /dev/null +++ b/app/Examples/AreaChart.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +module Examples.AreaChart where + +import Charts +import qualified Data.Text as T + +chartColumns :: [Column] +chartColumns = [StringColumn "Year", NumberColumn "Attendance", AnnotationColumn, NumberColumn "Other", AnnotationColumn] + +areaChart :: Chart +areaChart = autoChartWithHeaders defaultChartOptions AreaChart chartColumns chartData + +chartData :: [(T.Text, Int, T.Text, Int, T.Text)] +chartData = + [ ("2004", 1000, "A'", 400, "A") + , ("2005", 1170, "B'", 460, "B") + , ("2006", 660, "C'", 1120, "C") + , ("2007", 1030, "D'", 540, "D") + ] diff --git a/app/Examples/Auto.hs b/app/Examples/Auto.hs new file mode 100644 --- /dev/null +++ b/app/Examples/Auto.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Examples.Auto where + +import qualified Data.Text as T +import Data.Aeson + +import Charts + +myAutoChart :: Chart +myAutoChart = autoChartWithHeaders defaultChartOptions BarChart headers myData + where + headers :: [Column] + headers = [StringColumn "Series", NumberColumn "Successes", NumberColumn "Inconclusive"] + myData :: [(T.Text, Float, Int)] + myData = [ ("A", 16, 20) + , ("B", 11, 23) + , ("C", 9, 25) + , ("D", 8, 34) + ] + + + diff --git a/app/Examples/BarChart.hs b/app/Examples/BarChart.hs new file mode 100644 --- /dev/null +++ b/app/Examples/BarChart.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Examples.BarChart where + +import Charts +import qualified Data.Text as T +import Data.Aeson + +chartColumns :: [Column] +chartColumns = [StringColumn "Year", NumberColumn "Attendance", AnnotationColumn, NumberColumn "Other", AnnotationColumn] + +barChart :: Chart +barChart = autoChartWithHeaders chartOptions BarChart chartColumns chartData + where + chartOptions = ChartOptions $ object ["title" .= ("Attendance Chart" :: T.Text)] + +-- chartData :: [(T.Text, Int, T.Text, Int, T.Text)] +chartData = + [ [ "2004", Number 1000, "A'", Number 400, "A" ] + , [ "2005", Number 1170, "B'", Number 460, "B" ] + , [ "2006", Number 660, "C'", Number 1120, "C" ] + , [ "2007", Number 1030, "D'", Number 540, "D" ] + ] + +-- t :: Chart +-- t = buildChart defaultChartOptions BarChart +-- [StringColumn "Year", NumberColumn "Population"] +-- [ [ String "2004", Number 1000 ] +-- , [ String "2005", Number 1170 ] +-- , [ String "2006", Number 660 ] +-- , [ String "2007", Number 1030 ] +-- ] diff --git a/app/Examples/ColumnChart.hs b/app/Examples/ColumnChart.hs new file mode 100644 --- /dev/null +++ b/app/Examples/ColumnChart.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +module Examples.ColumnChart where + +import Charts +import qualified Data.Text as T + +chartColumns :: [Column] +chartColumns = [StringColumn "Year", NumberColumn "Attendance", AnnotationColumn, NumberColumn "Other", AnnotationColumn] + +columnChart :: Chart +columnChart = autoChartWithHeaders defaultChartOptions ColumnChart chartColumns chartData + +chartData :: [(T.Text, Int, T.Text, Int, T.Text)] +chartData = + [ ("2004", 1000, "A'", 400, "A") + , ("2005", 1170, "B'", 460, "B") + , ("2006", 660, "C'", 1120, "C") + , ("2007", 1030, "D'", 540, "D") + ] diff --git a/app/Examples/Histogram.hs b/app/Examples/Histogram.hs new file mode 100644 --- /dev/null +++ b/app/Examples/Histogram.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module Examples.Histogram where + +import Charts +import Data.Aeson +import qualified Data.Text as T + +histogram :: Chart +histogram = buildChart defaultChartOptions Histogram dinoColumns dinoData + +dinoColumns :: [Column] +dinoColumns = [StringColumn "Dinosaur", NumberColumn "Length"] + +-- Dinosaur histogram data +dinoData :: [[Value]] +dinoData = fmap asData + [ ("Acrocanthosaurus (top-spined lizard)", 12.2) + , ("Albertosaurus (Alberta lizard)", 9.1) + , ("Allosaurus (other lizard)", 12.2) + , ("Apatosaurus (deceptive lizard)", 22.9) + , ("Archaeopteryx (ancient wing)", 0.9) + , ("Argentinosaurus (Argentina lizard)", 36.6) + , ("Baryonyx (heavy claws)", 9.1) + , ("Brachiosaurus (arm lizard)", 30.5) + , ("Ceratosaurus (horned lizard)", 6.1) + , ("Coelophysis (hollow form)", 2.7) + , ("Compsognathus (elegant jaw)", 0.9) + , ("Deinonychus (terrible claw)", 2.7) + , ("Diplodocus (double beam)", 27.1) + , ("Dromicelomimus (emu mimic)", 3.4) + , ("Gallimimus (fowl mimic)", 5.5) + , ("Mamenchisaurus (Mamenchi lizard)", 21.0) + , ("Megalosaurus (big lizard)", 7.9) + , ("Microvenator (small hunter)", 1.2) + , ("Ornithomimus (bird mimic)", 4.6) + , ("Oviraptor (egg robber)", 1.5) + , ("Plateosaurus (flat lizard)", 7.9) + , ("Sauronithoides (narrow-clawed lizard)", 2.0) + , ("Seismosaurus (tremor lizard)", 45.7) + , ("Spinosaurus (spiny lizard)", 12.2) + , ("Supersaurus (super lizard)", 30.5) + , ("Tyrannosaurus (tyrant lizard)", 15.2) + , ("Ultrasaurus (ultra lizard)", 30.5) + , ("Velociraptor (swift robber)", 1.8) + ] + where + asData :: (T.Text, Float) -> [Value] + asData (a, b) = [toJSON a, toJSON b] diff --git a/app/Examples/LineChart.hs b/app/Examples/LineChart.hs new file mode 100644 --- /dev/null +++ b/app/Examples/LineChart.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +module Examples.LineChart where + +import Charts +import Data.Aeson +import qualified Data.Text as T + +chartColumns :: [Column] +chartColumns = [StringColumn "Year", NumberColumn "Attendance", NumberColumn "Other", AnnotationColumn] + +lineChart :: Chart +lineChart = buildChart defaultChartOptions LineChart chartColumns chartData + +chartData :: [[Value]] +chartData = asJSON <$> + [ ("2004", 1000, 400, "A") + , ("2005", 1170, 460, "B") + , ("2006", 660, 1120, "C") + , ("2007", 1030, 540, "D") + ] + where + asJSON :: (T.Text, Int, Int, T.Text) -> [Value] + asJSON (a, b, c, d) = [toJSON a, toJSON b, toJSON c, toJSON d] diff --git a/app/Examples/Random.hs b/app/Examples/Random.hs new file mode 100644 --- /dev/null +++ b/app/Examples/Random.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module Examples.Random where + +import Charts +import Control.Monad.Random +import Data.Traversable +import Data.Aeson +import Control.Concurrent + +randomChart :: IO Chart +randomChart = do + rows <- for [1..10] $ \i -> do + a <- randomRIO (0, 1) + b <- randomRIO (0, 1) + return [toJSON @Int i, toJSON @Float a, toJSON @Double b] + return $ buildChart defaultChartOptions ScatterChart [NumberColumn "Iteration", NumberColumn "Value A", NumberColumn "Value B"] rows + +buildRandomChart :: (Chart -> IO ()) -> IO () +buildRandomChart sendChart = forever $ do + randomChart >>= sendChart + threadDelay 2000000 + +serveUpdatingRandomChart :: IO () +serveUpdatingRandomChart = serveDynamicChart 8080 buildRandomChart diff --git a/app/Examples/ScatterChart.hs b/app/Examples/ScatterChart.hs new file mode 100644 --- /dev/null +++ b/app/Examples/ScatterChart.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module Examples.ScatterChart where + +import Charts + +scatterChart :: Chart +scatterChart = autoChartWithHeaders defaultChartOptions ScatterChart chartColumns chartData + +chartColumns :: [Column] +chartColumns = [NumberColumn "Age", NumberColumn "Weight"] + +chartData :: [(Float, Float)] +chartData = + [ (8, 12) + , (4, 5.5) + , (11, 14) + , (4, 5) + , (3, 3.5) + , (6.5, 7) + ] diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Charts +import Examples.Histogram +import Examples.Random +import Examples.LineChart +import Examples.Auto +import Examples.ScatterChart +import Examples.BarChart +import Examples.ColumnChart +import Examples.AreaChart + +-- main :: IO () +-- main = serveChart 8080 myAutoChart + +main :: IO () +main = serveChart 8080 myAutoChart +-- main = serveUpdatingRandomChart diff --git a/charter.cabal b/charter.cabal new file mode 100644 --- /dev/null +++ b/charter.cabal @@ -0,0 +1,114 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: cf81c27c2154f32ddbe86abce94d1426deb270ad096348ad4ce50a26188e70e5 + +name: charter +version: 0.1.1.0 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/charter#readme +bug-reports: https://github.com/githubuser/charter/issues +author: Author name here +maintainer: example@example.com +copyright: 2020 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md +data-files: + templates/index.html + +source-repository head + type: git + location: https://github.com/githubuser/charter + +library + exposed-modules: + Charts + Charts.Internal.Auto + Charts.Internal.Chart + Charts.Internal.Server + other-modules: + Paths_charter + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + aeson + , async + , base >=4.7 && <5 + , bytestring + , containers + , http-types + , mtl + , one-liner + , process + , scientific + , text + , wai + , warp + default-language: Haskell2010 + +executable charter-exe + main-is: Main.hs + other-modules: + Examples.AreaChart + Examples.Auto + Examples.BarChart + Examples.ColumnChart + Examples.Histogram + Examples.LineChart + Examples.Random + Examples.ScatterChart + Paths_charter + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + MonadRandom + , aeson + , async + , base >=4.7 && <5 + , bytestring + , charter + , containers + , http-types + , mtl + , one-liner + , process + , random + , scientific + , text + , wai + , warp + default-language: Haskell2010 + +test-suite charter-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_charter + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + aeson + , async + , base >=4.7 && <5 + , bytestring + , charter + , containers + , http-types + , mtl + , one-liner + , process + , scientific + , text + , wai + , warp + default-language: Haskell2010 diff --git a/src/Charts.hs b/src/Charts.hs new file mode 100644 --- /dev/null +++ b/src/Charts.hs @@ -0,0 +1,20 @@ +module Charts ( serveChart + , serveDynamicChart + , Chart + , Column(..) + , ChartOptions(..) + , ChartStyle(..) + , buildChart + , defaultChartOptions + + , autoChart + , autoChartWithHeaders + , ChartRowAuto + , ChartRowHeaderAuto + , ChartColumn(..) + ) where + +import Charts.Internal.Server +import Charts.Internal.Chart +import Charts.Internal.Auto + diff --git a/src/Charts/Internal/Auto.hs b/src/Charts/Internal/Auto.hs new file mode 100644 --- /dev/null +++ b/src/Charts/Internal/Auto.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module Charts.Internal.Auto where + +import Charts.Internal.Chart +import Generics.OneLiner +import Data.Aeson +import Data.Proxy +import qualified Data.Text as T +import Data.Scientific + +-- | Class representing types for which a column type can be inferred. +-- +-- You can implement your own instances for this if you like, but generally shouldn't need to. +class ChartColumn a where + columnHeader :: Proxy a -> Column + +instance ChartColumn Int where + columnHeader _ = NumberColumn "" + +instance ChartColumn Float where + columnHeader _ = NumberColumn "" + +instance ChartColumn Double where + columnHeader _ = NumberColumn "" + +instance ChartColumn Scientific where + columnHeader _ = NumberColumn "" + +instance ChartColumn T.Text where + columnHeader _ = StringColumn "" + +instance ChartColumn String where + columnHeader _ = StringColumn "" + +instance ChartColumn Bool where + columnHeader _ = BoolColumn "" + +-- | A constraint representing a type which can be converted into a chart row +-- +-- This constraint is satisfied by tuple types containing JSON serializable types. +-- +-- E.g. data rows of type @(Text, Int, Float)@ will infer a chart with a String column and two number +-- columns. +-- +-- You shouldn't need to implement any instances of this constraint yourself. +type ChartRowAuto a = (ADT a, Constraints a ToJSON) + +-- | A constraint that a column-type can be determined for all elements of the provided tuple +-- type. +type ChartRowHeaderAuto a = (Constraints a ChartColumn) + + +-- | Create a chart from the provided options, style, and data by inferring column header +-- types. +-- +-- Prefer 'autoChartWithHeaders' when you know your column headers up front. +-- +-- E.g. The following generates a 2-series bar chart with 4 sections, A, B, C, D +-- +-- @ +-- myAutoChart :: Chart +-- myAutoChart = autoChart defaultChartOptions BarChart myData +-- where +-- myData :: [(T.Text, Float, Int)] +-- myData = [ ("A", 16, 20) +-- , ("B", 11, 23) +-- , ("C", 9, 25) +-- , ("D", 8, 34) +-- ] +-- @ +autoChart :: forall row. (ChartRowHeaderAuto row, ChartRowAuto row) => ChartOptions -> ChartStyle -> [row] -> Chart +autoChart opts styl xs@[] = autoChartWithHeaders opts styl [] xs +autoChart opts styl (x:xs) = autoChartWithHeaders opts styl cols (x:xs) + where + cols :: [Column] + cols = gfoldMap @ChartColumn toColumn x + toColumn :: forall a. ChartColumn a => a -> [Column] + toColumn _ = [columnHeader (Proxy @a)] + +-- | Create a chart from the provided options, style, and data, but use the explicitly +-- provided column headers and types. +-- +-- E.g. The following generates a 2-series bar chart with 4 sections, A, B, C, D +-- +-- @ +-- myAutoChart :: Chart +-- myAutoChart = autoChartWithHeaders defaultChartOptions BarChart headers myData +-- where +-- headers :: [Column] +-- headers = [StringColumn "Series", NumberColumn "Successes", NumberColumn "Inconclusive"] +-- myData :: [(T.Text, Float, Int)] +-- myData = [ ("A", 16, 20) +-- , ("B", 11, 23) +-- , ("C", 9, 25) +-- , ("D", 8, 34) +-- ] +-- @ +autoChartWithHeaders :: forall row. (ChartRowAuto row) => ChartOptions -> ChartStyle -> [Column] -> [row] -> Chart +autoChartWithHeaders opts styl cols [] = buildChart opts styl cols [] +autoChartWithHeaders opts styl cols (x:xs) = buildChart opts styl cols rows + where + rows :: [[Value]] + rows = rowToJSON <$> (x:xs) + rowToJSON :: row -> [Value] + rowToJSON row = gfoldMap @ToJSON singleToRow row + singleToRow :: forall a. ToJSON a => a -> [Value] + singleToRow = (:[]) . toJSON diff --git a/src/Charts/Internal/Chart.hs b/src/Charts/Internal/Chart.hs new file mode 100644 --- /dev/null +++ b/src/Charts/Internal/Chart.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Charts.Internal.Chart where + +import qualified Data.Text as T +import Data.Aeson as A + +-- | Valid Column types. Each "data" column also accepts a column header. +-- "Role" columns do not. +-- +-- See https://developers.google.com/chart/interactive/docs/roles +data Column = + NumberColumn T.Text + | StringColumn T.Text + | BoolColumn T.Text + | DateColumn T.Text + | DateTimeColumn T.Text + | TimeOfDayColumn T.Text + | AnnotationColumn + | AnnotationTextColumn + | CertaintyColumn + | EmphasisColumn + | IntervalColumn + | ScopeColumn + | StyleColumn + | TooltipColumn + | DomainColumn + -- ^ This is typically inferred and explicitly + | DataColumn + -- ^ This is typically inferred and explicitly + deriving (Show, Eq) + +-- Types from https://developers.google.com/chart/interactive/docs/reference#DataTable_addColumn +instance ToJSON Column where + toJSON col = + case col of + StringColumn a -> object [ "label" .= a, "type" ~= "string"] + NumberColumn a -> object [ "label" .= a, "type" ~= "number"] + BoolColumn a -> object [ "label" .= a, "type" ~= "boolean"] + DateColumn a -> object [ "label" .= a, "type" ~= "date"] + DateTimeColumn a -> object [ "label" .= a, "type" ~= "datetime"] + TimeOfDayColumn a -> object [ "label" .= a, "type" ~= "timeofday"] + AnnotationColumn -> object ["role" ~= "annotation"] + AnnotationTextColumn -> object ["role" ~= "annotationText"] + CertaintyColumn -> object ["role" ~= "certainty"] + EmphasisColumn -> object ["role" ~= "emphasis"] + IntervalColumn -> object ["role" ~= "interval"] + ScopeColumn -> object ["role" ~= "scope"] + StyleColumn -> object ["role" ~= "style"] + TooltipColumn -> object ["role" ~= "tooltip"] + DomainColumn -> object ["role" ~= "domain"] + DataColumn -> object ["role" ~= "data"] + where + (~=):: T.Text -> T.Text -> (T.Text, Value) + (~=) = (.=) + +-- | Supported chart types +-- See https://developers.google.com/chart/interactive/docs/gallery +data ChartStyle = LineChart + | Histogram + | BarChart + | ColumnChart + | ScatterChart + | AreaChart + | PieChart + | BubbleChart + | SteppedAreaChart + | CandlestickChart + deriving (Show, Eq, Ord) + +instance ToJSON ChartStyle where + toJSON = \case + LineChart -> "line" + Histogram -> "histogram" + BarChart -> "bar" + ColumnChart -> "column" + ScatterChart -> "scatter" + AreaChart -> "area" + PieChart -> "pie" + BubbleChart -> "bubble" + SteppedAreaChart -> "steppedarea" + CandlestickChart -> "candlestick" + +-- | I plan to make this typesafe for each partiular chart type +-- but that's a LOT of work, so for now it's just free-form, if you'd actually +-- use this, please make an issue on Github so I know folks need this behaviour :) +-- +-- Find your chart in the chart gallery to see which options it will accept. +-- +-- https://developers.google.com/chart/interactive/docs/gallery +data ChartOptions = ChartOptions Value + +instance ToJSON ChartOptions where + toJSON (ChartOptions v) = v + +-- | Empty chart options +defaultChartOptions :: ChartOptions +defaultChartOptions = ChartOptions (object []) + +-- | The primary chart type. Build using 'buildChart'. +data Chart = + Chart { options :: ChartOptions + , style :: ChartStyle + , columns :: [Column] + , dataTable :: [[Value]] + , dynamic :: Bool + } + +instance ToJSON Chart where + toJSON (Chart{..}) = + object [ "rows" .= dataTable + , "options" .= options + , "columns" .= columns + , "style" .= style + , "dynamic" .= dynamic + ] + +-- | Construct a chart. +-- +-- e.g. +-- +-- @ +-- buildChart defaultChartOptions BarChart +-- [StringColumn "Year", NumberColumn "Population"] +-- [ [ String "2004", Number 1000 ] +-- , [ String "2005", Number 1170 ] +-- , [ String "2006", Number 660 ] +-- , [ String "2007", Number 1030 ] +-- ] +-- @ +buildChart :: ChartOptions -> ChartStyle -> [Column] -> [[Value]] -> Chart +buildChart opts style columns vals = Chart opts style columns vals True diff --git a/src/Charts/Internal/Server.hs b/src/Charts/Internal/Server.hs new file mode 100644 --- /dev/null +++ b/src/Charts/Internal/Server.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module Charts.Internal.Server where + + +import Charts.Internal.Chart +import Network.Wai +import Network.Wai.Handler.Warp +import Network.HTTP.Types.Status +import Data.Aeson +import Paths_charter +import Control.Concurrent.Async +import System.Process +import Control.Monad +import Control.Concurrent.MVar + +-- | Serve a chart, updating along with the MVar +chartApp :: MVar Chart -> FilePath -> Application +chartApp chartVar indexFile req handler + | pathInfo req == ["data"] = do + chart <- readMVar chartVar + handler (responseLBS ok200 [("Content-Type", "application/json")] (encode chart)) + | otherwise = do + handler (responseFile ok200 mempty indexFile Nothing) + +-- | Serve a single static chart on the given port +serveChart :: Port -> Chart -> IO () +serveChart port chart = do + serveDynamicChart port (\handler -> handler (chart{dynamic=False})) + +-- | Serve a chart on the given port. +-- The application can update the chart using the given handler. +serveDynamicChart :: Port -> ((Chart -> IO ()) -> IO ()) -> IO () +serveDynamicChart port handler = do + indexHtml <- getDataFileName "templates/index.html" + chartVar <- newEmptyMVar + let runServer = run port (chartApp chartVar indexHtml) + let runHandler = handler (updateChart chartVar) + withAsync (concurrently_ runServer runHandler) $ \procHandle -> do + void $ spawnProcess "open" [("http://localhost:" <> show port)] + wait procHandle + where + updateChart :: MVar Chart -> Chart -> IO () + updateChart var c = void $ do + isEmpty <- isEmptyMVar var + if isEmpty then putMVar var c + else void $ swapMVar var c + diff --git a/templates/index.html b/templates/index.html new file mode 100644 --- /dev/null +++ b/templates/index.html @@ -0,0 +1,103 @@ + + + + + + + +
+ + + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"