{-# OPTIONS_GHC -Wall #-}

module Graphics.HappyHour (writeBarGraphSvgFile) where

-- base
import Data.List (genericLength)

-- Chart
import Graphics.Rendering.Chart.Easy hiding (bars)

-- Chart-diagrams
import Graphics.Rendering.Chart.Backend.Diagrams (renderableToFile, FileOptions, fo_size)

-- | Create an SVG file containing a bar graph.

writeBarGraphSvgFile
    :: FilePath
          -- ^ Where the file will be written. The containing directory must already exist. If there already exists a file at this path, it will be overwritten. If there exists a directory at this path, the action will fail.
    -> [(String, Int)]
          -- ^ The data to visualize. Each list entry represents a bar on the plot, ordered from left to right. The @String@ is the label on the X axis, and the @Int@ is the height of the bar.
    -> IO ()

writeBarGraphSvgFile :: FilePath -> [(FilePath, Int)] -> IO ()
writeBarGraphSvgFile FilePath
path [(FilePath, Int)]
bars =
  do
    let layout :: Layout PlotIndex Int
layout = [(FilePath, Int)] -> Endo (Layout PlotIndex Int)
applyBarPlot [(FilePath, Int)]
bars Layout PlotIndex Int
forall a. Default a => a
def :: Layout PlotIndex Int
    let r :: Renderable ()
r = Layout PlotIndex Int -> Renderable ()
forall a. ToRenderable a => a -> Renderable ()
toRenderable Layout PlotIndex Int
layout :: Renderable ()
    let fo :: FileOptions
fo = [(FilePath, Int)] -> Endo FileOptions
applyFileOptions [(FilePath, Int)]
bars FileOptions
forall a. Default a => a
def :: FileOptions
    PickFn ()
_ <- FileOptions -> FilePath -> Renderable () -> IO (PickFn ())
forall a. FileOptions -> FilePath -> Renderable a -> IO (PickFn a)
renderableToFile FileOptions
fo FilePath
path Renderable ()
r
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

type Bars = [(String, Int)]

type Endo a = a -> a

foldEndo :: [a -> a] -> (a -> a)
foldEndo :: [a -> a] -> a -> a
foldEndo = ((a -> a) -> (a -> a) -> a -> a) -> (a -> a) -> [a -> a] -> a -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) a -> a
forall a. a -> a
id

applyFileOptions :: Bars -> Endo FileOptions
applyFileOptions :: [(FilePath, Int)] -> Endo FileOptions
applyFileOptions [(FilePath, Int)]
bars =
    ASetter FileOptions FileOptions (Double, Double) (Double, Double)
-> (Double, Double) -> Endo FileOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter FileOptions FileOptions (Double, Double) (Double, Double)
Lens' FileOptions (Double, Double)
fo_size ([Double] -> Double
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([FilePath -> Double
forall a. [a] -> Double
l FilePath
x | (FilePath
x, Int
_) <- [(FilePath, Int)]
bars]) Double -> Double -> Double
forall a. Num a => a -> a -> a
* [(FilePath, Int)] -> Double
forall a. [a] -> Double
l [(FilePath, Int)]
bars Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
50, Double
600)
  where
    l :: [a] -> Double
l = [a] -> Double
forall i a. Num i => [a] -> i
genericLength

-- | Add a single bar plot to a layout, configure its X axis labels to match the data, and style the layout to look nice with a bar plot.
applyBarPlot :: Bars -> Endo (Layout PlotIndex Int)
applyBarPlot :: [(FilePath, Int)] -> Endo (Layout PlotIndex Int)
applyBarPlot [(FilePath, Int)]
bars =
  [Endo (Layout PlotIndex Int)] -> Endo (Layout PlotIndex Int)
