diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,10 @@ +0.5.0 +----- +* renamed `ColumnsWidth` to more intuitive `ColumnsProperties` and + added some more fields to it +* added pivot table field sorting and hidden values support +* added support for 4 more chart types + 0.4.3 ----- * added (legacy) sheet protection support diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -79,7 +79,7 @@ } deriving Show -type Caches = [(CacheId, (Text, CellRef, [PivotFieldName]))] +type Caches = [(CacheId, (Text, CellRef, [CacheField]))] extractSheet :: Zip.Archive -> SharedStringTable diff --git a/src/Codec/Xlsx/Parser/Internal.hs b/src/Codec/Xlsx/Parser/Internal.hs --- a/src/Codec/Xlsx/Parser/Internal.hs +++ b/src/Codec/Xlsx/Parser/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Codec.Xlsx.Parser.Internal ( ParseException(..) , n_ @@ -15,6 +16,7 @@ , maybeElementValueDef , maybeBoolElementValue , maybeFromElement + , attrValIs , contentOrEmpty , readSuccess , readFailure @@ -112,6 +114,12 @@ maybeFromElement name cursor = case cursor $/ element name of [cursor'] -> Just <$> fromCursor cursor' _ -> [Nothing] + +attrValIs :: (Eq a, FromAttrVal a) => Name -> a -> Axis +attrValIs n v c = + case fromAttribute n c of + [x] | x == v -> [c] + _ -> [] contentOrEmpty :: Cursor -> [Text] contentOrEmpty c = diff --git a/src/Codec/Xlsx/Parser/Internal/PivotTable.hs b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs --- a/src/Codec/Xlsx/Parser/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs @@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Codec.Xlsx.Parser.Internal.PivotTable ( - parsePivotTable +module Codec.Xlsx.Parser.Internal.PivotTable + ( parsePivotTable , parseCache -) where + ) where import Control.Applicative +import Control.Arrow ((&&&)) import Data.ByteString.Lazy (ByteString) import Data.Maybe (listToMaybe, maybeToList) import Data.Text (Text) @@ -18,7 +19,7 @@ import Codec.Xlsx.Types.PivotTable.Internal parsePivotTable - :: (CacheId -> Maybe (Text, Range, [PivotFieldName])) + :: (CacheId -> Maybe (Text, Range, [CacheField])) -> ByteString -> Maybe PivotTable parsePivotTable srcByCacheId bs = @@ -28,7 +29,7 @@ cacheId <- fromAttribute "cacheId" cur case srcByCacheId cacheId of Nothing -> fail "no such cache" - Just (_pvtSrcSheet, _pvtSrcRef, fieldNames) -> do + Just (_pvtSrcSheet, _pvtSrcRef, cacheFields) -> do _pvtDataCaption <- attribute "dataCaption" cur _pvtName <- attribute "name" cur _pvtLocation <- cur $/ element (n_ "location") >=> fromAttribute "ref" @@ -36,14 +37,21 @@ _pvtColumnGrandTotals <- fromAttributeDef "colGrandTotals" True cur _pvtOutline <- fromAttributeDef "outline" False cur _pvtOutlineData <- fromAttributeDef "outlineData" False cur - let nToField = zip [0 ..] fieldNames - outlines = - cur $/ element (n_ "pivotFields") &/ element (n_ "pivotField") >=> - fromAttributeDef "outline" True + let name2CacheField = map (cfName &&& id) cacheFields _pvtFields = - [ PivotFieldInfo {_pfiName = name, _pfiOutline = outline} - | (name, outline) <- zip fieldNames outlines - ] + cur $/ element (n_ "pivotFields") &/ element (n_ "pivotField") >=> \c -> do + _pfiName <- fromAttribute "name" c + _pfiSortType <- fromAttributeDef "sortType" FieldSortManual c + _pfiOutline <- fromAttributeDef "outline" True c + let hidden = + c $/ element (n_ "items") &/ element (n_ "item") >=> + attrValIs "h" True >=> fromAttribute "x" + items = maybe [] cfItems $ lookup _pfiName name2CacheField + _pfiHiddenItems = + [item | (n, item) <- zip [(0 :: Int) ..] items, n `elem` hidden] + return PivotFieldInfo {..} + nToFieldName = zip [0 ..] $ map _pfiName _pvtFields + fieldNameList fld = maybeToList $ lookup fld nToFieldName _pvtRowFields = cur $/ element (n_ "rowFields") &/ element (n_ "field") >=> fromAttribute "x" >=> fieldPosition @@ -53,7 +61,7 @@ _pvtDataFields = cur $/ element (n_ "dataFields") &/ element (n_ "dataField") >=> \c -> do fld <- fromAttribute "fld" c - _dfField <- maybeToList $ lookup fld nToField + _dfField <- fieldNameList fld -- TOFIX _dfName <- fromAttributeDef "name" "" c _dfFunction <- fromAttributeDef "subtotal" ConsolidateSum c @@ -61,17 +69,17 @@ fieldPosition :: Int -> [PositionedField] fieldPosition (-2) = return DataPosition fieldPosition n = - FieldPosition <$> maybeToList (lookup n nToField) + FieldPosition <$> fieldNameList n return PivotTable {..} -parseCache :: ByteString -> Maybe (Text, CellRef, [PivotFieldName]) +parseCache :: ByteString -> Maybe (Text, CellRef, [CacheField]) parseCache bs = listToMaybe . parse . fromDocument $ parseLBS_ def bs where parse cur = do (sheet, ref) <- cur $/ element (n_ "cacheSource") &/ element (n_ "worksheetSource") >=> liftA2 (,) <$> attribute "sheet" <*> fromAttribute "ref" - let fieldNames = + let fields = cur $/ element (n_ "cacheFields") &/ element (n_ "cacheField") >=> - fromAttribute "name" - return (sheet, ref, fieldNames) + fromCursor + return (sheet, ref, fields) diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -7,7 +7,7 @@ Xlsx(..) , Styles(..) , DefinedNames(..) - , ColumnsWidth(..) + , ColumnsProperties(..) , PageSetup(..) , Worksheet(..) , CellMap @@ -22,7 +22,7 @@ , xlDefinedNames , xlCustomProperties -- ** Worksheet - , wsColumns + , wsColumnsProperties , wsRowPropertiesMap , wsCells , wsDrawing @@ -36,10 +36,10 @@ , wsTables , wsProtection -- ** Cells - , cellValue - , cellStyle - , cellComment - , cellFormula + , Cell.cellValue + , Cell.cellStyle + , Cell.cellComment + , Cell.cellFormula -- * Style helpers , emptyStyles , renderStyleSheet @@ -61,14 +61,14 @@ import Data.List (groupBy) import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, isJust) import Data.Text (Text) -import Text.XML (Element (..), parseLBS, - renderLBS) +import Text.XML (parseLBS, renderLBS) import Text.XML.Cursor import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.AutoFilter as X +import Codec.Xlsx.Types.Cell as Cell import Codec.Xlsx.Types.Comment as X import Codec.Xlsx.Types.Common as X import Codec.Xlsx.Types.ConditionalFormatting as X @@ -86,83 +86,51 @@ import Codec.Xlsx.Types.Variant as X import Codec.Xlsx.Writer.Internal --- | Formula for the cell. --- --- TODO: array. dataTable and shared formula types support --- --- See 18.3.1.40 "f (Formula)" (p. 1636) -data CellFormula - = NormalCellFormula - { _cellfExpression :: Formula - , _cellfAssignsToName :: Bool - -- ^ Specifies that this formula assigns a value to a name. - , _cellfCalculate :: Bool - -- ^ Indicates that this formula needs to be recalculated - -- the next time calculation is performed. - -- [/Example/: This is always set on volatile functions, - -- like =RAND(), and circular references. /end example/] - } deriving (Eq, Show) - -simpleCellFormula :: Text -> CellFormula -simpleCellFormula expr = NormalCellFormula - { _cellfExpression = Formula expr - , _cellfAssignsToName = False - , _cellfCalculate = False - } - --- | Currently cell details include only cell values and style ids --- (e.g. formulas from @\@ and inline strings from @\@ --- subelements are ignored) -data Cell = Cell - { _cellStyle :: Maybe Int - , _cellValue :: Maybe CellValue - , _cellComment :: Maybe Comment - , _cellFormula :: Maybe CellFormula - } deriving (Eq, Show) - -makeLenses ''Cell - -instance Default Cell where - def = Cell Nothing Nothing Nothing Nothing - --- | Map containing cell values which are indexed by row and column --- if you need to use more traditional (x,y) indexing please you could --- use corresponding accessors from ''Codec.Xlsx.Lens'' -type CellMap = Map (Int, Int) Cell - data RowProperties = RowProps { rowHeight :: Maybe Double, rowStyle::Maybe Int} deriving (Read,Eq,Show,Ord) --- | Column range (from cwMin to cwMax) width -data ColumnsWidth = ColumnsWidth - { cwMin :: Int +-- | Column range (from cwMin to cwMax) properties +data ColumnsProperties = ColumnsProperties + { cpMin :: Int -- ^ First column affected by this 'ColumnWidth' record. - , cwMax :: Int + , cpMax :: Int -- ^ Last column affected by this 'ColumnWidth' record. - , cwWidth :: Double + , cpWidth :: Maybe Double -- ^ Column width measured as the number of characters of the -- maximum digit width of the numbers 0, 1, 2, ..., 9 as rendered in -- the normal style's font. -- -- See longer description in Section 18.3.1.13 "col (Column Width & -- Formatting)" (p. 1605) - , cwStyle :: Maybe Int + , cpStyle :: Maybe Int -- ^ Default style for the affected column(s). Affects cells not yet -- allocated in the column(s). In other words, this style applies -- to new columns. + , cpHidden :: Bool + -- ^ Flag indicating if the affected column(s) are hidden on this + -- worksheet. + , cpCollapsed :: Bool + -- ^ Flag indicating if the outlining of the affected column(s) is + -- in the collapsed state. + , cpBestFit :: Bool + -- ^ Flag indicating if the specified column(s) is set to 'best + -- fit'. } deriving (Eq, Show) -instance FromCursor ColumnsWidth where +instance FromCursor ColumnsProperties where fromCursor c = do - cwMin <- fromAttribute "min" c - cwMax <- fromAttribute "max" c - cwWidth <- fromAttribute "width" c - cwStyle <- maybeAttribute "style" c - return ColumnsWidth {..} + cpMin <- fromAttribute "min" c + cpMax <- fromAttribute "max" c + cpWidth <- maybeAttribute "width" c + cpStyle <- maybeAttribute "style" c + cpHidden <- fromAttributeDef "hidden" False c + cpCollapsed <- fromAttributeDef "collapsed" False c + cpBestFit <- fromAttributeDef "bestFit" False c + return ColumnsProperties {..} -- | Xlsx worksheet data Worksheet = Worksheet - { _wsColumns :: [ColumnsWidth] -- ^ column widths + { _wsColumnsProperties :: [ColumnsProperties] -- ^ column widths , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs , _wsDrawing :: Maybe Drawing -- ^ SpreadsheetML Drawing @@ -182,7 +150,7 @@ instance Default Worksheet where def = Worksheet - { _wsColumns = [] + { _wsColumnsProperties = [] , _wsRowPropertiesMap = M.empty , _wsCells = M.empty , _wsDrawing = Nothing @@ -282,32 +250,17 @@ where mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells -{------------------------------------------------------------------------------- - Parsing --------------------------------------------------------------------------------} -instance FromCursor CellFormula where - fromCursor cur = do - t <- fromAttributeDef "t" "normal" cur - typedCellFormula t cur - -typedCellFormula :: Text -> Cursor -> [CellFormula] -typedCellFormula "normal" cur = do - _cellfExpression <- fromCursor cur - _cellfAssignsToName <- fromAttributeDef "bx" False cur - _cellfCalculate <- fromAttributeDef "ca" False cur - return NormalCellFormula{..} -typedCellFormula _ _ = fail "parseable cell formula type was not found" - -{------------------------------------------------------------------------------- - Rendering --------------------------------------------------------------------------------} - -instance ToElement CellFormula where - toElement nm NormalCellFormula{..} = - let formulaEl = toElement nm _cellfExpression - in formulaEl - { elementAttributes = - M.fromList $ catMaybes [ "bx" .=? justTrue _cellfAssignsToName - , "ca" .=? justTrue _cellfCalculate ] - } +instance ToElement ColumnsProperties where + toElement nm ColumnsProperties {..} = leafElement nm attrs + where + attrs = + ["min" .= cpMin, "max" .= cpMax] ++ + catMaybes + [ "style" .=? (justNonDef 0 =<< cpStyle) + , "width" .=? cpWidth + , "customWidth" .=? justTrue (isJust cpWidth) + , "hidden" .=? justTrue cpHidden + , "collapsed" .=? justTrue cpCollapsed + , "bestFit" .=? justTrue cpBestFit + ] diff --git a/src/Codec/Xlsx/Types/Cell.hs b/src/Codec/Xlsx/Types/Cell.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Cell.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Codec.Xlsx.Types.Cell + ( CellFormula(..) + , simpleCellFormula + , Cell(..) + , cellStyle + , cellValue + , cellComment + , cellFormula + , CellMap + ) where + +import Control.Lens.TH (makeLenses) +import Data.Default +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Text.XML +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Comment +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Writer.Internal + +-- | Formula for the cell. +-- +-- TODO: array. dataTable and shared formula types support +-- +-- See 18.3.1.40 "f (Formula)" (p. 1636) +data CellFormula + = NormalCellFormula + { _cellfExpression :: Formula + , _cellfAssignsToName :: Bool + -- ^ Specifies that this formula assigns a value to a name. + , _cellfCalculate :: Bool + -- ^ Indicates that this formula needs to be recalculated + -- the next time calculation is performed. + -- [/Example/: This is always set on volatile functions, + -- like =RAND(), and circular references. /end example/] + } deriving (Eq, Show) + +simpleCellFormula :: Text -> CellFormula +simpleCellFormula expr = NormalCellFormula + { _cellfExpression = Formula expr + , _cellfAssignsToName = False + , _cellfCalculate = False + } + +-- | Currently cell details include cell values, style ids and cell +-- formulas (inline strings from @\@ subelements are ignored) +data Cell = Cell + { _cellStyle :: Maybe Int + , _cellValue :: Maybe CellValue + , _cellComment :: Maybe Comment + , _cellFormula :: Maybe CellFormula + } deriving (Eq, Show) + +instance Default Cell where + def = Cell Nothing Nothing Nothing Nothing + +makeLenses ''Cell + +-- | Map containing cell values which are indexed by row and column +-- if you need to use more traditional (x,y) indexing please you could +-- use corresponding accessors from ''Codec.Xlsx.Lens'' +type CellMap = Map (Int, Int) Cell + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor CellFormula where + fromCursor cur = do + t <- fromAttributeDef "t" "normal" cur + typedCellFormula t cur + +typedCellFormula :: Text -> Cursor -> [CellFormula] +typedCellFormula "normal" cur = do + _cellfExpression <- fromCursor cur + _cellfAssignsToName <- fromAttributeDef "bx" False cur + _cellfCalculate <- fromAttributeDef "ca" False cur + return NormalCellFormula {..} +typedCellFormula _ _ = fail "parseable cell formula type was not found" + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement CellFormula where + toElement nm NormalCellFormula {..} = + let formulaEl = toElement nm _cellfExpression + in formulaEl + { elementAttributes = + M.fromList $ + catMaybes + [ "bx" .=? justTrue _cellfAssignsToName + , "ca" .=? justTrue _cellfCalculate + ] + } diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -137,7 +137,6 @@ newtype Formula = Formula {unFormula :: Text} deriving (Eq, Ord, Show) - -- | Cell values include text, numbers and booleans, -- standard includes date format also but actually dates -- are represented by numbers with a date format assigned diff --git a/src/Codec/Xlsx/Types/Drawing.hs b/src/Codec/Xlsx/Types/Drawing.hs --- a/src/Codec/Xlsx/Types/Drawing.hs +++ b/src/Codec/Xlsx/Types/Drawing.hs @@ -122,7 +122,7 @@ { _spXfrm = Nothing , _spGeometry = Nothing , _spFill = Just NoFill - , _spOutline = Just $ LineProperties (Just NoFill) + , _spOutline = Just $ def {_lnFill = Just NoFill} } -- | helper to retrive information about all picture files in diff --git a/src/Codec/Xlsx/Types/Drawing/Chart.hs b/src/Codec/Xlsx/Types/Drawing/Chart.hs --- a/src/Codec/Xlsx/Types/Drawing/Chart.hs +++ b/src/Codec/Xlsx/Types/Drawing/Chart.hs @@ -1,22 +1,24 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} 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 +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 +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 +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Drawing.Common +import Codec.Xlsx.Writer.Internal -- | Main Chart holder, combines -- TODO: title, autoTitleDeleted, pivotFmts @@ -75,18 +77,31 @@ -- | Specific Chart -- TODO: --- areaChart, area3DChart, line3DChart, stockChart, radarChart, scatterChart, --- pieChart, pie3DChart, doughnutChart, barChart, bar3DChart, ofPieChart, +-- area3DChart, line3DChart, stockChart, radarChart, +-- pie3DChart, doughnutChart, bar3DChart, ofPieChart, -- surfaceChart, surface3DChart, bubbleChart -data Chart = LineChart - { _lnchGrouping :: ChartGrouping - , _lnchSeries :: [LineSeries] - , _lnchMarker :: Maybe Bool - -- ^ specifies that the marker shall be shown - , _lnchSmooth :: Maybe Bool - -- ^ specifies the line connecting the points on the chart shall be - -- smoothed using Catmull-Rom splines - } deriving (Eq, Show) +data Chart + = LineChart { _lnchGrouping :: ChartGrouping + , _lnchSeries :: [LineSeries] + , _lnchMarker :: Maybe Bool + -- ^ specifies that the marker shall be shown + , _lnchSmooth :: Maybe Bool + -- ^ specifies the line connecting the points on the chart shall be + -- smoothed using Catmull-Rom splines + } + | 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) -- | Possible groupings for a bar chart -- @@ -103,6 +118,40 @@ -- axis. deriving (Eq, Show) +-- | Possible directions for a bar chart +-- +-- See 21.2.3.3 "ST_BarDir (Bar Direction)" (p. 3441) +data BarDirection + = DirectionBar + | DirectionColumn + deriving (Eq, Show) + +-- | Possible styles of scatter chart +-- +-- /Note:/ It appears that even for 'ScatterMarker' style Exel draws a +-- line between chart points if otline fill for '_scserShared' isn't +-- set to so it's not quite clear how could Excel use this property +-- +-- See 21.2.3.40 "ST_ScatterStyle (Scatter Style)" (p. 3455) +data ScatterStyle + = ScatterNone + | ScatterLine + | ScatterLineMarker + | ScatterMarker + | ScatterSmooth + | ScatterSmoothMarker + deriving (Eq, Show) + +-- | Single data point options +-- +-- TODO: invertIfNegative, bubble3D, explosion, pictureOptions, extLst +-- +-- See 21.2.2.52 "dPt (Data Point)" (p. 3384) +data DataPoint = DataPoint + { _dpMarker :: Maybe DataMarker + , _dpShapeProperties :: Maybe ShapeProperties + } deriving (Eq, Show) + -- | Specifies common series options -- TODO: spPr -- @@ -111,6 +160,7 @@ { _serTx :: Maybe Formula -- ^ specifies text for a series name, without rich text formatting -- currently only reference formula is supported + , _serShapeProperties :: Maybe ShapeProperties } deriving (Eq, Show) -- | A series on a line chart @@ -127,6 +177,57 @@ , _lnserSmooth :: Maybe Bool } deriving (Eq, Show) +-- | A series on an area chart +-- +-- TODO: pictureOptions, dPt, trendline, errBars, cat, extLst +-- +-- See @CT_AreaSer@ (p. 4065) +data AreaSeries = AreaSeries + { _arserShared :: Series + , _arserDataLblProps :: Maybe DataLblProps + , _arserVal :: Maybe Formula + } deriving (Eq, Show) + +-- | A series on a bar chart +-- +-- TODO: invertIfNegative, pictureOptions, dPt, trendline, errBars, +-- cat, shape, extLst +-- +-- See @CT_BarSer@ (p. 4064) +data BarSeries = BarSeries + { _brserShared :: Series + , _brserDataLblProps :: Maybe DataLblProps + , _brserVal :: Maybe Formula + } deriving (Eq, Show) + +-- | A series on a pie chart +-- +-- TODO: explosion, cat, extLst +-- +-- See @CT_PieSer@ (p. 4065) +data PieSeries = PieSeries + { _piserShared :: Series + , _piserDataPoints :: [DataPoint] + -- ^ normally you should set fill for chart datapoints to make them + -- properly colored + , _piserDataLblProps :: Maybe DataLblProps + , _piserVal :: Maybe Formula + } deriving (Eq, Show) + +-- | A series on a scatter chart +-- +-- TODO: dPt, trendline, errBars, smooth, extLst +-- +-- See @CT_ScatterSer@ (p. 4064) +data ScatterSeries = ScatterSeries + { _scserShared :: Series + , _scserMarker :: Maybe DataMarker + , _scserDataLblProps :: Maybe DataLblProps + , _scserXVal :: Maybe Formula + , _scserYVal :: Maybe Formula + , _scserSmooth :: Maybe Bool + } deriving (Eq, Show) + -- See @CT_Marker@ (p. 4061) data DataMarker = DataMarker { _dmrkSymbol :: Maybe DataMarkerSymbol @@ -177,7 +278,16 @@ -- ^ (Outside) Specifies the tick marks shall be outside the plot area. deriving (Eq, Show) +makeLenses ''DataPoint + {------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default DataPoint where + def = DataPoint Nothing Nothing + +{------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -200,6 +310,22 @@ _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 @@ -215,12 +341,55 @@ _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 {..} + -- should we respect idx and order? 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 @@ -229,6 +398,12 @@ _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 @@ -244,6 +419,20 @@ 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 @@ -305,7 +494,7 @@ where -- no such element gives a chart space with rounded corners nonRounded = elementValue "roundedCorners" False - chSpPr = toElement "spPr" $ def {_spFill = Just SolidFill} + chSpPr = toElement "spPr" $ def {_spFill = Just $ solidRgb "ffffff"} chartEl = elementListSimple "chart" elements elements = catMaybes @@ -317,90 +506,147 @@ , elementValue "plotVisOnly" <$> _chspPlotVisOnly , elementValue "dispBlanksAs" <$> _chspDispBlanksAs ] - -- we reserve 2 axes - X and Y for line charts - -- this needs to be reworked when other chart types will be added - 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 } + 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) -chartToElement :: Chart -> Int -> Int -> Element -chartToElement LineChart {..} cId vId = elementListSimple "lineChart" elements +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 - elements = - (grouping : varyColors : series) ++ - catMaybes - [ elementValue "marker" <$> _lnchMarker - , elementValue "smooth" <$> _lnchSmooth - ] ++ - map (elementValue "axId") [cId, vId] - grouping = elementValue "grouping" _lnchGrouping + 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) -- no element seems to be equal to varyColors=true in Excel Online varyColors = elementValue "varyColors" False - series = [indexedSeriesEl i s | (i, s) <- zip [0 ..] _lnchSeries] - indexedSeriesEl :: Int -> LineSeries -> Element + 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 {..} = serEl - { elementNodes = elementNodes serEl ++ - map NodeElement elements } + toElement nm LineSeries {..} = simpleSeries nm _lnserShared _lnserVal pr ap where - serEl = toElement nm _lnserShared - elements = + pr = catMaybes [ toElement "marker" <$> _lnserMarker , toElement "dLbls" <$> _lnserDataLblProps - , Just $ valEl _lnserVal - , elementValue "smooth" <$> _lnserSmooth ] - valEl v = - elementListSimple - "val" - [elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)] + 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 @@ -436,15 +682,56 @@ , 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)] + -- should we respect idx and order? instance ToElement Series where toElement nm Series {..} = - elementListSimple - nm - [ elementListSimple - "tx" - [elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)] - ] + elementListSimple nm $ + [ elementListSimple + "tx" + [elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)] + ] ++ + maybeToList (toElement "spPr" <$> _serShapeProperties) instance ToElement ChartTitle where toElement nm (ChartTitle body) = @@ -459,10 +746,10 @@ , elementValue "overlay" <$>_legendOverlay] instance ToAttrVal LegendPos where - toAttrVal LegendBottom = "b" - toAttrVal LegendLeft = "l" - toAttrVal LegendRight = "r" - toAttrVal LegendTop = "t" + toAttrVal LegendBottom = "b" + toAttrVal LegendLeft = "l" + toAttrVal LegendRight = "r" + toAttrVal LegendTop = "t" toAttrVal LegendTopRight = "tr" instance ToAttrVal DispBlanksAs where diff --git a/src/Codec/Xlsx/Types/Drawing/Common.hs b/src/Codec/Xlsx/Types/Drawing/Common.hs --- a/src/Codec/Xlsx/Types/Drawing/Common.hs +++ b/src/Codec/Xlsx/Types/Drawing/Common.hs @@ -1,25 +1,27 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types.Drawing.Common where -import Control.Arrow (first) -import Control.Monad (join) -import Data.Default -import Data.Maybe (catMaybes, listToMaybe) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as T -import Text.XML -import Text.XML.Cursor +import Control.Arrow (first) +import Control.Lens.TH +import Control.Monad (join) +import Data.Default +import Data.Maybe (catMaybes, listToMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Text.XML +import Text.XML.Cursor #if !MIN_VERSION_base(4,8,0) -import Control.Applicative +import Control.Applicative #endif -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal -- | This simple type represents an angle in 60,000ths of a degree. -- Positive angles are clockwise (i.e., towards the positive y axis); negative @@ -251,23 +253,50 @@ -- TODO: bwMode, a_EG_EffectProperties, scene3d, sp3d, extLst } deriving (Eq, Show) +-- | Specifies an outline style that can be applied to a number of +-- different objects such as shapes and text. +-- +-- TODO: cap, cmpd, algn, a_EG_LineDashProperties, +-- a_EG_LineJoinProperties, headEnd, tailEnd, extLst +-- -- See 20.1.2.2.24 "ln (Outline)" (p. 2744) data LineProperties = LineProperties { _lnFill :: Maybe FillProperties - -- TODO: w, cap, cmpd, algn, a_EG_LineDashProperties, - -- a_EG_LineJoinProperties, headEnd, tailEnd, extLst + , _lnWidth :: Int + -- ^ Specifies the width to be used for the underline stroke. The + -- value is in EMU, is greater of equal to 0 and maximum value is + -- 20116800. } deriving (Eq, Show) +-- | Color choice for some drawing element +-- +-- TODO: scrgbClr, hslClr, sysClr, schemeClr, prstClr +-- +-- See @EG_ColorChoice@ (p. 3996) +data ColorChoice = + RgbColor Text + -- ^ Specifies a color using the red, green, blue RGB color + -- model. Red, green, and blue is expressed as sequence of hex + -- digits, RRGGBB. A perceptual gamma of 2.2 is used. + -- + -- See 20.1.2.3.32 "srgbClr (RGB Color Model - Hex Variant)" (p. 2773) + deriving (Eq, Show) + -- TODO: gradFill, pattFill data FillProperties = NoFill -- ^ See 20.1.8.44 "noFill (No Fill)" (p. 2872) - | SolidFill + | SolidFill (Maybe ColorChoice) -- ^ Solid fill - -- TODO: colors -- See 20.1.8.54 "solidFill (Solid Fill)" (p. 2879) deriving (Eq, Show) +-- | solid fill with color specified by hexadecimal RGB color +solidRgb :: Text -> FillProperties +solidRgb t = SolidFill . Just $ RgbColor t + +makeLenses ''ShapeProperties + {------------------------------------------------------------------------------- Default instances -------------------------------------------------------------------------------} @@ -275,6 +304,9 @@ instance Default ShapeProperties where def = ShapeProperties Nothing Nothing Nothing Nothing +instance Default LineProperties where + def = LineProperties Nothing 0 + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -376,6 +408,7 @@ instance FromCursor LineProperties where fromCursor cur = do let _lnFill = listToMaybe $ cur $/ anyElement >=> fromCursor + _lnWidth <- fromAttributeDef "w" 0 cur return LineProperties{..} instance FromCursor Point2D where @@ -394,10 +427,21 @@ fromCursor = fillPropsFromNode . node fillPropsFromNode :: Node -> [FillProperties] -fillPropsFromNode n | n `nodeElNameIs` a_ "noFill" = return NoFill - | n `nodeElNameIs` a_ "solidFill" = return SolidFill - | otherwise = fail "no matching line fill node" +fillPropsFromNode n + | n `nodeElNameIs` a_ "noFill" = return NoFill + | n `nodeElNameIs` a_ "solidFill" = do + let color = + listToMaybe $ fromNode n $/ anyElement >=> colorChoiceFromNode . node + return $ SolidFill color + | otherwise = fail "no matching line fill node" +colorChoiceFromNode :: Node -> [ColorChoice] +colorChoiceFromNode n + | n `nodeElNameIs` a_ "srgbClr" = do + val <- fromAttribute "val" $ fromNode n + return $ RgbColor val + | otherwise = fail "no matching color choice node" + coordinate :: Monad m => Text -> m Coordinate coordinate t = case T.decimal t of Right (d, leftover) | leftover == T.empty -> @@ -531,12 +575,19 @@ leafElement (a_ "prstGeom") ["prst" .= ("rect" :: Text)] instance ToElement LineProperties where - toElement nm LineProperties{..} = - elementListSimple nm $ catMaybes [ fillPropsToElement <$> _lnFill ] + toElement nm LineProperties {..} = elementList nm attrs elements + where + attrs = catMaybes ["w" .=? justNonDef 0 _lnWidth] + elements = catMaybes [fillPropsToElement <$> _lnFill] fillPropsToElement :: FillProperties -> Element fillPropsToElement NoFill = emptyElement (a_ "noFill") -fillPropsToElement SolidFill = emptyElement (a_ "solidFill") +fillPropsToElement (SolidFill color) = + elementListSimple (a_ "solidFill") $ catMaybes [colorChoiceToElement <$> color] + +colorChoiceToElement :: ColorChoice -> Element +colorChoiceToElement (RgbColor color) = + leafElement (a_ "srgbClr") ["val" .= color] -- | Add DrawingML namespace to name a_ :: Text -> Name diff --git a/src/Codec/Xlsx/Types/PivotTable.hs b/src/Codec/Xlsx/Types/PivotTable.hs --- a/src/Codec/Xlsx/Types/PivotTable.hs +++ b/src/Codec/Xlsx/Types/PivotTable.hs @@ -4,6 +4,7 @@ ( PivotTable(..) , PivotFieldName(..) , PivotFieldInfo(..) + , FieldSortType(..) , PositionedField(..) , DataField(..) , ConsolidateFunction(..) @@ -35,8 +36,19 @@ data PivotFieldInfo = PivotFieldInfo { _pfiName :: PivotFieldName , _pfiOutline :: Bool + , _pfiSortType :: FieldSortType + , _pfiHiddenItems :: [CellValue] } deriving (Eq, Show) +-- | Sort orders that can be applied to fields in a PivotTable +-- +-- See 18.18.28 "ST_FieldSortType (Field Sort Type)" (p. 2454) +data FieldSortType + = FieldSortAscending + | FieldSortDescending + | FieldSortManual + deriving (Eq, Ord, Show) + newtype PivotFieldName = PivotFieldName Text deriving (Eq, Ord, Show) @@ -109,6 +121,11 @@ instance ToAttrVal PivotFieldName where toAttrVal (PivotFieldName n) = toAttrVal n +instance ToAttrVal FieldSortType where + toAttrVal FieldSortManual = "manual" + toAttrVal FieldSortAscending = "ascending" + toAttrVal FieldSortDescending = "descending" + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -129,3 +146,9 @@ instance FromAttrVal PivotFieldName where fromAttrVal = fmap (first PivotFieldName) . fromAttrVal + +instance FromAttrVal FieldSortType where + fromAttrVal "manual" = readSuccess FieldSortManual + fromAttrVal "ascending" = readSuccess FieldSortAscending + fromAttrVal "descending" = readSuccess FieldSortDescending + fromAttrVal t = invalidText "FieldSortType" t diff --git a/src/Codec/Xlsx/Types/PivotTable/Internal.hs b/src/Codec/Xlsx/Types/PivotTable/Internal.hs --- a/src/Codec/Xlsx/Types/PivotTable/Internal.hs +++ b/src/Codec/Xlsx/Types/PivotTable/Internal.hs @@ -1,16 +1,79 @@ -module Codec.Xlsx.Types.PivotTable.Internal ( - CacheId(..) -) where +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Types.PivotTable.Internal + ( CacheId(..) + , CacheField(..) + ) where import Control.Arrow (first) +import Data.Maybe (catMaybes) +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.PivotTable +import Codec.Xlsx.Writer.Internal newtype CacheId = CacheId Int deriving Eq +data CacheField = CacheField + { cfName :: PivotFieldName + , cfItems :: [CellValue] + } deriving (Eq, Show) + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} instance FromAttrVal CacheId where fromAttrVal = fmap (first CacheId) . fromAttrVal + +instance FromCursor CacheField where + fromCursor cur = do + cfName <- fromAttribute "name" cur + let cfItems = + cur $/ element (n_ "sharedItems") &/ anyElement >=> + cellValueFromNode . node + return CacheField {..} + +cellValueFromNode :: Node -> [CellValue] +cellValueFromNode n + | n `nodeElNameIs` (n_ "s") = CellText <$> attributeV + | n `nodeElNameIs` (n_ "n") = CellDouble <$> attributeV + | otherwise = fail "no matching shared item" + where + cur = fromNode n + attributeV :: FromAttrVal a => [a] + attributeV = fromAttribute "v" cur + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement CacheField where + toElement nm CacheField {..} = + elementList nm ["name" .= cfName] [sharedItems] + where + sharedItems = elementList "sharedItems" typeAttrs $ map cvToItem cfItems + cvToItem (CellText t) = leafElement "s" ["v" .= t] + cvToItem (CellDouble n) = leafElement "n" ["v" .= n] + cvToItem _ = error "Only string and number values are currently supported" + typeAttrs = + catMaybes + [ "containsNumber" .=? justTrue containsNumber + , "containsString" .=? justFalse containsString + , "containsSemiMixedTypes" .=? justFalse containsString + , "containsMixedTypes" .=? justTrue (containsNumber && containsString) + ] + containsNumber = any isNumber cfItems + isNumber (CellDouble _) = True + isNumber _ = False + containsString = any isString cfItems + isString (CellText _) = True + isString _ = False diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs --- a/src/Codec/Xlsx/Writer.hs +++ b/src/Codec/Xlsx/Writer.hs @@ -116,7 +116,7 @@ elementListSimple "worksheet" rootEls rootEls = catMaybes $ [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews - , nonEmptyElListSimple "cols" . map cwEl $ ws ^. wsColumns + , nonEmptyElListSimple "cols" . map (toElement "col") $ ws ^. wsColumnsProperties , Just . elementListSimple "sheetData" $ sheetDataXml cells (ws ^. wsRowPropertiesMap) , toElement "sheetProtection" <$> (ws ^. wsProtection) , toElement "autoFilter" <$> (ws ^. wsAutoFilter) @@ -131,10 +131,6 @@ ] cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings dvPairs = map DvPair . M.toList $ ws ^. wsDataValidations - cwEl cw = - leafElement "col" $ - ["min" .= cwMin cw, "max" .= cwMax cw, "width" .= cwWidth cw] ++ - catMaybes ["style" .=? (justNonDef 0 =<< cwStyle cw)] mergeE1 r = leafElement "mergeCell" [("ref" .= r)] sheetRels = if null referencedFiles @@ -301,8 +297,8 @@ , pvgOthers :: [FileData] } -generatePivotFiles :: [[PivotTable]] -> PvGenerated -generatePivotFiles tables = PvGenerated cacheFiles shTableFiles others +generatePivotFiles :: [(CellMap, [PivotTable])] -> PvGenerated +generatePivotFiles cmTables = PvGenerated cacheFiles shTableFiles others where cacheFiles = [cacheFile | (cacheFile, _, _) <- flatRendered] shTableFiles = map (map (\(_, tableFile, _) -> tableFile)) rendered @@ -311,11 +307,11 @@ flatRendered = concat rendered (_, rendered) = mapAccumL - (\c ts -> mapAccumL (\c' t -> (c' + 1, render c' t)) c ts) + (\c (cm, ts) -> mapAccumL (\c' t -> (c' + 1, render cm c' t)) c ts) firstCacheId - tables - render cacheIdRaw tbl = - let PivotTableFiles {..} = renderPivotTableFiles cacheIdRaw tbl + cmTables + render cm cacheIdRaw tbl = + let PivotTableFiles {..} = renderPivotTableFiles cm cacheIdRaw tbl cacheId = CacheId cacheIdRaw cacheIdStr = show cacheIdRaw cachePath = @@ -451,11 +447,14 @@ let style = (stRId, FileData "xl/styles.xml" (smlCT "styles") "styles" $ unStyles (xlsx ^. xlStyles)) - let PvGenerated - {pvgCacheFiles=cacheIdFiles, - pvgOthers=pivotOtherFiles, - pvgSheetTableFiles=sheetPivotTables} = - generatePivotFiles (xlsx ^. xlSheets . to (map (^. _2 . wsPivotTables))) + let PvGenerated { pvgCacheFiles = cacheIdFiles + , pvgOthers = pivotOtherFiles + , pvgSheetTableFiles = sheetPivotTables + } = + generatePivotFiles + [ (_wsCells, _wsPivotTables) + | (_, Worksheet {..}) <- xlsx ^. xlSheets + ] sheetCells = map (transformSheetData shared) sheets sheetInputs = zip3 sheetCells sheetPivotTables sheets tblIdRef <- newSTRef 1 diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs --- a/src/Codec/Xlsx/Writer/Internal.hs +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -136,7 +136,7 @@ instance ToAttrVal String where toAttrVal = fromString instance ToAttrVal Int where toAttrVal = txti instance ToAttrVal Integer where toAttrVal = txti -instance ToAttrVal Double where toAttrVal = fromString . show +instance ToAttrVal Double where toAttrVal = txtd instance ToAttrVal Bool where toAttrVal True = "1" diff --git a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs --- a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs @@ -6,14 +6,17 @@ ) where import Data.ByteString.Lazy (ByteString) +import Data.List.Extra (nubOrd) import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Text (Text) import Safe (fromJustNote) import Text.XML import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.PivotTable +import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Writer.Internal data PivotTableFiles = PivotTableFiles @@ -21,30 +24,26 @@ , pvtfCacheDefinition :: ByteString } deriving (Eq, Show) -newtype CacheField = - CacheField Text - deriving (Eq, Show) - data CacheDefinition = CacheDefinition { cdSourceRef :: CellRef , cdSourceSheet :: Text , cdFields :: [CacheField] } deriving (Eq, Show) -renderPivotTableFiles :: Int -> PivotTable -> PivotTableFiles -renderPivotTableFiles cacheId t = PivotTableFiles {..} +renderPivotTableFiles :: CellMap -> Int -> PivotTable -> PivotTableFiles +renderPivotTableFiles cm cacheId t = PivotTableFiles {..} where - pvtfTable = renderLBS def $ ptDefinitionDocument cacheId t - cacheDefinition = generateCache t - pvtfCacheDefinition = renderLBS def $ toDocument cacheDefinition + pvtfTable = renderLBS def $ ptDefinitionDocument cacheId cache t + cache = generateCache cm t + pvtfCacheDefinition = renderLBS def $ toDocument cache -ptDefinitionDocument :: Int -> PivotTable -> Document -ptDefinitionDocument cacheId t = +ptDefinitionDocument :: Int -> CacheDefinition -> PivotTable -> Document +ptDefinitionDocument cacheId cache t = documentFromElement "Pivot table generated by xlsx" $ - ptDefinitionElement "pivotTableDefinition" cacheId t + ptDefinitionElement "pivotTableDefinition" cacheId cache t -ptDefinitionElement :: Name -> Int -> PivotTable -> Element -ptDefinitionElement nm cacheId PivotTable {..} = +ptDefinitionElement :: Name -> Int -> CacheDefinition -> PivotTable -> Element +ptDefinitionElement nm cacheId cache PivotTable {..} = elementList nm attrs elements where attrs = @@ -52,7 +51,7 @@ [ "colGrandTotals" .=? justFalse _pvtColumnGrandTotals , "rowGrandTotals" .=? justFalse _pvtRowGrandTotals , "outline" .=? justTrue _pvtOutline - , "outlineData" .=? justTrue _pvtOutlineData + , "outlineData" .=? justTrue _pvtOutlineData ] ++ [ "name" .= _pvtName , "dataCaption" .= _pvtDataCaption @@ -71,13 +70,16 @@ ] name2x = M.fromList $ zip (map _pfiName _pvtFields) [0 ..] mapFieldToX f = fromJustNote "no field" $ M.lookup f name2x - pivotFields = - elementListSimple "pivotFields" $ map pFieldEl _pvtFields - pFieldEl PivotFieldInfo{_pfiName=fName, _pfiOutline=outline} + pivotFields = elementListSimple "pivotFields" $ map pFieldEl _pvtFields + pFieldEl PivotFieldInfo { _pfiName = fName + , _pfiOutline = outline + , _pfiSortType = sortType + , _pfiHiddenItems = hidden + } | FieldPosition fName `elem` _pvtRowFields = - pFieldEl' fName outline ("axisRow" :: Text) + pFieldEl' fName outline ("axisRow" :: Text) hidden sortType | FieldPosition fName `elem` _pvtColumnFields = - pFieldEl' fName outline ("axisCol" :: Text) + pFieldEl' fName outline ("axisCol" :: Text) hidden sortType | otherwise = leafElement "pivotField" @@ -86,17 +88,28 @@ , "showAll" .= False , "outline" .= outline ] - pFieldEl' fName outline axis = + pFieldEl' fName outline axis hidden sortType = elementList "pivotField" - [ "name" .= fName - , "axis" .= axis - , "showAll" .= False - , "outline" .= outline - ] + ([ "name" .= fName + , "axis" .= axis + , "showAll" .= False + , "outline" .= outline + ] ++ + catMaybes ["sortType" .=? justNonDef FieldSortManual sortType]) [ elementListSimple "items" $ + items fName hidden ++ [leafElement "item" ["t" .= ("default" :: Text)]] ] + items fName hidden = + [ itemEl x item hidden + | (x, item) <- zip [0 ..] . fromMaybe [] $ M.lookup fName cachedItems + ] + itemEl x item hidden = + leafElement "item" $ + ["x" .= (x :: Int)] ++ catMaybes ["h" .=? justTrue (item `elem` hidden)] + cachedItems = + M.fromList $ [(cfName, cfItems) | CacheField {..} <- cdFields cache] rowFields = elementListSimple "rowFields" . map fieldEl $ if length _pvtDataFields > 1 @@ -115,8 +128,8 @@ , "subtotal" .=? justNonDef ConsolidateSum _dfFunction ] -generateCache :: PivotTable -> CacheDefinition -generateCache PivotTable {..} = +generateCache :: CellMap -> PivotTable -> CacheDefinition +generateCache cm PivotTable {..} = CacheDefinition { cdSourceRef = _pvtSrcRef , cdSourceSheet = _pvtSrcSheet @@ -124,7 +137,22 @@ } where cachedFields = map (cache . _pfiName) _pvtFields - cache (PivotFieldName name) = CacheField name + cache name = + CacheField + { cfName = name + , cfItems = + fromJustNote "specified pivot table field does not exist" $ + M.lookup name itemsByName + } + ((r1, c1), (r2, c2)) = + fromJustNote "Invalid src ref of pivot table " $ fromRange _pvtSrcRef + getCellValue ix = M.lookup ix cm >>= _cellValue + itemsByName = + M.fromList $ + flip mapMaybe [c1 .. c2] $ \c -> do + CellText nm <- getCellValue (r1, c) + let values = mapMaybe (\r -> getCellValue (r, c)) [(r1 + 1) .. r2] + return (PivotFieldName nm, nubOrd values) instance ToDocument CacheDefinition where toDocument = @@ -146,7 +174,3 @@ ] cacheFields = elementListSimple "cacheFields" $ map (toElement "cacheField") cdFields - -instance ToElement CacheField where - toElement nm (CacheField fieldName) = leafElement nm ["name" .= fieldName] - diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -0,0 +1,11 @@ +module Common + ( parseBS + ) where +import Data.ByteString.Lazy (ByteString) +import Text.XML +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal + +parseBS :: FromCursor a => ByteString -> [a] +parseBS = fromCursor . fromDocument . parseLBS_ def diff --git a/test/DataTest.hs b/test/DataTest.hs deleted file mode 100644 --- a/test/DataTest.hs +++ /dev/null @@ -1,873 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -module Main (main) where - -import Control.Lens -import Control.Monad.State.Lazy -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LB -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.Vector as V -import Text.RawString.QQ -import Text.XML -import Text.XML.Cursor - -import Test.Tasty (defaultMain, - testGroup) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.SmallCheck (testProperty) - -import Test.SmallCheck.Series (Positive (..)) -import Test.Tasty.HUnit (HUnitFailure (..), - (@=?)) - -import Codec.Xlsx -import Codec.Xlsx.Formatted -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Parser.Internal.PivotTable -import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Types.Internal.CommentTable -import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties -import Codec.Xlsx.Types.Internal.SharedStringTable -import Codec.Xlsx.Types.PivotTable.Internal -import Codec.Xlsx.Types.StyleSheet -import Codec.Xlsx.Writer.Internal -import Codec.Xlsx.Writer.Internal.PivotTable - -import Diff - -main :: IO () -main = defaultMain $ - testGroup "Tests" - [ testProperty "col2int . int2col == id" $ - \(Positive i) -> i == col2int (int2col i) - , testCase "write . read == id" $ do - let bs = fromXlsx testTime testXlsx - LB.writeFile "data-test.xlsx" bs - testXlsx @==? toXlsx (fromXlsx testTime testXlsx) - , testCase "fromRows . toRows == id" $ - testCellMap1 @=? fromRows (toRows testCellMap1) - , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $ - testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet)) - , testCase "correct shared strings parsing" $ - [testSharedStringTable] @=? parseBS testStrings - , testCase "correct shared strings parsing even when one of the shared strings entry is just " $ - [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty - , testCase "correct comments parsing" $ - [testCommentTable] @=? parseBS testComments - , testCase "correct drawing parsing" $ - [testDrawing] @==? parseBS testDrawingFile - , testCase "write . read == id for Drawings" $ - [testDrawing] @==? parseBS testWrittenDrawing - , testCase "correct chart parsing" $ - [testChartSpace] @==? parseBS testChartFile - , testCase "write . read == id for Charts" $ - [testChartSpace] @==? parseBS testWrittenChartSpace - , testCase "correct custom properties parsing" $ - [testCustomProperties] @==? parseBS testCustomPropertiesXml - , testCase "proper results from `formatted`" $ - testFormattedResult @==? testRunFormatted - , testCase "formatted . toFormattedCells = id" $ do - let fmtd = formatted testFormattedCells minimalStyleSheet - testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd) - (formattedStyleSheet fmtd) - , testCase "proper results from `conditionalltyFormatted`" $ - testCondFormattedResult @==? testRunCondFormatted - , testCase "toXlsxEither: properly formatted" $ - Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) - , testCase "toXlsxEither: invalid format" $ - Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file" - , testCase "proper pivot table rendering" $ do - let ptFiles = renderPivotTableFiles 3 testPivotTable - parseLBS_ def (pvtfTable ptFiles) @==? - stripContentSpaces (parseLBS_ def testPivotTableDefinition) - parseLBS_ def (pvtfCacheDefinition ptFiles) @==? - stripContentSpaces (parseLBS_ def testPivotCacheDefinition) - , testCase "proper pivot table parsing" $ do - let sheetName = "Sheet1" - ref = CellRef "A1:D5" - fields = - [ PivotFieldName "Color" - , PivotFieldName "Year" - , PivotFieldName "Price" - , PivotFieldName "Count" - ] - forCacheId (CacheId 3) = Just (sheetName, ref, fields) - forCacheId _ = Nothing - Just (sheetName, ref, fields) @==? parseCache testPivotCacheDefinition - Just testPivotTable @==? parsePivotTable forCacheId testPivotTableDefinition - ] - -parseBS :: FromCursor a => ByteString -> [a] -parseBS = fromCursor . fromDocument . parseLBS_ def - -testXlsx :: Xlsx -testXlsx = Xlsx sheets minimalStyles definedNames customProperties - where - sheets = - [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)] - sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges - sheetViews pageSetup cFormatting validations [] (Just autoFilter) tables (Just protection) - autoFilter = def & afRef ?~ CellRef "A1:E10" - & afFilterColumns .~ fCols - fCols = M.fromList [ (1, Filters ["a","b","ZZZ"]) - , (2, CustomFiltersAnd (CustomFilter FltrGreaterThanOrEqual "0") - (CustomFilter FltrLessThan "42"))] - tables = - [ Table - { tblName = "Table1" - , tblDisplayName = "Table1" - , tblRef = CellRef "A3" - , tblColumns = [TableColumn "another text"] - , tblAutoFilter = Just (def & afRef ?~ CellRef "A3") - } - ] - protection = - fullSheetProtection - { _sprScenarios = False - , _sprLegacyPassword = Just $ legacyPassword "hard password" - } - sheet2 = def & wsCells .~ testCellMap2 - pvSheet = sheetWithPvCells & wsPivotTables .~ [testPivotTable] - sheetWithPvCells = flip execState def $ do - forM_ (zip [1..] ["Color", "Year", "Price", "Count"]) $ \(c, n) -> - cellValueAt (1, c) ?= CellText n - cellValueAt (2, 1) ?= CellText "brown" - cellValueAt (2, 2) ?= CellDouble 2016 - cellValueAt (2, 3) ?= CellDouble 12.34 - cellValueAt (2, 4) ?= CellDouble 42 - rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] - cols = [ColumnsWidth 1 10 15 (Just 1)] - drawing = Just $ testDrawing { _xdrAnchors = map resolve $ _xdrAnchors testDrawing } - resolve :: Anchor RefId RefId -> Anchor FileInfo ChartSpace - resolve Anchor {..} = - let obj = - case _anchObject of - Picture {..} -> - let picBlipFill = (_picBlipFill & bfpImageInfo ?~ fileInfo) - in Picture - { _picMacro = _picMacro - , _picPublished = _picPublished - , _picNonVisual = _picNonVisual - , _picBlipFill = picBlipFill - , _picShapeProperties = _picShapeProperties - } - Graphic nv _ tr -> - Graphic nv testChartSpace tr - in Anchor - { _anchAnchoring = _anchAnchoring - , _anchObject = obj - , _anchClientData = _anchClientData - } - fileInfo = FileInfo "dummy.png" "image/png" "fake contents" - ranges = [mkRange (1,1) (1,2), mkRange (2,2) (10, 5)] - minimalStyles = renderStyleSheet minimalStyleSheet - definedNames = DefinedNames [("SampleName", Nothing, "A10:A20")] - sheetViews = Just [sheetView1, sheetView2] - sheetView1 = def & sheetViewRightToLeft ?~ True - & sheetViewTopLeftCell ?~ CellRef "B5" - sheetView2 = def & sheetViewType ?~ SheetViewTypePageBreakPreview - & sheetViewWorkbookViewId .~ 5 - & sheetViewSelection .~ [ def & selectionActiveCell ?~ CellRef "C2" - & selectionPane ?~ PaneTypeBottomRight - , def & selectionActiveCellId ?~ 1 - & selectionSqref ?~ SqRef [ CellRef "A3:A10" - , CellRef "B1:G3"] - ] - pageSetup = Just $ def & pageSetupBlackAndWhite ?~ True - & pageSetupCopies ?~ 2 - & pageSetupErrors ?~ PrintErrorsDash - & pageSetupPaperSize ?~ PaperA4 - customProperties = M.fromList [("some_prop", VtInt 42)] - cFormatting = M.fromList [(SqRef [CellRef "A1:B3"], rules1), (SqRef [CellRef "C1:C10"], rules2)] - cfRule c d = CfRule { _cfrCondition = c - , _cfrDxfId = Just d - , _cfrPriority = topCfPriority - , _cfrStopIfTrue = Nothing - } - rules1 = [ cfRule ContainsBlanks 1 - , cfRule (ContainsText "foo") 2 - , cfRule (CellIs (OpBetween (Formula "A1") (Formula "B10"))) 3 - ] - rules2 = [ cfRule ContainsErrors 3 ] - -testCellMap1 :: CellMap -testCellMap1 = M.fromList [ ((1, 2), cd1_2), ((1, 5), cd1_5) - , ((3, 1), cd3_1), ((3, 2), cd3_2), ((3, 7), cd3_7) - , ((4, 1), cd4_1), ((4, 2), cd4_2), ((4, 3), cd4_3) - ] - where - cd v = def {_cellValue=Just v} - cd1_2 = cd (CellText "just a text") - cd1_5 = cd (CellDouble 42.4567) - cd3_1 = cd (CellText "another text") - cd3_2 = def -- shouldn't it be skipped? - cd3_7 = cd (CellBool True) - cd4_1 = cd (CellDouble 1) - cd4_2 = cd (CellDouble 2) - cd4_3 = (cd (CellDouble (1+2))) { _cellFormula = - Just $ simpleCellFormula "A4+B4" - } - -testCellMap2 :: CellMap -testCellMap2 = M.fromList [ ((1, 2), def & cellValue ?~ CellText "something here") - , ((3, 5), def & cellValue ?~ CellDouble 123.456) - , ((2, 4), - def & cellValue ?~ CellText "value" - & cellComment ?~ comment1 - ) - , ((10, 7), - def & cellValue ?~ CellText "value" - & cellComment ?~ comment2 - ) - , ((11, 4), def & cellComment ?~ comment3) - ] - where - comment1 = Comment (XlsxText "simple comment") "bob" True - comment2 = Comment (XlsxRichText [rich1, rich2]) "alice" False - comment3 = Comment (XlsxText "comment for an empty cell") "bob" True - rich1 = def & richTextRunText.~ "Look ma!" - & richTextRunProperties ?~ ( - def & runPropertiesBold ?~ True - & runPropertiesFont ?~ "Tahoma") - rich2 = def & richTextRunText .~ "It's blue!" - & richTextRunProperties ?~ ( - def & runPropertiesItalic ?~ True - & runPropertiesColor ?~ (def & colorARGB ?~ "FF000080")) - -testTime :: POSIXTime -testTime = 123 - -fromRight :: Either a b -> b -fromRight (Right b) = b - -testStyleSheet :: StyleSheet -testStyleSheet = minimalStyleSheet & styleSheetDxfs .~ [dxf1, dxf2] - & styleSheetNumFmts .~ M.fromList [(164, "0.000")] - & styleSheetCellXfs %~ (++ [cellXf1, cellXf2]) - where - dxf1 = def & dxfFont ?~ (def & fontBold ?~ True - & fontSize ?~ 12) - dxf2 = def & dxfFill ?~ (def & fillPattern ?~ (def & fillPatternBgColor ?~ red)) - red = def & colorARGB ?~ "FFFF0000" - cellXf1 = def - { _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 2 } - cellXf2 = def - { _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 164 } - -testSharedStringTable :: SharedStringTable -testSharedStringTable = SharedStringTable $ V.fromList items - where - items = [text, rich] - text = XlsxText "plain text" - rich = XlsxRichText [ RichTextRun Nothing "Just " - , RichTextRun (Just props) "example" ] - props = def & runPropertiesBold .~ Just True - & runPropertiesUnderline .~ Just FontUnderlineSingle - & runPropertiesSize .~ Just 10 - & runPropertiesFont .~ Just "Arial" - & runPropertiesFontFamily .~ Just FontFamilySwiss - -testSharedStringTableWithEmpty :: SharedStringTable -testSharedStringTableWithEmpty = - SharedStringTable $ V.fromList [XlsxText ""] - -testCommentTable = CommentTable $ M.fromList - [ (CellRef "D4", Comment (XlsxRichText rich) "Bob" True) - , (CellRef "A2", Comment (XlsxText "Some comment here") "CBR" True) ] - where - rich = [ RichTextRun - { _richTextRunProperties = - Just $ def & runPropertiesBold ?~ True - & runPropertiesCharset ?~ 1 - & runPropertiesColor ?~ def -- TODO: why not Nothing here? - & runPropertiesFont ?~ "Calibri" - & runPropertiesScheme ?~ FontSchemeMinor - & runPropertiesSize ?~ 8.0 - , _richTextRunText = "Bob:"} - , RichTextRun - { _richTextRunProperties = - Just $ def & runPropertiesCharset ?~ 1 - & runPropertiesColor ?~ def - & runPropertiesFont ?~ "Calibri" - & runPropertiesScheme ?~ FontSchemeMinor - & runPropertiesSize ?~ 8.0 - , _richTextRunText = "Why such high expense?"}] - -testStrings :: ByteString -testStrings = "\ - \\ - \plain text\ - \Just \ - \example\ - \" - -testStringsWithEmpty :: ByteString -testStringsWithEmpty = "\ - \\ - \\ - \" - -testComments :: ByteString -testComments = [r| - - - - Bob - CBR - - - - - - - - - - Bob: - - - - - - - Why such high expense? - - - - - Some comment here - - - -|] - -testDrawing :: UnresolvedDrawing -testDrawing = Drawing [anchor1, anchor2] - where - anchor1 = - Anchor - {_anchAnchoring = anchoring1, _anchObject = pic, _anchClientData = def} - anchoring1 = - TwoCellAnchor - { tcaFrom = unqMarker (0, 0) (0, 0) - , tcaTo = unqMarker (12, 320760) (33, 38160) - , tcaEditAs = EditAsAbsolute - } - pic = - Picture - { _picMacro = Nothing - , _picPublished = False - , _picNonVisual = nonVis1 - , _picBlipFill = bfProps - , _picShapeProperties = shProps - } - nonVis1 = - PicNonVisual $ - NonVisualDrawingProperties - { _nvdpId = DrawingElementId 0 - , _nvdpName = "Picture 1" - , _nvdpDescription = Just "" - , _nvdpHidden = False - , _nvdpTitle = Nothing - } - bfProps = - BlipFillProperties - {_bfpImageInfo = Just (RefId "rId1"), _bfpFillMode = Just FillStretch} - shProps = - ShapeProperties - { _spXfrm = Just trnsfrm - , _spGeometry = Just PresetGeometry - , _spFill = Nothing - , _spOutline = Just $ LineProperties (Just NoFill) - } - trnsfrm = - Transform2D - { _trRot = Angle 0 - , _trFlipH = False - , _trFlipV = False - , _trOffset = Just (unqPoint2D 0 0) - , _trExtents = - Just - (PositiveSize2D - (PositiveCoordinate 10074240) - (PositiveCoordinate 5402520)) - } - anchor2 = - Anchor - { _anchAnchoring = anchoring2 - , _anchObject = graphic - , _anchClientData = def - } - anchoring2 = - TwoCellAnchor - { tcaFrom = unqMarker (0, 87840) (21, 131040) - , tcaTo = unqMarker (7, 580320) (38, 132480) - , tcaEditAs = EditAsOneCell - } - graphic = - Graphic - { _grNonVisual = nonVis2 - , _grChartSpace = RefId "rId2" - , _grTransform = transform - } - nonVis2 = GraphNonVisual $ - NonVisualDrawingProperties - { _nvdpId = DrawingElementId 1 - , _nvdpName = "" - , _nvdpDescription = Nothing - , _nvdpHidden = False - , _nvdpTitle = Nothing - } - transform = - Transform2D - { _trRot = Angle 0 - , _trFlipH = False - , _trFlipV = False - , _trOffset = Just (unqPoint2D 0 0) - , _trExtents = - Just - (PositiveSize2D - (PositiveCoordinate 10074240) - (PositiveCoordinate 5402520)) - } - - -testDrawingFile :: ByteString -testDrawingFile = [r| - - - - - 00 - 00 - - - 12320760 - 3338160 - - - - - - - - - - - - - - 087840 - 21131040 - - - 7580320 - 38132480 - - - - - - - - - - - - - -|] - -testWrittenDrawing :: ByteString -testWrittenDrawing = renderLBS def $ toDocument testDrawing - -testCustomProperties :: CustomProperties -testCustomProperties = CustomProperties.fromList - [ ("testTextProp", VtLpwstr "test text property value") - , ("prop2", VtLpwstr "222") - , ("bool", VtBool False) - , ("prop333", VtInt 1) - , ("decimal", VtDecimal 1.234) ] - -testCustomPropertiesXml :: ByteString -testCustomPropertiesXml = [r| - - - - 222 - - - 1 - - - test text property value - - - 1.234 - - - false - - - - ZXhhbXBs - ZSBibG9i - IGNvbnRl - bnRz - - - -|] - -testFormattedResult :: Formatted -testFormattedResult = Formatted cm styleSheet merges - where - cm = M.fromList [ ((1, 1), cell11) - , ((1, 2), cell12) - , ((2, 5), cell25) ] - cell11 = Cell - { _cellStyle = Just 1 - , _cellValue = Just (CellText "text at A1") - , _cellComment = Nothing - , _cellFormula = Nothing } - cell12 = Cell - { _cellStyle = Just 2 - , _cellValue = Just (CellDouble 1.23) - , _cellComment = Nothing - , _cellFormula = Nothing } - cell25 = Cell - { _cellStyle = Just 3 - , _cellValue = Just (CellDouble 1.23456) - , _cellComment = Nothing - , _cellFormula = Nothing } - merges = [] - styleSheet = - minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3]) - & styleSheetFonts %~ (++ [font1, font2]) - & styleSheetNumFmts .~ numFmts - nextFontId = length (minimalStyleSheet ^. styleSheetFonts) - cellXf1 = def - { _cellXfApplyFont = Just True - , _cellXfFontId = Just nextFontId } - font1 = def - { _fontName = Just "Calibri" - , _fontBold = Just True } - cellXf2 = def - { _cellXfApplyFont = Just True - , _cellXfFontId = Just (nextFontId + 1) - , _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 164 } - font2 = def - { _fontItalic = Just True } - cellXf3 = def - { _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 2 } - numFmts = M.fromList [(164, "0.0000")] - -testRunFormatted :: Formatted -testRunFormatted = formatted formattedCellMap minimalStyleSheet - where - formattedCellMap = flip execState def $ do - let font1 = def & fontBold ?~ True - & fontName ?~ "Calibri" - at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1" - & formattedFormat . formatFont ?~ font1) - at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23 - & formattedFormat . formatFont . non def . fontItalic ?~ True - & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4) - at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456 - & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) - -testCondFormattedResult :: CondFormatted -testCondFormattedResult = CondFormatted styleSheet formattings - where - styleSheet = - minimalStyleSheet & styleSheetDxfs .~ dxfs - dxfs = [ def & dxfFont ?~ (def & fontUnderline ?~ FontUnderlineSingle) - , def & dxfFont ?~ (def & fontStrikeThrough ?~ True) - , def & dxfFont ?~ (def & fontBold ?~ True) ] - formattings = M.fromList [ (SqRef [CellRef "A1:A2", CellRef "B2:B3"], [cfRule1, cfRule2]) - , (SqRef [CellRef "C3:E10"], [cfRule1]) - , (SqRef [CellRef "F1:G10"], [cfRule3]) ] - cfRule1 = CfRule - { _cfrCondition = ContainsBlanks - , _cfrDxfId = Just 0 - , _cfrPriority = 1 - , _cfrStopIfTrue = Nothing } - cfRule2 = CfRule - { _cfrCondition = BeginsWith "foo" - , _cfrDxfId = Just 1 - , _cfrPriority = 1 - , _cfrStopIfTrue = Nothing } - cfRule3 = CfRule - { _cfrCondition = CellIs (OpGreaterThan (Formula "A1")) - , _cfrDxfId = Just 2 - , _cfrPriority = 1 - , _cfrStopIfTrue = Nothing } - -testFormattedCells :: Map (Int, Int) FormattedCell -testFormattedCells = flip execState def $ do - at (1,1) ?= (def & formattedRowSpan .~ 5 - & formattedColSpan .~ 5 - & formattedFormat . formatBorder . non def . borderTop . - non def . borderStyleLine ?~ LineStyleDashed - & formattedFormat . formatBorder . non def . borderBottom . - non def . borderStyleLine ?~ LineStyleDashed) - at (10,2) ?= (def & formattedFormat . formatFont . non def . fontBold ?~ True) - -testRunCondFormatted :: CondFormatted -testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet - where - condFmts = flip execState def $ do - let cfRule1 = def & condfmtCondition .~ ContainsBlanks - & condfmtDxf . dxfFont . non def . fontUnderline ?~ FontUnderlineSingle - cfRule2 = def & condfmtCondition .~ BeginsWith "foo" - & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True - cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1")) - & condfmtDxf . dxfFont . non def . fontBold ?~ True - at (CellRef "A1:A2") ?= [cfRule1, cfRule2] - at (CellRef "B2:B3") ?= [cfRule1, cfRule2] - at (CellRef "C3:E10") ?= [cfRule1] - at (CellRef "F1:G10") ?= [cfRule3] - -testChartFile :: ByteString -testChartFile = [r| - - - - - Line chart title - - - - - - - Sheet1!$A$1 - - Sheet1!$B$1:$D$1 - - - - - Sheet1!$A$2 - - Sheet1!$B$2:$D$2 - - - - - - - - - - -|] - -testChartSpace :: ChartSpace -testChartSpace = - ChartSpace - { _chspTitle = Just $ ChartTitle titleBody - , _chspCharts = charts - , _chspLegend = Nothing - , _chspPlotVisOnly = Just True - , _chspDispBlanksAs = Just DispBlanksAsGap - } - where - titleBody = - TextBody - { _txbdRotation = Angle 0 - , _txbdSpcFirstLastPara = False - , _txbdVertOverflow = TextVertOverflow - , _txbdVertical = TextVerticalHorz - , _txbdWrap = TextWrapSquare - , _txbdAnchor = TextAnchoringBottom - , _txbdAnchorCenter = False - , _txbdParagraphs = - [TextParagraph Nothing [RegularRun Nothing "Line chart title"]] - } - charts = - [ LineChart - { _lnchGrouping = StandardGrouping - , _lnchSeries = series - , _lnchMarker = Just False - , _lnchSmooth = Just False - } - ] - series = - [ LineSeries - { _lnserShared = Series . Just $ Formula "Sheet1!$A$1" - , _lnserMarker = Just markerNone - , _lnserDataLblProps = Nothing - , _lnserVal = Just $ Formula "Sheet1!$B$1:$D$1" - , _lnserSmooth = Just False - } - , LineSeries - { _lnserShared = Series . Just $ Formula "Sheet1!$A$2" - , _lnserMarker = Just markerNone - , _lnserDataLblProps = Nothing - , _lnserVal = Just $ Formula "Sheet1!$B$2:$D$2" - , _lnserSmooth = Just False - } - ] - markerNone = - DataMarker {_dmrkSymbol = Just DataMarkerNone, _dmrkSize = Nothing} - -testWrittenChartSpace :: ByteString -testWrittenChartSpace = renderLBS def{rsNamespaces=nss} $ toDocument testChartSpace - where - nss = [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart") - , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") ] - - -validations :: Map SqRef DataValidation -validations = M.fromList - [ ( SqRef [CellRef "A1"], def - ) - , ( SqRef [CellRef "A1", CellRef "B2:C3"], def - { _dvAllowBlank = True - , _dvError = Just "incorrect data" - , _dvErrorStyle = ErrorStyleInformation - , _dvErrorTitle = Just "error title" - , _dvPrompt = Just "enter data" - , _dvPromptTitle = Just "prompt title" - , _dvShowDropDown = True - , _dvShowErrorMessage = True - , _dvShowInputMessage = True - , _dvValidationType = ValidationTypeList ["aaaa","bbbb","cccc"] - } - ) - , ( SqRef [CellRef "A6", CellRef "I2"], def - { _dvAllowBlank = False - , _dvError = Just "aaa" - , _dvErrorStyle = ErrorStyleWarning - , _dvErrorTitle = Just "bbb" - , _dvPrompt = Just "ccc" - , _dvPromptTitle = Just "ddd" - , _dvShowDropDown = False - , _dvShowErrorMessage = False - , _dvShowInputMessage = False - , _dvValidationType = ValidationTypeDecimal $ ValGreaterThan $ Formula "10" - } - ) - , ( SqRef [CellRef "A7"], def - { _dvAllowBlank = False - , _dvError = Just "aaa" - , _dvErrorStyle = ErrorStyleStop - , _dvErrorTitle = Just "bbb" - , _dvPrompt = Just "ccc" - , _dvPromptTitle = Just "ddd" - , _dvShowDropDown = False - , _dvShowErrorMessage = False - , _dvShowInputMessage = False - , _dvValidationType = ValidationTypeWhole $ ValNotBetween (Formula "10") (Formula "12") - } - ) - ] - -testPivotTable :: PivotTable -testPivotTable = - PivotTable - { _pvtName = "PivotTable1" - , _pvtDataCaption = "Values" - , _pvtLocation = CellRef "A3:D12" - , _pvtSrcRef = CellRef "A1:D5" - , _pvtSrcSheet = "Sheet1" - , _pvtRowFields = [FieldPosition colorField, DataPosition] - , _pvtColumnFields = [FieldPosition yearField] - , _pvtDataFields = - [ DataField - { _dfName = "Sum of field Price" - , _dfField = priceField - , _dfFunction = ConsolidateSum - } - , DataField - { _dfName = "Sum of field Count" - , _dfField = countField - , _dfFunction = ConsolidateSum - } - ] - , _pvtFields = - [ PivotFieldInfo colorField False - , PivotFieldInfo yearField True - , PivotFieldInfo priceField False - , PivotFieldInfo countField False - ] - , _pvtRowGrandTotals = True - , _pvtColumnGrandTotals = False - , _pvtOutline = False - , _pvtOutlineData = False - } - where - colorField = PivotFieldName "Color" - yearField = PivotFieldName "Year" - priceField = PivotFieldName "Price" - countField = PivotFieldName "Count" - -testPivotTableDefinition :: ByteString -testPivotTableDefinition = [r| - - - - - - - - - - - - - - - - - - - - - - - - -|] - -testPivotCacheDefinition :: ByteString -testPivotCacheDefinition = [r| - - - - - - - - - - - - -|] - -stripContentSpaces :: Document -> Document -stripContentSpaces doc@Document {documentRoot = root} = - doc {documentRoot = go root} - where - go e@Element {elementNodes = nodes} = - e {elementNodes = mapMaybe goNode nodes} - goNode (NodeElement el) = Just $ NodeElement (go el) - goNode t@(NodeContent txt) = - if T.strip txt == T.empty - then Nothing - else Just t - goNode other = Just $ other diff --git a/test/DrawingTests.hs b/test/DrawingTests.hs new file mode 100644 --- /dev/null +++ b/test/DrawingTests.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module DrawingTests + ( tests + , testDrawing + , testLineChartSpace + ) where + +import Control.Lens +import Data.ByteString.Lazy (ByteString) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.HUnit (testCase) +import Text.RawString.QQ +import Text.XML + +import Codec.Xlsx +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Writer.Internal + +import Common +import Diff + +tests :: TestTree +tests = + testGroup + "Drawing tests" + [ testCase "correct drawing parsing" $ + [testDrawing] @==? parseBS testDrawingFile + , testCase "write . read == id for Drawings" $ + [testDrawing] @==? parseBS testWrittenDrawing + , testCase "correct chart parsing" $ + [testLineChartSpace] @==? parseBS testLineChartFile + , testCase "parse . render == id for line Charts" $ + [testLineChartSpace] @==? parseBS (renderChartSpace testLineChartSpace) + , testCase "parse . render == id for area Charts" $ + [testAreaChartSpace] @==? parseBS (renderChartSpace testAreaChartSpace) + , testCase "parse . render == id for bar Charts" $ + [testBarChartSpace] @==? parseBS (renderChartSpace testBarChartSpace) + , testCase "parse . render == id for pie Charts" $ + [testPieChartSpace] @==? parseBS (renderChartSpace testPieChartSpace) + , testCase "parse . render == id for scatter Charts" $ + [testScatterChartSpace] @==? parseBS (renderChartSpace testScatterChartSpace) + ] + +testDrawing :: UnresolvedDrawing +testDrawing = Drawing [anchor1, anchor2] + where + anchor1 = + Anchor + {_anchAnchoring = anchoring1, _anchObject = pic, _anchClientData = def} + anchoring1 = + TwoCellAnchor + { tcaFrom = unqMarker (0, 0) (0, 0) + , tcaTo = unqMarker (12, 320760) (33, 38160) + , tcaEditAs = EditAsAbsolute + } + pic = + Picture + { _picMacro = Nothing + , _picPublished = False + , _picNonVisual = nonVis1 + , _picBlipFill = bfProps + , _picShapeProperties = shProps + } + nonVis1 = + PicNonVisual $ + NonVisualDrawingProperties + { _nvdpId = DrawingElementId 0 + , _nvdpName = "Picture 1" + , _nvdpDescription = Just "" + , _nvdpHidden = False + , _nvdpTitle = Nothing + } + bfProps = + BlipFillProperties + {_bfpImageInfo = Just (RefId "rId1"), _bfpFillMode = Just FillStretch} + shProps = + ShapeProperties + { _spXfrm = Just trnsfrm + , _spGeometry = Just PresetGeometry + , _spFill = Nothing + , _spOutline = Just $ def {_lnFill = Just NoFill} + } + trnsfrm = + Transform2D + { _trRot = Angle 0 + , _trFlipH = False + , _trFlipV = False + , _trOffset = Just (unqPoint2D 0 0) + , _trExtents = + Just + (PositiveSize2D + (PositiveCoordinate 10074240) + (PositiveCoordinate 5402520)) + } + anchor2 = + Anchor + { _anchAnchoring = anchoring2 + , _anchObject = graphic + , _anchClientData = def + } + anchoring2 = + TwoCellAnchor + { tcaFrom = unqMarker (0, 87840) (21, 131040) + , tcaTo = unqMarker (7, 580320) (38, 132480) + , tcaEditAs = EditAsOneCell + } + graphic = + Graphic + { _grNonVisual = nonVis2 + , _grChartSpace = RefId "rId2" + , _grTransform = transform + } + nonVis2 = + GraphNonVisual $ + NonVisualDrawingProperties + { _nvdpId = DrawingElementId 1 + , _nvdpName = "" + , _nvdpDescription = Nothing + , _nvdpHidden = False + , _nvdpTitle = Nothing + } + transform = + Transform2D + { _trRot = Angle 0 + , _trFlipH = False + , _trFlipV = False + , _trOffset = Just (unqPoint2D 0 0) + , _trExtents = + Just + (PositiveSize2D + (PositiveCoordinate 10074240) + (PositiveCoordinate 5402520)) + } + +testDrawingFile :: ByteString +testDrawingFile = [r| + + + + + 00 + 00 + + + 12320760 + 3338160 + + + + + + + + + + + + + + 087840 + 21131040 + + + 7580320 + 38132480 + + + + + + + + + + + + + +|] + +testWrittenDrawing :: ByteString +testWrittenDrawing = renderLBS def $ toDocument testDrawing + +testLineChartFile :: ByteString +testLineChartFile = [r| + + + + + Line chart title + + + + + + + Sheet1!$A$1 + + + + + + Sheet1!$B$1:$D$1 + + + + + Sheet1!$A$2 + + + + + + Sheet1!$B$2:$D$2 + + + + + + + + + + +|] + +oneChartChartSpace :: Chart -> ChartSpace +oneChartChartSpace chart = + ChartSpace + { _chspTitle = Just $ ChartTitle titleBody + , _chspCharts = [chart] + , _chspLegend = Nothing + , _chspPlotVisOnly = Just True + , _chspDispBlanksAs = Just DispBlanksAsGap + } + where + titleBody = + TextBody + { _txbdRotation = Angle 0 + , _txbdSpcFirstLastPara = False + , _txbdVertOverflow = TextVertOverflow + , _txbdVertical = TextVerticalHorz + , _txbdWrap = TextWrapSquare + , _txbdAnchor = TextAnchoringBottom + , _txbdAnchorCenter = False + , _txbdParagraphs = + [TextParagraph Nothing [RegularRun Nothing "Line chart title"]] + } + +renderChartSpace :: ChartSpace -> ByteString +renderChartSpace = renderLBS def {rsNamespaces = nss} . toDocument + where + nss = + [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart") + , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") + ] + +testLineChartSpace :: ChartSpace +testLineChartSpace = oneChartChartSpace lineChart + where + lineChart = + LineChart + { _lnchGrouping = StandardGrouping + , _lnchSeries = series + , _lnchMarker = Just False + , _lnchSmooth = Just False + } + series = + [ LineSeries + { _lnserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$1" + , _serShapeProperties = Just $ rgbShape "0000FF" + } + , _lnserMarker = Just markerNone + , _lnserDataLblProps = Nothing + , _lnserVal = Just $ Formula "Sheet1!$B$1:$D$1" + , _lnserSmooth = Just False + } + , LineSeries + { _lnserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$2" + , _serShapeProperties = Just $ rgbShape "FF0000" + } + , _lnserMarker = Just markerNone + , _lnserDataLblProps = Nothing + , _lnserVal = Just $ Formula "Sheet1!$B$2:$D$2" + , _lnserSmooth = Just False + } + ] + rgbShape color = + def + { _spFill = Just $ solidRgb color + , _spOutline = + Just $ + LineProperties {_lnFill = Just $ solidRgb color, _lnWidth = 28800} + } + markerNone = + DataMarker {_dmrkSymbol = Just DataMarkerNone, _dmrkSize = Nothing} + +testAreaChartSpace :: ChartSpace +testAreaChartSpace = oneChartChartSpace areaChart + where + areaChart = + AreaChart {_archGrouping = Just StandardGrouping, _archSeries = series} + series = + [ AreaSeries + { _arserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$1" + , _serShapeProperties = + Just $ + def + { _spFill = Just $ solidRgb "000088" + , _spOutline = Just $ def {_lnFill = Just NoFill} + } + } + , _arserDataLblProps = Nothing + , _arserVal = Just $ Formula "Sheet1!$B$1:$D$1" + } + ] + +testBarChartSpace :: ChartSpace +testBarChartSpace = + oneChartChartSpace + BarChart + { _brchDirection = DirectionColumn + , _brchGrouping = Just StandardGrouping + , _brchSeries = + [ BarSeries + { _brserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$1" + , _serShapeProperties = + Just $ + def + { _spFill = Just $ solidRgb "000088" + , _spOutline = Just $ def {_lnFill = Just NoFill} + } + } + , _brserDataLblProps = Nothing + , _brserVal = Just $ Formula "Sheet1!$B$1:$D$1" + } + ] + } + +testPieChartSpace :: ChartSpace +testPieChartSpace = + oneChartChartSpace + PieChart + { _pichSeries = + [ PieSeries + { _piserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$1" + , _serShapeProperties = Nothing + } + , _piserDataPoints = + [ def & dpShapeProperties ?~ solidFill "000088" + , def & dpShapeProperties ?~ solidFill "008800" + , def & dpShapeProperties ?~ solidFill "880000" + ] + , _piserDataLblProps = Nothing + , _piserVal = Just $ Formula "Sheet1!$B$1:$D$1" + } + ] + } + where + solidFill color = def & spFill ?~ solidRgb color + +testScatterChartSpace :: ChartSpace +testScatterChartSpace = + oneChartChartSpace + ScatterChart + { _scchStyle = ScatterMarker + , _scchSeries = + [ ScatterSeries + { _scserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$2" + , _serShapeProperties = + Just $ def {_spOutline = Just $ def {_lnFill = Just NoFill}} + } + , _scserMarker = Just $ DataMarker (Just DataMarkerSquare) Nothing + , _scserDataLblProps = Nothing + , _scserXVal = Just $ Formula "Sheet1!$B$1:$D$1" + , _scserYVal = Just $ Formula "Sheet1!$B$2:$D$2" + , _scserSmooth = Nothing + } + ] + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,505 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +module Main (main) where + +import Control.Lens +import Control.Monad.State.Lazy +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Map (Map) +import qualified Data.Map as M +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Vector as V +import Text.RawString.QQ +import Text.XML + +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.SmallCheck (testProperty) + +import Test.SmallCheck.Series (Positive(..)) +import Test.Tasty.HUnit ((@=?)) + +import Codec.Xlsx +import Codec.Xlsx.Formatted +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Types.Internal.CommentTable +import Codec.Xlsx.Types.Internal.CustomProperties + as CustomProperties +import Codec.Xlsx.Types.Internal.SharedStringTable + +import Common +import Diff +import PivotTableTests +import DrawingTests + +main :: IO () +main = defaultMain $ + testGroup "Tests" + [ testProperty "col2int . int2col == id" $ + \(Positive i) -> i == col2int (int2col i) + , testCase "write . read == id" $ do + let bs = fromXlsx testTime testXlsx + LB.writeFile "data-test.xlsx" bs + testXlsx @==? toXlsx (fromXlsx testTime testXlsx) + , testCase "fromRows . toRows == id" $ + testCellMap1 @=? fromRows (toRows testCellMap1) + , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $ + testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet)) + , testCase "correct shared strings parsing" $ + [testSharedStringTable] @=? parseBS testStrings + , testCase "correct shared strings parsing even when one of the shared strings entry is just " $ + [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty + , testCase "correct comments parsing" $ + [testCommentTable] @=? parseBS testComments + , testCase "correct custom properties parsing" $ + [testCustomProperties] @==? parseBS testCustomPropertiesXml + , testCase "proper results from `formatted`" $ + testFormattedResult @==? testRunFormatted + , testCase "formatted . toFormattedCells = id" $ do + let fmtd = formatted testFormattedCells minimalStyleSheet + testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd) + (formattedStyleSheet fmtd) + , testCase "proper results from `conditionalltyFormatted`" $ + testCondFormattedResult @==? testRunCondFormatted + , testCase "toXlsxEither: properly formatted" $ + Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) + , testCase "toXlsxEither: invalid format" $ + Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file" + , PivotTableTests.tests + , DrawingTests.tests + ] + +testXlsx :: Xlsx +testXlsx = Xlsx sheets minimalStyles definedNames customProperties + where + sheets = + [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)] + sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges + sheetViews pageSetup cFormatting validations [] (Just autoFilter) tables (Just protection) + autoFilter = def & afRef ?~ CellRef "A1:E10" + & afFilterColumns .~ fCols + fCols = M.fromList [ (1, Filters ["a","b","ZZZ"]) + , (2, CustomFiltersAnd (CustomFilter FltrGreaterThanOrEqual "0") + (CustomFilter FltrLessThan "42"))] + tables = + [ Table + { tblName = "Table1" + , tblDisplayName = "Table1" + , tblRef = CellRef "A3" + , tblColumns = [TableColumn "another text"] + , tblAutoFilter = Just (def & afRef ?~ CellRef "A3") + } + ] + protection = + fullSheetProtection + { _sprScenarios = False + , _sprLegacyPassword = Just $ legacyPassword "hard password" + } + sheet2 = def & wsCells .~ testCellMap2 + pvSheet = sheetWithPvCells & wsPivotTables .~ [testPivotTable] + sheetWithPvCells = def & wsCells .~ testPivotSrcCells + rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] + cols = [ColumnsProperties 1 10 (Just 15) (Just 1) False False False] + drawing = Just $ testDrawing { _xdrAnchors = map resolve $ _xdrAnchors testDrawing } + resolve :: Anchor RefId RefId -> Anchor FileInfo ChartSpace + resolve Anchor {..} = + let obj = + case _anchObject of + Picture {..} -> + let blipFill = (_picBlipFill & bfpImageInfo ?~ fileInfo) + in Picture + { _picMacro = _picMacro + , _picPublished = _picPublished + , _picNonVisual = _picNonVisual + , _picBlipFill = blipFill + , _picShapeProperties = _picShapeProperties + } + Graphic nv _ tr -> + Graphic nv testLineChartSpace tr + in Anchor + { _anchAnchoring = _anchAnchoring + , _anchObject = obj + , _anchClientData = _anchClientData + } + fileInfo = FileInfo "dummy.png" "image/png" "fake contents" + ranges = [mkRange (1,1) (1,2), mkRange (2,2) (10, 5)] + minimalStyles = renderStyleSheet minimalStyleSheet + definedNames = DefinedNames [("SampleName", Nothing, "A10:A20")] + sheetViews = Just [sheetView1, sheetView2] + sheetView1 = def & sheetViewRightToLeft ?~ True + & sheetViewTopLeftCell ?~ CellRef "B5" + sheetView2 = def & sheetViewType ?~ SheetViewTypePageBreakPreview + & sheetViewWorkbookViewId .~ 5 + & sheetViewSelection .~ [ def & selectionActiveCell ?~ CellRef "C2" + & selectionPane ?~ PaneTypeBottomRight + , def & selectionActiveCellId ?~ 1 + & selectionSqref ?~ SqRef [ CellRef "A3:A10" + , CellRef "B1:G3"] + ] + pageSetup = Just $ def & pageSetupBlackAndWhite ?~ True + & pageSetupCopies ?~ 2 + & pageSetupErrors ?~ PrintErrorsDash + & pageSetupPaperSize ?~ PaperA4 + customProperties = M.fromList [("some_prop", VtInt 42)] + cFormatting = M.fromList [(SqRef [CellRef "A1:B3"], rules1), (SqRef [CellRef "C1:C10"], rules2)] + cfRule c d = CfRule { _cfrCondition = c + , _cfrDxfId = Just d + , _cfrPriority = topCfPriority + , _cfrStopIfTrue = Nothing + } + rules1 = [ cfRule ContainsBlanks 1 + , cfRule (ContainsText "foo") 2 + , cfRule (CellIs (OpBetween (Formula "A1") (Formula "B10"))) 3 + ] + rules2 = [ cfRule ContainsErrors 3 ] + +testCellMap1 :: CellMap +testCellMap1 = M.fromList [ ((1, 2), cd1_2), ((1, 5), cd1_5) + , ((3, 1), cd3_1), ((3, 2), cd3_2), ((3, 7), cd3_7) + , ((4, 1), cd4_1), ((4, 2), cd4_2), ((4, 3), cd4_3) + ] + where + cd v = def {_cellValue=Just v} + cd1_2 = cd (CellText "just a text") + cd1_5 = cd (CellDouble 42.4567) + cd3_1 = cd (CellText "another text") + cd3_2 = def -- shouldn't it be skipped? + cd3_7 = cd (CellBool True) + cd4_1 = cd (CellDouble 1) + cd4_2 = cd (CellDouble 2) + cd4_3 = (cd (CellDouble (1+2))) { _cellFormula = + Just $ simpleCellFormula "A4+B4" + } + +testCellMap2 :: CellMap +testCellMap2 = M.fromList [ ((1, 2), def & cellValue ?~ CellText "something here") + , ((3, 5), def & cellValue ?~ CellDouble 123.456) + , ((2, 4), + def & cellValue ?~ CellText "value" + & cellComment ?~ comment1 + ) + , ((10, 7), + def & cellValue ?~ CellText "value" + & cellComment ?~ comment2 + ) + , ((11, 4), def & cellComment ?~ comment3) + ] + where + comment1 = Comment (XlsxText "simple comment") "bob" True + comment2 = Comment (XlsxRichText [rich1, rich2]) "alice" False + comment3 = Comment (XlsxText "comment for an empty cell") "bob" True + rich1 = def & richTextRunText.~ "Look ma!" + & richTextRunProperties ?~ ( + def & runPropertiesBold ?~ True + & runPropertiesFont ?~ "Tahoma") + rich2 = def & richTextRunText .~ "It's blue!" + & richTextRunProperties ?~ ( + def & runPropertiesItalic ?~ True + & runPropertiesColor ?~ (def & colorARGB ?~ "FF000080")) + +testTime :: POSIXTime +testTime = 123 + +fromRight :: Show a => Either a b -> b +fromRight (Right b) = b +fromRight (Left x) = error $ "Right _ was expected but Left " ++ show x ++ " found" + +testStyleSheet :: StyleSheet +testStyleSheet = minimalStyleSheet & styleSheetDxfs .~ [dxf1, dxf2] + & styleSheetNumFmts .~ M.fromList [(164, "0.000")] + & styleSheetCellXfs %~ (++ [cellXf1, cellXf2]) + where + dxf1 = def & dxfFont ?~ (def & fontBold ?~ True + & fontSize ?~ 12) + dxf2 = def & dxfFill ?~ (def & fillPattern ?~ (def & fillPatternBgColor ?~ red)) + red = def & colorARGB ?~ "FFFF0000" + cellXf1 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 2 } + cellXf2 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 164 } + +testSharedStringTable :: SharedStringTable +testSharedStringTable = SharedStringTable $ V.fromList items + where + items = [text, rich] + text = XlsxText "plain text" + rich = XlsxRichText [ RichTextRun Nothing "Just " + , RichTextRun (Just props) "example" ] + props = def & runPropertiesBold .~ Just True + & runPropertiesUnderline .~ Just FontUnderlineSingle + & runPropertiesSize .~ Just 10 + & runPropertiesFont .~ Just "Arial" + & runPropertiesFontFamily .~ Just FontFamilySwiss + +testSharedStringTableWithEmpty :: SharedStringTable +testSharedStringTableWithEmpty = + SharedStringTable $ V.fromList [XlsxText ""] + +testCommentTable :: CommentTable +testCommentTable = CommentTable $ M.fromList + [ (CellRef "D4", Comment (XlsxRichText rich) "Bob" True) + , (CellRef "A2", Comment (XlsxText "Some comment here") "CBR" True) ] + where + rich = [ RichTextRun + { _richTextRunProperties = + Just $ def & runPropertiesBold ?~ True + & runPropertiesCharset ?~ 1 + & runPropertiesColor ?~ def -- TODO: why not Nothing here? + & runPropertiesFont ?~ "Calibri" + & runPropertiesScheme ?~ FontSchemeMinor + & runPropertiesSize ?~ 8.0 + , _richTextRunText = "Bob:"} + , RichTextRun + { _richTextRunProperties = + Just $ def & runPropertiesCharset ?~ 1 + & runPropertiesColor ?~ def + & runPropertiesFont ?~ "Calibri" + & runPropertiesScheme ?~ FontSchemeMinor + & runPropertiesSize ?~ 8.0 + , _richTextRunText = "Why such high expense?"}] + +testStrings :: ByteString +testStrings = "\ + \\ + \plain text\ + \Just \ + \example\ + \" + +testStringsWithEmpty :: ByteString +testStringsWithEmpty = "\ + \\ + \\ + \" + +testComments :: ByteString +testComments = [r| + + + + Bob + CBR + + + + + + + + + + Bob: + + + + + + + Why such high expense? + + + + + Some comment here + + + +|] + +testCustomProperties :: CustomProperties +testCustomProperties = CustomProperties.fromList + [ ("testTextProp", VtLpwstr "test text property value") + , ("prop2", VtLpwstr "222") + , ("bool", VtBool False) + , ("prop333", VtInt 1) + , ("decimal", VtDecimal 1.234) ] + +testCustomPropertiesXml :: ByteString +testCustomPropertiesXml = [r| + + + + 222 + + + 1 + + + test text property value + + + 1.234 + + + false + + + + ZXhhbXBs + ZSBibG9i + IGNvbnRl + bnRz + + + +|] + +testFormattedResult :: Formatted +testFormattedResult = Formatted cm styleSheet merges + where + cm = M.fromList [ ((1, 1), cell11) + , ((1, 2), cell12) + , ((2, 5), cell25) ] + cell11 = Cell + { _cellStyle = Just 1 + , _cellValue = Just (CellText "text at A1") + , _cellComment = Nothing + , _cellFormula = Nothing } + cell12 = Cell + { _cellStyle = Just 2 + , _cellValue = Just (CellDouble 1.23) + , _cellComment = Nothing + , _cellFormula = Nothing } + cell25 = Cell + { _cellStyle = Just 3 + , _cellValue = Just (CellDouble 1.23456) + , _cellComment = Nothing + , _cellFormula = Nothing } + merges = [] + styleSheet = + minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3]) + & styleSheetFonts %~ (++ [font1, font2]) + & styleSheetNumFmts .~ numFmts + nextFontId = length (minimalStyleSheet ^. styleSheetFonts) + cellXf1 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just nextFontId } + font1 = def + { _fontName = Just "Calibri" + , _fontBold = Just True } + cellXf2 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just (nextFontId + 1) + , _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 164 } + font2 = def + { _fontItalic = Just True } + cellXf3 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 2 } + numFmts = M.fromList [(164, "0.0000")] + +testRunFormatted :: Formatted +testRunFormatted = formatted formattedCellMap minimalStyleSheet + where + formattedCellMap = flip execState def $ do + let font1 = def & fontBold ?~ True + & fontName ?~ "Calibri" + at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1" + & formattedFormat . formatFont ?~ font1) + at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23 + & formattedFormat . formatFont . non def . fontItalic ?~ True + & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4) + at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456 + & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) + +testCondFormattedResult :: CondFormatted +testCondFormattedResult = CondFormatted styleSheet formattings + where + styleSheet = + minimalStyleSheet & styleSheetDxfs .~ dxfs + dxfs = [ def & dxfFont ?~ (def & fontUnderline ?~ FontUnderlineSingle) + , def & dxfFont ?~ (def & fontStrikeThrough ?~ True) + , def & dxfFont ?~ (def & fontBold ?~ True) ] + formattings = M.fromList [ (SqRef [CellRef "A1:A2", CellRef "B2:B3"], [cfRule1, cfRule2]) + , (SqRef [CellRef "C3:E10"], [cfRule1]) + , (SqRef [CellRef "F1:G10"], [cfRule3]) ] + cfRule1 = CfRule + { _cfrCondition = ContainsBlanks + , _cfrDxfId = Just 0 + , _cfrPriority = 1 + , _cfrStopIfTrue = Nothing } + cfRule2 = CfRule + { _cfrCondition = BeginsWith "foo" + , _cfrDxfId = Just 1 + , _cfrPriority = 1 + , _cfrStopIfTrue = Nothing } + cfRule3 = CfRule + { _cfrCondition = CellIs (OpGreaterThan (Formula "A1")) + , _cfrDxfId = Just 2 + , _cfrPriority = 1 + , _cfrStopIfTrue = Nothing } + +testFormattedCells :: Map (Int, Int) FormattedCell +testFormattedCells = flip execState def $ do + at (1,1) ?= (def & formattedRowSpan .~ 5 + & formattedColSpan .~ 5 + & formattedFormat . formatBorder . non def . borderTop . + non def . borderStyleLine ?~ LineStyleDashed + & formattedFormat . formatBorder . non def . borderBottom . + non def . borderStyleLine ?~ LineStyleDashed) + at (10,2) ?= (def & formattedFormat . formatFont . non def . fontBold ?~ True) + +testRunCondFormatted :: CondFormatted +testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet + where + condFmts = flip execState def $ do + let cfRule1 = def & condfmtCondition .~ ContainsBlanks + & condfmtDxf . dxfFont . non def . fontUnderline ?~ FontUnderlineSingle + cfRule2 = def & condfmtCondition .~ BeginsWith "foo" + & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True + cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1")) + & condfmtDxf . dxfFont . non def . fontBold ?~ True + at (CellRef "A1:A2") ?= [cfRule1, cfRule2] + at (CellRef "B2:B3") ?= [cfRule1, cfRule2] + at (CellRef "C3:E10") ?= [cfRule1] + at (CellRef "F1:G10") ?= [cfRule3] + +validations :: Map SqRef DataValidation +validations = M.fromList + [ ( SqRef [CellRef "A1"], def + ) + , ( SqRef [CellRef "A1", CellRef "B2:C3"], def + { _dvAllowBlank = True + , _dvError = Just "incorrect data" + , _dvErrorStyle = ErrorStyleInformation + , _dvErrorTitle = Just "error title" + , _dvPrompt = Just "enter data" + , _dvPromptTitle = Just "prompt title" + , _dvShowDropDown = True + , _dvShowErrorMessage = True + , _dvShowInputMessage = True + , _dvValidationType = ValidationTypeList ["aaaa","bbbb","cccc"] + } + ) + , ( SqRef [CellRef "A6", CellRef "I2"], def + { _dvAllowBlank = False + , _dvError = Just "aaa" + , _dvErrorStyle = ErrorStyleWarning + , _dvErrorTitle = Just "bbb" + , _dvPrompt = Just "ccc" + , _dvPromptTitle = Just "ddd" + , _dvShowDropDown = False + , _dvShowErrorMessage = False + , _dvShowInputMessage = False + , _dvValidationType = ValidationTypeDecimal $ ValGreaterThan $ Formula "10" + } + ) + , ( SqRef [CellRef "A7"], def + { _dvAllowBlank = False + , _dvError = Just "aaa" + , _dvErrorStyle = ErrorStyleStop + , _dvErrorTitle = Just "bbb" + , _dvPrompt = Just "ccc" + , _dvPromptTitle = Just "ddd" + , _dvShowDropDown = False + , _dvShowErrorMessage = False + , _dvShowInputMessage = False + , _dvValidationType = ValidationTypeWhole $ ValNotBetween (Formula "10") (Formula "12") + } + ) + ] diff --git a/test/PivotTableTests.hs b/test/PivotTableTests.hs new file mode 100644 --- /dev/null +++ b/test/PivotTableTests.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module PivotTableTests + ( tests + , testPivotTable + , testPivotSrcCells + ) where + +import Control.Lens +import Data.ByteString.Lazy (ByteString) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.HUnit (testCase) +import Text.RawString.QQ +import Text.XML + +import Codec.Xlsx +import Codec.Xlsx.Parser.Internal.PivotTable +import Codec.Xlsx.Types.PivotTable.Internal +import Codec.Xlsx.Writer.Internal.PivotTable + +import Diff + +tests :: TestTree +tests = + testGroup + "Pivot table tests" + [ testCase "proper pivot table rendering" $ do + let ptFiles = renderPivotTableFiles testPivotSrcCells 3 testPivotTable + parseLBS_ def (pvtfTable ptFiles) @==? + stripContentSpaces (parseLBS_ def testPivotTableDefinition) + parseLBS_ def (pvtfCacheDefinition ptFiles) @==? + stripContentSpaces (parseLBS_ def testPivotCacheDefinition) + , testCase "proper pivot table parsing" $ do + let sheetName = "Sheet1" + ref = CellRef "A1:D5" + forCacheId (CacheId 3) = Just (sheetName, ref, testPivotCacheFields) + forCacheId _ = Nothing + Just (sheetName, ref, testPivotCacheFields) @==? + parseCache testPivotCacheDefinition + Just testPivotTable @==? + parsePivotTable forCacheId testPivotTableDefinition + ] + +testPivotTable :: PivotTable +testPivotTable = + PivotTable + { _pvtName = "PivotTable1" + , _pvtDataCaption = "Values" + , _pvtLocation = CellRef "A3:D12" + , _pvtSrcRef = CellRef "A1:D5" + , _pvtSrcSheet = "Sheet1" + , _pvtRowFields = [FieldPosition colorField, DataPosition] + , _pvtColumnFields = [FieldPosition yearField] + , _pvtDataFields = + [ DataField + { _dfName = "Sum of field Price" + , _dfField = priceField + , _dfFunction = ConsolidateSum + } + , DataField + { _dfName = "Sum of field Count" + , _dfField = countField + , _dfFunction = ConsolidateSum + } + ] + , _pvtFields = + [ PivotFieldInfo colorField False FieldSortAscending [CellText "green"] + , PivotFieldInfo yearField True FieldSortManual [] + , PivotFieldInfo priceField False FieldSortManual [] + , PivotFieldInfo countField False FieldSortManual [] + ] + , _pvtRowGrandTotals = True + , _pvtColumnGrandTotals = False + , _pvtOutline = False + , _pvtOutlineData = False + } + where + colorField = PivotFieldName "Color" + yearField = PivotFieldName "Year" + priceField = PivotFieldName "Price" + countField = PivotFieldName "Count" + +testPivotSrcCells :: CellMap +testPivotSrcCells = + M.fromList $ + concat + [ [((row, col), def & cellValue ?~ v) | (col, v) <- zip [1 ..] cells] + | (row, cells) <- zip [1 ..] cellMap + ] + where + cellMap = + [ [CellText "Color", CellText "Year", CellText "Price", CellText "Count"] + , [CellText "green", CellDouble 2012, CellDouble 12.23, CellDouble 17] + , [CellText "white", CellDouble 2011, CellDouble 73.99, CellDouble 21] + , [CellText "red", CellDouble 2012, CellDouble 10.19, CellDouble 172] + , [CellText "white", CellDouble 2012, CellDouble 34.99, CellDouble 49] + ] + +testPivotCacheFields :: [CacheField] +testPivotCacheFields = + [ CacheField + (PivotFieldName "Color") + [CellText "green", CellText "white", CellText "red"] + , CacheField (PivotFieldName "Year") [CellDouble 2012, CellDouble 2011] + , CacheField + (PivotFieldName "Price") + [CellDouble 12.23, CellDouble 73.99, CellDouble 10.19, CellDouble 34.99] + , CacheField + (PivotFieldName "Count") + [CellDouble 17, CellDouble 21, CellDouble 172, CellDouble 49] + ] + +testPivotTableDefinition :: ByteString +testPivotTableDefinition = [r| + + + + + + + + + + + + + + + + + + + + + + + + +|] + +testPivotCacheDefinition :: ByteString +testPivotCacheDefinition = [r| + + + + + + + + + + + + + + + + + + + + + + + + + + + + +|] + +stripContentSpaces :: Document -> Document +stripContentSpaces doc@Document {documentRoot = root} = + doc {documentRoot = go root} + where + go e@Element {elementNodes = nodes} = + e {elementNodes = mapMaybe goNode nodes} + goNode (NodeElement el) = Just $ NodeElement (go el) + goNode t@(NodeContent txt) = + if T.strip txt == T.empty + then Nothing + else Just t + goNode other = Just $ other diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.4.3 +Version: 0.5.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -41,6 +41,7 @@ , Codec.Xlsx.Parser.Internal , Codec.Xlsx.Parser.Internal.PivotTable , Codec.Xlsx.Types.AutoFilter + , Codec.Xlsx.Types.Cell , Codec.Xlsx.Types.Comment , Codec.Xlsx.Types.Common , Codec.Xlsx.Types.ConditionalFormatting @@ -106,9 +107,12 @@ test-suite data-test type: exitcode-stdio-1.0 - main-is: DataTest.hs + main-is: Main.hs hs-source-dirs: test/ - other-modules: Diff + other-modules: Common + , Diff + , DrawingTests + , PivotTableTests Build-Depends: base , bytestring , containers