module Codec.Xlsx.Types.Drawing.Chart where
import GHC.Generics (Generic)
import Control.Lens.TH
import Data.Default
import Data.Maybe (catMaybes, maybeToList)
import Data.Text (Text)
import Text.XML
import Text.XML.Cursor
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.Drawing.Common
import Codec.Xlsx.Writer.Internal
data ChartSpace = ChartSpace
{ _chspTitle :: Maybe ChartTitle
, _chspCharts :: [Chart]
, _chspLegend :: Maybe Legend
, _chspPlotVisOnly :: Maybe Bool
, _chspDispBlanksAs :: Maybe DispBlanksAs
} deriving (Eq, Show, Generic)
newtype ChartTitle =
ChartTitle TextBody
deriving (Eq, Show, Generic)
data DispBlanksAs
= DispBlanksAsGap
| DispBlanksAsSpan
| DispBlanksAsZero
deriving (Eq, Show, Generic)
data Legend = Legend
{ _legendPos :: Maybe LegendPos
, _legendOverlay :: Maybe Bool
} deriving (Eq, Show, Generic)
data LegendPos
= LegendBottom
| LegendLeft
| LegendRight
| LegendTop
| LegendTopRight
deriving (Eq, Show, Generic)
data Chart
= LineChart { _lnchGrouping :: ChartGrouping
, _lnchSeries :: [LineSeries]
, _lnchMarker :: Maybe Bool
, _lnchSmooth :: Maybe Bool
}
| AreaChart { _archGrouping :: Maybe ChartGrouping
, _archSeries :: [AreaSeries]
}
| BarChart { _brchDirection :: BarDirection
, _brchGrouping :: Maybe ChartGrouping
, _brchSeries :: [BarSeries]
}
| PieChart { _pichSeries :: [PieSeries]
}
| ScatterChart { _scchStyle :: ScatterStyle
, _scchSeries :: [ScatterSeries]
}
deriving (Eq, Show, Generic)
data ChartGrouping
= PercentStackedGrouping
| StackedGrouping
| StandardGrouping
deriving (Eq, Show, Generic)
data BarDirection
= DirectionBar
| DirectionColumn
deriving (Eq, Show, Generic)
data ScatterStyle
= ScatterNone
| ScatterLine
| ScatterLineMarker
| ScatterMarker
| ScatterSmooth
| ScatterSmoothMarker
deriving (Eq, Show, Generic)
data DataPoint = DataPoint
{ _dpMarker :: Maybe DataMarker
, _dpShapeProperties :: Maybe ShapeProperties
} deriving (Eq, Show, Generic)
data Series = Series
{ _serTx :: Maybe Formula
, _serShapeProperties :: Maybe ShapeProperties
} deriving (Eq, Show, Generic)
data LineSeries = LineSeries
{ _lnserShared :: Series
, _lnserMarker :: Maybe DataMarker
, _lnserDataLblProps :: Maybe DataLblProps
, _lnserVal :: Maybe Formula
, _lnserSmooth :: Maybe Bool
} deriving (Eq, Show, Generic)
data AreaSeries = AreaSeries
{ _arserShared :: Series
, _arserDataLblProps :: Maybe DataLblProps
, _arserVal :: Maybe Formula
} deriving (Eq, Show, Generic)
data BarSeries = BarSeries
{ _brserShared :: Series
, _brserDataLblProps :: Maybe DataLblProps
, _brserVal :: Maybe Formula
} deriving (Eq, Show, Generic)
data PieSeries = PieSeries
{ _piserShared :: Series
, _piserDataPoints :: [DataPoint]
, _piserDataLblProps :: Maybe DataLblProps
, _piserVal :: Maybe Formula
} deriving (Eq, Show, Generic)
data ScatterSeries = ScatterSeries
{ _scserShared :: Series
, _scserMarker :: Maybe DataMarker
, _scserDataLblProps :: Maybe DataLblProps
, _scserXVal :: Maybe Formula
, _scserYVal :: Maybe Formula
, _scserSmooth :: Maybe Bool
} deriving (Eq, Show, Generic)
data DataMarker = DataMarker
{ _dmrkSymbol :: Maybe DataMarkerSymbol
, _dmrkSize :: Maybe Int
} deriving (Eq, Show, Generic)
data DataMarkerSymbol
= DataMarkerCircle
| DataMarkerDash
| DataMarkerDiamond
| DataMarkerDot
| DataMarkerNone
| DataMarkerPicture
| DataMarkerPlus
| DataMarkerSquare
| DataMarkerStar
| DataMarkerTriangle
| DataMarkerX
| DataMarkerAuto
deriving (Eq, Show, Generic)
data DataLblProps = DataLblProps
{ _dlblShowLegendKey :: Maybe Bool
, _dlblShowVal :: Maybe Bool
, _dlblShowCatName :: Maybe Bool
, _dlblShowSerName :: Maybe Bool
, _dlblShowPercent :: Maybe Bool
} deriving (Eq, Show, Generic)
data TickMark
= TickMarkCross
| TickMarkIn
| TickMarkNone
| TickMarkOut
deriving (Eq, Show, Generic)
makeLenses ''DataPoint
instance Default DataPoint where
def = DataPoint Nothing Nothing
instance FromCursor ChartSpace where
fromCursor cur = do
cur' <- cur $/ element (c_ "chart")
_chspTitle <- maybeFromElement (c_ "title") cur'
let _chspCharts =
cur' $/ element (c_ "plotArea") &/ anyElement >=> chartFromNode . node
_chspLegend <- maybeFromElement (c_ "legend") cur'
_chspPlotVisOnly <- maybeBoolElementValue (c_ "plotVisOnly") cur'
_chspDispBlanksAs <- maybeElementValue (c_ "dispBlanksAs") cur'
return ChartSpace {..}
chartFromNode :: Node -> [Chart]
chartFromNode n
| n `nodeElNameIs` (c_ "lineChart") = do
_lnchGrouping <- fromElementValue (c_ "grouping") cur
let _lnchSeries = cur $/ element (c_ "ser") >=> fromCursor
_lnchMarker <- maybeBoolElementValue (c_ "marker") cur
_lnchSmooth <- maybeBoolElementValue (c_ "smooth") cur
return LineChart {..}
| n `nodeElNameIs` (c_ "areaChart") = do
_archGrouping <- maybeElementValue (c_ "grouping") cur
let _archSeries = cur $/ element (c_ "ser") >=> fromCursor
return AreaChart {..}
| n `nodeElNameIs` (c_ "barChart") = do
_brchDirection <- fromElementValue (c_ "barDir") cur
_brchGrouping <- maybeElementValue (c_ "grouping") cur
let _brchSeries = cur $/ element (c_ "ser") >=> fromCursor
return BarChart {..}
| n `nodeElNameIs` (c_ "pieChart") = do
let _pichSeries = cur $/ element (c_ "ser") >=> fromCursor
return PieChart {..}
| n `nodeElNameIs` (c_ "scatterChart") = do
_scchStyle <- fromElementValue (c_ "scatterStyle") cur
let _scchSeries = cur $/ element (c_ "ser") >=> fromCursor
return ScatterChart {..}
| otherwise = fail "no matching chart node"
where
cur = fromNode n
instance FromCursor LineSeries where
fromCursor cur = do
_lnserShared <- fromCursor cur
_lnserMarker <- maybeFromElement (c_ "marker") cur
_lnserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_lnserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
_lnserSmooth <- maybeElementValueDef (c_ "smooth") True cur
return LineSeries {..}
instance FromCursor AreaSeries where
fromCursor cur = do
_arserShared <- fromCursor cur
_arserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_arserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
return AreaSeries {..}
instance FromCursor BarSeries where
fromCursor cur = do
_brserShared <- fromCursor cur
_brserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_brserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
return BarSeries {..}
instance FromCursor PieSeries where
fromCursor cur = do
_piserShared <- fromCursor cur
let _piserDataPoints = cur $/ element (c_ "dPt") >=> fromCursor
_piserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_piserVal <-
cur $/ element (c_ "val") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
return PieSeries {..}
instance FromCursor ScatterSeries where
fromCursor cur = do
_scserShared <- fromCursor cur
_scserMarker <- maybeFromElement (c_ "marker") cur
_scserDataLblProps <- maybeFromElement (c_ "dLbls") cur
_scserXVal <-
cur $/ element (c_ "xVal") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
_scserYVal <-
cur $/ element (c_ "yVal") &/ element (c_ "numRef") >=>
maybeFromElement (c_ "f")
_scserSmooth <- maybeElementValueDef (c_ "smooth") True cur
return ScatterSeries {..}
instance FromCursor Series where
fromCursor cur = do
_serTx <-
cur $/ element (c_ "tx") &/ element (c_ "strRef") >=>
maybeFromElement (c_ "f")
_serShapeProperties <- maybeFromElement (c_ "spPr") cur
return Series {..}
instance FromCursor DataMarker where
fromCursor cur = do
_dmrkSymbol <- maybeElementValue (c_ "symbol") cur
_dmrkSize <- maybeElementValue (c_ "size") cur
return DataMarker {..}
instance FromCursor DataPoint where
fromCursor cur = do
_dpMarker <- maybeFromElement (c_ "marker") cur
_dpShapeProperties <- maybeFromElement (c_ "spPr") cur
return DataPoint {..}
instance FromAttrVal DataMarkerSymbol where
fromAttrVal "circle" = readSuccess DataMarkerCircle
fromAttrVal "dash" = readSuccess DataMarkerDash
fromAttrVal "diamond" = readSuccess DataMarkerDiamond
fromAttrVal "dot" = readSuccess DataMarkerDot
fromAttrVal "none" = readSuccess DataMarkerNone
fromAttrVal "picture" = readSuccess DataMarkerPicture
fromAttrVal "plus" = readSuccess DataMarkerPlus
fromAttrVal "square" = readSuccess DataMarkerSquare
fromAttrVal "star" = readSuccess DataMarkerStar
fromAttrVal "triangle" = readSuccess DataMarkerTriangle
fromAttrVal "x" = readSuccess DataMarkerX
fromAttrVal "auto" = readSuccess DataMarkerAuto
fromAttrVal t = invalidText "DataMarkerSymbol" t
instance FromAttrVal BarDirection where
fromAttrVal "bar" = readSuccess DirectionBar
fromAttrVal "col" = readSuccess DirectionColumn
fromAttrVal t = invalidText "BarDirection" t
instance FromAttrVal ScatterStyle where
fromAttrVal "none" = readSuccess ScatterNone
fromAttrVal "line" = readSuccess ScatterLine
fromAttrVal "lineMarker" = readSuccess ScatterLineMarker
fromAttrVal "marker" = readSuccess ScatterMarker
fromAttrVal "smooth" = readSuccess ScatterSmooth
fromAttrVal "smoothMarker" = readSuccess ScatterSmoothMarker
fromAttrVal t = invalidText "ScatterStyle" t
instance FromCursor DataLblProps where
fromCursor cur = do
_dlblShowLegendKey <- maybeBoolElementValue (c_ "showLegendKey") cur
_dlblShowVal <- maybeBoolElementValue (c_ "showVal") cur
_dlblShowCatName <- maybeBoolElementValue (c_ "showCatName") cur
_dlblShowSerName <- maybeBoolElementValue (c_ "showSerName") cur
_dlblShowPercent <- maybeBoolElementValue (c_ "showPercent") cur
return DataLblProps {..}
instance FromAttrVal ChartGrouping where
fromAttrVal "percentStacked" = readSuccess PercentStackedGrouping
fromAttrVal "standard" = readSuccess StandardGrouping
fromAttrVal "stacked" = readSuccess StackedGrouping
fromAttrVal t = invalidText "ChartGrouping" t
instance FromCursor ChartTitle where
fromCursor cur =
cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fmap ChartTitle . fromCursor
instance FromCursor Legend where
fromCursor cur = do
_legendPos <- maybeElementValue (c_ "legendPos") cur
_legendOverlay <- maybeElementValueDef (c_ "overlay") True cur
return Legend {..}
instance FromAttrVal LegendPos where
fromAttrVal "b" = readSuccess LegendBottom
fromAttrVal "l" = readSuccess LegendLeft
fromAttrVal "r" = readSuccess LegendRight
fromAttrVal "t" = readSuccess LegendTop
fromAttrVal "tr" = readSuccess LegendTopRight
fromAttrVal t = invalidText "LegendPos" t
instance FromAttrVal DispBlanksAs where
fromAttrVal "gap" = readSuccess DispBlanksAsGap
fromAttrVal "span" = readSuccess DispBlanksAsSpan
fromAttrVal "zero" = readSuccess DispBlanksAsZero
fromAttrVal t = invalidText "DispBlanksAs" t
instance Default Legend where
def = Legend {_legendPos = Just LegendBottom, _legendOverlay = Just False}
instance ToDocument ChartSpace where
toDocument =
documentFromNsPrefElement "Charts generated by xlsx" chartNs (Just "c") .
toElement "chartSpace"
instance ToElement ChartSpace where
toElement nm ChartSpace {..} =
elementListSimple nm [nonRounded, chartEl, chSpPr]
where
nonRounded = elementValue "roundedCorners" False
chSpPr = toElement "spPr" $ def {_spFill = Just $ solidRgb "ffffff"}
chartEl = elementListSimple "chart" elements
elements =
catMaybes
[ toElement "title" <$> _chspTitle
, Just $ elementValue "autoTitleDeleted" False
, Just $ elementListSimple "plotArea" areaEls
, toElement "legend" <$> _chspLegend
, elementValue "plotVisOnly" <$> _chspPlotVisOnly
, elementValue "dispBlanksAs" <$> _chspDispBlanksAs
]
areaEls = charts ++ axes
(_, charts, axes) = foldr addChart (1, [], []) _chspCharts
addChart ch (i, cs, as) =
let (c, as') = chartToElements ch i
in (i + length as', c : cs, as' ++ as)
chartToElements :: Chart -> Int -> (Element, [Element])
chartToElements chart axId =
case chart of
LineChart {..} ->
chartElement
"lineChart"
stdAxes
(Just _lnchGrouping)
_lnchSeries
[]
(catMaybes
[ elementValue "marker" <$> _lnchMarker
, elementValue "smooth" <$> _lnchSmooth
])
AreaChart {..} ->
chartElement "areaChart" stdAxes _archGrouping _archSeries [] []
BarChart {..} ->
chartElement
"barChart"
stdAxes
_brchGrouping
_brchSeries
[elementValue "barDir" _brchDirection]
[]
PieChart {..} -> chartElement "pieChart" [] Nothing _pichSeries [] []
ScatterChart {..} ->
chartElement
"scatterChart"
xyAxes
Nothing
_scchSeries
[elementValue "scatterStyle" _scchStyle]
[]
where
chartElement
:: ToElement s
=> Name
-> [Element]
-> Maybe ChartGrouping
-> [s]
-> [Element]
-> [Element]
-> (Element, [Element])
chartElement nm axes mGrouping series prepended appended =
( elementListSimple nm $
prepended ++
(maybeToList $ elementValue "grouping" <$> mGrouping) ++
(varyColors : seriesEls series) ++
appended ++ zipWith (\n _ -> elementValue "axId" n) [axId ..] axes
, axes)
varyColors = elementValue "varyColors" False
seriesEls series = [indexedSeriesEl i s | (i, s) <- zip [0 ..] series]
indexedSeriesEl
:: ToElement a
=> Int -> a -> Element
indexedSeriesEl i s = prependI i $ toElement "ser" s
prependI i e@Element {..} = e {elementNodes = iNodes i ++ elementNodes}
iNodes i = map NodeElement [elementValue n i | n <- ["idx", "order"]]
stdAxes = [catAx axId (axId + 1), valAx "l" (axId + 1) axId]
xyAxes = [valAx "b" axId (axId + 1), valAx "l" (axId + 1) axId]
catAx :: Int -> Int -> Element
catAx i cr =
elementListSimple "catAx" $
[ elementValue "axId" i
, emptyElement "scaling"
, elementValue "delete" False
, elementValue "axPos" ("b" :: Text)
, elementValue "majorTickMark" TickMarkNone
, elementValue "minorTickMark" TickMarkNone
, toElement "spPr" grayLines
, elementValue "crossAx" cr
, elementValue "auto" True
]
valAx :: Text -> Int -> Int -> Element
valAx pos i cr =
elementListSimple "valAx" $
[ elementValue "axId" i
, emptyElement "scaling"
, elementValue "delete" False
, elementValue "axPos" pos
, gridLinesEl
, elementValue "majorTickMark" TickMarkNone
, elementValue "minorTickMark" TickMarkNone
, toElement "spPr" grayLines
, elementValue "crossAx" cr
]
grayLines = def {_spOutline = Just def {_lnFill = Just $ solidRgb "b3b3b3"}}
gridLinesEl =
elementListSimple "majorGridlines" [toElement "spPr" grayLines]
instance ToAttrVal ChartGrouping where
toAttrVal PercentStackedGrouping = "percentStacked"
toAttrVal StandardGrouping = "standard"
toAttrVal StackedGrouping = "stacked"
instance ToAttrVal BarDirection where
toAttrVal DirectionBar = "bar"
toAttrVal DirectionColumn = "col"
instance ToAttrVal ScatterStyle where
toAttrVal ScatterNone = "none"
toAttrVal ScatterLine = "line"
toAttrVal ScatterLineMarker = "lineMarker"
toAttrVal ScatterMarker = "marker"
toAttrVal ScatterSmooth = "smooth"
toAttrVal ScatterSmoothMarker = "smoothMarker"
instance ToElement LineSeries where
toElement nm LineSeries {..} = simpleSeries nm _lnserShared _lnserVal pr ap
where
pr =
catMaybes
[ toElement "marker" <$> _lnserMarker
, toElement "dLbls" <$> _lnserDataLblProps
]
ap = maybeToList $ elementValue "smooth" <$> _lnserSmooth
simpleSeries :: Name
-> Series
-> Maybe Formula
-> [Element]
-> [Element]
-> Element
simpleSeries nm shared val prepended appended =
serEl {elementNodes = elementNodes serEl ++ map NodeElement elements}
where
serEl = toElement nm shared
elements = prepended ++ (valEl val : appended)
valEl v =
elementListSimple
"val"
[elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)]
instance ToElement DataMarker where
toElement nm DataMarker {..} = elementListSimple nm elements
where
elements =
catMaybes
[ elementValue "symbol" <$> _dmrkSymbol
, elementValue "size" <$> _dmrkSize
]
instance ToAttrVal DataMarkerSymbol where
toAttrVal DataMarkerCircle = "circle"
toAttrVal DataMarkerDash = "dash"
toAttrVal DataMarkerDiamond = "diamond"
toAttrVal DataMarkerDot = "dot"
toAttrVal DataMarkerNone = "none"
toAttrVal DataMarkerPicture = "picture"
toAttrVal DataMarkerPlus = "plus"
toAttrVal DataMarkerSquare = "square"
toAttrVal DataMarkerStar = "star"
toAttrVal DataMarkerTriangle = "triangle"
toAttrVal DataMarkerX = "x"
toAttrVal DataMarkerAuto = "auto"
instance ToElement DataLblProps where
toElement nm DataLblProps {..} = elementListSimple nm elements
where
elements =
catMaybes
[ elementValue "showLegendKey" <$> _dlblShowLegendKey
, elementValue "showVal" <$> _dlblShowVal
, elementValue "showCatName" <$> _dlblShowCatName
, elementValue "showSerName" <$> _dlblShowSerName
, elementValue "showPercent" <$> _dlblShowPercent
]
instance ToElement AreaSeries where
toElement nm AreaSeries {..} = simpleSeries nm _arserShared _arserVal pr []
where
pr = maybeToList $ fmap (toElement "dLbls") _arserDataLblProps
instance ToElement BarSeries where
toElement nm BarSeries {..} = simpleSeries nm _brserShared _brserVal pr []
where
pr = maybeToList $ fmap (toElement "dLbls") _brserDataLblProps
instance ToElement PieSeries where
toElement nm PieSeries {..} = simpleSeries nm _piserShared _piserVal pr []
where
pr = dPts ++ maybeToList (fmap (toElement "dLbls") _piserDataLblProps)
dPts = zipWith dPtEl [(0 :: Int) ..] _piserDataPoints
dPtEl i DataPoint {..} =
elementListSimple
"dPt"
(elementValue "idx" i :
catMaybes
[ toElement "marker" <$> _dpMarker
, toElement "spPr" <$> _dpShapeProperties
])
instance ToElement ScatterSeries where
toElement nm ScatterSeries {..} =
serEl {elementNodes = elementNodes serEl ++ map NodeElement elements}
where
serEl = toElement nm _scserShared
elements =
catMaybes
[ toElement "marker" <$> _scserMarker
, toElement "dLbls" <$> _scserDataLblProps
] ++
[valEl "xVal" _scserXVal, valEl "yVal" _scserYVal] ++
(maybeToList $ fmap (elementValue "smooth") _scserSmooth)
valEl vnm v =
elementListSimple
vnm
[elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)]
instance ToElement Series where
toElement nm Series {..} =
elementListSimple nm $
[ elementListSimple
"tx"
[elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)]
] ++
maybeToList (toElement "spPr" <$> _serShapeProperties)
instance ToElement ChartTitle where
toElement nm (ChartTitle body) =
elementListSimple nm [txEl, elementValue "overlay" False]
where
txEl = elementListSimple "tx" [toElement (c_ "rich") body]
instance ToElement Legend where
toElement nm Legend{..} = elementListSimple nm elements
where
elements = catMaybes [ elementValue "legendPos" <$> _legendPos
, elementValue "overlay" <$>_legendOverlay]
instance ToAttrVal LegendPos where
toAttrVal LegendBottom = "b"
toAttrVal LegendLeft = "l"
toAttrVal LegendRight = "r"
toAttrVal LegendTop = "t"
toAttrVal LegendTopRight = "tr"
instance ToAttrVal DispBlanksAs where
toAttrVal DispBlanksAsGap = "gap"
toAttrVal DispBlanksAsSpan = "span"
toAttrVal DispBlanksAsZero = "zero"
instance ToAttrVal TickMark where
toAttrVal TickMarkCross = "cross"
toAttrVal TickMarkIn = "in"
toAttrVal TickMarkNone = "none"
toAttrVal TickMarkOut = "out"
c_ :: Text -> Name
c_ x =
Name {nameLocalName = x, nameNamespace = Just chartNs, namePrefix = Just "c"}
chartNs :: Text
chartNs = "http://schemas.openxmlformats.org/drawingml/2006/chart"