forall a. [a -> a] -> a -> a
foldEndo
    [ Endo (Layout PlotIndex Int)
forall x y. Endo (Layout x y)
applyLayoutStyle
    , [(FilePath, Int)] -> Endo (Layout PlotIndex Int)
forall x y. Integral x => [(FilePath, Int)] -> Endo (Layout x y)
applyLabels [(FilePath, Int)]
bars
    , ASetter
  (Layout PlotIndex Int)
  (Layout PlotIndex Int)
  [Plot PlotIndex Int]
  [Plot PlotIndex Int]
-> [Plot PlotIndex Int] -> Endo (Layout PlotIndex Int)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Layout PlotIndex Int)
  (Layout PlotIndex Int)
  [Plot PlotIndex Int]
  [Plot PlotIndex Int]
forall x y. Lens' (Layout x y) [Plot x y]
layout_plots [PlotBars PlotIndex Int -> Plot PlotIndex Int
forall y x. BarsPlotValue y => PlotBars x y -> Plot x y
plotBars (( Endo (PlotBars PlotIndex Int)
forall x y. Endo (PlotBars x y)
applyBarStyle Endo (PlotBars PlotIndex Int)
-> Endo (PlotBars PlotIndex Int) -> Endo (PlotBars PlotIndex Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, Int)] -> Endo (PlotBars PlotIndex Int)
applyValues [(FilePath, Int)]
bars ) PlotBars PlotIndex Int
forall a. Default a => a
def)]
    ]

-- | Set the data values on a bar plot.
applyValues :: Bars -> Endo (PlotBars PlotIndex Int)
applyValues :: [(FilePath, Int)] -> Endo (PlotBars PlotIndex Int)
applyValues [(FilePath, Int)]
bars =
    ASetter
  (PlotBars PlotIndex Int)
  (PlotBars PlotIndex Int)
  [(PlotIndex, [Int])]
  [(PlotIndex, [Int])]
-> [(PlotIndex, [Int])] -> Endo (PlotBars PlotIndex Int)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (PlotBars PlotIndex Int)
  (PlotBars PlotIndex Int)
  [(PlotIndex, [Int])]
  [(PlotIndex, [Int])]
forall x1 y x2.
Lens (PlotBars x1 y) (PlotBars x2 y) [(x1, [y])] [(x2, [y])]
plot_bars_values ([[Int]] -> [(PlotIndex, [Int])]
forall a. [a] -> [(PlotIndex, a)]
addIndexes [ [Int
y] | (FilePath
_, Int
y) <- [(FilePath, Int)]
bars ])

-- | Set up the X axis of a layout in preparation for adding the bar plot.
applyLabels :: Integral x => Bars -> Endo (Layout x y)
applyLabels :: [(FilePath, Int)] -> Endo (Layout x y)
applyLabels [(FilePath, Int)]
bars =
    ASetter (Layout x y) (Layout x y) (AxisFn x) (AxisFn x)
-> AxisFn x -> Endo (Layout x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ((LayoutAxis x -> Identity (LayoutAxis x))
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) (LayoutAxis x)
layout_x_axis ((LayoutAxis x -> Identity (LayoutAxis x))
 -> Layout x y -> Identity (Layout x y))
-> ((AxisFn x -> Identity (AxisFn x))
    -> LayoutAxis x -> Identity (LayoutAxis x))
-> ASetter (Layout x y) (Layout x y) (AxisFn x) (AxisFn x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AxisFn x -> Identity (AxisFn x))
-> LayoutAxis x -> Identity (LayoutAxis x)
forall x. Lens' (LayoutAxis x) (AxisFn x)
laxis_generate) ([FilePath] -> AxisFn x
forall i. Integral i => [FilePath] -> [i] -> AxisData i
autoIndexAxis [ FilePath
x | (FilePath
x, Int
_) <- [(FilePath, Int)]
bars ])

-- | Set some layout styles that look nice.
applyLayoutStyle :: Endo (Layout x y)
applyLayoutStyle :: Endo (Layout x y)
applyLayoutStyle =
  [Endo (Layout x y)] -> Endo (Layout x y)
