xlsx 0.4.3 → 0.5.0
raw patch · 21 files changed
+1923/−1169 lines, 21 files
Files
- CHANGELOG.markdown +7/−0
- src/Codec/Xlsx/Parser.hs +1/−1
- src/Codec/Xlsx/Parser/Internal.hs +8/−0
- src/Codec/Xlsx/Parser/Internal/PivotTable.hs +26/−18
- src/Codec/Xlsx/Types.hs +48/−95
- src/Codec/Xlsx/Types/Cell.hs +103/−0
- src/Codec/Xlsx/Types/Common.hs +0/−1
- src/Codec/Xlsx/Types/Drawing.hs +1/−1
- src/Codec/Xlsx/Types/Drawing/Chart.hs +385/−98
- src/Codec/Xlsx/Types/Drawing/Common.hs +76/−25
- src/Codec/Xlsx/Types/PivotTable.hs +23/−0
- src/Codec/Xlsx/Types/PivotTable/Internal.hs +66/−3
- src/Codec/Xlsx/Writer.hs +15/−16
- src/Codec/Xlsx/Writer/Internal.hs +1/−1
- src/Codec/Xlsx/Writer/Internal/PivotTable.hs +58/−34
- test/Common.hs +11/−0
- test/DataTest.hs +0/−873
- test/DrawingTests.hs +393/−0
- test/Main.hs +505/−0
- test/PivotTableTests.hs +189/−0
- xlsx.cabal +7/−3
CHANGELOG.markdown view
@@ -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
src/Codec/Xlsx/Parser.hs view
@@ -79,7 +79,7 @@ } deriving Show -type Caches = [(CacheId, (Text, CellRef, [PivotFieldName]))]+type Caches = [(CacheId, (Text, CellRef, [CacheField]))] extractSheet :: Zip.Archive -> SharedStringTable
src/Codec/Xlsx/Parser/Internal.hs view
@@ -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 =
src/Codec/Xlsx/Parser/Internal/PivotTable.hs view
@@ -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)
src/Codec/Xlsx/Types.hs view
@@ -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 @\<f\>@ and inline strings from @\<is\>@--- 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+ ]
+ src/Codec/Xlsx/Types/Cell.hs view
@@ -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 @\<is\>@ 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+ ]+ }
src/Codec/Xlsx/Types/Common.hs view
@@ -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
src/Codec/Xlsx/Types/Drawing.hs view
@@ -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
src/Codec/Xlsx/Types/Drawing/Chart.hs view
@@ -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
src/Codec/Xlsx/Types/Drawing/Common.hs view
@@ -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
src/Codec/Xlsx/Types/PivotTable.hs view
@@ -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
src/Codec/Xlsx/Types/PivotTable/Internal.hs view
@@ -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
src/Codec/Xlsx/Writer.hs view
@@ -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
src/Codec/Xlsx/Writer/Internal.hs view
@@ -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"
src/Codec/Xlsx/Writer/Internal/PivotTable.hs view
@@ -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]-
+ test/Common.hs view
@@ -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
− test/DataTest.hs
@@ -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 <t/>" $- [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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\- \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\- \<si><t>plain text</t></si>\- \<si><r><t>Just </t></r><r><rPr><b val=\"true\"/><u val=\"single\"/>\- \<sz val=\"10\"/><rFont val=\"Arial\"/><family val=\"2\"/></rPr><t>example</t></r></si>\- \</sst>"--testStringsWithEmpty :: ByteString-testStringsWithEmpty = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\- \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\- \<si><t/></si>\- \</sst>"--testComments :: ByteString-testComments = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<comments xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">- <authors>- <author>Bob</author>- <author>CBR</author>- </authors>- <commentList>- <comment ref="D4" authorId="0">- <text>- <r>- <rPr>- <b/><sz val="8"/><color indexed="81"/><rFont val="Calibri"/>- <charset val="1"/><scheme val="minor"/>- </rPr>- <t>Bob:</t>- </r>- <r>- <rPr>- <sz val="8"/><color indexed="81"/><rFont val="Calibri"/>- <charset val="1"/> <scheme val="minor"/>- </rPr>- <t xml:space="preserve">Why such high expense?</t>- </r>- </text>- </comment>- <comment ref="A2" authorId="1">- <text><t>Some comment here</t></text>- </comment>- </commentList>-</comments>-|]--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|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<xdr:wsDr xmlns:xdr="http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">- <xdr:twoCellAnchor editAs="absolute">- <xdr:from>- <xdr:col>0</xdr:col><xdr:colOff>0</xdr:colOff>- <xdr:row>0</xdr:row><xdr:rowOff>0</xdr:rowOff>- </xdr:from>- <xdr:to>- <xdr:col>12</xdr:col><xdr:colOff>320760</xdr:colOff>- <xdr:row>33</xdr:row><xdr:rowOff>38160</xdr:rowOff>- </xdr:to>- <xdr:pic>- <xdr:nvPicPr><xdr:cNvPr id="0" name="Picture 1" descr=""/><xdr:cNvPicPr/></xdr:nvPicPr>- <xdr:blipFill><a:blip r:embed="rId1"></a:blip><a:stretch/></xdr:blipFill>- <xdr:spPr>- <a:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></a:xfrm>- <a:prstGeom prst="rect"><a:avLst/></a:prstGeom><a:ln><a:noFill/></a:ln>- </xdr:spPr>- </xdr:pic>- <xdr:clientData/>- </xdr:twoCellAnchor>- <xdr:twoCellAnchor editAs="oneCell">- <xdr:from>- <xdr:col>0</xdr:col><xdr:colOff>87840</xdr:colOff>- <xdr:row>21</xdr:row><xdr:rowOff>131040</xdr:rowOff>- </xdr:from>- <xdr:to>- <xdr:col>7</xdr:col><xdr:colOff>580320</xdr:colOff>- <xdr:row>38</xdr:row><xdr:rowOff>132480</xdr:rowOff>- </xdr:to>- <xdr:graphicFrame>- <xdr:nvGraphicFramePr><xdr:cNvPr id="1" name=""/><xdr:cNvGraphicFramePr/></xdr:nvGraphicFramePr>- <xdr:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></xdr:xfrm>- <a:graphic>- <a:graphicData uri="http://schemas.openxmlformats.org/drawingml/2006/chart">- <c:chart xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" r:id="rId2"/>- </a:graphicData>- </a:graphic>- </xdr:graphicFrame>- <xdr:clientData/>- </xdr:twoCellAnchor>-</xdr:wsDr>-|]--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|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<Properties xmlns="http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="2" name="prop2">- <vt:lpwstr>222</vt:lpwstr>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="3" name="prop333">- <vt:int>1</vt:int>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="4" name="testTextProp">- <vt:lpwstr>test text property value</vt:lpwstr>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="5" name="decimal">- <vt:decimal>1.234</vt:decimal>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="6" name="bool">- <vt:bool>false</vt:bool>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="7" name="blob">- <vt:blob>- ZXhhbXBs- ZSBibG9i- IGNvbnRl- bnRz- </vt:blob>- </property>-</Properties>-|]--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|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<c:chartSpace xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">-<c:chart>-<c:title>- <c:tx><c:rich><a:bodyPr rot="0" anchor="b"/><a:p><a:r><a:t>Line chart title</a:t></a:r></a:p></c:rich></c:tx>-</c:title>-<c:plotArea>-<c:lineChart>-<c:grouping val="standard"/>-<c:ser>- <c:idx val="0"/><c:order val="0"/>- <c:tx><c:strRef><c:f>Sheet1!$A$1</c:f></c:strRef></c:tx>- <c:marker><c:symbol val="none"/></c:marker>- <c:val><c:numRef><c:f>Sheet1!$B$1:$D$1</c:f></c:numRef></c:val>- <c:smooth val="0"/>-</c:ser>-<c:ser>- <c:idx val="1"/><c:order val="1"/>- <c:tx><c:strRef><c:f>Sheet1!$A$2</c:f></c:strRef></c:tx>- <c:marker><c:symbol val="none"/></c:marker>- <c:val><c:numRef><c:f>Sheet1!$B$2:$D$2</c:f></c:numRef></c:val>- <c:smooth val="0"/>-</c:ser>-<c:marker val="0"/>-<c:smooth val="0"/>-</c:lineChart>-</c:plotArea>-<c:plotVisOnly val="1"/>-<c:dispBlanksAs val="gap"/>-</c:chart>-</c:chartSpace>-|]--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|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot table generated by xlsx-->-<pivotTableDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" name="PivotTable1" cacheId="3" dataOnRows="1" colGrandTotals="0" dataCaption="Values">- <location ref="A3:D12" firstHeaderRow="1" firstDataRow="2" firstDataCol="1"/>- <pivotFields>- <pivotField name="Color" axis="axisRow" showAll="0" outline="0">- <items>- <item t="default"/>- </items>- </pivotField>- <pivotField name="Year" axis="axisCol" showAll="0" outline="1">- <items>- <item t="default"/>- </items>- </pivotField>- <pivotField name="Price" dataField="1" showAll="0" outline="0"/>- <pivotField name="Count" dataField="1" showAll="0" outline="0"/>- </pivotFields>- <rowFields><field x="0"/><field x="-2"/></rowFields>- <colFields><field x="1"/></colFields>- <dataFields>- <dataField name="Sum of field Price" fld="2"/>- <dataField name="Sum of field Count" fld="3"/>- </dataFields>-</pivotTableDefinition>-|]--testPivotCacheDefinition :: ByteString-testPivotCacheDefinition = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot cache definition generated by xlsx-->-<pivotCacheDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"- invalid="1" refreshOnLoad="1"- xmlns:ns="http://schemas.openxmlformats.org/officeDocument/2006/relationships">- <cacheSource type="worksheet">- <worksheetSource ref="A1:D5" sheet="Sheet1"/>- </cacheSource>- <cacheFields>- <cacheField name="Color"/>- <cacheField name="Year"/>- <cacheField name="Price"/>- <cacheField name="Count"/>- </cacheFields>-</pivotCacheDefinition>-|]--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
+ test/DrawingTests.hs view
@@ -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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<xdr:wsDr xmlns:xdr="http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+ <xdr:twoCellAnchor editAs="absolute">+ <xdr:from>+ <xdr:col>0</xdr:col><xdr:colOff>0</xdr:colOff>+ <xdr:row>0</xdr:row><xdr:rowOff>0</xdr:rowOff>+ </xdr:from>+ <xdr:to>+ <xdr:col>12</xdr:col><xdr:colOff>320760</xdr:colOff>+ <xdr:row>33</xdr:row><xdr:rowOff>38160</xdr:rowOff>+ </xdr:to>+ <xdr:pic>+ <xdr:nvPicPr><xdr:cNvPr id="0" name="Picture 1" descr=""/><xdr:cNvPicPr/></xdr:nvPicPr>+ <xdr:blipFill><a:blip r:embed="rId1"></a:blip><a:stretch/></xdr:blipFill>+ <xdr:spPr>+ <a:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></a:xfrm>+ <a:prstGeom prst="rect"><a:avLst/></a:prstGeom><a:ln><a:noFill/></a:ln>+ </xdr:spPr>+ </xdr:pic>+ <xdr:clientData/>+ </xdr:twoCellAnchor>+ <xdr:twoCellAnchor editAs="oneCell">+ <xdr:from>+ <xdr:col>0</xdr:col><xdr:colOff>87840</xdr:colOff>+ <xdr:row>21</xdr:row><xdr:rowOff>131040</xdr:rowOff>+ </xdr:from>+ <xdr:to>+ <xdr:col>7</xdr:col><xdr:colOff>580320</xdr:colOff>+ <xdr:row>38</xdr:row><xdr:rowOff>132480</xdr:rowOff>+ </xdr:to>+ <xdr:graphicFrame>+ <xdr:nvGraphicFramePr><xdr:cNvPr id="1" name=""/><xdr:cNvGraphicFramePr/></xdr:nvGraphicFramePr>+ <xdr:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></xdr:xfrm>+ <a:graphic>+ <a:graphicData uri="http://schemas.openxmlformats.org/drawingml/2006/chart">+ <c:chart xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" r:id="rId2"/>+ </a:graphicData>+ </a:graphic>+ </xdr:graphicFrame>+ <xdr:clientData/>+ </xdr:twoCellAnchor>+</xdr:wsDr>+|]++testWrittenDrawing :: ByteString+testWrittenDrawing = renderLBS def $ toDocument testDrawing++testLineChartFile :: ByteString+testLineChartFile = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<c:chartSpace xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+<c:chart>+<c:title>+ <c:tx><c:rich><a:bodyPr rot="0" anchor="b"/><a:p><a:r><a:t>Line chart title</a:t></a:r></a:p></c:rich></c:tx>+</c:title>+<c:plotArea>+<c:lineChart>+<c:grouping val="standard"/>+<c:ser>+ <c:idx val="0"/><c:order val="0"/>+ <c:tx><c:strRef><c:f>Sheet1!$A$1</c:f></c:strRef></c:tx>+ <c:spPr>+ <a:solidFill><a:srgbClr val="0000FF"/></a:solidFill>+ <a:ln w="28800"><a:solidFill><a:srgbClr val="0000FF"/></a:solidFill></a:ln>+ </c:spPr>+ <c:marker><c:symbol val="none"/></c:marker>+ <c:val><c:numRef><c:f>Sheet1!$B$1:$D$1</c:f></c:numRef></c:val>+ <c:smooth val="0"/>+</c:ser>+<c:ser>+ <c:idx val="1"/><c:order val="1"/>+ <c:tx><c:strRef><c:f>Sheet1!$A$2</c:f></c:strRef></c:tx>+ <c:spPr>+ <a:solidFill><a:srgbClr val="FF0000"/></a:solidFill>+ <a:ln w="28800"><a:solidFill><a:srgbClr val="FF0000"/></a:solidFill></a:ln>+ </c:spPr>+ <c:marker><c:symbol val="none"/></c:marker>+ <c:val><c:numRef><c:f>Sheet1!$B$2:$D$2</c:f></c:numRef></c:val>+ <c:smooth val="0"/>+</c:ser>+<c:marker val="0"/>+<c:smooth val="0"/>+</c:lineChart>+</c:plotArea>+<c:plotVisOnly val="1"/>+<c:dispBlanksAs val="gap"/>+</c:chart>+</c:chartSpace>+|]++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+ }+ ]+ }
+ test/Main.hs view
@@ -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 <t/>" $+ [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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\+ \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\+ \<si><t>plain text</t></si>\+ \<si><r><t>Just </t></r><r><rPr><b val=\"true\"/><u val=\"single\"/>\+ \<sz val=\"10\"/><rFont val=\"Arial\"/><family val=\"2\"/></rPr><t>example</t></r></si>\+ \</sst>"++testStringsWithEmpty :: ByteString+testStringsWithEmpty = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\+ \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\+ \<si><t/></si>\+ \</sst>"++testComments :: ByteString+testComments = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<comments xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">+ <authors>+ <author>Bob</author>+ <author>CBR</author>+ </authors>+ <commentList>+ <comment ref="D4" authorId="0">+ <text>+ <r>+ <rPr>+ <b/><sz val="8"/><color indexed="81"/><rFont val="Calibri"/>+ <charset val="1"/><scheme val="minor"/>+ </rPr>+ <t>Bob:</t>+ </r>+ <r>+ <rPr>+ <sz val="8"/><color indexed="81"/><rFont val="Calibri"/>+ <charset val="1"/> <scheme val="minor"/>+ </rPr>+ <t xml:space="preserve">Why such high expense?</t>+ </r>+ </text>+ </comment>+ <comment ref="A2" authorId="1">+ <text><t>Some comment here</t></text>+ </comment>+ </commentList>+</comments>+|]++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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<Properties xmlns="http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="2" name="prop2">+ <vt:lpwstr>222</vt:lpwstr>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="3" name="prop333">+ <vt:int>1</vt:int>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="4" name="testTextProp">+ <vt:lpwstr>test text property value</vt:lpwstr>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="5" name="decimal">+ <vt:decimal>1.234</vt:decimal>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="6" name="bool">+ <vt:bool>false</vt:bool>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="7" name="blob">+ <vt:blob>+ ZXhhbXBs+ ZSBibG9i+ IGNvbnRl+ bnRz+ </vt:blob>+ </property>+</Properties>+|]++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")+ }+ )+ ]
+ test/PivotTableTests.hs view
@@ -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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot table generated by xlsx-->+<pivotTableDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" name="PivotTable1" cacheId="3" dataOnRows="1" colGrandTotals="0" dataCaption="Values">+ <location ref="A3:D12" firstHeaderRow="1" firstDataRow="2" firstDataCol="1"/>+ <pivotFields>+ <pivotField name="Color" axis="axisRow" showAll="0" outline="0" sortType="ascending">+ <items>+ <item h="1" x="0"/><item x="1"/><item x="2"/><item t="default"/>+ </items>+ </pivotField>+ <pivotField name="Year" axis="axisCol" showAll="0" outline="1">+ <items>+ <item x="0"/><item x="1"/><item t="default"/>+ </items>+ </pivotField>+ <pivotField name="Price" dataField="1" showAll="0" outline="0"/>+ <pivotField name="Count" dataField="1" showAll="0" outline="0"/>+ </pivotFields>+ <rowFields><field x="0"/><field x="-2"/></rowFields>+ <colFields><field x="1"/></colFields>+ <dataFields>+ <dataField name="Sum of field Price" fld="2"/>+ <dataField name="Sum of field Count" fld="3"/>+ </dataFields>+</pivotTableDefinition>+|]++testPivotCacheDefinition :: ByteString+testPivotCacheDefinition = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot cache definition generated by xlsx-->+<pivotCacheDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"+ invalid="1" refreshOnLoad="1"+ xmlns:ns="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+ <cacheSource type="worksheet">+ <worksheetSource ref="A1:D5" sheet="Sheet1"/>+ </cacheSource>+ <cacheFields>+ <cacheField name="Color">+ <sharedItems>+ <s v="green"/><s v="white"/><s v="red"/>+ </sharedItems>+ </cacheField>+ <cacheField name="Year">+ <sharedItems containsNumber="1" containsString="0" containsSemiMixedTypes="0">+ <n v="2012"/><n v="2011"/>+ </sharedItems>+ </cacheField>+ <cacheField name="Price">+ <sharedItems containsNumber="1" containsString="0" containsSemiMixedTypes="0">+ <n v="12.23"/><n v="73.99"/><n v="10.19"/><n v="34.99"/>+ </sharedItems>+ </cacheField>+ <cacheField name="Count">+ <sharedItems containsNumber="1" containsString="0" containsSemiMixedTypes="0">+ <n v="17"/><n v="21"/><n v="172"/><n v="49"/>+ </sharedItems>+ </cacheField>+</cacheFields>+</pivotCacheDefinition>+|]++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
xlsx.cabal view
@@ -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