{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wall #-}
module Chart.Types
( Chart (..),
Chartable,
Annotation (..),
annotationText,
RectStyle (RectStyle),
defaultRectStyle,
blob,
clear,
border,
TextStyle (..),
defaultTextStyle,
Anchor (..),
fromAnchor,
toAnchor,
GlyphStyle (..),
defaultGlyphStyle,
GlyphShape (..),
glyphText,
LineStyle (..),
defaultLineStyle,
PixelStyle (..),
defaultPixelStyle,
Orientation (..),
fromOrientation,
toOrientation,
Spot (..),
toRect,
toPoint,
pattern SR,
pattern SP,
padRect,
SvgAspect (..),
toSvgAspect,
fromSvgAspect,
EscapeText (..),
CssOptions (..),
ScaleCharts (..),
SvgOptions (..),
defaultSvgOptions,
defaultSvgFrame,
ChartDims (..),
HudT (..),
Hud,
HudOptions (..),
defaultHudOptions,
defaultCanvas,
AxisOptions (..),
defaultAxisOptions,
Place (..),
placeText,
Bar (..),
defaultBar,
Title (..),
defaultTitle,
Tick (..),
defaultGlyphTick,
defaultTextTick,
defaultLineTick,
defaultTick,
TickStyle (..),
defaultTickStyle,
tickStyleText,
TickExtend (..),
Adjustments (..),
defaultAdjustments,
LegendOptions (..),
defaultLegendOptions,
FormatN (..),
defaultFormatN,
)
where
import Chart.Color
import Control.Lens
import Data.Generics.Labels ()
import Data.List ((!!))
import qualified Data.Text as Text
import GHC.Exts
import GHC.Generics
import NumHask.Space hiding (Element)
import Protolude
data Chart a
= Chart
{ annotation :: Annotation,
spots :: [Spot a]
}
deriving (Eq, Show, Generic)
type Chartable a =
(Real a, Fractional a, RealFrac a, RealFloat a, Floating a)
data Annotation
= RectA RectStyle
| TextA TextStyle [Text.Text]
| GlyphA GlyphStyle
| LineA LineStyle
| BlankA
| PixelA PixelStyle
deriving (Eq, Show, Generic)
annotationText :: Annotation -> Text
annotationText (RectA _) = "RectA"
annotationText TextA {} = "TextA"
annotationText (GlyphA _) = "GlyphA"
annotationText (LineA _) = "LineA"
annotationText BlankA = "BlankA"
annotationText (PixelA _) = "PixelA"
data RectStyle
= RectStyle
{ borderSize :: Double,
borderColor :: Colour,
color :: Colour
}
deriving (Show, Eq, Generic)
defaultRectStyle :: RectStyle
defaultRectStyle = RectStyle 0.02 (palette !! 0) (palette !! 1)
blob :: Colour -> RectStyle
blob = RectStyle 0 transparent
clear :: RectStyle
clear = RectStyle 0 transparent transparent
border :: Double -> Colour -> RectStyle
border s c = RectStyle s c transparent
data TextStyle
= TextStyle
{ size :: Double,
color :: Colour,
anchor :: Anchor,
hsize :: Double,
vsize :: Double,
nudge1 :: Double,
rotation :: Maybe Double,
translate :: Maybe (Point Double),
hasMathjax :: Bool
}
deriving (Show, Eq, Generic)
data Anchor = AnchorMiddle | AnchorStart | AnchorEnd deriving (Eq, Show, Generic)
fromAnchor :: (IsString s) => Anchor -> s
fromAnchor AnchorMiddle = "Middle"
fromAnchor AnchorStart = "Start"
fromAnchor AnchorEnd = "End"
toAnchor :: (Eq s, IsString s) => s -> Anchor
toAnchor "Middle" = AnchorMiddle
toAnchor "Start" = AnchorStart
toAnchor "End" = AnchorEnd
toAnchor _ = AnchorMiddle
defaultTextStyle :: TextStyle
defaultTextStyle =
TextStyle 0.08 colorText AnchorMiddle 0.5 1.45 (-0.2) Nothing Nothing False
data GlyphStyle
= GlyphStyle
{
size :: Double,
color :: Colour,
borderColor :: Colour,
borderSize :: Double,
shape :: GlyphShape,
rotation :: Maybe Double,
translate :: Maybe (Point Double)
}
deriving (Show, Eq, Generic)
defaultGlyphStyle :: GlyphStyle
defaultGlyphStyle =
GlyphStyle
0.03
(setAlpha (palette !! 0) 0.8)
(setAlpha (palette !! 1) 0.4)
0.003
SquareGlyph
Nothing
Nothing
data GlyphShape
= CircleGlyph
| SquareGlyph
| EllipseGlyph Double
| RectSharpGlyph Double
| RectRoundedGlyph Double Double Double
| TriangleGlyph (Point Double) (Point Double) (Point Double)
| VLineGlyph Double
| HLineGlyph Double
| PathGlyph Text
deriving (Show, Eq, Generic)
glyphText :: GlyphShape -> Text
glyphText sh =
case sh of
CircleGlyph -> "Circle"
SquareGlyph -> "Square"
TriangleGlyph {} -> "Triangle"
EllipseGlyph _ -> "Ellipse"
RectSharpGlyph _ -> "RectSharp"
RectRoundedGlyph {} -> "RectRounded"
VLineGlyph _ -> "VLine"
HLineGlyph _ -> "HLine"
PathGlyph _ -> "Path"
data LineStyle
= LineStyle
{ width :: Double,
color :: Colour
}
deriving (Show, Eq, Generic)
defaultLineStyle :: LineStyle
defaultLineStyle = LineStyle 0.012 (palette !! 0)
data PixelStyle
= PixelStyle
{ pixelColorMin :: Colour,
pixelColorMax :: Colour,
pixelGradient :: Double,
pixelRectStyle :: RectStyle,
pixelTextureId :: Text
}
deriving (Show, Eq, Generic)
defaultPixelStyle :: PixelStyle
defaultPixelStyle =
PixelStyle colorPixelMin colorPixelMax (pi / 2) (blob black) "pixel"
data Orientation = Vert | Hori deriving (Eq, Show, Generic)
fromOrientation :: (IsString s) => Orientation -> s
fromOrientation Hori = "Hori"
fromOrientation Vert = "Vert"
toOrientation :: (Eq s, IsString s) => s -> Orientation
toOrientation "Hori" = Hori
toOrientation "Vert" = Vert
toOrientation _ = Hori
data Spot a
= SpotPoint (Point a)
| SpotRect (Rect a)
deriving (Eq, Show, Functor)
instance (Ord a, Num a, Fractional a) => Num (Spot a) where
SpotPoint (Point x y) + SpotPoint (Point x' y') = SpotPoint (Point (x + x') (y + y'))
SpotPoint (Point x' y') + SpotRect (Rect x z y w) = SpotRect $ Rect (x + x') (z + x') (y + y') (w + y')
SpotRect (Rect x z y w) + SpotPoint (Point x' y') = SpotRect $ Rect (x + x') (z + x') (y + y') (w + y')
SpotRect (Rect x z y w) + SpotRect (Rect x' z' y' w') =
SpotRect $ Rect (x + x') (z + z') (y + y') (w + w')
x * y = SpotRect $ toRect x `multRect` toRect y
abs x = SpotPoint $ abs <$> toPoint x
signum x = SpotPoint $ signum <$> toPoint x
negate (SpotPoint (Point x y)) = SpotPoint (Point (- x) (- y))
negate (SpotRect (Rect x z y w)) = SpotRect (Rect (- x) (- z) (- y) (- w))
fromInteger x = SP (fromInteger x) (fromInteger x)
pattern SP :: a -> a -> Spot a
pattern SP a b = SpotPoint (Point a b)
{-# COMPLETE SP #-}
pattern SR :: a -> a -> a -> a -> Spot a
pattern SR a b c d = SpotRect (Rect a b c d)
{-# COMPLETE SR #-}
toRect :: Spot a -> Rect a
toRect (SP x y) = Rect x x y y
toRect (SpotRect a) = a
toPoint :: (Ord a, Fractional a) => Spot a -> Point a
toPoint (SP x y) = Point x y
toPoint (SpotRect (Ranges x y)) = Point (mid x) (mid y)
instance (Ord a) => Semigroup (Spot a) where
(<>) a b = SpotRect (toRect a `union` toRect b)
padRect :: (Num a) => a -> Rect a -> Rect a
padRect p (Rect x z y w) = Rect (x - p) (z + p) (y - p) (w + p)
data EscapeText = EscapeText | NoEscapeText deriving (Show, Eq, Generic)
data CssOptions = UseCssCrisp | NoCssOptions deriving (Show, Eq, Generic)
data ScaleCharts = ScaleCharts | NoScaleCharts deriving (Show, Eq, Generic)
data SvgAspect = ManualAspect Double | ChartAspect deriving (Show, Eq, Generic)
fromSvgAspect :: (IsString s) => SvgAspect -> s
fromSvgAspect (ManualAspect _) = "ManualAspect"
fromSvgAspect ChartAspect = "ChartAspect"
toSvgAspect :: (Eq s, IsString s) => s -> Double -> SvgAspect
toSvgAspect "ManualAspect" a = ManualAspect a
toSvgAspect "ChartAspect" _ = ChartAspect
toSvgAspect _ _ = ChartAspect
data SvgOptions
= SvgOptions
{ svgHeight :: Double,
outerPad :: Maybe Double,
innerPad :: Maybe Double,
chartFrame :: Maybe RectStyle,
escapeText :: EscapeText,
useCssCrisp :: CssOptions,
scaleCharts' :: ScaleCharts,
svgAspect :: SvgAspect
}
deriving (Eq, Show, Generic)
defaultSvgOptions :: SvgOptions
defaultSvgOptions = SvgOptions 300 (Just 0.02) Nothing Nothing NoEscapeText NoCssOptions ScaleCharts (ManualAspect 1.5)
defaultSvgFrame :: RectStyle
defaultSvgFrame = border 0.01 colorFrame
data ChartDims a
= ChartDims
{ chartDim :: Rect a,
canvasDim :: Rect a,
dataDim :: Rect a
}
deriving (Eq, Show, Generic)
newtype HudT m a = Hud {unhud :: [Chart a] -> StateT (ChartDims a) m [Chart a]}
type Hud = HudT Identity
instance (Monad m) => Semigroup (HudT m a) where
(<>) (Hud h1) (Hud h2) = Hud $ h1 >=> h2
instance (Monad m) => Monoid (HudT m a) where
mempty = Hud pure
data HudOptions
= HudOptions
{ hudCanvas :: Maybe RectStyle,
hudTitles :: [Title],
hudAxes :: [AxisOptions],
hudLegend :: Maybe (LegendOptions, [(Annotation, Text)])
}
deriving (Eq, Show, Generic)
instance Semigroup HudOptions where
(<>) (HudOptions c t a l) (HudOptions c' t' a' l') =
HudOptions (listToMaybe $ catMaybes [c, c']) (t <> t') (a <> a') (listToMaybe $ catMaybes [l, l'])
instance Monoid HudOptions where
mempty = HudOptions Nothing [] [] Nothing
defaultHudOptions :: HudOptions
defaultHudOptions =
HudOptions
(Just defaultCanvas)
[]
[ defaultAxisOptions,
defaultAxisOptions & #place .~ PlaceLeft
]
Nothing
defaultCanvas :: RectStyle
defaultCanvas = blob colorCanvas
data Place
= PlaceLeft
| PlaceRight
| PlaceTop
| PlaceBottom
| PlaceAbsolute (Point Double)
deriving (Show, Eq, Generic)
placeText :: Place -> Text
placeText p =
case p of
PlaceTop -> "Top"
PlaceBottom -> "Bottom"
PlaceLeft -> "Left"
PlaceRight -> "Right"
PlaceAbsolute _ -> "Absolute"
data AxisOptions
= AxisOptions
{ abar :: Maybe Bar,
adjust :: Maybe Adjustments,
atick :: Tick,
place :: Place
}
deriving (Eq, Show, Generic)
defaultAxisOptions :: AxisOptions
defaultAxisOptions = AxisOptions (Just defaultBar) (Just defaultAdjustments) defaultTick PlaceBottom
data Bar
= Bar
{ rstyle :: RectStyle,
wid :: Double,
buff :: Double
}
deriving (Show, Eq, Generic)
defaultBar :: Bar
defaultBar = Bar (RectStyle 0 colorGlyphTick colorGlyphTick) 0.005 0.01
data Title
= Title
{ text :: Text,
style :: TextStyle,
place :: Place,
anchor :: Anchor,
buff :: Double
}
deriving (Show, Eq, Generic)
defaultTitle :: Text -> Title
defaultTitle txt =
Title
txt
( (#size .~ 0.12)
. (#color .~ colorText)
$ defaultTextStyle
)
PlaceTop
AnchorMiddle
0.04
data Tick
= Tick
{ tstyle :: TickStyle,
gtick :: Maybe (GlyphStyle, Double),
ttick :: Maybe (TextStyle, Double),
ltick :: Maybe (LineStyle, Double)
}
deriving (Show, Eq, Generic)
defaultGlyphTick :: GlyphStyle
defaultGlyphTick =
defaultGlyphStyle
& #borderSize .~ 0.005
& #borderColor .~ colorGlyphTick
& #color .~ colorGlyphTick
& #shape .~ VLineGlyph 0.005
defaultTextTick :: TextStyle
defaultTextTick =
defaultTextStyle & #size .~ 0.05 & #color .~ colorTextTick
defaultLineTick :: LineStyle
defaultLineTick =
defaultLineStyle
& #color .~ colorLineTick
& #width .~ 5.0e-3
defaultTick :: Tick
defaultTick =
Tick
defaultTickStyle
(Just (defaultGlyphTick, 0.0125))
(Just (defaultTextTick, 0.015))
(Just (defaultLineTick, 0.005))
data TickStyle
=
TickNone
|
TickLabels [Text]
|
TickRound FormatN Int TickExtend
|
TickExact FormatN Int
|
TickPlaced [(Double, Text)]
deriving (Show, Eq, Generic)
defaultTickStyle :: TickStyle
defaultTickStyle = TickRound (FormatComma 0) 8 TickExtend
tickStyleText :: TickStyle -> Text
tickStyleText TickNone = "TickNone"
tickStyleText TickLabels {} = "TickLabels"
tickStyleText TickRound {} = "TickRound"
tickStyleText TickExact {} = "TickExact"
tickStyleText TickPlaced {} = "TickPlaced"
data TickExtend = TickExtend | NoTickExtend deriving (Eq, Show, Generic)
data Adjustments
= Adjustments
{ maxXRatio :: Double,
maxYRatio :: Double,
angledRatio :: Double,
allowDiagonal :: Bool
}
deriving (Show, Eq, Generic)
defaultAdjustments :: Adjustments
defaultAdjustments = Adjustments 0.08 0.06 0.12 True
data LegendOptions
= LegendOptions
{ lsize :: Double,
vgap :: Double,
hgap :: Double,
ltext :: TextStyle,
lmax :: Int,
innerPad :: Double,
outerPad :: Double,
legendFrame :: Maybe RectStyle,
lplace :: Place,
lscale :: Double
}
deriving (Show, Eq, Generic)
defaultLegendOptions :: LegendOptions
defaultLegendOptions =
LegendOptions
0.1
0.2
0.1
( defaultTextStyle
& #size .~ 0.08
& #color .~ colorGrey
)
10
0.1
0.1
(Just (RectStyle 0.02 (palette !! 0) black))
PlaceBottom
0.2
data FormatN
= FormatFixed Int
| FormatComma Int
| FormatExpt Int
| FormatDollar
| FormatPercent Int
| FormatNone
deriving (Eq, Show, Generic)
defaultFormatN :: FormatN
defaultFormatN = FormatComma 2