forall a. [a -> a] -> a -> a
foldEndo
    [ ASetter (Layout x y) (Layout x y) Double Double
-> Double -> Endo (Layout x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Layout x y) (Layout x y) Double Double
forall x y. Lens' (Layout x y) Double
layout_margin Double
40
    , Double -> Endo (Layout x y)
forall x y. Double -> Endo (Layout x y)
setAxisLineWidth Double
5
    , ASetter (Layout x y) (Layout x y) LineStyle LineStyle
-> (LineStyle -> LineStyle) -> Endo (Layout x y)
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Layout x y) (Layout x y) LineStyle LineStyle
forall x y. Lens' (Layout x y) LineStyle
yGridStyle (ASetter LineStyle LineStyle Double Double
-> Double -> LineStyle -> LineStyle
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter LineStyle LineStyle Double Double
Lens' LineStyle Double
line_width Double
5 (LineStyle -> LineStyle)
-> (LineStyle -> LineStyle) -> LineStyle -> LineStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter LineStyle LineStyle [Double] [Double]
-> [Double] -> LineStyle -> LineStyle
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter LineStyle LineStyle [Double] [Double]
Lens' LineStyle [Double]
line_dashes [Double
40, Double
20])
    , ASetter (Layout x y) (Layout x y) Double Double
-> Double -> Endo (Layout x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ((LayoutAxis y -> Identity (LayoutAxis y))
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) (LayoutAxis y)
layout_y_axis ((LayoutAxis y -> Identity (LayoutAxis y))
 -> Layout x y -> Identity (Layout x y))
-> ((Double -> Identity Double)
    -> LayoutAxis y -> Identity (LayoutAxis y))
-> ASetter (Layout x y) (Layout x y) Double Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AxisStyle -> Identity AxisStyle)
-> LayoutAxis y -> Identity (LayoutAxis y)
forall x. Lens' (LayoutAxis x) AxisStyle
laxis_style ((AxisStyle -> Identity AxisStyle)
 -> LayoutAxis y -> Identity (LayoutAxis y))
-> ((Double -> Identity Double) -> AxisStyle -> Identity AxisStyle)
-> (Double -> Identity Double)
-> LayoutAxis y
-> Identity (LayoutAxis y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double) -> AxisStyle -> Identity AxisStyle
Lens' AxisStyle Double
axis_label_gap) Double
25
    , ASetter (Layout x y) (Layout x y) Double Double
-> Double -> Endo (Layout x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ((FontStyle -> Identity FontStyle)
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) FontStyle
layout_title_style ((FontStyle -> Identity FontStyle)
 -> Layout x y -> Identity (Layout x y))
-> ((Double -> Identity Double) -> FontStyle -> Identity FontStyle)
-> ASetter (Layout x y) (Layout x y) Double Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double) -> FontStyle -> Identity FontStyle
Lens' FontStyle Double
font_size) Double
80
    , Double -> Endo (Layout x y)
forall x y. Double -> Endo (Layout x y)
setAxisFontSize Double
40
    ]

-- | Lens for the grid style on the Y axis
yGridStyle :: Lens' (Layout x y) LineStyle
yGridStyle :: (LineStyle -> f LineStyle) -> Layout x y -> f (Layout x y)
yGridStyle = (LayoutAxis y -> f (LayoutAxis y)) -> Layout x y -> f (Layout x y)
forall x y. Lens' (Layout x y) (LayoutAxis y)
layout_y_axis ((LayoutAxis y -> f (LayoutAxis y))
 -> Layout x y -> f (Layout x y))
