module Codec.Xlsx.Types.Drawing.Chart where
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)
newtype ChartTitle =
ChartTitle TextBody
deriving (Eq, Show)
data DispBlanksAs
= DispBlanksAsGap
| DispBlanksAsSpan
| DispBlanksAsZero
deriving (Eq, Show)
data Legend = Legend
{ _legendPos :: Maybe LegendPos
, _legendOverlay :: Maybe Bool
} deriving (Eq, Show)
data LegendPos
= LegendBottom
| LegendLeft
| LegendRight
| LegendTop
| LegendTopRight
deriving (Eq, Show)
data Chart = LineChart
{ _lnchGrouping :: ChartGrouping
, _lnchSeries :: [LineSeries]
, _lnchMarker :: Maybe Bool
, _lnchSmooth :: Maybe Bool
} deriving (Eq, Show)
data ChartGrouping
= PercentStackedGrouping
| StackedGrouping
| StandardGrouping
deriving (Eq, Show)
data Series = Series
{ _serTx :: Maybe Formula
} deriving (Eq, Show)
data LineSeries = LineSeries
{ _lnserShared :: Series
, _lnserMarker :: Maybe DataMarker
, _lnserDataLblProps :: Maybe DataLblProps
, _lnserVal :: Maybe Formula
, _lnserSmooth :: Maybe Bool
} deriving (Eq, Show)
data DataMarker = DataMarker
{ _dmrkSymbol :: Maybe DataMarkerSymbol
, _dmrkSize :: Maybe Int
} deriving (Eq, Show)
data DataMarkerSymbol
= DataMarkerCircle
| DataMarkerDash
| DataMarkerDiamond
| DataMarkerDot
| DataMarkerNone
| DataMarkerPicture
| DataMarkerPlus
| DataMarkerSquare
| DataMarkerStar
| DataMarkerTriangle
| DataMarkerX
| DataMarkerAuto
deriving (Eq, Show)
data DataLblProps = DataLblProps
{ _dlblShowLegendKey :: Maybe Bool
, _dlblShowVal :: Maybe Bool
, _dlblShowCatName :: Maybe Bool
, _dlblShowSerName :: Maybe Bool
, _dlblShowPercent :: Maybe Bool
} deriving (Eq, Show)
data TickMark
= TickMarkCross
| TickMarkIn
| TickMarkNone
| TickMarkOut
deriving (Eq, Show)
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 {..}
| 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 Series where
fromCursor cur = do
_serTx <-
cur $/ element (c_ "tx") &/ element (c_ "strRef") >=>
maybeFromElement (c_ "f")
return Series {..}
instance FromCursor DataMarker where
fromCursor cur = do
_dmrkSymbol <- maybeElementValue (c_ "symbol") cur
_dmrkSize <- maybeElementValue (c_ "size") cur
return DataMarker {..}
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 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 SolidFill}
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
]
enumCharts = zip [1,3 ..] _chspCharts
charts = [chartToElement ch i (i + 1) | (i, ch) <- enumCharts]
areaEls = charts ++ valAxes ++ catAxes
catAxes = [catAxEl i (i + 1) | (i, _) <- enumCharts]
valAxes = [valAxEl (i + 1) i | (i, _) <- enumCharts]
catAxEl :: Int -> Int -> Element
catAxEl i cr =
elementListSimple "catAx" $
[ elementValue "axId" i
, emptyElement "scaling"
, elementValue "delete" False
, elementValue "axPos" ("b" :: Text)
, elementValue "majorTickMark" TickMarkNone
, elementValue "minorTickMark" TickMarkNone
, toElement "spPr" noFill
, elementValue "crossAx" cr
, elementValue "auto" True
]
valAxEl :: Int -> Int -> Element
valAxEl i cr =
elementListSimple "valAx" $
[ elementValue "axId" i
, emptyElement "scaling"
, elementValue "delete" False
, elementValue "axPos" ("l" :: Text)
, gridLinesEl
, elementValue "majorTickMark" TickMarkNone
, elementValue "minorTickMark" TickMarkNone
, toElement "spPr" noFill
, elementValue "crossAx" cr
]
noFill =
def
{ _spFill = Just NoFill
, _spOutline = Just . LineProperties $ Just NoFill
}
gridLinesEl =
elementListSimple "majorGridlines" [toElement "spPr" lineFill]
lineFill = def { _spOutline = Just . LineProperties $ Just SolidFill }
chartToElement :: Chart -> Int -> Int -> Element
chartToElement LineChart {..} cId vId = elementListSimple "lineChart" elements
where
elements =
(grouping : varyColors : series) ++
catMaybes
[ elementValue "marker" <$> _lnchMarker
, elementValue "smooth" <$> _lnchSmooth
] ++
map (elementValue "axId") [cId, vId]
grouping = elementValue "grouping" _lnchGrouping
varyColors = elementValue "varyColors" False
series = [indexedSeriesEl i s | (i, s) <- zip [0 ..] _lnchSeries]
indexedSeriesEl :: Int -> LineSeries -> 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"]]
instance ToAttrVal ChartGrouping where
toAttrVal PercentStackedGrouping = "percentStacked"
toAttrVal StandardGrouping = "standard"
toAttrVal StackedGrouping = "stacked"
instance ToElement LineSeries where
toElement nm LineSeries {..} = serEl
{ elementNodes = elementNodes serEl ++
map NodeElement elements }
where
serEl = toElement nm _lnserShared
elements =
catMaybes
[ toElement "marker" <$> _lnserMarker
, toElement "dLbls" <$> _lnserDataLblProps
, Just $ valEl _lnserVal
, elementValue "smooth" <$> _lnserSmooth
]
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 Series where
toElement nm Series {..} =
elementListSimple
nm
[ elementListSimple
"tx"
[elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)]
]
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"