-> ((LineStyle -> f LineStyle) -> LayoutAxis y -> f (LayoutAxis y))
-> (LineStyle -> f LineStyle)
-> Layout x y
-> f (Layout x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AxisStyle -> f AxisStyle) -> LayoutAxis y -> f (LayoutAxis y)
forall x. Lens' (LayoutAxis x) AxisStyle
laxis_style ((AxisStyle -> f AxisStyle) -> LayoutAxis y -> f (LayoutAxis y))
-> ((LineStyle -> f LineStyle) -> AxisStyle -> f AxisStyle)
-> (LineStyle -> f LineStyle)
-> LayoutAxis y
-> f (LayoutAxis y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineStyle -> f LineStyle) -> AxisStyle -> f AxisStyle
Lens' AxisStyle LineStyle
axis_grid_style

-- | Lens for the width of an axis
axisLineWidth :: Lens' (LayoutAxis x) Double
axisLineWidth :: (Double -> f Double) -> LayoutAxis x -> f (LayoutAxis x)
axisLineWidth = (AxisStyle -> f AxisStyle) -> LayoutAxis x -> f (LayoutAxis x)
forall x. Lens' (LayoutAxis x) AxisStyle
laxis_style ((AxisStyle -> f AxisStyle) -> LayoutAxis x -> f (LayoutAxis x))
-> ((Double -> f Double) -> AxisStyle -> f AxisStyle)
-> (Double -> f Double)
-> LayoutAxis x
-> f (LayoutAxis x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LineStyle -> f LineStyle) -> AxisStyle -> f AxisStyle
Lens' AxisStyle LineStyle
axis_line_style ((LineStyle -> f LineStyle) -> AxisStyle -> f AxisStyle)
-> ((Double -> f Double) -> LineStyle -> f LineStyle)
-> (Double -> f Double)
-> AxisStyle
-> f AxisStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> f Double) -> LineStyle -> f LineStyle
Lens' LineStyle Double
line_width

-- | Lens for the label font size of an axis
axisLabelSize :: Lens' (LayoutAxis x) Double
axisLabelSize :: (Double -> f Double) -> LayoutAxis x -> f (LayoutAxis x)
axisLabelSize = (AxisStyle -> f AxisStyle) -> LayoutAxis x -> f (LayoutAxis x)
forall x. Lens' (LayoutAxis x) AxisStyle
laxis_style ((AxisStyle -> f AxisStyle) -> LayoutAxis x -> f (LayoutAxis x))
-> ((Double -> f Double) -> AxisStyle -> f AxisStyle)
-> (Double -> f Double)
-> LayoutAxis x
-> f (LayoutAxis x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FontStyle -> f FontStyle) -> AxisStyle -> f AxisStyle
Lens' AxisStyle FontStyle
axis_label_style ((FontStyle -> f FontStyle) -> AxisStyle -> f AxisStyle)
-> ((Double -> f Double) -> FontStyle -> f FontStyle)
-> (Double -> f Double)
-> AxisStyle
-> f AxisStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> f Double) -> FontStyle -> f FontStyle
Lens' FontStyle Double
font_size

-- | Set the line width on both axes.
setAxisLineWidth :: Double -> Endo (Layout x y)
setAxisLineWidth :: Double -> Endo (Layout x y)
setAxisLineWidth Double
v =
  [Endo (Layout x y)] -> Endo (Layout x y)
forall a. [a -> a] -> a -> a
foldEndo [ ASetter (Layout x y) (Layout x y) Double Double
-> Double -> Endo (Layout x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Layout x y) (Layout x y) Double Double
l Double
v | ASetter (Layout x y) (Layout x y) Double Double
l <- [ (LayoutAxis x -> Identity (LayoutAxis x))
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) (LayoutAxis x)
layout_x_axis ((LayoutAxis x -> Identity (LayoutAxis x))
 -> Layout x y -> Identity (Layout x y))
-> ((Double -> Identity Double)
    -> LayoutAxis x -> Identity (LayoutAxis x))
-> ASetter (Layout x y) (Layout x y) Double Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double)
-> LayoutAxis x -> Identity (LayoutAxis x)
forall x. Lens' (LayoutAxis x) Double
axisLineWidth
                            , (LayoutAxis y -> Identity (LayoutAxis y))
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) (LayoutAxis y)
layout_y_axis ((LayoutAxis y -> Identity (LayoutAxis y))
 -> Layout x y -> Identity (Layout x y))
-> ((Double -> Identity Double)
    -> LayoutAxis y -> Identity (LayoutAxis y))
-> ASetter (Layout x y) (Layout x y) Double Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double)
-> LayoutAxis y -> Identity (LayoutAxis y)
forall x. Lens' (LayoutAxis x) Double
axisLineWidth ] ]

-- | Set the label size on both axes.
setAxisFontSize :: Double -> Endo (Layout x y)
setAxisFontSize :: Double -> Endo (Layout x y)
setAxisFontSize Double
v =
  [Endo (Layout x y)] -> Endo (Layout x y)
forall a. [a -> a] -> a -> a
foldEndo [ ASetter (Layout x y) (Layout x y) Double Double
-> Double -> Endo (Layout x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Layout x y) (Layout x y) Double Double
l Double
v | ASetter (Layout x y) (Layout x y) Double Double
l <- [ (LayoutAxis x -> Identity (LayoutAxis x))
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) (LayoutAxis x)
layout_x_axis ((LayoutAxis x -> Identity (LayoutAxis x))
 -> Layout x y -> Identity (Layout x y))
-> ((Double -> Identity Double)
    -> LayoutAxis x -> Identity (LayoutAxis x))
-> ASetter (Layout x y) (Layout x y) Double Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double)
-> LayoutAxis x -> Identity (LayoutAxis x)
forall x. Lens' (LayoutAxis x) Double
axisLabelSize
                            , (LayoutAxis y -> Identity (LayoutAxis y))
-> Layout x y -> Identity (Layout x y)
forall x y. Lens' (Layout x y) (LayoutAxis y)
layout_y_axis ((LayoutAxis y -> Identity (LayoutAxis y))
 -> Layout x y -> Identity (Layout x y))
-> ((Double -> Identity Double)
    -> LayoutAxis y -> Identity (LayoutAxis y))
-> ASetter (Layout x y) (Layout x y) Double Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Identity Double)
-> LayoutAxis y -> Identity (LayoutAxis y)
forall x. Lens' (LayoutAxis x) Double
axisLabelSize ] ]

-- | Set some bar styles that look nice.
applyBarStyle :: Endo (PlotBars x y)
applyBarStyle :: Endo (PlotBars x y)
applyBarStyle =
  [Endo (PlotBars x y)] -> Endo (PlotBars x y)
forall a. [a -> a] -> a -> a
foldEndo
    [ ASetter
  (PlotBars x y) (PlotBars x y) PlotBarsSpacing PlotBarsSpacing
-> PlotBarsSpacing -> Endo (PlotBars x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (PlotBars x y) (PlotBars x y) PlotBarsSpacing PlotBarsSpacing
forall x y. Lens' (PlotBars x y) PlotBarsSpacing
plot_bars_spacing (Double -> Double -> PlotBarsSpacing
BarsFixGap Double
80 Double
20)
    , ASetter
  (PlotBars x y)
  (PlotBars x y)
  [(FillStyle, Maybe LineStyle)]
  [(FillStyle, Maybe LineStyle)]
-> [(FillStyle, Maybe LineStyle)] -> Endo (PlotBars x y)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (PlotBars x y)
  (PlotBars x y)
  [(FillStyle, Maybe LineStyle)]
  [(FillStyle, Maybe LineStyle)]
forall x y. Lens' (PlotBars x y) [(FillStyle, Maybe LineStyle)]
plot_bars_item_styles [(AlphaColour Double -> FillStyle
FillStyleSolid (Colour Double -> AlphaColour Double
forall a. Num a => Colour a -> AlphaColour a
opaque Colour Double
forall a. (Ord a, Floating a) => Colour a
steelblue), Maybe LineStyle
forall a. Maybe a
Nothing)]
    ]