diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,139 @@ +1.2.0 +------------ +* expose sheet state in stream parser + (thanks to Benjamin McRae ) +* drop unnecessary `n` namespace from stream writer + (thanks to Michael Schneider ) +* add support support for writing multiple sheets with stream writer + (thanks to Michael Schneider ) + +1.1.4 +------------ +* fix the problem with leading slashes for comments, drawings and pivot tables + (thanks to mindston ) + +1.1.3 +------------ +* fixed compatibility with xml-conduit moving `rsPretty` into internal module +* dropped support for GHC 9.0.* and added support for GHC 9.8.* + +1.1.2 +------------ +* Strip leading slash from target paths in relations as the ECMA-376 spec requires + (thanks to Luke Clifton ) + +1.1.1 +------------ +* dropped support for GHC 8.8.* and 8.10.* and added support for GHC 9.4.* and 9.6.* + +1.1.0 +------------ +* Fix default cell type in streaming parser + (thanks to Nikita Razmakhnin ) +* Implemented cell range data validation + (thanks to Florian Fouratier <6524406+flhorizon@users.noreply.github.com>) +* Added support for sheet visibility + (thanks to Florian Fouratier <6524406+flhorizon@users.noreply.github.com>) +* Added parsing of comment visibility + (thanks to Luke ) +* Added newtypes for column and row indices + (thanks to Luke ) + +1.0.0 +------------ +* Add support for streaming xlsx files +* dropped support for GHC 8.4.* and 8.6.* and added support for GHC 9.2.* +* Treat 1900 as a leap year like Excel does + +0.8.4 +------------ +* dropped support for GHC 8.0.* and 8.2.* and added support for GHC 8.10.* and 9.0.* + +0.8.3 +------------ +* compatibility with lens-5.0 +* don't output lists with no elements in stylesheet as it causes problems in + Excel + (thanks to David Hewson ) + +0.8.2 +------ +* added a flag allowing to use `microlens` instead of `lens` + (thanks to Samuel Balco ) + +0.8.1 +------ +* compatibility with smallcheck-1.2.0 + +0.8.0 +------ +* GHC 8.8 compatibility added (GHC 8.6 didn't need any updates). Dropped + compatilibity with GHC 7.10 + (thanks to David Hewson ) + +0.7.2 +----- +* GHC 8.4 compatibility + +0.7.1 +----- +* improved compatibility with Excel in pivot cache serialization +* added support for character references in fast parsing with `xeno` + +0.7.0 +----- +* fixed serialization of large integer values (thanks Radoslav Dorcik + ) +* added fast xlsx parsing using `xeno` library +* dropped support for GHC 7.8.4 and added support for GHC 8.2.2 +* added numer format support in differential formatting records + (thanks Emil Axelsson ) +* added `inlineStr` cell type support +* added shared formulas support +* added error values support +* helper functions for serialization/deserialization of date values + (thanks José Romildo Malaquias ) + +0.6.0 +----- +* fixed reading files with optional table name (thanks Aleksey Khudyakov + for reporting) +* removed unnecessary 10cm offset from `simpleAnchorXY` +* `customRowHeight` added to row properties (thanks Aleksey Khudyakov + ) +* added `Generic` instances for library types (thanks Remy Goldschmidt + ) +* `hidden` property added for rows (thanks Aleksey Khudyakov + ) + +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 +* switched to use `r` prefix for relationships namespace in + workbook.xml to improve compatibility with readers expecting that + prefix (thanks Stéphane Laurent for + reporting) +* fixed parsing cells with comments but with no content (thanks + Stéphane Laurent for reporting) +* added some higher-level helpers work with pictures in SpreadsheetML + Drawing + +0.4.2 +----- +* added basic tables support +* fixed boolean element parsing for rich text run properties (thanks + laurent stephane for reporting) +* fixed problem of `cwStyle` not being optional (thanks laurent + stephane for reporting) +* added basic autofilter support + 0.4.1 ----- * fixed serialization problem of empty validations and pivot caches diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Codec.Xlsx +import Codec.Xlsx.Parser.Stream +import Codec.Xlsx.Writer.Stream +import Control.DeepSeq +import Control.Lens +import Control.Monad (void) +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import qualified Data.Conduit as C +import qualified Data.Conduit.Combinators as C +import Data.Maybe + +main :: IO () +main = do + let filename = "data/testInput.xlsx" + -- "data/6000.rows.x.26.cols.xlsx" + bs <- BS.readFile filename + let bs' = LB.fromStrict bs + parsed :: Xlsx + parsed = toXlsxFast bs' + idx <- fmap (fromMaybe (error "ix not found")) $ runXlsxM filename $ makeIndexFromName "Sample list" + items <- runXlsxM filename $ collectItems idx + deepseq (parsed, bs', idx, items) (pure ()) + defaultMain + [ bgroup + "readFile" + [ bench "with xlsx" $ nf toXlsx bs' + , bench "with xlsx fast" $ nf toXlsxFast bs' + , bench "with stream (counting)" $ nfIO $ runXlsxM filename $ countRowsInSheet idx + , bench "with stream (reading)" $ nfIO $ runXlsxM filename $ readSheet idx (pure . rwhnf) + ] + , bgroup + "writeFile" + [ bench "with xlsx" $ nf (fromXlsx 0) parsed + , bench "with stream (no sst)" $ + nfIO $ C.runConduit $ + void (writeXlsxWithSharedStrings defaultSettings mempty $ C.yieldMany $ view si_row <$> items) + C..| C.fold + , bench "with stream (sst)" $ + nfIO $ C.runConduit $ + void (writeXlsx defaultSettings $ C.yieldMany $ view si_row <$> items) + C..| C.fold + ] + ] diff --git a/data/absolute_relationships.xlsx b/data/absolute_relationships.xlsx new file mode 100644 Binary files /dev/null and b/data/absolute_relationships.xlsx differ diff --git a/data/floats.xlsx b/data/floats.xlsx new file mode 100644 Binary files /dev/null and b/data/floats.xlsx differ diff --git a/data/inline-strings.xlsx b/data/inline-strings.xlsx new file mode 100644 Binary files /dev/null and b/data/inline-strings.xlsx differ diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -1,12 +1,14 @@ -- | Higher level interface for creating styled worksheets -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module Codec.Xlsx.Formatted ( - FormattedCell(..) +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Formatted + ( FormattedCell(..) , Formatted(..) + , Format(..) , formatted + , formatWorkbook , toFormattedCells , CondFormatted(..) , conditionallyFormatted @@ -32,26 +34,24 @@ , condfmtStopIfTrue ) where -import Control.Lens -import Control.Monad.State hiding (forM_, mapM) -import Data.Default -import Data.Foldable (asum, forM_) -import Data.Function (on) -import Data.List (foldl', groupBy, sortBy, sortBy) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Ord (comparing) -import Data.Text (Text) -import Data.Traversable (mapM) -import Data.Tuple (swap) -import Prelude hiding (mapM) -import Safe (headNote, fromJustNote) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Codec.Xlsx.LensCompat +import Control.Monad (forM, guard) +import Control.Monad.State hiding (forM_, mapM) +import Data.Default +import Data.Foldable (asum, forM_) +import Data.Function (on) +import Data.List (foldl', groupBy, sortBy, sortBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Ord (comparing) +import Data.Text (Text) +import Data.Traversable (mapM) +import Data.Tuple (swap) +import GHC.Generics (Generic) +import Prelude hiding (mapM) +import Safe (headNote, fromJustNote) -import Codec.Xlsx.Types +import Codec.Xlsx.Types {------------------------------------------------------------------------------- Internal: formatting state @@ -74,7 +74,7 @@ , _formattingCellXfs = fromValueList _styleSheetCellXfs , _formattingFills = fromValueList _styleSheetFills , _formattingFonts = fromValueList _styleSheetFonts - , _formattingNumFmts = M.empty + , _formattingNumFmts = M.fromList . map swap $ M.toList _styleSheetNumFmts , _formattingMerges = [] } @@ -118,7 +118,7 @@ , _condfmtDxf :: Dxf , _condfmtPriority :: Int , _condfmtStopIfTrue :: Maybe Bool - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) makeLenses ''FormattedCondFmt @@ -141,7 +141,7 @@ , _formatProtection :: Maybe Protection , _formatPivotButton :: Maybe Bool , _formatQuotePrefix :: Maybe Bool - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) makeLenses ''Format @@ -153,7 +153,7 @@ , _formattedFormat :: Format , _formattedColSpan :: Int , _formattedRowSpan :: Int - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) makeLenses ''FormattedCell @@ -200,7 +200,7 @@ -- | The final list of cell merges; see '_wsMerges' , formattedMerges :: [Range] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -- | Higher level API for creating formatted documents -- @@ -227,7 +227,7 @@ -- -- If you don't already have a 'StyleSheet' you want to use as starting point -- then 'minimalStyleSheet' is a good choice. -formatted :: Map (Int, Int) FormattedCell -> StyleSheet -> Formatted +formatted :: Map (RowIndex, ColumnIndex) FormattedCell -> StyleSheet -> Formatted formatted cs styleSheet = let initSt = stateFromStyleSheet styleSheet (cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt @@ -238,9 +238,26 @@ , formattedMerges = reverse (finalSt ^. formattingMerges) } +-- | Build an 'Xlsx', render provided cells as per the 'StyleSheet'. +formatWorkbook :: + [(Text, Map (RowIndex, ColumnIndex) FormattedCell)] -> StyleSheet -> Xlsx +formatWorkbook nfcss initStyle = extract go + where + initSt = stateFromStyleSheet initStyle + go = flip runState initSt $ + forM nfcss $ \(name, fcs) -> do + cs' <- forM (M.toList fcs) $ \(rc, fc) -> formatCell rc fc + merges <- reverse . _formattingMerges <$> get + return ( name + , def & wsCells .~ M.fromList (concat cs') + & wsMerges .~ merges) + extract (sheets, st) = + def & xlSheets .~ sheets + & xlStyles .~ renderStyleSheet (updateStyleSheetFromState initStyle st) + -- | reverse to 'formatted' which allows to get a map of formatted cells -- from an existing worksheet and its workbook's style sheet -toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (Int, Int) FormattedCell +toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (RowIndex, ColumnIndex) FormattedCell toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m where toFormattedCell cell@Cell{..} = @@ -278,18 +295,21 @@ if apply then prop cXf else fail "not applied" applyMerges cells = foldl' onlyTopLeft cells merges onlyTopLeft cells range = flip execState cells $ do - let ((r1, c1), (r2, c2)) = fromJustNote "fromRange" $ fromRange range + let ((r1, c1), (r2, c2)) = + fromJustNote "fromRange" $ fromRange range nonTopLeft = tail [(r, c) | r<-[r1..r2], c<-[c1..c2]] forM_ nonTopLeft (modify . M.delete) - at (r1, c1) . non def . formattedRowSpan .= (r2 - r1 +1) - at (r1, c1) . non def . formattedColSpan .= (c2 - c1 +1) + at (r1, c1) . non def . formattedRowSpan .= + (unRowIndex r2 - unRowIndex r1 + 1) + at (r1, c1) . non def . formattedColSpan .= + (unColumnIndex c2 - unColumnIndex c1 + 1) data CondFormatted = CondFormatted { -- | The resulting stylesheet condformattedStyleSheet :: StyleSheet -- | The final map of conditional formatting rules applied to ranges , condformattedFormattings :: Map SqRef ConditionalFormatting - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) conditionallyFormatted :: Map CellRef [FormattedCondFmt] -> StyleSheet -> CondFormatted conditionallyFormatted cfs styleSheet = CondFormatted @@ -311,14 +331,16 @@ -------------------------------------------------------------------------------} -- | Format a cell with (potentially) rowspan or colspan -formatCell :: (Int, Int) -> FormattedCell -> State FormattingState [((Int, Int), Cell)] +formatCell :: (RowIndex, ColumnIndex) -> FormattedCell + -> State FormattingState [((RowIndex, ColumnIndex), Cell)] formatCell (row, col) cell = do let (block, mMerge) = cellBlock (row, col) cell forM_ mMerge $ \merge -> formattingMerges %= (:) merge mapM go block where - go :: ((Int, Int), FormattedCell) -> State FormattingState ((Int, Int), Cell) - go (pos, c@ FormattedCell{..}) = do + go :: ((RowIndex, ColumnIndex), FormattedCell) + -> State FormattingState ((RowIndex, ColumnIndex), Cell) + go (pos, c@FormattedCell{..}) = do styleId <- cellStyleId c return (pos, _formattedCell{_cellStyle = styleId}) @@ -331,11 +353,11 @@ -- remaining cells are the cells covered by the rowspan/colspan. -- -- Also returns the cell merge instruction, if any. -cellBlock :: (Int, Int) -> FormattedCell - -> ([((Int, Int), FormattedCell)], Maybe Range) +cellBlock :: (RowIndex, ColumnIndex) -> FormattedCell + -> ([((RowIndex, ColumnIndex), FormattedCell)], Maybe Range) cellBlock (row, col) cell@FormattedCell{..} = (block, merge) where - block :: [((Int, Int), FormattedCell)] + block :: [((RowIndex, ColumnIndex), FormattedCell)] block = [ ((row', col'), cellAt (row', col')) | row' <- [topRow .. bottomRow] , col' <- [leftCol .. rightCol] @@ -345,7 +367,7 @@ merge = do guard (topRow /= bottomRow || leftCol /= rightCol) return $ mkRange (topRow, leftCol) (bottomRow, rightCol) - cellAt :: (Int, Int) -> FormattedCell + cellAt :: (RowIndex, ColumnIndex) -> FormattedCell cellAt (row', col') = if row' == row && col == col' then cell @@ -353,18 +375,19 @@ border = _formatBorder _formattedFormat - borderAt :: (Int, Int) -> Border + borderAt :: (RowIndex, ColumnIndex) -> Border borderAt (row', col') = def & borderTop .~ do guard (row' == topRow) ; _borderTop =<< border & borderBottom .~ do guard (row' == bottomRow) ; _borderBottom =<< border & borderLeft .~ do guard (col' == leftCol) ; _borderLeft =<< border & borderRight .~ do guard (col' == rightCol) ; _borderRight =<< border - topRow, bottomRow, leftCol, rightCol :: Int + topRow, bottomRow :: RowIndex + leftCol, rightCol :: ColumnIndex topRow = row - bottomRow = row + _formattedRowSpan - 1 + bottomRow = RowIndex $ unRowIndex row + _formattedRowSpan - 1 leftCol = col - rightCol = col + _formattedColSpan - 1 + rightCol = ColumnIndex $ unColumnIndex col + _formattedColSpan - 1 cellStyleId :: FormattedCell -> State FormattingState (Maybe Int) cellStyleId c = mapM (getId formattingCellXfs) =<< constructCellXf c diff --git a/src/Codec/Xlsx/Lens.hs b/src/Codec/Xlsx/Lens.hs --- a/src/Codec/Xlsx/Lens.hs +++ b/src/Codec/Xlsx/Lens.hs @@ -1,36 +1,32 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} -- | lenses to access sheets, cells and values of 'Xlsx' - module Codec.Xlsx.Lens - ( ixSheet - , atSheet - , ixCell - , ixCellRC - , ixCellXY - , atCell - , atCellRC - , atCellXY - , cellValueAt - , cellValueAtRC - , cellValueAtXY - ) where - -import Codec.Xlsx.Types -import Control.Lens -import Data.Function (on) -import Data.List (deleteBy) -import Data.Text -import Data.Tuple (swap) + ( ixSheet + , atSheet + , ixCell + , ixCellRC + , ixCellXY + , atCell + , atCellRC + , atCellXY + , cellValueAt + , cellValueAtRC + , cellValueAtXY + ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Codec.Xlsx.Types +import Codec.Xlsx.LensCompat +import Data.Function (on) +import Data.List (deleteBy) +import Data.Text +import Data.Tuple (swap) +import GHC.Generics (Generic) newtype SheetList = SheetList{ unSheetList :: [(Text, Worksheet)] } - deriving (Eq, Show) + deriving (Eq, Show, Generic) type instance IxValue (SheetList) = Worksheet type instance Index (SheetList) = Text @@ -56,61 +52,58 @@ then (k,v):r else (k1,v1):upsert k v r -sheetList :: Iso' [(Text, Worksheet)] SheetList -sheetList = iso SheetList unSheetList - -- | lens giving access to a worksheet from 'Xlsx' object -- by its name ixSheet :: Text -> Traversal' Xlsx Worksheet -ixSheet s = xlSheets . sheetList . ix s +ixSheet s = xlSheets . \f -> fmap unSheetList . ix s f . SheetList -- | 'Control.Lens.At' variant of 'ixSheet' lens -- -- /Note:/ if there is no such sheet in this workbook then new sheet will be -- added as the last one to the sheet list atSheet :: Text -> Lens' Xlsx (Maybe Worksheet) -atSheet s = xlSheets . sheetList . at s +atSheet s = xlSheets . \f -> fmap unSheetList . at s f . SheetList -- | lens giving access to a cell in some worksheet -- by its position, by default row+column index is used -- so this lens is a synonym of 'ixCellRC' -ixCell :: (Int, Int) -> Traversal' Worksheet Cell +ixCell :: (RowIndex, ColumnIndex) -> Traversal' Worksheet Cell ixCell = ixCellRC -- | lens to access cell in a worksheet -ixCellRC :: (Int, Int) -> Traversal' Worksheet Cell +ixCellRC :: (RowIndex, ColumnIndex) -> Traversal' Worksheet Cell ixCellRC i = wsCells . ix i -- | lens to access cell in a worksheet using more traditional -- x+y coordinates -ixCellXY :: (Int, Int) -> Traversal' Worksheet Cell -ixCellXY = ixCellRC . swap +ixCellXY :: (ColumnIndex, RowIndex) -> Traversal' Worksheet Cell +ixCellXY i = ixCellRC $ swap i -- | accessor that can read, write or delete cell in a worksheet -- synonym of 'atCellRC' so uses row+column index -atCell :: (Int, Int) -> Lens' Worksheet (Maybe Cell) +atCell :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe Cell) atCell = atCellRC -- | lens to read, write or delete cell in a worksheet -atCellRC :: (Int, Int) -> Lens' Worksheet (Maybe Cell) +atCellRC :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe Cell) atCellRC i = wsCells . at i -- | lens to read, write or delete cell in a worksheet -- using more traditional x+y or row+column index -atCellXY :: (Int, Int) -> Lens' Worksheet (Maybe Cell) -atCellXY = atCellRC . swap +atCellXY :: (ColumnIndex, RowIndex) -> Lens' Worksheet (Maybe Cell) +atCellXY i = atCellRC $ swap i -- | lens to read, write or delete cell value in a worksheet -- with row+column coordinates, synonym for 'cellValueRC' -cellValueAt :: (Int, Int) -> Lens' Worksheet (Maybe CellValue) +cellValueAt :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe CellValue) cellValueAt = cellValueAtRC -- | lens to read, write or delete cell value in a worksheet -- using row+column coordinates of that cell -cellValueAtRC :: (Int, Int) -> Lens' Worksheet (Maybe CellValue) +cellValueAtRC :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe CellValue) cellValueAtRC i = atCell i . non def . cellValue -- | lens to read, write or delete cell value in a worksheet -- using traditional x+y coordinates -cellValueAtXY :: (Int, Int) -> Lens' Worksheet (Maybe CellValue) -cellValueAtXY = cellValueAtRC . swap +cellValueAtXY :: (ColumnIndex, RowIndex) -> Lens' Worksheet (Maybe CellValue) +cellValueAtXY i = cellValueAtRC $ swap i diff --git a/src/Codec/Xlsx/LensCompat.hs b/src/Codec/Xlsx/LensCompat.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/LensCompat.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +module Codec.Xlsx.LensCompat + ( module L + , Prism + , Prism' + , prism + , (<>=) + ) where + +#ifdef USE_MICROLENS + +import Lens.Micro as L +import Lens.Micro.GHC () +import Lens.Micro.Mtl as L +import Lens.Micro.Platform as L +import Data.Profunctor.Choice +import Data.Profunctor (dimap) +import Data.Traversable.WithIndex as L +import Lens.Micro.Internal as L +import Control.Monad.State.Class (MonadState, modify) + +-- Since micro-lens denies the existence of prisms, +-- I copied over the definitions from Control.Lens for the prism +-- function. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) +type Prism' s a = Prism s s a a + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism bt seta = dimap seta (either pure (fmap bt)) . right' + +(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () +l <>= a = modify (l <>~ a) + +#else + +import Control.Lens as L + +#endif diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -1,196 +1,527 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -- | This module provides a function for reading .xlsx files module Codec.Xlsx.Parser - ( toXlsx - , toXlsxEither - , ParseError (..) - , Parser - ) where + ( toXlsx + , toXlsxEither + , toXlsxFast + , toXlsxEitherFast + , ParseError(..) + , Parser + ) where -import qualified Codec.Archive.Zip as Zip -import Control.Applicative -import Control.Arrow (left) -import Control.Error.Safe (headErr) -import Control.Error.Util (note) -import Control.Lens hiding (element, - views, (<.>)) -import Control.Monad.Except (catchError, - throwError) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Char8 () -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid -import Data.Ord -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as T -import Data.Traversable -import Prelude hiding (sequence) -import System.FilePath.Posix -import Text.XML as X -import Text.XML.Cursor +import qualified "zip-archive" Codec.Archive.Zip as Zip +import Control.Applicative +import Control.Arrow (left) +import Control.Error.Safe (headErr) +import Control.Error.Util (note) +import Control.Exception (Exception) +import Codec.Xlsx.LensCompat hiding ((<.>), element, views) +import Control.Monad (join, void, liftM4) +import Control.Monad.Except (catchError, throwError) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as LB +import Data.ByteString.Lazy.Char8 () +import Data.List +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Traversable +import GHC.Generics (Generic) +import Prelude hiding (sequence) +import Safe (headNote) +import System.FilePath.Posix +import Text.XML as X +import Text.XML.Cursor hiding (bool) +import qualified Xeno.DOM as Xeno -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Parser.Internal.PivotTable -import Codec.Xlsx.Types -import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Types.Internal.CfPair -import Codec.Xlsx.Types.Internal.CommentTable -import Codec.Xlsx.Types.Internal.ContentTypes as ContentTypes -import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties -import Codec.Xlsx.Types.Internal.DvPair -import Codec.Xlsx.Types.Internal.Relationships as Relationships -import Codec.Xlsx.Types.Internal.SharedStringTable -import Codec.Xlsx.Types.PivotTable.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Parser.Internal.PivotTable +import Codec.Xlsx.Types +import Codec.Xlsx.Types.Cell (formulaDataFromCursor) +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Types.Internal.CfPair +import Codec.Xlsx.Types.Internal.CommentTable as CommentTable +import Codec.Xlsx.Types.Internal.ContentTypes as ContentTypes +import Codec.Xlsx.Types.Internal.CustomProperties + as CustomProperties +import Codec.Xlsx.Types.Internal.DvPair +import Codec.Xlsx.Types.Internal.FormulaData +import Codec.Xlsx.Types.Internal.Relationships as Relationships +import Codec.Xlsx.Types.Internal.SharedStringTable +import Codec.Xlsx.Types.PivotTable.Internal -- | Reads `Xlsx' from raw data (lazy bytestring) toXlsx :: L.ByteString -> Xlsx toXlsx = either (error . show) id . toXlsxEither -data ParseError = InvalidZipArchive +data ParseError = InvalidZipArchive String | MissingFile FilePath - | InvalidFile FilePath + | InvalidFile FilePath Text | InvalidRef FilePath RefId | InconsistentXlsx Text - deriving (Show, Eq) + deriving (Eq, Show, Generic) +instance Exception ParseError + type Parser = Either ParseError --- | Reads `Xlsx' from raw data (lazy bytestring), failing with Left on parse error +-- | Reads `Xlsx' from raw data (lazy bytestring) using @xeno@ library +-- using some "cheating": +-- +-- * not doing 100% xml validation +-- * replacing only +-- and +-- (without checking codepoint validity) +-- * almost not using XML namespaces +toXlsxFast :: L.ByteString -> Xlsx +toXlsxFast = either (error . show) id . toXlsxEitherFast + +-- | Reads `Xlsx' from raw data (lazy bytestring), failing with 'Left' on parse error toXlsxEither :: L.ByteString -> Parser Xlsx -toXlsxEither bs = do - ar <- left (const InvalidZipArchive) $ Zip.toArchiveOrFail bs +toXlsxEither = toXlsxEitherBase extractSheet + +-- | Fast parsing with 'Left' on parse error, see 'toXlsxFast' +toXlsxEitherFast :: L.ByteString -> Parser Xlsx +toXlsxEitherFast = toXlsxEitherBase extractSheetFast + +toXlsxEitherBase :: + (Zip.Archive -> SharedStringTable -> ContentTypes -> Caches -> WorksheetFile -> Parser Worksheet) + -> L.ByteString + -> Parser Xlsx +toXlsxEitherBase parseSheet bs = do + ar <- left InvalidZipArchive $ Zip.toArchiveOrFail bs sst <- getSharedStrings ar contentTypes <- getContentTypes ar - (wfs, names, cacheSources) <- readWorkbook ar + (wfs, names, cacheSources, dateBase) <- readWorkbook ar sheets <- forM wfs $ \wf -> do - sheet <- extractSheet ar sst contentTypes cacheSources wf - return (wfName wf, sheet) + sheet <- parseSheet ar sst contentTypes cacheSources wf + return . (wfName wf,) . (wsState .~ wfState wf) $ sheet CustomProperties customPropMap <- getCustomProperties ar - return $ Xlsx sheets (getStyles ar) names customPropMap + return $ Xlsx sheets (getStyles ar) names customPropMap dateBase data WorksheetFile = WorksheetFile { wfName :: Text + , wfSheetId :: Int + , wfState :: SheetState , wfPath :: FilePath } - deriving Show + deriving (Show, Generic) -type Caches = [(CacheId, (Text, CellRef, [PivotFieldName]))] +type Caches = [(CacheId, (Text, CellRef, [CacheField]))] -extractSheet :: Zip.Archive - -> SharedStringTable - -> ContentTypes - -> Caches - -> WorksheetFile - -> Parser Worksheet +extractSheetFast :: Zip.Archive + -> SharedStringTable + -> ContentTypes + -> Caches + -> WorksheetFile + -> Parser Worksheet +extractSheetFast ar sst contentTypes caches wf = do + file <- + note (MissingFile filePath) $ + Zip.fromEntry <$> Zip.findEntryByPath filePath ar + sheetRels <- getRels ar filePath + root <- + left (\ex -> InvalidFile filePath $ T.pack (show ex)) $ + Xeno.parse (LB.toStrict file) + parseWorksheet root sheetRels + where + filePath = wfPath wf + parseWorksheet :: Xeno.Node -> Relationships -> Parser Worksheet + parseWorksheet root sheetRels = do + let prefixes = nsPrefixes root + odrNs = + "http://schemas.openxmlformats.org/officeDocument/2006/relationships" + odrX = addPrefix prefixes odrNs + skip = void . maybeChild + (ws, tableIds, drawingRId, legacyDrRId) <- + liftEither . collectChildren root $ do + skip "sheetPr" + skip "dimension" + _wsSheetViews <- fmap justNonEmpty . maybeParse "sheetViews" $ \n -> + collectChildren n $ fromChildList "sheetView" + skip "sheetFormatPr" + _wsColumnsProperties <- + fmap (fromMaybe []) . maybeParse "cols" $ \n -> + collectChildren n (fromChildList "col") + (_wsRowPropertiesMap, _wsCells, _wsSharedFormulas) <- + requireAndParse "sheetData" $ \n -> do + rows <- collectChildren n $ childList "row" + collectRows <$> forM rows parseRow + skip "sheetCalcPr" + _wsProtection <- maybeFromChild "sheetProtection" + skip "protectedRanges" + skip "scenarios" + _wsAutoFilter <- maybeFromChild "autoFilter" + skip "sortState" + skip "dataConsolidate" + skip "customSheetViews" + _wsMerges <- fmap (fromMaybe []) . maybeParse "mergeCells" $ \n -> do + mCells <- collectChildren n $ childList "mergeCell" + forM mCells $ \mCell -> parseAttributes mCell $ fromAttr "ref" + _wsConditionalFormattings <- + M.fromList . map unCfPair <$> fromChildList "conditionalFormatting" + _wsDataValidations <- + fmap (fromMaybe mempty) . maybeParse "dataValidations" $ \n -> do + M.fromList . map unDvPair <$> + collectChildren n (fromChildList "dataValidation") + skip "hyperlinks" + skip "printOptions" + skip "pageMargins" + _wsPageSetup <- maybeFromChild "pageSetup" + skip "headerFooter" + skip "rowBreaks" + skip "colBreaks" + skip "customProperties" + skip "cellWatches" + skip "ignoredErrors" + skip "smartTags" + drawingRId <- maybeParse "drawing" $ \n -> + parseAttributes n $ fromAttr (odrX "id") + legacyDrRId <- maybeParse "legacyDrawing" $ \n -> + parseAttributes n $ fromAttr (odrX "id") + tableIds <- fmap (fromMaybe []) . maybeParse "tableParts" $ \n -> do + tParts <- collectChildren n $ childList "tablePart" + forM tParts $ \part -> + parseAttributes part $ fromAttr (odrX "id") + + -- all explicitly assigned fields filled below + return ( + Worksheet + { _wsDrawing = Nothing + , _wsPivotTables = [] + , _wsTables = [] + , _wsState = wfState wf + , .. + } + , tableIds + , drawingRId + , legacyDrRId) + + let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" + commentTarget :: Maybe FilePath + commentTarget = logicalNameToZipItemName . relTarget <$> findRelByType commentsType sheetRels + legacyDrPath = fmap (logicalNameToZipItemName . relTarget) . flip Relationships.lookup sheetRels =<< legacyDrRId + commentsMap <- + fmap join . forM commentTarget $ getComments ar legacyDrPath + let commentCells = + M.fromList + [ (fromSingleCellRefNoting r, def { _cellComment = Just cmnt}) + | (r, cmnt) <- maybe [] CommentTable.toList commentsMap + ] + assignComment withCmnt noCmnt = + noCmnt & cellComment .~ (withCmnt ^. cellComment) + mergeComments = M.unionWith assignComment commentCells + tables <- forM tableIds $ \rId -> do + fp <- lookupRelPath filePath sheetRels rId + getTable ar fp + drawing <- forM drawingRId $ \dId -> do + fp <- lookupRelPath filePath sheetRels dId + getDrawing ar contentTypes fp + let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable" + pivotTables <- forM (allByType ptType sheetRels) $ \rel -> do + let ptPath = logicalNameToZipItemName $ relTarget rel + bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar + note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $ + parsePivotTable (flip Prelude.lookup caches) bs + + return $ ws & wsTables .~ tables + & wsCells %~ mergeComments + & wsDrawing .~ drawing + & wsPivotTables .~ pivotTables + liftEither :: Either Text a -> Parser a + liftEither = left (\t -> InvalidFile filePath t) + justNonEmpty v@(Just (_:_)) = v + justNonEmpty _ = Nothing + collectRows = foldr collectRow (M.empty, M.empty, M.empty) + collectRow :: + ( RowIndex + , Maybe RowProperties + , [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))]) + -> ( Map RowIndex RowProperties + , CellMap + , Map SharedFormulaIndex SharedFormulaOptions) + -> ( Map RowIndex RowProperties + , CellMap + , Map SharedFormulaIndex SharedFormulaOptions) + collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) = + let (newCells0, newSharedF0) = + unzip [(((rInd, cInd), cd), shared) | (rInd, cInd, cd, shared) <- rowCells] + newCells = M.fromAscList newCells0 + newSharedF = M.fromAscList $ catMaybes newSharedF0 + newRowMap = + case mRP of + Just rp -> M.insert r rp rowMap + Nothing -> rowMap + in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) + parseRow :: + Xeno.Node + -> Either Text ( RowIndex + , Maybe RowProperties + , [( RowIndex + , ColumnIndex + , Cell + , Maybe (SharedFormulaIndex, SharedFormulaOptions))]) + parseRow row = do + (r, s, ht, cstHt, hidden) <- + parseAttributes row $ + ((,,,,) <$> fromAttr "r" <*> maybeAttr "s" <*> maybeAttr "ht" <*> + fromAttrDef "customHeight" False <*> + fromAttrDef "hidden" False) + let props = + RowProps + { rowHeight = + if cstHt + then CustomHeight <$> ht + else AutomaticHeight <$> ht + , rowStyle = s + , rowHidden = hidden + } + cellNodes <- collectChildren row $ childList "c" + cells <- forM cellNodes parseCell + return + ( RowIndex r + , if props == def + then Nothing + else Just props + , cells) + + -- NB: According to format specification default value for cells without + -- `t` attribute is a `n` - number. + -- + -- Schema part from spec (see the `CellValue` spec reference): + -- + -- .. + -- + -- + parseCell :: + Xeno.Node + -> Either Text ( RowIndex + , ColumnIndex + , Cell + , Maybe (SharedFormulaIndex, SharedFormulaOptions)) + parseCell cell = do + (ref, s, t) <- + parseAttributes cell $ + (,,) <$> fromAttr "r" <*> maybeAttr "s" <*> fromAttrDef "t" "n" + (fNode, vNode, isNode) <- + collectChildren cell $ + (,,) <$> maybeChild "f" <*> maybeChild "v" <*> maybeChild "is" + let vConverted :: (FromAttrBs a) => Either Text (Maybe a) + vConverted = + case contentBs <$> vNode of + Nothing -> return Nothing + Just c -> Just <$> fromAttrBs c + mFormulaData <- mapM fromXenoNode fNode + d <- + case t of + ("s" :: ByteString) -> do + si <- vConverted + case sstItem sst =<< si of + Just xlTxt -> return $ Just (xlsxTextToCellValue xlTxt) + Nothing -> throwError "bad shared string index" + "inlineStr" -> mapM (fmap xlsxTextToCellValue . fromXenoNode) isNode + "str" -> fmap CellText <$> vConverted + "n" -> fmap CellDouble <$> vConverted + "b" -> fmap CellBool <$> vConverted + "e" -> fmap CellError <$> vConverted + unexpected -> + throwError $ "unexpected cell type " <> T.pack (show unexpected) + let (r, c) = fromSingleCellRefNoting ref + f = frmdFormula <$> mFormulaData + shared = frmdShared =<< mFormulaData + return (r, c, Cell s d Nothing f, shared) + +extractSheet :: + Zip.Archive + -> SharedStringTable + -> ContentTypes + -> Caches + -> WorksheetFile + -> Parser Worksheet extractSheet ar sst contentTypes caches wf = do let filePath = wfPath wf file <- note (MissingFile filePath) $ Zip.fromEntry <$> Zip.findEntryByPath filePath ar - cur <- fmap fromDocument . left (\_ -> InvalidFile filePath) $ + cur <- fmap fromDocument . left (\ex -> InvalidFile filePath (T.pack $ show ex)) $ parseLBS def file sheetRels <- getRels ar filePath -- The specification says the file should contain either 0 or 1 @sheetViews@ -- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910) - let sheetViewList = cur $/ element (n_ "sheetViews") &/ element (n_ "sheetView") >=> fromCursor + let sheetViewList = cur $/ element (addSmlNamespace "sheetViews") &/ element (addSmlNamespace "sheetView") >=> fromCursor sheetViews = case sheetViewList of [] -> Nothing views -> Just views let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" commentTarget :: Maybe FilePath - commentTarget = relTarget <$> findRelByType commentsType sheetRels - legacyDrRId = cur $/ element (n_ "legacyDrawing") >=> fromAttribute (odr"id") - legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId + commentTarget = logicalNameToZipItemName . relTarget <$> findRelByType commentsType sheetRels + legacyDrRId = cur $/ element (addSmlNamespace "legacyDrawing") >=> fromAttribute (odr"id") + legacyDrPath = fmap (logicalNameToZipItemName . relTarget) . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget -- Likewise, @pageSetup@ also occurs either 0 or 1 times - let pageSetup = listToMaybe $ cur $/ element (n_ "pageSetup") >=> fromCursor + let pageSetup = listToMaybe $ cur $/ element (addSmlNamespace "pageSetup") >=> fromCursor - cws = cur $/ element (n_ "cols") &/ element (n_ "col") >=> fromCursor + cws = cur $/ element (addSmlNamespace "cols") &/ element (addSmlNamespace "col") >=> fromCursor - (rowProps, cells) = collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow - parseRow :: Cursor -> [(Int, Maybe RowProperties, [(Int, Int, Cell)])] + (rowProps, cells0, sharedFormulas) = + collect $ cur $/ element (addSmlNamespace "sheetData") &/ element (addSmlNamespace "row") >=> parseRow + parseRow :: + Cursor + -> [( RowIndex + , Maybe RowProperties + , [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])] parseRow c = do - r <- c $| attribute "r" >=> decimal - let ht = if attribute "customHeight" c == ["true"] - then listToMaybe $ c $| attribute "ht" >=> rational - else Nothing - let s = listToMaybe $ decimal =<< attribute "s" c :: Maybe Int - let rp = if isNothing s && isNothing ht - then Nothing - else Just (RowProps ht s) - return (r, rp, c $/ element (n_ "c") >=> parseCell) - parseCell :: Cursor -> [(Int, Int, Cell)] + r <- RowIndex <$> fromAttribute "r" c + let prop = RowProps + { rowHeight = do h <- listToMaybe $ fromAttribute "ht" c + case fromAttribute "customHeight" c of + [True] -> return $ CustomHeight h + _ -> return $ AutomaticHeight h + , rowStyle = listToMaybe $ fromAttribute "s" c + , rowHidden = + case fromAttribute "hidden" c of + [] -> False + f:_ -> f + } + return ( r + , if prop == def then Nothing else Just prop + , c $/ element (addSmlNamespace "c") >=> parseCell + ) + parseCell :: + Cursor + -> [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))] parseCell cell = do ref <- fromAttribute "r" cell - let - s = listToMaybe $ cell $| attribute "s" >=> decimal - t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" - d = listToMaybe $ cell $/ element (n_ "v") &/ content >=> extractCellValue sst t - f = listToMaybe $ cell $/ element (n_ "f") >=> fromCursor - (c, r) = T.span (>'9') $ unCellRef ref - comment = commentsMap >>= lookupComment ref - return (int r, col2int c, Cell s d comment f) - collect = foldr collectRow (M.empty, M.empty) - collectRow (_, Nothing, rowCells) (rowMap, cellMap) = - (rowMap, foldr collectCell cellMap rowCells) - collectRow (r, Just h, rowCells) (rowMap, cellMap) = - (M.insert r h rowMap, foldr collectCell cellMap rowCells) - collectCell (x, y, cd) = M.insert (x,y) cd + let s = listToMaybe $ cell $| attribute "s" >=> decimal + -- NB: According to format specification default value for cells without + -- `t` attribute is a `n` - number. + -- + -- + -- .. + -- + -- + t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" + d = listToMaybe $ extractCellValue sst t cell + mFormulaData = listToMaybe $ cell $/ element (addSmlNamespace "f") >=> formulaDataFromCursor + f = fst <$> mFormulaData + shared = snd =<< mFormulaData + (r, c) = fromSingleCellRefNoting ref + comment = commentsMap >>= lookupComment ref + return (r, c, Cell s d comment f, shared) + collect = foldr collectRow (M.empty, M.empty, M.empty) + collectRow :: + ( RowIndex + , Maybe RowProperties + , [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))]) + -> (Map RowIndex RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions) + -> (Map RowIndex RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions) + collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) = + let (newCells0, newSharedF0) = + unzip [(((x,y),cd), shared) | (x, y, cd, shared) <- rowCells] + newCells = M.fromList newCells0 + newSharedF = M.fromList $ catMaybes newSharedF0 + newRowMap = case mRP of + Just rp -> M.insert r rp rowMap + Nothing -> rowMap + in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) - mDrawingId = listToMaybe $ cur $/ element (n_ "drawing") >=> fromAttribute (odr"id") + commentCells = + M.fromList + [ (fromSingleCellRefNoting r, def {_cellComment = Just cmnt}) + | (r, cmnt) <- maybe [] CommentTable.toList commentsMap + ] + cells = cells0 `M.union` commentCells + mProtection = listToMaybe $ cur $/ element (addSmlNamespace "sheetProtection") >=> fromCursor + + mDrawingId = listToMaybe $ cur $/ element (addSmlNamespace "drawing") >=> fromAttribute (odr"id") + merges = cur $/ parseMerges parseMerges :: Cursor -> [Range] - parseMerges = element (n_ "mergeCells") &/ element (n_ "mergeCell") >=> fromAttribute "ref" + parseMerges = element (addSmlNamespace "mergeCells") &/ element (addSmlNamespace "mergeCell") >=> fromAttribute "ref" - condFormtattings = M.fromList . map unCfPair $ cur $/ element (n_ "conditionalFormatting") >=> fromCursor + condFormtattings = M.fromList . map unCfPair $ cur $/ element (addSmlNamespace "conditionalFormatting") >=> fromCursor validations = M.fromList . map unDvPair $ - cur $/ element (n_ "dataValidations") &/ element (n_ "dataValidation") >=> fromCursor + cur $/ element (addSmlNamespace "dataValidations") &/ element (addSmlNamespace "dataValidation") >=> fromCursor + tableIds = + cur $/ element (addSmlNamespace "tableParts") &/ element (addSmlNamespace "tablePart") >=> + fromAttribute (odr "id") + + let mAutoFilter = listToMaybe $ cur $/ element (addSmlNamespace "autoFilter") >=> fromCursor + mDrawing <- case mDrawingId of Just dId -> do - rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels - Just <$> getDrawing ar contentTypes (relTarget rel) + fp <- lookupRelPath filePath sheetRels dId + Just <$> getDrawing ar contentTypes fp Nothing -> return Nothing let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable" pTables <- forM (allByType ptType sheetRels) $ \rel -> do - let ptPath = relTarget rel + let ptPath = logicalNameToZipItemName $ relTarget rel bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $ parsePivotTable (flip Prelude.lookup caches) bs - return $ Worksheet cws rowProps cells mDrawing merges sheetViews pageSetup condFormtattings validations pTables + tables <- forM tableIds $ \rId -> do + fp <- lookupRelPath filePath sheetRels rId + getTable ar fp -extractCellValue :: SharedStringTable -> Text -> Text -> [CellValue] -extractCellValue sst "s" v = - case T.decimal v of - Right (d, _) -> - case sstItem sst d of - XlsxText txt -> [CellText txt] - XlsxRichText rich -> [CellRich rich] - _ -> - [] -extractCellValue _ "str" str = [CellText str] -extractCellValue _ "n" v = - case T.rational v of - Right (d, _) -> [CellDouble d] - _ -> [] -extractCellValue _ "b" "1" = [CellBool True] -extractCellValue _ "b" "0" = [CellBool False] -extractCellValue _ _ _ = [] + return $ + Worksheet + cws + rowProps + cells + mDrawing + merges + sheetViews + pageSetup + condFormtattings + validations + pTables + mAutoFilter + tables + mProtection + sharedFormulas + (wfState wf) +extractCellValue :: SharedStringTable -> Text -> Cursor -> [CellValue] +extractCellValue sst t cur + | t == "s" = do + si <- vConverted "shared string" + case sstItem sst si of + Just xlTxt -> return $ xlsxTextToCellValue xlTxt + Nothing -> fail "bad shared string index" + | t == "inlineStr" = + cur $/ element (addSmlNamespace "is") >=> fmap xlsxTextToCellValue . fromCursor + | t == "str" = CellText <$> vConverted "string" + | t == "n" = CellDouble <$> vConverted "double" + | t == "b" = CellBool <$> vConverted "boolean" + | t == "e" = CellError <$> vConverted "error" + | otherwise = fail "bad cell value" + where + vConverted typeStr = do + vContent <- cur $/ element (addSmlNamespace "v") >=> \c -> + return (T.concat $ c $/ content) + case fromAttrVal vContent of + Right (val, _) -> return $ val + _ -> fail $ "bad " ++ typeStr ++ " cell value" + -- | Get xml cursor from the specified file inside the zip archive. xmlCursorOptional :: Zip.Archive -> FilePath -> Parser (Maybe Cursor) xmlCursorOptional ar fname = @@ -204,16 +535,30 @@ xmlCursorRequired :: Zip.Archive -> FilePath -> Parser Cursor xmlCursorRequired ar fname = do entry <- note (MissingFile fname) $ Zip.findEntryByPath fname ar - cur <- left (\_ -> InvalidFile fname) $ parseLBS def (Zip.fromEntry entry) + cur <- left (\ex -> InvalidFile fname (T.pack $ show ex)) $ parseLBS def (Zip.fromEntry entry) return $ fromDocument cur +fromFileCursorDef :: + FromCursor a => Zip.Archive -> FilePath -> Text -> a -> Parser a +fromFileCursorDef x fp contentsDescr defVal = do + mCur <- xmlCursorOptional x fp + case mCur of + Just cur -> + headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur + Nothing -> return defVal + +fromFileCursor :: FromCursor a => Zip.Archive -> FilePath -> Text -> Parser a +fromFileCursor x fp contentsDescr = do + cur <- xmlCursorRequired x fp + headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur + -- | Get shared string table getSharedStrings :: Zip.Archive -> Parser SharedStringTable -getSharedStrings x = maybe sstEmpty (head . fromCursor) <$> - xmlCursorOptional x "xl/sharedStrings.xml" +getSharedStrings x = + fromFileCursorDef x "xl/sharedStrings.xml" "shared strings" sstEmpty getContentTypes :: Zip.Archive -> Parser ContentTypes -getContentTypes x = head . fromCursor <$> xmlCursorRequired x "[Content_Types].xml" +getContentTypes x = fromFileCursor x "[Content_Types].xml" "content types" getStyles :: Zip.Archive -> Styles getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of @@ -242,13 +587,14 @@ return $ singleCellRef (r0 + 1, c0 + 1) getCustomProperties :: Zip.Archive -> Parser CustomProperties -getCustomProperties ar = maybe CustomProperties.empty (head . fromCursor) <$> xmlCursorOptional ar "docProps/custom.xml" +getCustomProperties ar = + fromFileCursorDef ar "docProps/custom.xml" "custom properties" CustomProperties.empty getDrawing :: Zip.Archive -> ContentTypes -> FilePath -> Parser Drawing getDrawing ar contentTypes fp = do cur <- xmlCursorRequired ar fp drawingRels <- getRels ar fp - unresolved <- headErr (InvalidFile fp) (fromCursor cur) + unresolved <- headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels return $ Drawing anchors where @@ -273,19 +619,22 @@ return uAnch {_anchObject = Graphic nv chart tr} lookupFI _ Nothing = return Nothing lookupFI rels (Just rId) = do - path <- lookupRelPath fp rels rId + path <- lookupRelPath fp rels rId -- content types use paths starting with / - contentType <- note (InvalidFile path) $ ContentTypes.lookup ("/" <> path) contentTypes - contents <- Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar) - return . Just $ FileInfo (stripMediaPrefix path) contentType contents + contentType <- + note (InvalidFile path "Missing content type") $ + ContentTypes.lookup ("/" <> path) contentTypes + contents <- + Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar) + return . Just $ FileInfo (stripMediaPrefix path) contentType contents stripMediaPrefix :: FilePath -> FilePath stripMediaPrefix p = fromMaybe p $ stripPrefix "xl/media/" p readChart :: Zip.Archive -> FilePath -> Parser ChartSpace -readChart ar path = head . fromCursor <$> xmlCursorRequired ar path +readChart ar path = fromFileCursor ar path "chart" -- | readWorkbook pulls the names of the sheets and the defined names -readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches) +readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches, DateBase) readWorkbook ar = do let wbPath = "xl/workbook.xml" cur <- xmlCursorRequired ar wbPath @@ -294,49 +643,73 @@ let mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)] mkDefinedName c = return - ( head $ attribute "name" c + ( headNote "Missing name attribute" $ attribute "name" c , listToMaybe $ attribute "localSheetId" c , T.concat $ c $/ content) names = - cur $/ element (n_ "definedNames") &/ element (n_ "definedName") >=> + cur $/ element (addSmlNamespace "definedNames") &/ element (addSmlNamespace "definedName") >=> mkDefinedName sheets <- sequence $ - cur $/ element (n_ "sheets") &/ element (n_ "sheet") >=> - liftA2 (worksheetFile wbPath wbRels) <$> attribute "name" <*> + cur $/ element (addSmlNamespace "sheets") &/ element (addSmlNamespace "sheet") >=> + liftM4 (worksheetFile wbPath wbRels) <$> attribute "name" <*> fromAttribute "sheetId" <*> fromAttributeDef "state" def <*> fromAttribute (odr "id") let cacheRefs = - cur $/ element (n_ "pivotCaches") &/ element (n_ "pivotCache") >=> + cur $/ element (addSmlNamespace "pivotCaches") &/ element (addSmlNamespace "pivotCache") >=> liftA2 (,) <$> fromAttribute "cacheId" <*> fromAttribute (odr "id") caches <- forM cacheRefs $ \(cacheId, rId) -> do path <- lookupRelPath wbPath wbRels rId bs <- note (MissingFile path) $ Zip.fromEntry <$> Zip.findEntryByPath path ar - sources <- + (sheet, ref, fields0, mRecRId) <- note (InconsistentXlsx $ "Bad pivot table cache in " <> T.pack path) $ parseCache bs - return (cacheId, sources) - return (sheets, DefinedNames names, caches) + fields <- case mRecRId of + Just recId -> do + cacheRels <- getRels ar path + recsPath <- lookupRelPath path cacheRels recId + rCur <- xmlCursorRequired ar recsPath + let recs = rCur $/ element (addSmlNamespace "r") >=> \cur' -> + return $ cur' $/ anyElement >=> recordValueFromNode . node + return $ fillCacheFieldsFromRecords fields0 recs + Nothing -> + return fields0 + return $ (cacheId, (sheet, ref, fields)) + let dateBase = bool DateBase1900 DateBase1904 . fromMaybe False . listToMaybe $ + cur $/ element (addSmlNamespace "workbookPr") >=> fromAttribute "date1904" + return (sheets, DefinedNames names, caches, dateBase) +getTable :: Zip.Archive -> FilePath -> Parser Table +getTable ar fp = do + cur <- xmlCursorRequired ar fp + headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) -worksheetFile :: FilePath -> Relationships -> Text -> RefId -> Parser WorksheetFile -worksheetFile parentPath wbRels name rId = - WorksheetFile name <$> lookupRelPath parentPath wbRels rId +worksheetFile :: FilePath -> Relationships -> Text -> Int -> SheetState -> RefId -> Parser WorksheetFile +worksheetFile parentPath wbRels name sheetId visibility rId = + WorksheetFile name sheetId visibility <$> lookupRelPath parentPath wbRels rId getRels :: Zip.Archive -> FilePath -> Parser Relationships getRels ar fp = do let (dir, file) = splitFileName fp relsPath = dir "_rels" file <.> "rels" c <- xmlCursorOptional ar relsPath - return $ maybe Relationships.empty (setTargetsFrom fp . head . fromCursor) c + return $ maybe Relationships.empty (setTargetsFrom fp . headNote "Missing rels" . fromCursor) c +-- According to part 2, section 7.3.4 of ECMA-376, when mapping logical item +-- names to ZIP item names we need to remove the leading slash. +-- +-- Non-ASCII characters should be percent-encoded as well, but this is not +-- currently implemented. +-- +-- https://ecma-international.org/publications-and-standards/standards/ecma-376/ +logicalNameToZipItemName :: FilePath -> FilePath +logicalNameToZipItemName ('/' : name) = name +logicalNameToZipItemName name = name + lookupRelPath :: FilePath -> Relationships -> RefId -> Either ParseError FilePath lookupRelPath fp rels rId = - relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels) - -int :: Text -> Int -int = either error fst . T.decimal + logicalNameToZipItemName . relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels) diff --git a/src/Codec/Xlsx/Parser/Internal.hs b/src/Codec/Xlsx/Parser/Internal.hs --- a/src/Codec/Xlsx/Parser/Internal.hs +++ b/src/Codec/Xlsx/Parser/Internal.hs @@ -1,45 +1,50 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Codec.Xlsx.Parser.Internal - ( ParseException(..) - , n_ - , nodeElNameIs - , FromCursor(..) - , FromAttrVal(..) - , fromAttribute - , fromAttributeDef - , maybeAttribute - , fromElementValue - , maybeElementValue - , maybeElementValueDef - , maybeBoolElementValue - , maybeFromElement - , contentOrEmpty - , readSuccess - , readFailure - , invalidText - , defaultReadFailure - , boolean - , decimal - , rational - ) where + ( ParseException(..) + , n_ + , addSmlNamespace + , nodeElNameIs + , FromCursor(..) + , FromAttrVal(..) + , fromAttribute + , fromAttributeDef + , maybeAttribute + , fromElementValue + , maybeElementValue + , maybeElementValueDef + , maybeBoolElementValue + , maybeFromElement + , attrValIs + , contentOrEmpty + , readSuccess + , readFailure + , invalidText + , defaultReadFailure + , module Codec.Xlsx.Parser.Internal.Util + , module Codec.Xlsx.Parser.Internal.Fast + ) where -import Control.Exception (Exception) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as T -import Data.Typeable (Typeable) -import Text.XML -import Text.XML.Cursor +import Control.Exception (Exception) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal.Fast +import Codec.Xlsx.Parser.Internal.Util data ParseException = ParseException String - deriving (Show, Typeable) + deriving (Show, Typeable, Generic) instance Exception ParseException @@ -113,6 +118,12 @@ [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 = case c $/ content of @@ -137,26 +148,15 @@ Right (r, leftover) | T.null leftover -> [r] _ -> [] --- | Add sml namespace to name + +{-# DEPRECATED n_ "Renamed to addSmlNamespace" #-} n_ :: Text -> Name -n_ x = Name +n_ = addSmlNamespace + +-- | Add sml namespace to name +addSmlNamespace :: Text -> Name +addSmlNamespace x = Name { nameLocalName = x - , nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main" - , namePrefix = Just "n" + , nameNamespace = Just mainNamespace + , namePrefix = Nothing } - -decimal :: (Monad m, Integral a) => Text -> m a -decimal t = case T.signed T.decimal $ t of - Right (d, leftover) | T.null leftover -> return d - _ -> fail $ "invalid decimal" ++ show t - -rational :: Monad m => Text -> m Double -rational t = case T.rational t of - Right (r, leftover) | T.null leftover -> return r - _ -> fail $ "invalid rational: " ++ show t - -boolean :: Monad m => Text -> m Bool -boolean t = case T.strip t of - "true" -> return True - "false" -> return False - _ -> fail $ "invalid boolean: " ++ show t diff --git a/src/Codec/Xlsx/Parser/Internal/Fast.hs b/src/Codec/Xlsx/Parser/Internal/Fast.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Internal/Fast.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Codec.Xlsx.Parser.Internal.Fast + ( FromXenoNode(..) + , collectChildren + , maybeChild + , requireChild + , childList + , maybeFromChild + , fromChild + , fromChildList + , maybeParse + , requireAndParse + , childListAny + , maybeElementVal + , toAttrParser + , parseAttributes + , FromAttrBs(..) + , unexpectedAttrBs + , maybeAttrBs + , maybeAttr + , fromAttr + , fromAttrDef + , contentBs + , contentX + , nsPrefixes + , addPrefix + ) where + +import Control.Applicative +import Control.Arrow (second) +import Control.Exception (Exception, throw) +import Control.Monad (ap, forM, join, liftM) +import Data.Bifunctor (first) +import Data.Bits ((.|.), shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as SU +import Data.Char (chr) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Word (Word8) +import Xeno.DOM hiding (parse) + +import Codec.Xlsx.Parser.Internal.Util + +class FromXenoNode a where + fromXenoNode :: Node -> Either Text a + +newtype ChildCollector a = ChildCollector + { runChildCollector :: [Node] -> Either Text ([Node], a) + } + +instance Functor ChildCollector where + fmap f a = ChildCollector $ \ns -> + second f <$> runChildCollector a ns + +instance Applicative ChildCollector where + pure a = ChildCollector $ \ns -> + return (ns, a) + cf <*> ca = ChildCollector $ \ns -> do + (ns', f) <- runChildCollector cf ns + (ns'', a) <- runChildCollector ca ns' + return (ns'', f a) + +instance Alternative ChildCollector where + empty = ChildCollector $ \_ -> Left "ChildCollector.empty" + ChildCollector f <|> ChildCollector g = ChildCollector $ \ns -> + either (const $ g ns) Right (f ns) + +instance Monad ChildCollector where + return = pure + ChildCollector f >>= g = ChildCollector $ \ns -> + either Left (\(!ns', f') -> runChildCollector (g f') ns') (f ns) + +toChildCollector :: Either Text a -> ChildCollector a +toChildCollector unlifted = + case unlifted of + Right a -> return a + Left e -> ChildCollector $ \_ -> Left e + +collectChildren :: Node -> ChildCollector a -> Either Text a +collectChildren n c = snd <$> runChildCollector c (children n) + +maybeChild :: ByteString -> ChildCollector (Maybe Node) +maybeChild nm = + ChildCollector $ \case + (n:ns) + | name n == nm -> pure (ns, Just n) + ns -> pure (ns, Nothing) + +requireChild :: ByteString -> ChildCollector Node +requireChild nm = + ChildCollector $ \case + (n:ns) + | name n == nm -> pure (ns, n) + _ -> + Left $ "required element " <> T.pack (show nm) <> " was not found" + +childList :: ByteString -> ChildCollector [Node] +childList nm = do + mNode <- maybeChild nm + case mNode of + Just n -> (n:) <$> childList nm + Nothing -> return [] + +maybeFromChild :: (FromXenoNode a) => ByteString -> ChildCollector (Maybe a) +maybeFromChild nm = do + mNode <- maybeChild nm + mapM (toChildCollector . fromXenoNode) mNode + +fromChild :: (FromXenoNode a) => ByteString -> ChildCollector a +fromChild nm = do + n <- requireChild nm + case fromXenoNode n of + Right a -> return a + Left e -> ChildCollector $ \_ -> Left e + +fromChildList :: (FromXenoNode a) => ByteString -> ChildCollector [a] +fromChildList nm = do + mA <- maybeFromChild nm + case mA of + Just a -> (a:) <$> fromChildList nm + Nothing -> return [] + +maybeParse :: ByteString -> (Node -> Either Text a) -> ChildCollector (Maybe a) +maybeParse nm parse = maybeChild nm >>= (toChildCollector . mapM parse) + +requireAndParse :: ByteString -> (Node -> Either Text a) -> ChildCollector a +requireAndParse nm parse = requireChild nm >>= (toChildCollector . parse) + +childListAny :: (FromXenoNode a) => Node -> Either Text [a] +childListAny = mapM fromXenoNode . children + +maybeElementVal :: (FromAttrBs a) => ByteString -> ChildCollector (Maybe a) +maybeElementVal nm = do + mN <- maybeChild nm + fmap join . forM mN $ \n -> + toChildCollector . parseAttributes n $ maybeAttr "val" + +-- Stolen from XML Conduit +newtype AttrParser a = AttrParser + { runAttrParser :: [(ByteString, ByteString)] -> Either Text ( [( ByteString + , ByteString)] + , a) + } + +instance Monad AttrParser where + return a = AttrParser $ \as -> Right (as, a) + (AttrParser f) >>= g = + AttrParser $ \as -> + either Left (\(as', f') -> runAttrParser (g f') as') (f as) +instance Applicative AttrParser where + pure = return + (<*>) = ap +instance Functor AttrParser where + fmap = liftM + +attrError :: Text -> AttrParser a +attrError err = AttrParser $ \_ -> Left err + +toAttrParser :: Either Text a -> AttrParser a +toAttrParser unlifted = + case unlifted of + Right a -> return a + Left e -> AttrParser $ \_ -> Left e + +maybeAttrBs :: ByteString -> AttrParser (Maybe ByteString) +maybeAttrBs attrName = AttrParser $ go id + where + go front [] = Right (front [], Nothing) + go front (a@(nm, val):as) = + if nm == attrName + then Right (front as, Just val) + else go (front . (:) a) as + +requireAttrBs :: ByteString -> AttrParser ByteString +requireAttrBs nm = do + mVal <- maybeAttrBs nm + case mVal of + Just val -> return val + Nothing -> attrError $ "attribute " <> T.pack (show nm) <> " is required" + +unexpectedAttrBs :: Text -> ByteString -> Either Text a +unexpectedAttrBs typ val = + Left $ "Unexpected value for " <> typ <> ": " <> T.pack (show val) + +fromAttr :: FromAttrBs a => ByteString -> AttrParser a +fromAttr nm = do + bs <- requireAttrBs nm + toAttrParser $ fromAttrBs bs + +maybeAttr :: FromAttrBs a => ByteString -> AttrParser (Maybe a) +maybeAttr nm = do + mBs <- maybeAttrBs nm + forM mBs (toAttrParser . fromAttrBs) + +fromAttrDef :: FromAttrBs a => ByteString -> a -> AttrParser a +fromAttrDef nm defVal = fromMaybe defVal <$> maybeAttr nm + +parseAttributes :: Node -> AttrParser a -> Either Text a +parseAttributes n attrParser = + case runAttrParser attrParser (attributes n) of + Left e -> Left e + Right (_, a) -> return a + +class FromAttrBs a where + fromAttrBs :: ByteString -> Either Text a + +instance FromAttrBs ByteString where + fromAttrBs = pure + +instance FromAttrBs Bool where + fromAttrBs x | x == "1" || x == "true" = return True + | x == "0" || x == "false" = return False + | otherwise = unexpectedAttrBs "boolean" x + +instance FromAttrBs Int where + -- it appears that parser in text is more optimized than the one in + -- attoparsec at least as of text-1.2.2.2 and attoparsec-0.13.1.0 + fromAttrBs = first T.pack . eitherDecimal . T.decodeLatin1 + +instance FromAttrBs Double where + -- as for rationals + fromAttrBs = first T.pack . eitherRational . T.decodeLatin1 + +instance FromAttrBs Text where + fromAttrBs = replaceEntititesBs + +replaceEntititesBs :: ByteString -> Either Text Text +replaceEntititesBs str = + T.decodeUtf8 . BS.concat <$> findAmp 0 + where + findAmp :: Int -> Either Text [ByteString] + findAmp index = + case elemIndexFrom ampersand str index of + Nothing -> if BS.null text then return [] else return [text] + where text = BS.drop index str + Just fromAmp -> + if BS.null text + then checkEntity fromAmp + else (text:) <$> checkEntity fromAmp + where text = substring str index fromAmp + checkEntity index = + case elemIndexFrom semicolon str index of + Just fromSemi | fromSemi >= index + 3 -> do + entity <- checkElementVal (index + 1) (fromSemi - index - 1) + (BS.singleton entity:) <$> findAmp (fromSemi + 1) + _ -> Left "Unending entity" + checkElementVal index len = + if | len == 2 + && s_index this 0 == 108 -- l + && s_index this 1 == 116 -- t + -> return 60 -- '<' + | len == 2 + && s_index this 0 == 103 -- g + && s_index this 1 == 116 -- t + -> return 62 -- '>' + | len == 3 + && s_index this 0 == 97 -- a + && s_index this 1 == 109 -- m + && s_index this 2 == 112 -- p + -> return 38 -- '&' + | len == 4 + && s_index this 0 == 113 -- q + && s_index this 1 == 117 -- u + && s_index this 2 == 111 -- o + && s_index this 3 == 116 -- t + -> return 34 -- '"' + | len == 4 + && s_index this 0 == 97 -- a + && s_index this 1 == 112 -- p + && s_index this 2 == 111 -- o + && s_index this 3 == 115 -- s + -> return 39 -- '\'' + | s_index this 0 == 35 -- '#' + -> + if s_index this 1 == 120 -- 'x' + then toEnum <$> checkHexadecimal (index + 2) (len - 2) + else toEnum <$> checkDecimal (index + 1) (len - 1) + | otherwise -> Left $ "Bad entity " <> T.pack (show $ (substring str (index-1) (index+len+1))) + where + this = BS.drop index str + checkDecimal index len = BS.foldl' go (Right 0) (substring str index (index + len)) + where + go :: Either Text Int -> Word8 -> Either Text Int + go prev c = do + a <- prev + if c >= 48 && c <= 57 + then return $ a * 10 + fromIntegral (c - 48) + else Left $ "Expected decimal digit but encountered " <> T.pack (show (chr $ fromIntegral c)) + checkHexadecimal index len = BS.foldl' go (Right 0) (substring str index (index + len)) + where + go :: Either Text Int -> Word8 -> Either Text Int + go prev c = do + a <- prev + if | c >= 48 && c <= 57 + -> return $ (a `shiftL` 4) .|. fromIntegral (c - 48) + | c >= 97 && c <= 122 + -> return $ (a `shiftL` 4) .|. fromIntegral (c - 87) + | c >= 65 && c <= 90 + -> return $ (a `shiftL` 4) .|. fromIntegral (c - 55) + | otherwise + -> + Left $ "Expected hexadecimal digit but encountered " <> T.pack (show (chr $ fromIntegral c)) + ampersand = 38 + semicolon = 59 + +data EntityReplaceException = EntityReplaceException deriving Show + +instance Exception EntityReplaceException + +-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. +s_index :: ByteString -> Int -> Word8 +s_index ps n + | n < 0 = throw EntityReplaceException + | n >= BS.length ps = throw EntityReplaceException + | otherwise = ps `SU.unsafeIndex` n +{-# INLINE s_index #-} + +-- | Get index of an element starting from offset. +elemIndexFrom :: Word8 -> ByteString -> Int -> Maybe Int +elemIndexFrom c str offset = fmap (+ offset) (BS.elemIndex c (BS.drop offset str)) +-- Without the INLINE below, the whole function is twice as slow and +-- has linear allocation. See git commit with this comment for +-- results. +{-# INLINE elemIndexFrom #-} + +-- | Get a substring of a string. +substring :: ByteString -> Int -> Int -> ByteString +substring s start end = BS.take (end - start) (BS.drop start s) +{-# INLINE substring #-} + +newtype NsPrefixes = NsPrefixes [(ByteString, ByteString)] + +nsPrefixes :: Node -> NsPrefixes +nsPrefixes root = + NsPrefixes . flip mapMaybe (attributes root) $ \(nm, val) -> + (val, ) <$> BS.stripPrefix "xmlns:" nm + +addPrefix :: NsPrefixes -> ByteString -> (ByteString -> ByteString) +addPrefix (NsPrefixes prefixes) ns = + maybe id (\prefix nm -> BS.concat [prefix, ":", nm]) $ Prelude.lookup ns prefixes + +contentBs :: Node -> ByteString +contentBs n = BS.concat . map toBs $ contents n + where + toBs (Element _) = BS.empty + toBs (Text bs) = bs + toBs (CData bs) = bs + +contentX :: Node -> Either Text Text +contentX = replaceEntititesBs . contentBs diff --git a/src/Codec/Xlsx/Parser/Internal/Memoize.hs b/src/Codec/Xlsx/Parser/Internal/Memoize.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Internal/Memoize.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +-- | I rewrote: https://hackage.haskell.org/package/unliftio-0.2.20/docs/src/UnliftIO.Memoize.html#Memoized +-- for monad trans basecontrol +-- we don't need a generic `m` anyway. it's good enough in base IO. +module Codec.Xlsx.Parser.Internal.Memoize + ( Memoized + , runMemoized + , memoizeRef + ) where + +import Control.Applicative as A +import Control.Monad (join) +import Control.Monad.IO.Class +import Data.IORef +import Control.Exception + +-- | A \"run once\" value, with results saved. Extract the value with +-- 'runMemoized'. For single-threaded usage, you can use 'memoizeRef' to +-- create a value. If you need guarantees that only one thread will run the +-- action at a time, use 'memoizeMVar'. +-- +-- Note that this type provides a 'Show' instance for convenience, but not +-- useful information can be provided. +newtype Memoized a = Memoized (IO a) + deriving (Functor, A.Applicative, Monad) +instance Show (Memoized a) where + show _ = "<>" + +-- | Extract a value from a 'Memoized', running an action if no cached value is +-- available. +runMemoized :: MonadIO m => Memoized a -> m a +runMemoized (Memoized m) = liftIO m +{-# INLINE runMemoized #-} + +-- | Create a new 'Memoized' value using an 'IORef' under the surface. Note that +-- the action may be run in multiple threads simultaneously, so this may not be +-- thread safe (depending on the underlying action). +memoizeRef :: IO a -> IO (Memoized a) +memoizeRef action = do + ref <- newIORef Nothing + pure $ Memoized $ do + mres <- readIORef ref + res <- + case mres of + Just res -> pure res + Nothing -> do + res <- try @SomeException action + writeIORef ref $ Just res + pure res + either throwIO pure res diff --git a/src/Codec/Xlsx/Parser/Internal/PivotTable.hs b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs --- a/src/Codec/Xlsx/Parser/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs @@ -1,24 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module Codec.Xlsx.Parser.Internal.PivotTable ( - parsePivotTable +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Parser.Internal.PivotTable + ( parsePivotTable , parseCache -) where + , fillCacheFieldsFromRecords + ) where import Control.Applicative import Data.ByteString.Lazy (ByteString) -import Data.Maybe (listToMaybe, maybeToList) +import Data.List (transpose) +import Data.Maybe (listToMaybe, mapMaybe, maybeToList) import Data.Text (Text) +import Safe (atMay) import Text.XML import Text.XML.Cursor import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Types.Internal.Relationships (odr) import Codec.Xlsx.Types.PivotTable import Codec.Xlsx.Types.PivotTable.Internal parsePivotTable - :: (CacheId -> Maybe (Text, Range, [PivotFieldName])) + :: (CacheId -> Maybe (Text, Range, [CacheField])) -> ByteString -> Maybe PivotTable parsePivotTable srcByCacheId bs = @@ -28,32 +34,45 @@ 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" + _pvtLocation <- cur $/ element (addSmlNamespace "location") >=> fromAttribute "ref" _pvtRowGrandTotals <- fromAttributeDef "rowGrandTotals" True cur _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 - _pvtFields = - [ PivotFieldInfo {_pfiName = name, _pfiOutline = outline} - | (name, outline) <- zip fieldNames outlines - ] + let pvtFieldsWithHidden = + cur $/ element (addSmlNamespace "pivotFields") &/ element (addSmlNamespace "pivotField") >=> \c -> do + -- actually gets overwritten from cache to have consistent field names + _pfiName <- maybeAttribute "name" c + _pfiSortType <- fromAttributeDef "sortType" FieldSortManual c + _pfiOutline <- fromAttributeDef "outline" True c + let hidden = + c $/ element (addSmlNamespace "items") &/ element (addSmlNamespace "item") >=> + attrValIs "h" True >=> fromAttribute "x" + _pfiHiddenItems = [] + return (PivotFieldInfo {..}, hidden) + _pvtFields = flip map (zip [0.. ] pvtFieldsWithHidden) $ + \(i, (PivotFieldInfo {..}, hidden)) -> + let _pfiHiddenItems = + [item | (n, item) <- zip [(0 :: Int) ..] items, n `elem` hidden] + (_pfiName, items) = case atMay cacheFields i of + Just CacheField{..} -> (Just cfName, cfItems) + Nothing -> (Nothing, []) + in PivotFieldInfo {..} + nToFieldName = zip [0 ..] $ map cfName cacheFields + fieldNameList fld = maybeToList $ lookup fld nToFieldName _pvtRowFields = - cur $/ element (n_ "rowFields") &/ element (n_ "field") >=> + cur $/ element (addSmlNamespace "rowFields") &/ element (addSmlNamespace "field") >=> fromAttribute "x" >=> fieldPosition _pvtColumnFields = - cur $/ element (n_ "colFields") &/ element (n_ "field") >=> + cur $/ element (addSmlNamespace "colFields") &/ element (addSmlNamespace "field") >=> fromAttribute "x" >=> fieldPosition _pvtDataFields = - cur $/ element (n_ "dataFields") &/ element (n_ "dataField") >=> \c -> do + cur $/ element (addSmlNamespace "dataFields") &/ element (addSmlNamespace "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 +80,30 @@ 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], Maybe RefId) parseCache bs = listToMaybe . parse . fromDocument $ parseLBS_ def bs where parse cur = do + refId <- maybeAttribute (odr "id") cur (sheet, ref) <- - cur $/ element (n_ "cacheSource") &/ element (n_ "worksheetSource") >=> + cur $/ element (addSmlNamespace "cacheSource") &/ element (addSmlNamespace "worksheetSource") >=> liftA2 (,) <$> attribute "sheet" <*> fromAttribute "ref" - let fieldNames = - cur $/ element (n_ "cacheFields") &/ element (n_ "cacheField") >=> - fromAttribute "name" - return (sheet, ref, fieldNames) + let fields = + cur $/ element (addSmlNamespace "cacheFields") &/ element (addSmlNamespace "cacheField") >=> + fromCursor + return (sheet, ref, fields, refId) + +fillCacheFieldsFromRecords :: [CacheField] -> [CacheRecord] -> [CacheField] +fillCacheFieldsFromRecords fields recs = + zipWith addValues fields (transpose recs) + where + addValues field recVals = + if null (cfItems field) + then field {cfItems = mapMaybe recToCellValue recVals} + else field + recToCellValue (CacheText t) = Just $ CellText t + recToCellValue (CacheNumber n) = Just $ CellDouble n + recToCellValue (CacheIndex _) = Nothing diff --git a/src/Codec/Xlsx/Parser/Internal/Util.hs b/src/Codec/Xlsx/Parser/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Internal/Util.hs @@ -0,0 +1,43 @@ +module Codec.Xlsx.Parser.Internal.Util + ( boolean + , eitherBoolean + , decimal + , eitherDecimal + , rational + , eitherRational + ) where + +import Data.Text (Text) +import Control.Monad.Fail (MonadFail) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import qualified Control.Monad.Fail as F + +decimal :: (MonadFail m, Integral a) => Text -> m a +decimal = fromEither . eitherDecimal + +eitherDecimal :: (Integral a) => Text -> Either String a +eitherDecimal t = case T.signed T.decimal t of + Right (d, leftover) | T.null leftover -> Right d + _ -> Left $ "invalid decimal: " ++ show t + +rational :: (MonadFail m) => Text -> m Double +rational = fromEither . eitherRational + +eitherRational :: Text -> Either String Double +eitherRational t = case T.signed T.rational t of + Right (r, leftover) | T.null leftover -> Right r + _ -> Left $ "invalid rational: " ++ show t + +boolean :: (MonadFail m) => Text -> m Bool +boolean = fromEither . eitherBoolean + +eitherBoolean :: Text -> Either String Bool +eitherBoolean t = case T.unpack $ T.strip t of + "true" -> Right True + "false" -> Right False + _ -> Left $ "invalid boolean: " ++ show t + +fromEither :: (MonadFail m) => Either String b -> m b +fromEither (Left a) = F.fail a +fromEither (Right b) = return b diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -0,0 +1,718 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- Module : Codex.Xlsx.Parser.Stream +-- Description : Stream parser for xlsx files +-- Copyright : +-- (c) Adam, 2021 +-- (c) Supercede, 2021 +-- License : MIT +-- Stability : experimental +-- Portability : POSIX +-- +-- Parse @.xlsx@ sheets in constant memory. +-- +-- All actions on an xlsx file run inside the 'XlsxM' monad, and must +-- be run with 'runXlsxM'. XlsxM is not a monad transformer, a design +-- inherited from the "zip" package's ZipArchive monad. +-- +-- Inside the XlsxM monad, you can stream 'SheetItem's (a row) from a +-- particular sheet, using 'readSheetByIndex', which is callback-based and tied to IO. +-- +module Codec.Xlsx.Parser.Stream + ( XlsxM + , runXlsxM + , WorkbookInfo(..) + , SheetInfo(..) + , wiSheets + , getOrParseSharedStringss + , getWorkbookInfo + , CellRow + , readSheet + , readSheetIdentifier + , countRowsInSheet + , countRowsInSheetIdentifier + , collectItems + , collectItemsIdentifier + -- ** Index + , SheetIndex + , makeIndex + , makeIndexFromName + -- ** Identifier + , SheetIdentifier + , getSheetIdentifier + , makeIdentifierFromName + -- ** SheetItem + , SheetItem(..) + , si_sheet_index + , si_row + -- ** Row + , Row(..) + , ri_row_index + , ri_cell_row + -- * Errors + , SheetErrors(..) + , AddCellErrors(..) + , CoordinateErrors(..) + , TypeError(..) + , WorkbookError(..) + ) where + +import qualified "zip" Codec.Archive.Zip as Zip +import Codec.Xlsx.Types.Cell +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Internal (RefId (..)) +import Codec.Xlsx.Types.Internal.Relationships (Relationship (..), + Relationships (..)) +import Conduit (PrimMonad, (.|)) +import qualified Conduit as C +import qualified Data.Vector as V +import Codec.Xlsx.LensCompat + +import Codec.Xlsx.Parser.Internal +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Bifunctor +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Conduit (ConduitT) +import qualified Data.DList as DL +import Data.Foldable +import Data.IORef +import qualified Data.IntMap.Strict as IntMap +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Read as Read +import Data.Traversable (for) +import Data.XML.Types +import GHC.Generics +import Codec.Xlsx.Parser.Internal.Memoize + +import qualified Codec.Xlsx.Parser.Stream.HexpatInternal as HexpatInternal +import Control.Monad.Base +import Control.Monad.Trans.Control +import Text.XML.Expat.Internal.IO as Hexpat +import Text.XML.Expat.SAX as Hexpat +import Codec.Xlsx.Types +import Codec.Xlsx.Parser.Stream.SheetInfo +import Codec.Xlsx.Parser.Stream.Row +import Codec.Xlsx.Parser.Stream.SheetItem +import Codec.Xlsx.Parser.Stream.SheetIdentifier +import Codec.Xlsx.Parser.Stream.SheetIndex + +type SharedStringsMap = V.Vector Text + +-- | Type of the excel value +-- +-- Note: Some values are untyped and rules of their type resolution are not known. +-- They may be treated simply as strings as well as they may be context-dependent. +-- By far we do not bother with it. +data ExcelValueType + = TS -- ^ shared string + | TStr -- ^ either an inline string ("inlineStr") or a formula string ("str") + | TN -- ^ number + | TB -- ^ boolean + | TE -- ^ excell error, the sheet can contain error values, for example if =1/0, causes division by zero + | Untyped -- ^ Not all values have types + deriving stock (Generic, Show) + +-- | State for parsing sheets +data ParserState = MkParserState + { _ps_row :: ~CellRow -- ^ Current row + , _ps_cell_row_index :: RowIndex -- ^ Current row number + , _ps_cell_col_index :: ColumnIndex -- ^ Current column number + , _ps_cell_style :: Maybe Int + , _ps_is_in_val :: Bool -- ^ Flag for indexing wheter the parser is in value or not + , _ps_shared_strings :: SharedStringsMap -- ^ Shared string map + , _ps_type :: ExcelValueType -- ^ The last detected value type + + , _ps_text_buf :: Text + -- ^ for hexpat only, which can break up char data into multiple events + , _ps_worksheet_ended :: Bool + -- ^ For hexpat only, which can throw errors right at the end of the sheet + -- rather than ending gracefully. + } deriving stock (Generic, Show) +makeLenses 'MkParserState + +-- | State for parsing shared strings +data SharedStringsState = MkSharedStringsState + { _ss_string :: TB.Builder -- ^ String we are parsing + -- TODO: At the moment SharedStrings can be used only to create CellText values. + -- We should add support for CellRich values. + , _ss_list :: DL.DList Text -- ^ list of shared strings + } deriving stock (Generic, Show) +makeLenses 'MkSharedStringsState + +type HasParserState = MonadState ParserState +type HasSharedStringsState = MonadState SharedStringsState + +-- | Information about the workbook contained in xl/workbook.xml +-- (currently a subset) +data WorkbookInfo = WorkbookInfo + { _wiSheets :: [SheetInfo] + } deriving Show +makeLenses 'WorkbookInfo + +data XlsxMState = MkXlsxMState + { _xs_shared_strings :: Memoized (V.Vector Text) + , _xs_workbook_info :: Memoized WorkbookInfo + , _xs_relationships :: Memoized Relationships + } + +newtype XlsxM a = XlsxM {_unXlsxM :: ReaderT XlsxMState Zip.ZipArchive a} + deriving newtype + ( Functor, + Applicative, + Monad, + MonadIO, + MonadCatch, + MonadMask, + MonadThrow, + MonadReader XlsxMState, + MonadBase IO, + MonadBaseControl IO + ) + +-- | Initial parsing state +initialParserState :: ParserState +initialParserState = MkParserState + { _ps_row = mempty + , _ps_cell_row_index = 0 + , _ps_cell_col_index = 0 + , _ps_is_in_val = False + , _ps_shared_strings = mempty + , _ps_type = Untyped + , _ps_text_buf = mempty + , _ps_worksheet_ended = False + , _ps_cell_style = Nothing + } + +-- | Initial parsing state +initialSharedStrings :: SharedStringsState +initialSharedStrings = MkSharedStringsState + { _ss_string = mempty + , _ss_list = mempty + } + +-- | Parse shared string entry from xml event and return it once +-- we've reached the end of given element +{-# SCC parseSharedStrings #-} +parseSharedStrings + :: ( MonadThrow m + , HasSharedStringsState m + ) + => HexpatEvent -> m (Maybe Text) +parseSharedStrings = \case + -- TODO: Add parsing of text styles to further create CellRich values. + StartElement "si" _ -> Nothing <$ (ss_string .= mempty) + EndElement "si" -> Just . LT.toStrict . TB.toLazyText <$> gets _ss_string + CharacterData txt -> Nothing <$ (ss_string <>= TB.fromText txt) + _ -> pure Nothing + +-- | Run a series of actions on an Xlsx file +runXlsxM :: MonadIO m => FilePath -> XlsxM a -> m a +runXlsxM xlsxFile (XlsxM act) = liftIO $ do + -- TODO: don't run the withArchive multiple times but use liftWith or runInIO instead + _xs_workbook_info <- memoizeRef (Zip.withArchive xlsxFile readWorkbookInfo) + _xs_relationships <- memoizeRef (Zip.withArchive xlsxFile readWorkbookRelationships) + _xs_shared_strings <- memoizeRef (Zip.withArchive xlsxFile parseSharedStringss) + Zip.withArchive xlsxFile $ runReaderT act $ MkXlsxMState{..} + +liftZip :: Zip.ZipArchive a -> XlsxM a +liftZip = XlsxM . ReaderT . const + +parseSharedStringss :: Zip.ZipArchive (V.Vector Text) +parseSharedStringss = do + sharedStrsSel <- Zip.mkEntrySelector "xl/sharedStrings.xml" + hasSharedStrs <- Zip.doesEntryExist sharedStrsSel + if not hasSharedStrs + then pure mempty + else do + let state0 = initialSharedStrings + byteSrc <- Zip.getEntrySource sharedStrsSel + st <- liftIO $ runExpat state0 byteSrc $ \evs -> forM_ evs $ \ev -> do + mTxt <- parseSharedStrings ev + for_ mTxt $ \txt -> + ss_list %= (`DL.snoc` txt) + pure $ V.fromList $ DL.toList $ _ss_list st + +{-# SCC getOrParseSharedStringss #-} +getOrParseSharedStringss :: XlsxM (V.Vector Text) +getOrParseSharedStringss = runMemoized =<< asks _xs_shared_strings + +readWorkbookInfo :: Zip.ZipArchive WorkbookInfo +readWorkbookInfo = do + sel <- Zip.mkEntrySelector "xl/workbook.xml" + src <- Zip.getEntrySource sel + sheetIndexRef <- liftIO $ newIORef 0 + sheets <- liftIO $ runExpat [] src $ \evs -> forM_ evs $ \case + StartElement ("sheet" :: ByteString) attrs -> do + nm <- lookupBy "name" attrs + sheetId <- lookupBy "sheetId" attrs + rId <- lookupBy "r:id" attrs + sheetState <- case lookup "state" attrs of + Nothing -> pure Visible -- default to visible if not found + Just ss -> case ss of + "visible" -> pure Visible + "hidden" -> pure Hidden + "veryHidden" -> pure VeryHidden + _ -> throwM $ InvalidSheetState ss + sheetNum <- either (throwM . ParseDecimalError sheetId) pure $ eitherDecimal sheetId + sheetIndex <- liftIO $ atomicModifyIORef' sheetIndexRef $ \i -> (succ i, i) + let info = MkSheetInfo nm (RefId rId) sheetNum sheetIndex sheetState + modify' (info :) + _ -> pure () + pure $ WorkbookInfo sheets + +lookupBy :: MonadThrow m => ByteString -> [(ByteString, Text)] -> m Text +lookupBy fields attrs = maybe (throwM $ LookupError attrs fields) pure $ lookup fields attrs + +-- | Returns information about the workbook, found in +-- xl/workbook.xml. The result is cached so the XML will only be +-- decompressed and parsed once inside a larger XlsxM action. +getWorkbookInfo :: XlsxM WorkbookInfo +getWorkbookInfo = runMemoized =<< asks _xs_workbook_info + +readWorkbookRelationships :: Zip.ZipArchive Relationships +readWorkbookRelationships = do + sel <- Zip.mkEntrySelector "xl/_rels/workbook.xml.rels" + src <- Zip.getEntrySource sel + liftIO $ fmap Relationships $ runExpat mempty src $ \evs -> forM_ evs $ \case + StartElement ("Relationship" :: ByteString) attrs -> do + rId <- lookupBy "Id" attrs + rTarget <- lookupBy "Target" attrs + rType <- lookupBy "Type" attrs + modify' $ M.insert (RefId rId) $ + Relationship { relType = rType, + relTarget = T.unpack rTarget + } + _ -> pure () + +-- | Gets relationships for the workbook (this means the filenames in +-- the relationships map are relative to "xl/" base path within the +-- zip file. +-- +-- The relationships xml file will only be parsed once when called +-- multiple times within a larger XlsxM action. +getWorkbookRelationships :: XlsxM Relationships +getWorkbookRelationships = runMemoized =<< asks _xs_relationships + +type HexpatEvent = SAXEvent ByteString Text + +relIdToEntrySelector :: RefId -> XlsxM (Maybe Zip.EntrySelector) +relIdToEntrySelector rid = do + Relationships rels <- getWorkbookRelationships + for (M.lookup rid rels) $ \rel -> do + Zip.mkEntrySelector $ "xl/" <> relTarget rel + +-- If the given sheet number exists, returns Just a conduit source of the stream +-- of XML events in a particular sheet. Returns Nothing when the sheet doesn't +-- exist. +{-# SCC getSheetXmlSource #-} +getSheetXmlSource :: + (PrimMonad m, MonadThrow m, C.MonadResource m) => + SheetIdentifier -> + XlsxM (Maybe (ConduitT () ByteString m ())) +getSheetXmlSource (SheetIdentifier refId _sheetId) = do + -- TODO: The Zip library may throw exceptions that aren't exposed from this + -- module, so downstream library users would need to add the 'zip' package to + -- handle them. Consider re-wrapping zip library exceptions, or just + -- re-export them? + mSheetSel <- relIdToEntrySelector refId + sheetExists <- maybe (pure False) (liftZip . Zip.doesEntryExist) mSheetSel + case mSheetSel of + Just sheetSel + | sheetExists -> + Just <$> liftZip (Zip.getEntrySource sheetSel) + _ -> pure Nothing + +{-# SCC runExpat #-} +runExpat :: forall state tag text. + (GenericXMLString tag, GenericXMLString text) => + state -> + ConduitT () ByteString (C.ResourceT IO) () -> + ([SAXEvent tag text] -> StateT state IO ()) -> + IO state +runExpat initialState byteSource handler = do + -- Set up state + ref <- newIORef initialState + -- Set up parser and callbacks + (parseChunk, _getLoc) <- Hexpat.hexpatNewParser Nothing Nothing False + let noExtra _ offset = pure ((), offset) + {-# SCC processChunk #-} + {-# INLINE processChunk #-} + processChunk isFinalChunk chunk = do + (buf, len, mError) <- parseChunk chunk isFinalChunk + saxen <- HexpatInternal.parseBuf buf len noExtra + case mError of + Just err -> error $ "expat error: " <> show err + Nothing -> do + state0 <- liftIO $ readIORef ref + state1 <- + {-# SCC "runExpat_runStateT_call" #-} + execStateT (handler $ map fst saxen) state0 + writeIORef ref state1 + C.runConduitRes $ + byteSource .| + C.awaitForever (liftIO . processChunk False) + processChunk True BS.empty + readIORef ref + +runExpatForSheet :: + ParserState -> + ConduitT () ByteString (C.ResourceT IO) () -> + (Row -> IO ()) -> + XlsxM () +runExpatForSheet initState byteSource inner = + void $ liftIO $ runExpat initState byteSource handler + where + handler evs = forM_ evs $ \ev -> do + parseRes <- runExceptT $ matchHexpatEvent ev + case parseRes of + Left err -> throwM err + Right (Just cellRow) + | not (IntMap.null cellRow) -> do + rowNum <- use ps_cell_row_index + liftIO $ inner $ MkRow rowNum cellRow + _ -> pure () + +-- | this will collect the sheetitems in a list. +-- useful for cases were memory is of no concern but a sheetitem +-- type in a list is needed. +{-# DEPRECATED collectItems "prefer to use collectItemsIdentifier, see issue #193" #-} +collectItems :: + SheetIndex -> + XlsxM [SheetItem] +collectItems (MkSheetIndex sheetId) = makeIdentifierFromId sheetId >>= \case + Nothing -> pure [] + Just identifier -> fmap (MkSheetItem sheetId) <$> collectItemsIdentifier identifier + +-- | this will collect the rows in a list. +-- useful for cases were memory is of no concern but a row +-- type in a list is needed. +collectItemsIdentifier :: + SheetIdentifier -> + XlsxM [Row] +collectItemsIdentifier sheetIdentifier = do + res <- liftIO $ newIORef [] + void $ readSheetIdentifier sheetIdentifier $ \item -> + liftIO (modifyIORef' res (item :)) + fmap reverse $ liftIO $ readIORef res + +-- | Look up the index of a case insensitive sheet name +{-# DEPRECATED makeIndexFromName "prefer to use makeIdentifierFromName" #-} +makeIndexFromName :: Text -> XlsxM (Maybe SheetIndex) +makeIndexFromName sheetName = do + fmap (makeIndex . siSheetId) <$> makeIdentifierFromName sheetName + +-- | Look up the identifier of a case insensitive sheet name +makeIdentifierFromName :: Text -> XlsxM (Maybe SheetIdentifier) +makeIdentifierFromName sheetName = do + wi <- getWorkbookInfo + -- The Excel UI does not allow a user to create two sheets whose + -- names differ only in alphabetic case (at least for ascii...) + let sheetNameCI = T.toLower sheetName + findRes :: Maybe SheetInfo + findRes = find ((== sheetNameCI) . T.toLower . sheetInfoName) $ _wiSheets wi + pure $ getSheetIdentifier <$> findRes + +-- | Look up the identifier of a sheet id. Not for exporting since it is somewhat +-- nonsensical if you do not have the sheet id. +makeIdentifierFromId :: Int -> XlsxM (Maybe SheetIdentifier) +makeIdentifierFromId sheetId = do + WorkbookInfo sheets <- getWorkbookInfo + pure $ getSheetIdentifier <$> find ((== sheetId) . sheetInfoSheetId) sheets + +{-# DEPRECATED readSheet "prefer to use readSheetIdentifier" #-} +readSheet :: + SheetIndex -> + -- | Function to consume the sheet's rows + (SheetItem -> IO ()) -> + -- | Returns False if sheet doesn't exist, or True otherwise + XlsxM Bool +readSheet (MkSheetIndex sheetId) inner = makeIdentifierFromId sheetId >>= \case + Nothing -> pure False + Just identifier -> readSheetIdentifier identifier (inner . MkSheetItem sheetId) + +readSheetIdentifier :: + SheetIdentifier -> + -- | Function to consume the sheet's rows + (Row -> IO ()) -> + -- | Returns False if sheet doesn't exist, or True otherwise + XlsxM Bool +readSheetIdentifier identifier inner = do + mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <- getSheetXmlSource identifier + let + case mSrc of + Nothing -> pure False + Just sourceSheetXml -> do + sharedStrs <- getOrParseSharedStringss + let sheetState0 = initialParserState + & ps_shared_strings .~ sharedStrs + runExpatForSheet sheetState0 sourceSheetXml inner + pure True + +-- | Returns number of rows in the given sheet (identified by the +-- sheet's ID, AKA the sheetId attribute, AKA 'sheetInfoSheetId'), or Nothing +-- if the sheet does not exist. Does not perform a full parse of the +-- XML into 'SheetItem's, so it should be more efficient than counting +-- via 'readSheetByIndex'. +{-# DEPRECATED countRowsInSheet "prefer to use countRowsInSheetIdentifier" #-} +countRowsInSheet :: SheetIndex -> XlsxM (Maybe Int) +countRowsInSheet (MkSheetIndex sheetId) = + makeIdentifierFromId sheetId >>= \case + Nothing -> pure Nothing + Just identifier -> countRowsInSheetIdentifier identifier + +-- | Returns number of rows in the given sheet or Nothing +-- if the sheet does not exist. Does not perform a full parse of the +-- XML into 'SheetItem's, so it should be more efficient than counting +-- via 'readSheetByIndex'. +countRowsInSheetIdentifier :: SheetIdentifier -> XlsxM (Maybe Int) +countRowsInSheetIdentifier identifier = do + mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <- + getSheetXmlSource identifier + for mSrc $ \sourceSheetXml -> do + liftIO $ runExpat @Int @ByteString @ByteString 0 sourceSheetXml $ \evs -> + forM_ evs $ \case + StartElement "row" _ -> modify' (+1) + _ -> pure () + +-- | Return row from the state and empty it +popRow :: HasParserState m => m CellRow +popRow = do + row <- use ps_row + ps_row .= mempty + pure row + +data AddCellErrors + = ReadError -- ^ Could not read current cell value + Text -- ^ Original value + String -- ^ Error message + | SharedStringsNotFound -- ^ Could not find string by index in shared string table + Int -- ^ Given index + (V.Vector Text) -- ^ Given shared strings to lookup in + deriving Show + +-- | Parse the given value +-- +-- If it's a string, we try to get it our of a shared string table +{-# SCC parseValue #-} +parseValue :: SharedStringsMap -> Text -> ExcelValueType -> Either AddCellErrors CellValue +parseValue sstrings txt = \case + TS -> do + (idx, _) <- ReadError txt `first` Read.decimal @Int txt + string <- maybe (Left $ SharedStringsNotFound idx sstrings) Right $ {-# SCC "sstrings_lookup_scc" #-} (sstrings ^? ix idx) + Right $ CellText string + TStr -> pure $ CellText txt + TN -> bimap (ReadError txt) (CellDouble . fst) $ Read.double txt + TE -> bimap (ReadError txt) (CellError . fst) $ fromAttrVal txt + TB | txt == "1" -> Right $ CellBool True + | txt == "0" -> Right $ CellBool False + | otherwise -> Left $ ReadError txt "Could not read Excel boolean value (expected 0 or 1)" + Untyped -> Right (parseUntypedValue txt) + +-- TODO: some of the cells are untyped and we need to test whether +-- they all are strings or something more complicated +parseUntypedValue :: Text -> CellValue +parseUntypedValue = CellText + +-- | Adds a cell to row in state monad +{-# SCC addCellToRow #-} +addCellToRow + :: ( MonadError SheetErrors m + , HasParserState m + ) + => Text -> m () +addCellToRow txt = do + st <- get + style <- use ps_cell_style + when (_ps_is_in_val st) $ do + val <- liftEither $ first ParseCellError $ parseValue (_ps_shared_strings st) txt (_ps_type st) + put $ st { _ps_row = IntMap.insert (unColumnIndex $ _ps_cell_col_index st) + (Cell { _cellStyle = style + , _cellValue = Just val + , _cellComment = Nothing + , _cellFormula = Nothing + }) $ _ps_row st} + +data SheetErrors + = ParseCoordinateError CoordinateErrors -- ^ Error while parsing coordinates + | ParseTypeError TypeError -- ^ Error while parsing types + | ParseCellError AddCellErrors -- ^ Error while parsing cells + | ParseStyleErrors StyleError + | HexpatParseError Hexpat.XMLParseError + deriving stock Show + deriving anyclass Exception + +type SheetValue = (ByteString, Text) +type SheetValues = [SheetValue] + +data CoordinateErrors + = CoordinateNotFound SheetValues -- ^ If the coordinate was not specified in "r" attribute + | NoListElement SheetValue SheetValues -- ^ If the value is empty for some reason + | NoTextContent Content SheetValues -- ^ If the value has something besides @ContentText@ inside + | DecodeFailure Text SheetValues -- ^ If malformed coordinate text was passed + deriving stock Show + deriving anyclass Exception + +data TypeError + = TypeNotFound SheetValues + | TypeNoListElement SheetValue SheetValues + | UnkownType Text SheetValues + | TypeNoTextContent Content SheetValues + deriving Show + deriving anyclass Exception + +data WorkbookError = LookupError { lookup_attrs :: [(ByteString, Text)], lookup_field :: ByteString } + | ParseDecimalError Text String + | InvalidSheetState Text + deriving Show + deriving anyclass Exception + +{-# SCC matchHexpatEvent #-} +matchHexpatEvent :: + ( MonadError SheetErrors m, + HasParserState m + ) => + HexpatEvent -> + m (Maybe CellRow) +matchHexpatEvent ev = case ev of + CharacterData txt -> {-# SCC "handle_CharData" #-} do + inVal <- use ps_is_in_val + when inVal $ + {-# SCC "append_text_buf" #-} (ps_text_buf <>= txt) + pure Nothing + StartElement "c" attrs -> Nothing <$ (setCoord attrs *> setType attrs *> setStyle attrs) + StartElement "is" _ -> Nothing <$ (ps_is_in_val .= True) + EndElement "is" -> Nothing <$ finaliseCellValue + StartElement "v" _ -> Nothing <$ (ps_is_in_val .= True) + EndElement "v" -> Nothing <$ finaliseCellValue + -- If beginning of row, empty the state and return nothing. + -- We don't know if there is anything in the state, the user may have + -- decided to (not closing). In any case it's the beginning of a new row + -- so we clear the state. + StartElement "row" _ -> Nothing <$ popRow + -- If at the end of the row, we have collected the whole row into + -- the current state. Empty the state and return the row. + EndElement "row" -> Just <$> popRow + StartElement "worksheet" _ -> ps_worksheet_ended .= False >> pure Nothing + EndElement "worksheet" -> ps_worksheet_ended .= True >> pure Nothing + -- Skip everything else, e.g. the formula elements + FailDocument err -> do + -- this event is emitted at the end the xml stream (possibly + -- because the xml files in xlsx archives don't end in a + -- newline, but that's a guess), so we use state to determine if + -- it's expected. + finished <- use ps_worksheet_ended + unless finished $ + throwError $ HexpatParseError err + pure Nothing + _ -> pure Nothing + +{-# INLINE finaliseCellValue #-} +finaliseCellValue :: + ( MonadError SheetErrors m, HasParserState m ) => m () +finaliseCellValue = do + txt <- gets _ps_text_buf + addCellToRow txt + modify' $ \st -> + st { _ps_is_in_val = False + , _ps_text_buf = mempty + } + +-- | Update state coordinates accordingly to @parseCoordinates@ +{-# SCC setCoord #-} +setCoord + :: ( MonadError SheetErrors m + , HasParserState m + ) + => SheetValues -> m () +setCoord list = do + coordinates <- liftEither $ first ParseCoordinateError $ parseCoordinates list + ps_cell_col_index .= (coordinates ^. _2) + ps_cell_row_index .= (coordinates ^. _1) + +-- | Parse type from values and update state accordingly +setType + :: ( MonadError SheetErrors m + , HasParserState m + ) + => SheetValues -> m () +setType list = do + type' <- liftEither $ first ParseTypeError $ parseType list + ps_type .= type' + +-- | Find sheet value by its name +findName :: ByteString -> SheetValues -> Maybe SheetValue +findName name = find ((name ==) . fst) +{-# INLINE findName #-} + +setStyle :: (MonadError SheetErrors m, HasParserState m) => SheetValues -> m () +setStyle list = do + style <- liftEither $ first ParseStyleErrors $ parseStyle list + ps_cell_style .= style + +data StyleError = InvalidStyleRef { seInput:: Text, seErrorMsg :: String} + deriving Show + +parseStyle :: SheetValues -> Either StyleError (Maybe Int) +parseStyle list = + case findName "s" list of + Nothing -> pure Nothing + Just (_nm, valTex) -> case Read.decimal valTex of + Left err -> Left (InvalidStyleRef valTex err) + Right (i, _rem) -> pure $ Just i + +-- | Parse value type +{-# SCC parseType #-} +parseType :: SheetValues -> Either TypeError ExcelValueType +parseType list = + case findName "t" list of + -- NB: According to format specification default value for cells without + -- `t` attribute is a `n` - number. + -- + -- + -- .. + -- + -- + Nothing -> Right TN + Just (_nm, valText)-> + case valText of + "n" -> Right TN + "s" -> Right TS + -- "Cell containing a formula string". Probably shouldn't be TStr.. + "str" -> Right TStr + "inlineStr" -> Right TStr + "b" -> Right TB + "e" -> Right TE + other -> Left $ UnkownType other list + +-- | Parse coordinates from a list of xml elements if such were found on "r" key +{-# SCC parseCoordinates #-} +parseCoordinates :: SheetValues -> Either CoordinateErrors (RowIndex, ColumnIndex) +parseCoordinates list = do + (_nm, valText) <- maybe (Left $ CoordinateNotFound list) Right $ findName "r" list + maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText diff --git a/src/Codec/Xlsx/Parser/Stream/HexpatInternal.hs b/src/Codec/Xlsx/Parser/Stream/HexpatInternal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/HexpatInternal.hs @@ -0,0 +1,95 @@ +{- +Under BSD 3-Clause license, (c) 2009 Doug Beardsley , (c) 2009-2012 Stephen Blackheath , (c) 2009 Gregory Collins, (c) 2008 Evan Martin , (c) 2009 Matthew Pocock , (c) 2007-2009 Galois Inc., (c) 2010 Kevin Jardine, (c) 2012 Simon Hengel + +From https://hackage.haskell.org/package/hexpat-0.20.13 + https://github.com/the-real-blackh/hexpat/blob/master/Text/XML/Expat/SAX.hs#L227 + +copied over because the upstream library doesn't expose this function. +-} +module Codec.Xlsx.Parser.Stream.HexpatInternal (parseBuf) where + +import Control.Monad +import Text.XML.Expat.SAX +import qualified Data.ByteString.Internal as I +import Data.Bits +import Data.Int +import Data.ByteString.Internal (c_strlen) +import Data.Word +import Foreign.C +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable + +{-# SCC parseBuf #-} +parseBuf :: (GenericXMLString tag, GenericXMLString text) => + ForeignPtr Word8 -> CInt -> (Ptr Word8 -> Int -> IO (a, Int)) -> IO [(SAXEvent tag text, a)] +parseBuf buf _ processExtra = withForeignPtr buf $ \pBuf -> doit [] pBuf 0 + where + roundUp32 offset = (offset + 3) .&. complement 3 + doit acc pBuf offset0 = offset0 `seq` do + typ <- peek (pBuf `plusPtr` offset0 :: Ptr Word32) + (a, offset) <- processExtra pBuf (offset0 + 4) + case typ of + 0 -> return (reverse acc) + 1 -> do + nAtts <- peek (pBuf `plusPtr` offset :: Ptr Word32) + let pName = pBuf `plusPtr` (offset + 4) + lName <- fromIntegral <$> c_strlen pName + let name = gxFromByteString $ I.fromForeignPtr buf (offset + 4) lName + (atts, offset') <- foldM (\(atts, offset) _ -> do + let pAtt = pBuf `plusPtr` offset + lAtt <- fromIntegral <$> c_strlen pAtt + let att = gxFromByteString $ I.fromForeignPtr buf offset lAtt + offset' = offset + lAtt + 1 + pValue = pBuf `plusPtr` offset' + lValue <- fromIntegral <$> c_strlen pValue + let value = gxFromByteString $ I.fromForeignPtr buf offset' lValue + return ((att, value):atts, offset' + lValue + 1) + ) ([], offset + 4 + lName + 1) [1,3..nAtts] + doit ((StartElement name (reverse atts), a) : acc) pBuf (roundUp32 offset') + 2 -> do + let pName = pBuf `plusPtr` offset + lName <- fromIntegral <$> c_strlen pName + let name = gxFromByteString $ I.fromForeignPtr buf offset lName + offset' = offset + lName + 1 + doit ((EndElement name, a) : acc) pBuf (roundUp32 offset') + 3 -> do + len <- fromIntegral <$> peek (pBuf `plusPtr` offset :: Ptr Word32) + let text = gxFromByteString $ I.fromForeignPtr buf (offset + 4) len + offset' = offset + 4 + len + doit ((CharacterData text, a) : acc) pBuf (roundUp32 offset') + 4 -> do + let pEnc = pBuf `plusPtr` offset + lEnc <- fromIntegral <$> c_strlen pEnc + let enc = gxFromByteString $ I.fromForeignPtr buf offset lEnc + offset' = offset + lEnc + 1 + pVer = pBuf `plusPtr` offset' + pVerFirst <- peek (castPtr pVer :: Ptr Word8) + (mVer, offset'') <- case pVerFirst of + 0 -> return (Nothing, offset' + 1) + 1 -> do + lVer <- fromIntegral <$> c_strlen (pVer `plusPtr` 1) + return (Just $ gxFromByteString $ I.fromForeignPtr buf (offset' + 1) lVer, offset' + 1 + lVer + 1) + _ -> error "hexpat: bad data from C land" + cSta <- peek (pBuf `plusPtr` offset'' :: Ptr Int8) + let sta = if cSta < 0 then Nothing else + if cSta == 0 then Just False else + Just True + doit ((XMLDeclaration enc mVer sta, a) : acc) pBuf (roundUp32 (offset'' + 1)) + 5 -> doit ((StartCData, a) : acc) pBuf offset + 6 -> doit ((EndCData, a) : acc) pBuf offset + 7 -> do + let pTarget = pBuf `plusPtr` offset + lTarget <- fromIntegral <$> c_strlen pTarget + let target = gxFromByteString $ I.fromForeignPtr buf offset lTarget + offset' = offset + lTarget + 1 + pData = pBuf `plusPtr` offset' + lData <- fromIntegral <$> c_strlen pData + let dat = gxFromByteString $ I.fromForeignPtr buf offset' lData + doit ((ProcessingInstruction target dat, a) : acc) pBuf (roundUp32 (offset' + lData + 1)) + 8 -> do + let pText = pBuf `plusPtr` offset + lText <- fromIntegral <$> c_strlen pText + let text = gxFromByteString $ I.fromForeignPtr buf offset lText + doit ((Comment text, a) : acc) pBuf (roundUp32 (offset + lText + 1)) + _ -> error "hexpat: bad data from C land" diff --git a/src/Codec/Xlsx/Parser/Stream/Row.hs b/src/Codec/Xlsx/Parser/Stream/Row.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/Row.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Codec.Xlsx.Parser.Stream.Row where + +import Codec.Xlsx.LensCompat +import Codec.Xlsx.Types.Cell (Cell) +import Codec.Xlsx.Types.Common ( RowIndex) +import Data.IntMap.Strict (IntMap) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) + +type CellRow = IntMap Cell + +data Row = MkRow + { _ri_row_index :: !RowIndex -- ^ Row number + , _ri_cell_row :: CellRow -- ^ Row itself + } deriving stock (Generic, Show) + deriving anyclass NFData + +makeLenses 'MkRow diff --git a/src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs b/src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Codec.Xlsx.Parser.Stream.SheetIdentifier + ( SheetIdentifier (SheetIdentifier, siRefId, siSheetId) + , unsafeGetSheetIdentifier + ) where + +import Codec.Xlsx.Types.RefId ( RefId ) + +-- | Opaque identifier for a sheet. +data SheetIdentifier = MkSheetIdentifier RefId Int + deriving (Eq, Ord) + +pattern SheetIdentifier :: RefId -> Int -> SheetIdentifier +pattern SheetIdentifier { siRefId, siSheetId } <- MkSheetIdentifier siRefId siSheetId + +{-# COMPLETE SheetIdentifier #-} + +unsafeGetSheetIdentifier :: RefId -> Int -> SheetIdentifier +unsafeGetSheetIdentifier = MkSheetIdentifier diff --git a/src/Codec/Xlsx/Parser/Stream/SheetIndex.hs b/src/Codec/Xlsx/Parser/Stream/SheetIndex.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetIndex.hs @@ -0,0 +1,20 @@ + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +module Codec.Xlsx.Parser.Stream.SheetIndex (SheetIndex (..), makeIndex) where + +import Control.DeepSeq + +-- | datatype representing a sheet index, looking it up by name +-- can be done with 'makeIndexFromName', which is the preferred approach. +-- although 'makeIndex' is available in case it's already known. +newtype SheetIndex = MkSheetIndex Int + deriving newtype (NFData, Show) + +-- | This does *no* checking if the index exists or not. +-- you could have index out of bounds issues because of this. +makeIndex :: Int -> SheetIndex +makeIndex = MkSheetIndex + +{-# DEPRECATED SheetIndex, MkSheetIndex, makeIndex "SheetIndex will not be supported in future, see issue #193. Use SheetIdentifier instead" #-} diff --git a/src/Codec/Xlsx/Parser/Stream/SheetInfo.hs b/src/Codec/Xlsx/Parser/Stream/SheetInfo.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetInfo.hs @@ -0,0 +1,27 @@ + +module Codec.Xlsx.Parser.Stream.SheetInfo where + +import Data.Text (Text) +import Codec.Xlsx.Types.RefId (RefId) +import Codec.Xlsx.Parser.Stream.SheetIdentifier + (SheetIdentifier, unsafeGetSheetIdentifier) +import Codec.Xlsx.Types (SheetState) + +-- | Represents sheets from the workbook.xml file. E.g. +-- SheetIdentifier +getSheetIdentifier sheetInfo = unsafeGetSheetIdentifier (sheetInfoRelId sheetInfo) (sheetInfoSheetId sheetInfo) diff --git a/src/Codec/Xlsx/Parser/Stream/SheetItem.hs b/src/Codec/Xlsx/Parser/Stream/SheetItem.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetItem.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Codec.Xlsx.Parser.Stream.SheetItem where + +import Codec.Xlsx.Parser.Stream.Row (Row) + +import Codec.Xlsx.LensCompat +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) + + +-- | Sheet item +-- +-- The current sheet at a time, every sheet is constructed of these items. +data SheetItem = MkSheetItem + { _si_sheet_index :: !Int -- ^ The sheet number + , _si_row :: Row + } deriving stock (Generic, Show) + deriving anyclass NFData + +{-# WARNING SheetItem, MkSheetItem "SheetItem will not be supported in future, see issue #193. Use Row directly instead" #-} +makeLenses 'MkSheetItem +{-# DEPRECATED si_sheet_index, si_row "SheetItem will not be supported in future, see issue #193" #-} diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -2,18 +2,26 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} + module Codec.Xlsx.Types ( -- * The main types Xlsx(..) , Styles(..) , DefinedNames(..) - , ColumnsWidth(..) + , ColumnsProperties(..) , PageSetup(..) , Worksheet(..) + , SheetState(..) , CellMap , CellValue(..) , CellFormula(..) + , FormulaExpression(..) + , Cell.SharedFormulaIndex(..) + , Cell.SharedFormulaOptions(..) , Cell(..) + , RowHeight(..) , RowProperties (..) -- * Lenses -- ** Workbook @@ -21,8 +29,9 @@ , xlStyles , xlDefinedNames , xlCustomProperties + , xlDateBase -- ** Worksheet - , wsColumns + , wsColumnsProperties , wsRowPropertiesMap , wsCells , wsDrawing @@ -32,121 +41,208 @@ , wsConditionalFormattings , wsDataValidations , wsPivotTables + , wsAutoFilter + , wsTables + , wsProtection + , wsSharedFormulas + , wsState -- ** Cells - , cellValue - , cellStyle - , cellComment - , cellFormula + , Cell.cellValue + , Cell.cellStyle + , Cell.cellComment + , Cell.cellFormula + -- ** Row properties + , rowHeightLens + , _CustomHeight + , _AutomaticHeight -- * Style helpers , emptyStyles , renderStyleSheet , parseStyleSheet -- * Misc , simpleCellFormula + , sharedFormulaByIndex , def , toRows , fromRows , module X ) where -import Control.Exception (SomeException, - toException) -import Control.Lens.TH -import qualified Data.ByteString.Lazy as L -import Data.Default -import Data.Function (on) -import Data.List (groupBy) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (catMaybes) -import Data.Text (Text) -import Text.XML (Element (..), parseLBS, - renderLBS) -import Text.XML.Cursor +import Control.Exception (SomeException, toException) +import Codec.Xlsx.LensCompat (lens, Lens', makeLenses, Prism', prism) +import Control.DeepSeq (NFData) +import qualified Data.ByteString.Lazy as L +import Data.Default +import Data.Function (on) +import Data.List (groupBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, isJust) +import Data.Text (Text) +import GHC.Generics (Generic) +import Text.XML (parseLBS, renderLBS) +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Comment as X -import Codec.Xlsx.Types.Common as X -import Codec.Xlsx.Types.ConditionalFormatting as X -import Codec.Xlsx.Types.DataValidation as X -import Codec.Xlsx.Types.Drawing as X -import Codec.Xlsx.Types.Drawing.Chart as X -import Codec.Xlsx.Types.Drawing.Common as X -import Codec.Xlsx.Types.PageSetup as X -import Codec.Xlsx.Types.PivotTable as X -import Codec.Xlsx.Types.RichText as X -import Codec.Xlsx.Types.SheetViews as X -import Codec.Xlsx.Types.StyleSheet as X -import Codec.Xlsx.Types.Variant as X -import Codec.Xlsx.Writer.Internal +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 +import Codec.Xlsx.Types.DataValidation as X +import Codec.Xlsx.Types.Drawing as X +import Codec.Xlsx.Types.Drawing.Chart as X +import Codec.Xlsx.Types.Drawing.Common as X +import Codec.Xlsx.Types.PageSetup as X +import Codec.Xlsx.Types.PivotTable as X +import Codec.Xlsx.Types.Protection as X +import Codec.Xlsx.Types.RichText as X +import Codec.Xlsx.Types.SheetViews as X +import Codec.Xlsx.Types.StyleSheet as X +import Codec.Xlsx.Types.Table as X +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) +-- | Height of a row in points (1/72in) +data RowHeight + = CustomHeight !Double + -- ^ Row height is set by the user + | AutomaticHeight !Double + -- ^ Row height is set automatically by the program + deriving (Eq, Ord, Show, Read, Generic) +instance NFData RowHeight -simpleCellFormula :: Text -> CellFormula -simpleCellFormula expr = NormalCellFormula - { _cellfExpression = Formula expr - , _cellfAssignsToName = False - , _cellfCalculate = False - } +_CustomHeight :: Prism' RowHeight Double +_CustomHeight + = (prism (\ x1_a4xgd -> CustomHeight x1_a4xgd)) + (\ x_a4xge + -> case x_a4xge of + CustomHeight y1_a4xgf -> Right y1_a4xgf + _ -> Left x_a4xge) +{-# INLINE _CustomHeight #-} --- | Currently cell details include only cell values and style ids --- (e.g. formulas from @\@ and inline strings from @\@ --- subelements are ignored) -data Cell = Cell - { _cellStyle :: Maybe Int - , _cellValue :: Maybe CellValue - , _cellComment :: Maybe Comment - , _cellFormula :: Maybe CellFormula - } deriving (Eq, Show) +_AutomaticHeight :: Prism' RowHeight Double +_AutomaticHeight + = (prism (\ x1_a4xgg -> AutomaticHeight x1_a4xgg)) + (\ x_a4xgh + -> case x_a4xgh of + AutomaticHeight y1_a4xgi -> Right y1_a4xgi + _ -> Left x_a4xgh) +{-# INLINE _AutomaticHeight #-} -makeLenses ''Cell +-- | Properties of a row. See §18.3.1.73 "row (Row)" for more details +data RowProperties = RowProps + { rowHeight :: Maybe RowHeight + -- ^ Row height in points + , rowStyle :: Maybe Int + -- ^ Style to be applied to row + , rowHidden :: Bool + -- ^ Whether row is visible or not + } deriving (Eq, Ord, Show, Read, Generic) +instance NFData RowProperties -instance Default Cell where - def = Cell Nothing Nothing Nothing Nothing +rowHeightLens :: Lens' RowProperties (Maybe RowHeight) +rowHeightLens = lens rowHeight $ \x y -> x{rowHeight=y} --- | 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 +instance Default RowProperties where + def = RowProps { rowHeight = Nothing + , rowStyle = Nothing + , rowHidden = False + } -data RowProperties = RowProps { rowHeight :: Maybe Double, rowStyle::Maybe Int} - deriving (Read,Eq,Show,Ord) +-- | Column range (from cwMin to cwMax) properties +data ColumnsProperties = ColumnsProperties + { cpMin :: Int + -- ^ First column affected by this 'ColumnWidth' record. + , cpMax :: Int + -- ^ Last column affected by this 'ColumnWidth' record. + , 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) + , 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, Generic) +instance NFData ColumnsProperties --- | Column range (from cwMin to cwMax) width -data ColumnsWidth = ColumnsWidth - { cwMin :: Int - , cwMax :: Int - , cwWidth :: Double - , cwStyle :: Int - } deriving (Eq, Show) +instance FromCursor ColumnsProperties where + fromCursor c = do + 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 {..} -instance FromCursor ColumnsWidth where - fromCursor c = do - cwMin <- decimal =<< attribute "min" c - cwMax <- decimal =<< attribute "max" c - cwWidth <- rational =<< attribute "width" c - cwStyle <- decimal =<< attribute "style" c - return ColumnsWidth{..} +instance FromXenoNode ColumnsProperties where + fromXenoNode root = parseAttributes root $ do + cpMin <- fromAttr "min" + cpMax <- fromAttr "max" + cpWidth <- maybeAttr "width" + cpStyle <- maybeAttr "style" + cpHidden <- fromAttrDef "hidden" False + cpCollapsed <- fromAttrDef "collapsed" False + cpBestFit <- fromAttrDef "bestFit" False + return ColumnsProperties {..} +-- | Sheet visibility state +-- cf. Ecma Office Open XML Part 1: +-- 18.18.68 ST_SheetState (Sheet Visibility Types) +-- * "visible" +-- Indicates the sheet is visible (default) +-- * "hidden" +-- Indicates the workbook window is hidden, but can be shown by the user via the user interface. +-- * "veryHidden" +-- Indicates the sheet is hidden and cannot be shown in the user interface (UI). This state is only available programmatically. +data SheetState = + Visible -- ^ state="visible" + | Hidden -- ^ state="hidden" + | VeryHidden -- ^ state="veryHidden" + deriving (Eq, Show, Generic) + +instance NFData SheetState + +instance Default SheetState where + def = Visible + +instance FromAttrVal SheetState where + fromAttrVal "visible" = readSuccess Visible + fromAttrVal "hidden" = readSuccess Hidden + fromAttrVal "veryHidden" = readSuccess VeryHidden + fromAttrVal t = invalidText "SheetState" t + +instance FromAttrBs SheetState where + fromAttrBs "visible" = return Visible + fromAttrBs "hidden" = return Hidden + fromAttrBs "veryHidden" = return VeryHidden + fromAttrBs t = unexpectedAttrBs "SheetState" t + +instance ToAttrVal SheetState where + toAttrVal Visible = "visible" + toAttrVal Hidden = "hidden" + toAttrVal VeryHidden = "veryHidden" + -- | Xlsx worksheet data Worksheet = Worksheet - { _wsColumns :: [ColumnsWidth] -- ^ column widths - , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map + { _wsColumnsProperties :: [ColumnsProperties] -- ^ column widths + , _wsRowPropertiesMap :: Map RowIndex RowProperties + -- ^ custom row properties (height, style) map , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs , _wsDrawing :: Maybe Drawing -- ^ SpreadsheetML Drawing , _wsMerges :: [Range] -- ^ list of cell merges @@ -155,24 +251,57 @@ , _wsConditionalFormattings :: Map SqRef ConditionalFormatting , _wsDataValidations :: Map SqRef DataValidation , _wsPivotTables :: [PivotTable] - } deriving (Eq, Show) + , _wsAutoFilter :: Maybe AutoFilter + , _wsTables :: [Table] + , _wsProtection :: Maybe SheetProtection + , _wsSharedFormulas :: Map SharedFormulaIndex SharedFormulaOptions + , _wsState :: SheetState + } deriving (Eq, Show, Generic) +instance NFData Worksheet makeLenses ''Worksheet instance Default Worksheet where - def = Worksheet [] M.empty M.empty Nothing [] Nothing Nothing M.empty M.empty [] + def = + Worksheet + { _wsColumnsProperties = [] + , _wsRowPropertiesMap = M.empty + , _wsCells = M.empty + , _wsDrawing = Nothing + , _wsMerges = [] + , _wsSheetViews = Nothing + , _wsPageSetup = Nothing + , _wsConditionalFormattings = M.empty + , _wsDataValidations = M.empty + , _wsPivotTables = [] + , _wsAutoFilter = Nothing + , _wsTables = [] + , _wsProtection = Nothing + , _wsSharedFormulas = M.empty + , _wsState = def + } +-- | Raw worksheet styles, for structured implementation see 'StyleSheet' +-- and functions in "Codec.Xlsx.Types.StyleSheet" newtype Styles = Styles {unStyles :: L.ByteString} - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData Styles -- | Structured representation of Xlsx file (currently a subset of its contents) data Xlsx = Xlsx - { _xlSheets :: [(Text, Worksheet)] - , _xlStyles :: Styles - , _xlDefinedNames :: DefinedNames - , _xlCustomProperties :: Map Text Variant - } deriving (Eq, Show) + { _xlSheets :: [(Text, Worksheet)] + , _xlStyles :: Styles + , _xlDefinedNames :: DefinedNames + , _xlCustomProperties :: Map Text Variant + , _xlDateBase :: DateBase + -- ^ date base to use when converting serial value (i.e. 'CellDouble d') + -- into date-time. Default value is 'DateBase1900' + -- + -- See also 18.17.4.1 "Date Conversion for Serial Date-Times" (p. 2067) + } deriving (Eq, Show, Generic) +instance NFData Xlsx + -- | Defined names -- -- Each defined name consists of a name, an optional local sheet ID, and a value. @@ -195,19 +324,19 @@ -- -- NOTE: Right now this is only a minimal implementation of defined names. newtype DefinedNames = DefinedNames [(Text, Maybe Text, Text)] - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData DefinedNames makeLenses ''Xlsx instance Default Xlsx where - def = Xlsx [] emptyStyles def M.empty + def = Xlsx [] emptyStyles def M.empty DateBase1900 instance Default DefinedNames where def = DefinedNames [] emptyStyles :: Styles -emptyStyles = Styles "\ -\" +emptyStyles = Styles "" -- | Render 'StyleSheet' -- @@ -233,7 +362,7 @@ -- | converts cells mapped by (row, column) into rows which contain -- row index and cells as pairs of column indices and cell values -toRows :: CellMap -> [(Int, [(Int, Cell)])] +toRows :: CellMap -> [(RowIndex, [(ColumnIndex, Cell)])] toRows cells = map extractRow $ groupBy ((==) `on` (fst . fst)) $ M.toList cells where @@ -242,37 +371,22 @@ extractRow _ = error "invalid CellMap row" -- | reverse to 'toRows' -fromRows :: [(Int, [(Int, Cell)])] -> CellMap +fromRows :: [(RowIndex, [(ColumnIndex, Cell)])] -> CellMap fromRows rows = M.fromList $ concatMap mapRow rows where mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells -{------------------------------------------------------------------------------- - Parsing --------------------------------------------------------------------------------} -instance FromCursor CellFormula where - fromCursor cur = do - t <- fromAttributeDef "t" "normal" cur - typedCellFormula t cur - -typedCellFormula :: Text -> Cursor -> [CellFormula] -typedCellFormula "normal" cur = do - _cellfExpression <- fromCursor cur - _cellfAssignsToName <- fromAttributeDef "bx" False cur - _cellfCalculate <- fromAttributeDef "ca" False cur - return NormalCellFormula{..} -typedCellFormula _ _ = fail "parseable cell formula type was not found" - -{------------------------------------------------------------------------------- - Rendering --------------------------------------------------------------------------------} - -instance ToElement CellFormula where - toElement nm NormalCellFormula{..} = - let formulaEl = toElement nm _cellfExpression - in formulaEl - { elementAttributes = - M.fromList $ catMaybes [ "bx" .=? justTrue _cellfAssignsToName - , "ca" .=? justTrue _cellfCalculate ] - } +instance ToElement ColumnsProperties where + toElement nm ColumnsProperties {..} = leafElement nm attrs + where + attrs = + ["min" .= cpMin, "max" .= cpMax] ++ + catMaybes + [ "style" .=? (justNonDef 0 =<< cpStyle) + , "width" .=? cpWidth + , "customWidth" .=? justTrue (isJust cpWidth) + , "hidden" .=? justTrue cpHidden + , "collapsed" .=? justTrue cpCollapsed + , "bestFit" .=? justTrue cpBestFit + ] diff --git a/src/Codec/Xlsx/Types/AutoFilter.hs b/src/Codec/Xlsx/Types/AutoFilter.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/AutoFilter.hs @@ -0,0 +1,742 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.AutoFilter where + +import Control.Arrow (first) +import Control.DeepSeq (NFData) +import Codec.Xlsx.LensCompat (makeLenses) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.Default +import Data.Foldable (asum) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor hiding (bool) +import qualified Xeno.DOM as Xeno + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.ConditionalFormatting (IconSetType) +import Codec.Xlsx.Writer.Internal + +-- | The filterColumn collection identifies a particular column in the +-- AutoFilter range and specifies filter information that has been +-- applied to this column. If a column in the AutoFilter range has no +-- criteria specified, then there is no corresponding filterColumn +-- collection expressed for that column. +-- +-- See 18.3.2.7 "filterColumn (AutoFilter Column)" (p. 1717) +data FilterColumn + = Filters FilterByBlank [FilterCriterion] + | ColorFilter ColorFilterOptions + | ACustomFilter CustomFilter + | CustomFiltersOr CustomFilter CustomFilter + | CustomFiltersAnd CustomFilter CustomFilter + | DynamicFilter DynFilterOptions + | IconFilter (Maybe Int) IconSetType + -- ^ Specifies the icon set and particular icon within that set to + -- filter by. Icon is specified using zero-based index of an icon in + -- an icon set. 'Nothing' means "no icon" + | BottomNFilter EdgeFilterOptions + -- ^ Specifies the bottom N (percent or number of items) to filter by + | TopNFilter EdgeFilterOptions + -- ^ Specifies the top N (percent or number of items) to filter by + deriving (Eq, Show, Generic) +instance NFData FilterColumn + +data FilterByBlank + = FilterByBlank + | DontFilterByBlank + deriving (Eq, Show, Generic) +instance NFData FilterByBlank + +data FilterCriterion + = FilterValue Text + | FilterDateGroup DateGroup + deriving (Eq, Show, Generic) +instance NFData FilterCriterion + +-- | Used to express a group of dates or times which are used in an +-- AutoFilter criteria +-- +-- Section 18.3.2.4 "dateGroupItem (Date Grouping)" (p. 1714) +data DateGroup + = DateGroupByYear Int + | DateGroupByMonth Int Int + | DateGroupByDay Int Int Int + | DateGroupByHour Int Int Int Int + | DateGroupByMinute Int Int Int Int Int + | DateGroupBySecond Int Int Int Int Int Int + deriving (Eq, Show, Generic) +instance NFData DateGroup + +data CustomFilter = CustomFilter + { cfltOperator :: CustomFilterOperator + , cfltValue :: Text + } deriving (Eq, Show, Generic) +instance NFData CustomFilter + +data CustomFilterOperator + = FltrEqual + -- ^ Show results which are equal to criteria. + | FltrGreaterThan + -- ^ Show results which are greater than criteria. + | FltrGreaterThanOrEqual + -- ^ Show results which are greater than or equal to criteria. + | FltrLessThan + -- ^ Show results which are less than criteria. + | FltrLessThanOrEqual + -- ^ Show results which are less than or equal to criteria. + | FltrNotEqual + -- ^ Show results which are not equal to criteria. + deriving (Eq, Show, Generic) +instance NFData CustomFilterOperator + +data EdgeFilterOptions = EdgeFilterOptions + { _efoUsePercents :: Bool + -- ^ Flag indicating whether or not to filter by percent value of + -- the column. A false value filters by number of items. + , _efoVal :: Double + -- ^ Top or bottom value to use as the filter criteria. + -- Example: "Filter by Top 10 Percent" or "Filter by Top 5 Items" + , _efoFilterVal :: Maybe Double + -- ^ The actual cell value in the range which is used to perform the + -- comparison for this filter. + } deriving (Eq, Show, Generic) +instance NFData EdgeFilterOptions + +-- | Specifies the color to filter by and whether to use the cell's +-- fill or font color in the filter criteria. If the cell's font or +-- fill color does not match the color specified in the criteria, the +-- rows corresponding to those cells are hidden from view. +-- +-- See 18.3.2.1 "colorFilter (Color Filter Criteria)" (p. 1712) +data ColorFilterOptions = ColorFilterOptions + { _cfoCellColor :: Bool + -- ^ Flag indicating whether or not to filter by the cell's fill + -- color. 'True' indicates to filter by cell fill. 'False' indicates + -- to filter by the cell's font color. + -- + -- For rich text in cells, if the color specified appears in the + -- cell at all, it shall be included in the filter. + , _cfoDxfId :: Maybe Int + -- ^ Id of differential format record (dxf) in the Styles Part (see + -- '_styleSheetDxfs') which expresses the color value to filter by. + } deriving (Eq, Show, Generic) +instance NFData ColorFilterOptions + +-- | Specifies dynamic filter criteria. These criteria are considered +-- dynamic because they can change, either with the data itself (e.g., +-- "above average") or with the current system date (e.g., show values +-- for "today"). For any cells whose values do not meet the specified +-- criteria, the corresponding rows shall be hidden from view when the +-- filter is applied. +-- +-- '_dfoMaxVal' shall be required for 'DynFilterTday', +-- 'DynFilterYesterday', 'DynFilterTomorrow', 'DynFilterNextWeek', +-- 'DynFilterThisWeek', 'DynFilterLastWeek', 'DynFilterNextMonth', +-- 'DynFilterThisMonth', 'DynFilterLastMonth', 'DynFilterNextQuarter', +-- 'DynFilterThisQuarter', 'DynFilterLastQuarter', +-- 'DynFilterNextYear', 'DynFilterThisYear', 'DynFilterLastYear', and +-- 'DynFilterYearToDate. +-- +-- The above criteria are based on a value range; that is, if today's +-- date is September 22nd, then the range for thisWeek is the values +-- greater than or equal to September 17 and less than September +-- 24. In the thisWeek range, the lower value is expressed +-- '_dfoval'. The higher value is expressed using '_dfoMmaxVal'. +-- +-- These dynamic filters shall not require '_dfoVal or '_dfoMaxVal': +-- 'DynFilterQ1', 'DynFilterQ2', 'DynFilterQ3', 'DynFilterQ4', +-- 'DynFilterM1', 'DynFilterM2', 'DynFilterM3', 'DynFilterM4', +-- 'DynFilterM5', 'DynFilterM6', 'DynFilterM7', 'DynFilterM8', +-- 'DynFilterM9', 'DynFilterM10', 'DynFilterM11' and 'DynFilterM12'. +-- +-- The above criteria shall not specify the range using valIso and +-- maxValIso because Q1 always starts from M1 to M3, and M1 is always +-- January. +-- +-- These types of dynamic filters shall use valIso and shall not use +-- '_dfoMaxVal': 'DynFilterAboveAverage' and 'DynFilterBelowAverage' +-- +-- /Note:/ Specification lists 'valIso' and 'maxIso' to store datetime +-- values but it appears that Excel doesn't use them and stored them +-- as numeric values (as it does for datetimes in cell values) +-- +-- See 18.3.2.5 "dynamicFilter (Dynamic Filter)" (p. 1715) +data DynFilterOptions = DynFilterOptions + { _dfoType :: DynFilterType + , _dfoVal :: Maybe Double + -- ^ A minimum numeric value for dynamic filter. + , _dfoMaxVal :: Maybe Double + -- ^ A maximum value for dynamic filter. + } deriving (Eq, Show, Generic) +instance NFData DynFilterOptions + +-- | Specifies concrete type of dynamic filter used +-- +-- See 18.18.26 "ST_DynamicFilterType (Dynamic Filter)" (p. 2452) +data DynFilterType + = DynFilterAboveAverage + -- ^ Shows values that are above average. + | DynFilterBelowAverage + -- ^ Shows values that are below average. + | DynFilterLastMonth + -- ^ Shows last month's dates. + | DynFilterLastQuarter + -- ^ Shows last calendar quarter's dates. + | DynFilterLastWeek + -- ^ Shows last week's dates, using Sunday as the first weekday. + | DynFilterLastYear + -- ^ Shows last year's dates. + | DynFilterM1 + -- ^ Shows the dates that are in January, regardless of year. + | DynFilterM10 + -- ^ Shows the dates that are in October, regardless of year. + | DynFilterM11 + -- ^ Shows the dates that are in November, regardless of year. + | DynFilterM12 + -- ^ Shows the dates that are in December, regardless of year. + | DynFilterM2 + -- ^ Shows the dates that are in February, regardless of year. + | DynFilterM3 + -- ^ Shows the dates that are in March, regardless of year. + | DynFilterM4 + -- ^ Shows the dates that are in April, regardless of year. + | DynFilterM5 + -- ^ Shows the dates that are in May, regardless of year. + | DynFilterM6 + -- ^ Shows the dates that are in June, regardless of year. + | DynFilterM7 + -- ^ Shows the dates that are in July, regardless of year. + | DynFilterM8 + -- ^ Shows the dates that are in August, regardless of year. + | DynFilterM9 + -- ^ Shows the dates that are in September, regardless of year. + | DynFilterNextMonth + -- ^ Shows next month's dates. + | DynFilterNextQuarter + -- ^ Shows next calendar quarter's dates. + | DynFilterNextWeek + -- ^ Shows next week's dates, using Sunday as the first weekday. + | DynFilterNextYear + -- ^ Shows next year's dates. + | DynFilterNull + -- ^ Common filter type not available. + | DynFilterQ1 + -- ^ Shows the dates that are in the 1st calendar quarter, + -- regardless of year. + | DynFilterQ2 + -- ^ Shows the dates that are in the 2nd calendar quarter, + -- regardless of year. + | DynFilterQ3 + -- ^ Shows the dates that are in the 3rd calendar quarter, + -- regardless of year. + | DynFilterQ4 + -- ^ Shows the dates that are in the 4th calendar quarter, + -- regardless of year. + | DynFilterThisMonth + -- ^ Shows this month's dates. + | DynFilterThisQuarter + -- ^ Shows this calendar quarter's dates. + | DynFilterThisWeek + -- ^ Shows this week's dates, using Sunday as the first weekday. + | DynFilterThisYear + -- ^ Shows this year's dates. + | DynFilterToday + -- ^ Shows today's dates. + | DynFilterTomorrow + -- ^ Shows tomorrow's dates. + | DynFilterYearToDate + -- ^ Shows the dates between the beginning of the year and today, inclusive. + | DynFilterYesterday + -- ^ Shows yesterday's dates. + deriving (Eq, Show, Generic) +instance NFData DynFilterType + +-- | AutoFilter temporarily hides rows based on a filter criteria, +-- which is applied column by column to a table of datain the +-- worksheet. +-- +-- TODO: sortState, extList +-- +-- See 18.3.1.2 "autoFilter (AutoFilter Settings)" (p. 1596) +data AutoFilter = AutoFilter + { _afRef :: Maybe CellRef + , _afFilterColumns :: Map Int FilterColumn + } deriving (Eq, Show, Generic) +instance NFData AutoFilter + +makeLenses ''AutoFilter + + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default AutoFilter where + def = AutoFilter Nothing M.empty + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor AutoFilter where + fromCursor cur = do + _afRef <- maybeAttribute "ref" cur + let _afFilterColumns = M.fromList $ cur $/ element (addSmlNamespace "filterColumn") >=> \c -> do + colId <- fromAttribute "colId" c + fcol <- c $/ anyElement >=> fltColFromNode . node + return (colId, fcol) + return AutoFilter {..} + +instance FromXenoNode AutoFilter where + fromXenoNode root = do + _afRef <- parseAttributes root $ maybeAttr "ref" + _afFilterColumns <- + fmap M.fromList . collectChildren root $ fromChildList "filterColumn" + return AutoFilter {..} + +instance FromXenoNode (Int, FilterColumn) where + fromXenoNode root = do + colId <- parseAttributes root $ fromAttr "colId" + fCol <- + collectChildren root $ asum [filters, color, custom, dynamic, icon, top10] + return (colId, fCol) + where + filters = + requireAndParse "filters" $ \node -> do + filterBlank <- + parseAttributes node $ fromAttrDef "blank" DontFilterByBlank + filterCriteria <- childListAny node + return $ Filters filterBlank filterCriteria + color = + requireAndParse "colorFilter" $ \node -> + parseAttributes node $ do + _cfoCellColor <- fromAttrDef "cellColor" True + _cfoDxfId <- maybeAttr "dxfId" + return $ ColorFilter ColorFilterOptions {..} + custom = + requireAndParse "customFilters" $ \node -> do + isAnd <- parseAttributes node $ fromAttrDef "and" False + cfilters <- collectChildren node $ fromChildList "customFilter" + case cfilters of + [f] -> return $ ACustomFilter f + [f1, f2] -> + if isAnd + then return $ CustomFiltersAnd f1 f2 + else return $ CustomFiltersOr f1 f2 + _ -> + Left $ + "expected 1 or 2 custom filters but found " <> + T.pack (show $ length cfilters) + dynamic = + requireAndParse "dynamicFilter" . flip parseAttributes $ do + _dfoType <- fromAttr "type" + _dfoVal <- maybeAttr "val" + _dfoMaxVal <- maybeAttr "maxVal" + return $ DynamicFilter DynFilterOptions {..} + icon = + requireAndParse "iconFilter" . flip parseAttributes $ + IconFilter <$> maybeAttr "iconId" <*> fromAttr "iconSet" + top10 = + requireAndParse "top10" . flip parseAttributes $ do + top <- fromAttrDef "top" True + percent <- fromAttrDef "percent" False + val <- fromAttr "val" + filterVal <- maybeAttr "filterVal" + let opts = EdgeFilterOptions percent val filterVal + if top + then return $ TopNFilter opts + else return $ BottomNFilter opts + +instance FromXenoNode CustomFilter where + fromXenoNode root = + parseAttributes root $ + CustomFilter <$> fromAttrDef "operator" FltrEqual <*> fromAttr "val" + +fltColFromNode :: Node -> [FilterColumn] +fltColFromNode n | n `nodeElNameIs` (addSmlNamespace "filters") = do + let filterCriteria = cur $/ anyElement >=> fromCursor + filterBlank <- fromAttributeDef "blank" DontFilterByBlank cur + return $ Filters filterBlank filterCriteria + | n `nodeElNameIs` (addSmlNamespace "colorFilter") = do + _cfoCellColor <- fromAttributeDef "cellColor" True cur + _cfoDxfId <- maybeAttribute "dxfId" cur + return $ ColorFilter ColorFilterOptions {..} + | n `nodeElNameIs` (addSmlNamespace "customFilters") = do + isAnd <- fromAttributeDef "and" False cur + let cFilters = cur $/ element (addSmlNamespace "customFilter") >=> \c -> do + op <- fromAttributeDef "operator" FltrEqual c + val <- fromAttribute "val" c + return $ CustomFilter op val + case cFilters of + [f] -> + return $ ACustomFilter f + [f1, f2] -> + if isAnd + then return $ CustomFiltersAnd f1 f2 + else return $ CustomFiltersOr f1 f2 + _ -> + fail "bad custom filter" + | n `nodeElNameIs` (addSmlNamespace "dynamicFilter") = do + _dfoType <- fromAttribute "type" cur + _dfoVal <- maybeAttribute "val" cur + _dfoMaxVal <- maybeAttribute "maxVal" cur + return $ DynamicFilter DynFilterOptions{..} + | n `nodeElNameIs` (addSmlNamespace "iconFilter") = do + iconId <- maybeAttribute "iconId" cur + iconSet <- fromAttribute "iconSet" cur + return $ IconFilter iconId iconSet + | n `nodeElNameIs` (addSmlNamespace "top10") = do + top <- fromAttributeDef "top" True cur + let percent = fromAttributeDef "percent" False cur + val = fromAttribute "val" cur + filterVal = maybeAttribute "filterVal" cur + if top + then fmap TopNFilter $ + EdgeFilterOptions <$> percent <*> val <*> filterVal + else fmap BottomNFilter $ + EdgeFilterOptions <$> percent <*> val <*> filterVal + | otherwise = fail "no matching nodes" + where + cur = fromNode n + +instance FromCursor FilterCriterion where + fromCursor = filterCriterionFromNode . node + +instance FromXenoNode FilterCriterion where + fromXenoNode root = + case Xeno.name root of + "filter" -> parseAttributes root $ do FilterValue <$> fromAttr "val" + "dateGroupItem" -> + parseAttributes root $ do + grouping <- fromAttr "dateTimeGrouping" + group <- case grouping of + ("year" :: ByteString) -> + DateGroupByYear <$> fromAttr "year" + "month" -> + DateGroupByMonth <$> fromAttr "year" + <*> fromAttr "month" + "day" -> + DateGroupByDay <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + "hour" -> + DateGroupByHour <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + <*> fromAttr "hour" + "minute" -> + DateGroupByMinute <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + <*> fromAttr "hour" + <*> fromAttr "minute" + "second" -> + DateGroupBySecond <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + <*> fromAttr "hour" + <*> fromAttr "minute" + <*> fromAttr "second" + _ -> toAttrParser . Left $ "Unexpected date grouping" + return $ FilterDateGroup group + _ -> Left "Bad FilterCriterion" + +-- TODO: follow the spec about the fact that dategroupitem always go after filter +filterCriterionFromNode :: Node -> [FilterCriterion] +filterCriterionFromNode n + | n `nodeElNameIs` (addSmlNamespace "filter") = do + v <- fromAttribute "val" cur + return $ FilterValue v + | n `nodeElNameIs` (addSmlNamespace "dateGroupItem") = do + g <- fromAttribute "dateTimeGrouping" cur + let year = fromAttribute "year" cur + month = fromAttribute "month" cur + day = fromAttribute "day" cur + hour = fromAttribute "hour" cur + minute = fromAttribute "minute" cur + second = fromAttribute "second" cur + FilterDateGroup <$> + case g of + "year" -> DateGroupByYear <$> year + "month" -> DateGroupByMonth <$> year <*> month + "day" -> DateGroupByDay <$> year <*> month <*> day + "hour" -> DateGroupByHour <$> year <*> month <*> day <*> hour + "minute" -> + DateGroupByMinute <$> year <*> month <*> day <*> hour <*> minute + "second" -> + DateGroupBySecond <$> year <*> month <*> day <*> hour <*> minute <*> + second + _ -> fail $ "unexpected dateTimeGrouping " ++ show (g :: Text) + | otherwise = fail "no matching nodes" + where + cur = fromNode n + +instance FromAttrVal CustomFilterOperator where + fromAttrVal "equal" = readSuccess FltrEqual + fromAttrVal "greaterThan" = readSuccess FltrGreaterThan + fromAttrVal "greaterThanOrEqual" = readSuccess FltrGreaterThanOrEqual + fromAttrVal "lessThan" = readSuccess FltrLessThan + fromAttrVal "lessThanOrEqual" = readSuccess FltrLessThanOrEqual + fromAttrVal "notEqual" = readSuccess FltrNotEqual + fromAttrVal t = invalidText "CustomFilterOperator" t + +instance FromAttrBs CustomFilterOperator where + fromAttrBs "equal" = return FltrEqual + fromAttrBs "greaterThan" = return FltrGreaterThan + fromAttrBs "greaterThanOrEqual" = return FltrGreaterThanOrEqual + fromAttrBs "lessThan" = return FltrLessThan + fromAttrBs "lessThanOrEqual" = return FltrLessThanOrEqual + fromAttrBs "notEqual" = return FltrNotEqual + fromAttrBs x = unexpectedAttrBs "CustomFilterOperator" x + +instance FromAttrVal FilterByBlank where + fromAttrVal = + fmap (first $ bool DontFilterByBlank FilterByBlank) . fromAttrVal + +instance FromAttrBs FilterByBlank where + fromAttrBs = fmap (bool DontFilterByBlank FilterByBlank) . fromAttrBs + +instance FromAttrVal DynFilterType where + fromAttrVal "aboveAverage" = readSuccess DynFilterAboveAverage + fromAttrVal "belowAverage" = readSuccess DynFilterBelowAverage + fromAttrVal "lastMonth" = readSuccess DynFilterLastMonth + fromAttrVal "lastQuarter" = readSuccess DynFilterLastQuarter + fromAttrVal "lastWeek" = readSuccess DynFilterLastWeek + fromAttrVal "lastYear" = readSuccess DynFilterLastYear + fromAttrVal "M1" = readSuccess DynFilterM1 + fromAttrVal "M10" = readSuccess DynFilterM10 + fromAttrVal "M11" = readSuccess DynFilterM11 + fromAttrVal "M12" = readSuccess DynFilterM12 + fromAttrVal "M2" = readSuccess DynFilterM2 + fromAttrVal "M3" = readSuccess DynFilterM3 + fromAttrVal "M4" = readSuccess DynFilterM4 + fromAttrVal "M5" = readSuccess DynFilterM5 + fromAttrVal "M6" = readSuccess DynFilterM6 + fromAttrVal "M7" = readSuccess DynFilterM7 + fromAttrVal "M8" = readSuccess DynFilterM8 + fromAttrVal "M9" = readSuccess DynFilterM9 + fromAttrVal "nextMonth" = readSuccess DynFilterNextMonth + fromAttrVal "nextQuarter" = readSuccess DynFilterNextQuarter + fromAttrVal "nextWeek" = readSuccess DynFilterNextWeek + fromAttrVal "nextYear" = readSuccess DynFilterNextYear + fromAttrVal "null" = readSuccess DynFilterNull + fromAttrVal "Q1" = readSuccess DynFilterQ1 + fromAttrVal "Q2" = readSuccess DynFilterQ2 + fromAttrVal "Q3" = readSuccess DynFilterQ3 + fromAttrVal "Q4" = readSuccess DynFilterQ4 + fromAttrVal "thisMonth" = readSuccess DynFilterThisMonth + fromAttrVal "thisQuarter" = readSuccess DynFilterThisQuarter + fromAttrVal "thisWeek" = readSuccess DynFilterThisWeek + fromAttrVal "thisYear" = readSuccess DynFilterThisYear + fromAttrVal "today" = readSuccess DynFilterToday + fromAttrVal "tomorrow" = readSuccess DynFilterTomorrow + fromAttrVal "yearToDate" = readSuccess DynFilterYearToDate + fromAttrVal "yesterday" = readSuccess DynFilterYesterday + fromAttrVal t = invalidText "DynFilterType" t + +instance FromAttrBs DynFilterType where + fromAttrBs "aboveAverage" = return DynFilterAboveAverage + fromAttrBs "belowAverage" = return DynFilterBelowAverage + fromAttrBs "lastMonth" = return DynFilterLastMonth + fromAttrBs "lastQuarter" = return DynFilterLastQuarter + fromAttrBs "lastWeek" = return DynFilterLastWeek + fromAttrBs "lastYear" = return DynFilterLastYear + fromAttrBs "M1" = return DynFilterM1 + fromAttrBs "M10" = return DynFilterM10 + fromAttrBs "M11" = return DynFilterM11 + fromAttrBs "M12" = return DynFilterM12 + fromAttrBs "M2" = return DynFilterM2 + fromAttrBs "M3" = return DynFilterM3 + fromAttrBs "M4" = return DynFilterM4 + fromAttrBs "M5" = return DynFilterM5 + fromAttrBs "M6" = return DynFilterM6 + fromAttrBs "M7" = return DynFilterM7 + fromAttrBs "M8" = return DynFilterM8 + fromAttrBs "M9" = return DynFilterM9 + fromAttrBs "nextMonth" = return DynFilterNextMonth + fromAttrBs "nextQuarter" = return DynFilterNextQuarter + fromAttrBs "nextWeek" = return DynFilterNextWeek + fromAttrBs "nextYear" = return DynFilterNextYear + fromAttrBs "null" = return DynFilterNull + fromAttrBs "Q1" = return DynFilterQ1 + fromAttrBs "Q2" = return DynFilterQ2 + fromAttrBs "Q3" = return DynFilterQ3 + fromAttrBs "Q4" = return DynFilterQ4 + fromAttrBs "thisMonth" = return DynFilterThisMonth + fromAttrBs "thisQuarter" = return DynFilterThisQuarter + fromAttrBs "thisWeek" = return DynFilterThisWeek + fromAttrBs "thisYear" = return DynFilterThisYear + fromAttrBs "today" = return DynFilterToday + fromAttrBs "tomorrow" = return DynFilterTomorrow + fromAttrBs "yearToDate" = return DynFilterYearToDate + fromAttrBs "yesterday" = return DynFilterYesterday + fromAttrBs x = unexpectedAttrBs "DynFilterType" x + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement AutoFilter where + toElement nm AutoFilter {..} = + elementList + nm + (catMaybes ["ref" .=? _afRef]) + [ elementList + (addSmlNamespace "filterColumn") + ["colId" .= colId] + [fltColToElement fCol] + | (colId, fCol) <- M.toList _afFilterColumns + ] + +fltColToElement :: FilterColumn -> Element +fltColToElement (Filters filterBlank filterCriteria) = + let attrs = catMaybes ["blank" .=? justNonDef DontFilterByBlank filterBlank] + in elementList + (addSmlNamespace "filters") attrs $ map filterCriterionToElement filterCriteria +fltColToElement (ColorFilter opts) = toElement (addSmlNamespace "colorFilter") opts +fltColToElement (ACustomFilter f) = + elementListSimple (addSmlNamespace "customFilters") [toElement (addSmlNamespace "customFilter") f] +fltColToElement (CustomFiltersOr f1 f2) = + elementListSimple + (addSmlNamespace "customFilters") + [toElement (addSmlNamespace "customFilter") f | f <- [f1, f2]] +fltColToElement (CustomFiltersAnd f1 f2) = + elementList + (addSmlNamespace "customFilters") + ["and" .= True] + [toElement (addSmlNamespace "customFilter") f | f <- [f1, f2]] +fltColToElement (DynamicFilter opts) = toElement (addSmlNamespace "dynamicFilter") opts +fltColToElement (IconFilter iconId iconSet) = + leafElement (addSmlNamespace "iconFilter") $ + ["iconSet" .= iconSet] ++ catMaybes ["iconId" .=? iconId] +fltColToElement (BottomNFilter opts) = edgeFilter False opts +fltColToElement (TopNFilter opts) = edgeFilter True opts + +edgeFilter :: Bool -> EdgeFilterOptions -> Element +edgeFilter top EdgeFilterOptions {..} = + leafElement (addSmlNamespace "top10") $ + ["top" .= top, "percent" .= _efoUsePercents, "val" .= _efoVal] ++ + catMaybes ["filterVal" .=? _efoFilterVal] + +filterCriterionToElement :: FilterCriterion -> Element +filterCriterionToElement (FilterValue v) = + leafElement (addSmlNamespace "filter") ["val" .= v] +filterCriterionToElement (FilterDateGroup (DateGroupByYear y)) = + leafElement + (addSmlNamespace "dateGroupItem") + ["dateTimeGrouping" .= ("year" :: Text), "year" .= y] +filterCriterionToElement (FilterDateGroup (DateGroupByMonth y m)) = + leafElement + (addSmlNamespace "dateGroupItem") + ["dateTimeGrouping" .= ("month" :: Text), "year" .= y, "month" .= m] +filterCriterionToElement (FilterDateGroup (DateGroupByDay y m d)) = + leafElement + (addSmlNamespace "dateGroupItem") + ["dateTimeGrouping" .= ("day" :: Text), "year" .= y, "month" .= m, "day" .= d] +filterCriterionToElement (FilterDateGroup (DateGroupByHour y m d h)) = + leafElement + (addSmlNamespace "dateGroupItem") + [ "dateTimeGrouping" .= ("hour" :: Text) + , "year" .= y + , "month" .= m + , "day" .= d + , "hour" .= h + ] +filterCriterionToElement (FilterDateGroup (DateGroupByMinute y m d h mi)) = + leafElement + (addSmlNamespace "dateGroupItem") + [ "dateTimeGrouping" .= ("minute" :: Text) + , "year" .= y + , "month" .= m + , "day" .= d + , "hour" .= h + , "minute" .= mi + ] +filterCriterionToElement (FilterDateGroup (DateGroupBySecond y m d h mi s)) = + leafElement + (addSmlNamespace "dateGroupItem") + [ "dateTimeGrouping" .= ("second" :: Text) + , "year" .= y + , "month" .= m + , "day" .= d + , "hour" .= h + , "minute" .= mi + , "second" .= s + ] + +instance ToElement CustomFilter where + toElement nm CustomFilter {..} = + leafElement nm ["operator" .= cfltOperator, "val" .= cfltValue] + +instance ToAttrVal CustomFilterOperator where + toAttrVal FltrEqual = "equal" + toAttrVal FltrGreaterThan = "greaterThan" + toAttrVal FltrGreaterThanOrEqual = "greaterThanOrEqual" + toAttrVal FltrLessThan = "lessThan" + toAttrVal FltrLessThanOrEqual = "lessThanOrEqual" + toAttrVal FltrNotEqual = "notEqual" + +instance ToAttrVal FilterByBlank where + toAttrVal FilterByBlank = toAttrVal True + toAttrVal DontFilterByBlank = toAttrVal False + +instance ToElement ColorFilterOptions where + toElement nm ColorFilterOptions {..} = + leafElement nm $ + catMaybes ["cellColor" .=? justFalse _cfoCellColor, "dxfId" .=? _cfoDxfId] + +instance ToElement DynFilterOptions where + toElement nm DynFilterOptions {..} = + leafElement nm $ + ["type" .= _dfoType] ++ + catMaybes ["val" .=? _dfoVal, "maxVal" .=? _dfoMaxVal] + +instance ToAttrVal DynFilterType where + toAttrVal DynFilterAboveAverage = "aboveAverage" + toAttrVal DynFilterBelowAverage = "belowAverage" + toAttrVal DynFilterLastMonth = "lastMonth" + toAttrVal DynFilterLastQuarter = "lastQuarter" + toAttrVal DynFilterLastWeek = "lastWeek" + toAttrVal DynFilterLastYear = "lastYear" + toAttrVal DynFilterM1 = "M1" + toAttrVal DynFilterM10 = "M10" + toAttrVal DynFilterM11 = "M11" + toAttrVal DynFilterM12 = "M12" + toAttrVal DynFilterM2 = "M2" + toAttrVal DynFilterM3 = "M3" + toAttrVal DynFilterM4 = "M4" + toAttrVal DynFilterM5 = "M5" + toAttrVal DynFilterM6 = "M6" + toAttrVal DynFilterM7 = "M7" + toAttrVal DynFilterM8 = "M8" + toAttrVal DynFilterM9 = "M9" + toAttrVal DynFilterNextMonth = "nextMonth" + toAttrVal DynFilterNextQuarter = "nextQuarter" + toAttrVal DynFilterNextWeek = "nextWeek" + toAttrVal DynFilterNextYear = "nextYear" + toAttrVal DynFilterNull = "null" + toAttrVal DynFilterQ1 = "Q1" + toAttrVal DynFilterQ2 = "Q2" + toAttrVal DynFilterQ3 = "Q3" + toAttrVal DynFilterQ4 = "Q4" + toAttrVal DynFilterThisMonth = "thisMonth" + toAttrVal DynFilterThisQuarter = "thisQuarter" + toAttrVal DynFilterThisWeek = "thisWeek" + toAttrVal DynFilterThisYear = "thisYear" + toAttrVal DynFilterToday = "today" + toAttrVal DynFilterTomorrow = "tomorrow" + toAttrVal DynFilterYearToDate = "yearToDate" + toAttrVal DynFilterYesterday = "yesterday" diff --git a/src/Codec/Xlsx/Types/Cell.hs b/src/Codec/Xlsx/Types/Cell.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Cell.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Cell + ( CellFormula(..) + , FormulaExpression(..) + , simpleCellFormula + , sharedFormulaByIndex + , SharedFormulaIndex(..) + , SharedFormulaOptions(..) + , formulaDataFromCursor + , applySharedFormulaOpts + , Cell(..) + , cellStyle + , cellValue + , cellComment + , cellFormula + , CellMap + ) where + +import Control.Arrow (first) +import Codec.Xlsx.LensCompat (makeLenses) +import Control.DeepSeq (NFData) +import Data.Default +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, listToMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import GHC.Generics (Generic) +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 formula types support +-- +-- See 18.3.1.40 "f (Formula)" (p. 1636) +data CellFormula = CellFormula + { _cellfExpression :: FormulaExpression + , _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, Generic) +instance NFData CellFormula + +-- | formula type with type-specific options +data FormulaExpression + = NormalFormula Formula + | SharedFormula SharedFormulaIndex + deriving (Eq, Show, Generic) +instance NFData FormulaExpression + +defaultFormulaType :: Text +defaultFormulaType = "normal" + +-- | index of shared formula in worksheet's 'wsSharedFormulas' +-- property +newtype SharedFormulaIndex = SharedFormulaIndex Int + deriving (Eq, Ord, Show, Generic) +instance NFData SharedFormulaIndex + +data SharedFormulaOptions = SharedFormulaOptions + { _sfoRef :: CellRef + , _sfoExpression :: Formula + } + deriving (Eq, Show, Generic) +instance NFData SharedFormulaOptions + +simpleCellFormula :: Text -> CellFormula +simpleCellFormula expr = CellFormula + { _cellfExpression = NormalFormula $ Formula expr + , _cellfAssignsToName = False + , _cellfCalculate = False + } + +sharedFormulaByIndex :: SharedFormulaIndex -> CellFormula +sharedFormulaByIndex si = + CellFormula + { _cellfExpression = SharedFormula si + , _cellfAssignsToName = False + , _cellfCalculate = False + } + +-- | Currently cell details include cell values, style ids and cell +-- formulas (inline strings from @\@ subelements are ignored) +data Cell = Cell + { _cellStyle :: Maybe Int + , _cellValue :: Maybe CellValue + , _cellComment :: Maybe Comment + , _cellFormula :: Maybe CellFormula + } deriving (Eq, Show, Generic) +instance NFData Cell + +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 (RowIndex, ColumnIndex) Cell + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +formulaDataFromCursor :: + Cursor -> [(CellFormula, Maybe (SharedFormulaIndex, SharedFormulaOptions))] +formulaDataFromCursor cur = do + _cellfAssignsToName <- fromAttributeDef "bx" False cur + _cellfCalculate <- fromAttributeDef "ca" False cur + t <- fromAttributeDef "t" defaultFormulaType cur + (_cellfExpression, shared) <- + case t of + d| d == defaultFormulaType -> do + formula <- fromCursor cur + return (NormalFormula formula, Nothing) + "shared" -> do + let expr = listToMaybe $ fromCursor cur + ref <- maybeAttribute "ref" cur + si <- fromAttribute "si" cur + return (SharedFormula si, (,) <$> pure si <*> + (SharedFormulaOptions <$> ref <*> expr)) + _ -> + fail $ "Unexpected formula type" ++ show t + return (CellFormula {..}, shared) + +instance FromAttrVal SharedFormulaIndex where + fromAttrVal = fmap (first SharedFormulaIndex) . fromAttrVal + +instance FromAttrBs SharedFormulaIndex where + fromAttrBs = fmap SharedFormulaIndex . fromAttrBs + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement CellFormula where + toElement nm CellFormula {..} = + formulaEl {elementAttributes = elementAttributes formulaEl <> commonAttrs} + where + commonAttrs = + M.fromList $ + catMaybes + [ "bx" .=? justTrue _cellfAssignsToName + , "ca" .=? justTrue _cellfCalculate + , "t" .=? justNonDef defaultFormulaType fType + ] + (formulaEl, fType) = + case _cellfExpression of + NormalFormula f -> (toElement nm f, defaultFormulaType) + SharedFormula si -> (leafElement nm ["si" .= si], "shared") + +instance ToAttrVal SharedFormulaIndex where + toAttrVal (SharedFormulaIndex si) = toAttrVal si + +applySharedFormulaOpts :: SharedFormulaOptions -> Element -> Element +applySharedFormulaOpts SharedFormulaOptions {..} el = + el + { elementAttributes = elementAttributes el <> M.fromList ["ref" .= _sfoRef] + , elementNodes = NodeContent (unFormula _sfoExpression) : elementNodes el + } diff --git a/src/Codec/Xlsx/Types/Comment.hs b/src/Codec/Xlsx/Types/Comment.hs --- a/src/Codec/Xlsx/Types/Comment.hs +++ b/src/Codec/Xlsx/Types/Comment.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Comment where -import Data.Text (Text) +import Control.DeepSeq (NFData) +import Data.Text (Text) +import GHC.Generics (Generic) -import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Common -- | User comment for a cell -- @@ -17,4 +20,5 @@ , _commentAuthor :: Text -- ^ comment author , _commentVisible :: Bool - } deriving (Show, Eq) + } deriving (Eq, Show, Generic) +instance NFData Comment diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -1,41 +1,113 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Codec.Xlsx.Types.Common ( CellRef(..) + , RowCoord(..) + , ColumnCoord(..) + , CellCoord + , RangeCoord + , mapBoth + , col2coord + , coord2col + , row2coord + , coord2row , singleCellRef + , singleCellRef' , fromSingleCellRef + , fromSingleCellRef' + , fromSingleCellRefNoting + , escapeRefSheetName + , unEscapeRefSheetName + , mkForeignSingleCellRef + , fromForeignSingleCellRef , Range , mkRange + , mkRange' + , mkForeignRange , fromRange + , fromRange' + , fromForeignRange , SqRef(..) , XlsxText(..) + , xlsxTextToCellValue , Formula(..) , CellValue(..) + , ErrorType(..) + , DateBase(..) + , dateFromNumber + , dateToNumber , int2col , col2int + , columnIndexToText + , textToColumnIndex + -- ** prisms + , _XlsxText + , _XlsxRichText + , _CellText + , _CellDouble + , _CellBool + , _CellRich + , _CellError + , RowIndex(..) + , ColumnIndex(..) ) where +import GHC.Generics (Generic) + +import Control.Applicative (liftA2) import Control.Arrow -import Control.Monad (guard) +import Control.DeepSeq (NFData) +import Control.Monad (forM, guard) +import Data.Bifunctor (bimap) +import qualified Data.ByteString as BS import Data.Char +import Data.Maybe (isJust, fromMaybe) +import Data.Function ((&)) import Data.Ix (inRange) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Calendar (Day, addDays, diffDays, fromGregorian) +import Data.Time.Clock (UTCTime(UTCTime), picosecondsToDiffTime) +import Safe 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.RichText import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.LensCompat (Prism', prism) +newtype RowIndex = RowIndex {unRowIndex :: Int} + deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral) +newtype ColumnIndex = ColumnIndex {unColumnIndex :: Int} + deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral) +instance NFData RowIndex +instance NFData ColumnIndex + +instance ToAttrVal RowIndex where + toAttrVal = toAttrVal . unRowIndex + +{-# DEPRECATED int2col + "this function will be removed in an upcoming release, use columnIndexToText instead." #-} +int2col :: ColumnIndex -> Text +int2col = columnIndexToText + +{-# DEPRECATED col2int + "this function will be removed in an upcoming release, use textToColumnIndex instead." #-} +col2int :: Text -> ColumnIndex +col2int = textToColumnIndex + -- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\") -int2col :: Int -> Text -int2col = T.pack . reverse . map int2let . base26 +columnIndexToText :: ColumnIndex -> Text +columnIndexToText = T.pack . reverse . map int2let . base26 . unColumnIndex where int2let 0 = 'Z' int2let x = chr $ (x - 1) + ord 'A' @@ -44,61 +116,247 @@ i'' = if i' == 0 then 26 else i' in seq i' (i' : base26 ((i - i'') `div` 26)) --- | reverse to 'int2col' -col2int :: Text -> Int -col2int = T.foldl' (\i c -> i * 26 + let2int c) 0 +rowIndexToText :: RowIndex -> Text +rowIndexToText = T.pack . show . unRowIndex + +-- | reverse of 'columnIndexToText' +textToColumnIndex :: Text -> ColumnIndex +textToColumnIndex = ColumnIndex . T.foldl' (\i c -> i * 26 + let2int c) 0 where let2int c = 1 + ord c - ord 'A' --- | Excel cell or cell range reference (e.g. @E3@) +textToRowIndex :: Text -> RowIndex +textToRowIndex = RowIndex . read . T.unpack + +-- | Excel cell or cell range reference (e.g. @E3@), possibly absolute. -- See 18.18.62 @ST_Ref@ (p. 2482) +-- +-- Note: The @ST_Ref@ type can point to another sheet (supported) +-- or a sheet in another workbook (separate .xlsx file, not implemented). newtype CellRef = CellRef { unCellRef :: Text - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Generic) +instance NFData CellRef +-- | A helper type for coordinates to carry the intent of them being relative or absolute (preceded by '$'): +-- +-- > singleCellRefRaw' (RowRel 5, ColumnAbs 1) == "$A5" +data RowCoord + = RowAbs !RowIndex + | RowRel !RowIndex + deriving (Eq, Ord, Show, Read, Generic) +instance NFData RowCoord + +data ColumnCoord + = ColumnAbs !ColumnIndex + | ColumnRel !ColumnIndex + deriving (Eq, Ord, Show, Read, Generic) +instance NFData ColumnCoord + +type CellCoord = (RowCoord, ColumnCoord) + +type RangeCoord = (CellCoord, CellCoord) + +mkColumnCoord :: Bool -> ColumnIndex -> ColumnCoord +mkColumnCoord isAbs = if isAbs then ColumnAbs else ColumnRel + +mkRowCoord :: Bool -> RowIndex -> RowCoord +mkRowCoord isAbs = if isAbs then RowAbs else RowRel + +coord2col :: ColumnCoord -> Text +coord2col (ColumnAbs c) = "$" <> coord2col (ColumnRel c) +coord2col (ColumnRel c) = columnIndexToText c + +col2coord :: Text -> ColumnCoord +col2coord t = + let t' = T.stripPrefix "$" t + in mkColumnCoord (isJust t') (textToColumnIndex (fromMaybe t t')) + +coord2row :: RowCoord -> Text +coord2row (RowAbs c) = "$" <> coord2row (RowRel c) +coord2row (RowRel c) = rowIndexToText c + +row2coord :: Text -> RowCoord +row2coord t = + let t' = T.stripPrefix "$" t + in mkRowCoord (isJust t') (textToRowIndex (fromMaybe t t')) + +-- | Unwrap a Coord into an abstract Int coordinate +unRowCoord :: RowCoord -> RowIndex +unRowCoord (RowAbs i) = i +unRowCoord (RowRel i) = i + +-- | Unwrap a Coord into an abstract Int coordinate +unColumnCoord :: ColumnCoord -> ColumnIndex +unColumnCoord (ColumnAbs i) = i +unColumnCoord (ColumnRel i) = i + +-- | Helper function to apply the same transformation to both members of a tuple +-- +-- > mapBoth Abs (1, 2) == (Abs 1, Abs 2s) +mapBoth :: (a -> b) -> (a, a) -> (b, b) +mapBoth f = bimap f f + -- | Render position in @(row, col)@ format to an Excel reference. -- --- > mkCellRef (2, 4) == "D2" -singleCellRef :: (Int, Int) -> CellRef +-- > singleCellRef (RowIndex 2, ColumnIndex 4) == CellRef "D2" +singleCellRef :: (RowIndex, ColumnIndex) -> CellRef singleCellRef = CellRef . singleCellRefRaw -singleCellRefRaw :: (Int, Int) -> Text -singleCellRefRaw (row, col) = T.concat [int2col col, T.pack (show row)] +-- | Allow specifying whether a coordinate parameter is relative or absolute. +-- +-- > singleCellRef' (Rel 5, Abs 1) == CellRef "$A5" +singleCellRef' :: CellCoord -> CellRef +singleCellRef' = CellRef . singleCellRefRaw' --- | reverse to 'mkCellRef' -fromSingleCellRef :: CellRef -> Maybe (Int, Int) +singleCellRefRaw :: (RowIndex, ColumnIndex) -> Text +singleCellRefRaw (row, col) = T.concat [columnIndexToText col, rowIndexToText row] + +singleCellRefRaw' :: CellCoord -> Text +singleCellRefRaw' (row, col) = + coord2col col <> coord2row row + +-- | Converse function to 'singleCellRef' +-- Ignores a potential foreign sheet prefix. +fromSingleCellRef :: CellRef -> Maybe (RowIndex, ColumnIndex) fromSingleCellRef = fromSingleCellRefRaw . unCellRef -fromSingleCellRefRaw :: Text -> Maybe (Int, Int) -fromSingleCellRefRaw t = do - let (colT, rowT) = T.span (inRange ('A', 'Z')) t - guard $ not (T.null colT) && not (T.null rowT) && T.all isDigit rowT - row <- decimal rowT - return (row, col2int colT) +-- | Converse function to 'singleCellRef\'' +-- Ignores a potential foreign sheet prefix. +fromSingleCellRef' :: CellRef -> Maybe CellCoord +fromSingleCellRef' = fromSingleCellRefRaw' . unCellRef +fromSingleCellRefRaw :: Text -> Maybe (RowIndex, ColumnIndex) +fromSingleCellRefRaw = + fmap (first unRowCoord . second unColumnCoord) . fromSingleCellRefRaw' + +fromSingleCellRefRaw' :: Text -> Maybe CellCoord +fromSingleCellRefRaw' t' = ignoreRefSheetName t' >>= \t -> do + let (isColAbsolute, remT) = + T.stripPrefix "$" t + & \remT' -> (isJust remT', fromMaybe t remT') + let (colT, rowExpr) = T.span (inRange ('A', 'Z')) remT + let (isRowAbsolute, rowT) = + T.stripPrefix "$" rowExpr + & \rowT' -> (isJust rowT', fromMaybe rowExpr rowT') + guard $ not (T.null colT) && not (T.null rowT) && T.all isDigit rowT + row <- decimal rowT + return $ + bimap + (mkRowCoord isRowAbsolute) + (mkColumnCoord isColAbsolute) + (row, textToColumnIndex colT) + +-- | Converse function to 'singleCellRef' expecting valid reference and failig with +-- a standard error message like /"Bad cell reference 'XXX'"/ +fromSingleCellRefNoting :: CellRef -> (RowIndex, ColumnIndex) +fromSingleCellRefNoting ref = fromJustNote errMsg $ fromSingleCellRefRaw txt + where + txt = unCellRef ref + errMsg = "Bad cell reference '" ++ T.unpack txt ++ "'" + +-- | Frame and escape the referenced sheet name in single quotes (apostrophe). +-- +-- Sheet name in ST_Ref can be single-quoted when it contains non-alphanum class, non-ASCII range characters. +-- Intermediate squote characters are escaped in a doubled fashion: +-- "My ' Sheet" -> 'My '' Sheet' +escapeRefSheetName :: Text -> Text +escapeRefSheetName sheetName = + T.concat ["'", escape sheetName, "'"] + where + escape sn = T.splitOn "'" sn & T.intercalate "''" + +-- | Unframe and unescape the referenced sheet name. +unEscapeRefSheetName :: Text -> Text +unEscapeRefSheetName = unescape . unFrame + where + unescape = T.intercalate "'" . T.splitOn "''" + unFrame sn = fromMaybe sn $ T.stripPrefix "'" sn >>= T.stripSuffix "'" + +ignoreRefSheetName :: Text -> Maybe Text +ignoreRefSheetName t = + case T.split (== '!') t of + [_, r] -> Just r + [r] -> Just r + _ -> Nothing + +-- | Render a single cell existing in another worksheet. +-- This function always renders the sheet name single-quoted regardless the presence of spaces. +-- A sheet name shouldn't contain @"[]*:?/\"@ chars and apostrophe @"'"@ should not happen at extremities. +-- +-- > mkForeignRange "MyOtherSheet" (Rel 2, Rel 4) (Abs 6, Abs 8) == "'MyOtherSheet'!D2:$H$6" +mkForeignSingleCellRef :: Text -> CellCoord -> CellRef +mkForeignSingleCellRef sheetName coord = + let cr = singleCellRefRaw' coord + in CellRef $ T.concat [escapeRefSheetName sheetName, "!", cr] + +-- | Converse function to 'mkForeignSingleCellRef'. +-- The provided CellRef must be a foreign range. +fromForeignSingleCellRef :: CellRef -> Maybe (Text, CellCoord) +fromForeignSingleCellRef r = + case T.split (== '!') (unCellRef r) of + [sheetName, ref] -> (unEscapeRefSheetName sheetName,) <$> fromSingleCellRefRaw' ref + _ -> Nothing + -- | Excel range (e.g. @D13:H14@), actually store as as 'CellRef' in -- xlsx type Range = CellRef -- | Render range -- --- > mkRange (2, 4) (6, 8) == "D2:H6" -mkRange :: (Int, Int) -> (Int, Int) -> Range -mkRange fr to = CellRef $ T.concat [singleCellRefRaw fr, T.pack ":", singleCellRefRaw to] +-- > mkRange (RowIndex 2, ColumnIndex 4) (RowIndex 6, ColumnIndex 8) == CellRef "D2:H6" +mkRange :: (RowIndex, ColumnIndex) -> (RowIndex, ColumnIndex) -> Range +mkRange fr to = CellRef $ T.concat [singleCellRefRaw fr, ":", singleCellRefRaw to] --- | reverse to 'mkRange' -fromRange :: Range -> Maybe ((Int, Int), (Int, Int)) +-- | Render range with possibly absolute coordinates +-- +-- > mkRange' (Abs 2, Abs 4) (6, 8) == CellRef "$D$2:H6" +mkRange' :: (RowCoord,ColumnCoord) -> (RowCoord,ColumnCoord) -> Range +mkRange' fr to = + CellRef $ T.concat [singleCellRefRaw' fr, ":", singleCellRefRaw' to] + +-- | Render a cell range existing in another worksheet. +-- This function always renders the sheet name single-quoted regardless the presence of spaces. +-- A sheet name shouldn't contain @"[]*:?/\"@ chars and apostrophe @"'"@ should not happen at extremities. +-- +-- > mkForeignRange "MyOtherSheet" (Rel 2, Rel 4) (Abs 6, Abs 8) == "'MyOtherSheet'!D2:$H$6" +mkForeignRange :: Text -> CellCoord -> CellCoord -> Range +mkForeignRange sheetName fr to = + case mkRange' fr to of + CellRef cr -> CellRef $ T.concat [escapeRefSheetName sheetName, "!", cr] + +-- | Converse function to 'mkRange' ignoring absolute coordinates. +-- Ignores a potential foreign sheet prefix. +fromRange :: Range -> Maybe ((RowIndex, ColumnIndex), (RowIndex, ColumnIndex)) fromRange r = - case T.split (== ':') (unCellRef r) of - [from, to] -> (,) <$> fromSingleCellRefRaw from <*> fromSingleCellRefRaw to - _ -> Nothing + mapBoth (first unRowCoord . second unColumnCoord) <$> fromRange' r +-- | Converse function to 'mkRange\'' to handle possibly absolute coordinates. +-- Ignores a potential foreign sheet prefix. +fromRange' :: Range -> Maybe RangeCoord +fromRange' t' = parseRange =<< ignoreRefSheetName (unCellRef t') + where + parseRange t = + case T.split (== ':') t of + [from, to] -> liftA2 (,) (fromSingleCellRefRaw' from) (fromSingleCellRefRaw' to) + _ -> Nothing + +-- | Converse function to 'mkForeignRange'. +-- The provided Range must be a foreign range. +fromForeignRange :: Range -> Maybe (Text, RangeCoord) +fromForeignRange r = + case T.split (== '!') (unCellRef r) of + [sheetName, ref] -> (unEscapeRefSheetName sheetName,) <$> fromRange' (CellRef ref) + _ -> Nothing + -- | A sequence of cell references -- -- See 18.18.76 "ST_Sqref (Reference Sequence)" (p.2488) newtype SqRef = SqRef [CellRef] - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData SqRef + -- | Common type containing either simple string or rich formatted text. -- Used in @si@, @comment@ and @is@ elements -- @@ -119,26 +377,160 @@ -- See @CT_Rst@, p. 3903 data XlsxText = XlsxText Text | XlsxRichText [RichTextRun] - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData XlsxText + +xlsxTextToCellValue :: XlsxText -> CellValue +xlsxTextToCellValue (XlsxText txt) = CellText txt +xlsxTextToCellValue (XlsxRichText rich) = CellRich rich + -- | A formula -- -- See 18.18.35 "ST_Formula (Formula)" (p. 2457) newtype Formula = Formula {unFormula :: Text} - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData Formula -- | Cell values include text, numbers and booleans, -- standard includes date format also but actually dates -- are represented by numbers with a date format assigned -- to a cell containing it +-- Specification (ECMA-376): +-- - 18.3.1.4 c (Cell) +-- - 18.18.11 ST_CellType (Cell Type) data CellValue = CellText Text | CellDouble Double | CellBool Bool | CellRich [RichTextRun] - deriving (Eq, Ord, Show) + | CellError ErrorType + deriving (Eq, Ord, Show, Generic) + +instance NFData CellValue + +-- | The evaluation of an expression can result in an error having one +-- of a number of error values. +-- +-- See Annex L, L.2.16.8 "Error values" (p. 4764) +data ErrorType + = ErrorDiv0 + -- ^ @#DIV/0!@ - Intended to indicate when any number, including + -- zero, is divided by zero. + | ErrorNA + -- ^ @#N/A@ - Intended to indicate when a designated value is not + -- available. For example, some functions, such as @SUMX2MY2@, + -- perform a series of operations on corresponding elements in two + -- arrays. If those arrays do not have the same number of elements, + -- then for some elements in the longer array, there are no + -- corresponding elements in the shorter one; that is, one or more + -- values in the shorter array are not available. This error value + -- can be produced by calling the function @NA@. + | ErrorName + -- ^ @#NAME?@ - Intended to indicate when what looks like a name is + -- used, but no such name has been defined. For example, @XYZ/3@, + -- where @XYZ@ is not a defined name. @Total is & A10@, where + -- neither @Total@ nor @is@ is a defined name. Presumably, @"Total + -- is " & A10@ was intended. @SUM(A1C10)@, where the range @A1:C10@ + -- was intended. + | ErrorNull + -- ^ @#NULL!@ - Intended to indicate when two areas are required to + -- intersect, but do not. For example, In the case of @SUM(B1 C1)@, + -- the space between @B1@ and @C1@ is treated as the binary + -- intersection operator, when a comma was intended. + | ErrorNum + -- ^ @#NUM!@ - Intended to indicate when an argument to a function + -- has a compatible type, but has a value that is outside the domain + -- over which that function is defined. (This is known as a domain + -- error.) For example, Certain calls to @ASIN@, @ATANH@, @FACT@, + -- and @SQRT@ might result in domain errors. Intended to indicate + -- that the result of a function cannot be represented in a value of + -- the specified type, typically due to extreme magnitude. (This is + -- known as a range error.) For example, @FACT(1000)@ might result + -- in a range error. + | ErrorRef + -- ^ @#REF!@ - Intended to indicate when a cell reference is + -- invalid. For example, If a formula contains a reference to a + -- cell, and then the row or column containing that cell is deleted, + -- a @#REF!@ error results. If a worksheet does not support 20,001 + -- columns, @OFFSET(A1,0,20000)@ results in a @#REF!@ error. + | ErrorValue + -- ^ @#VALUE!@ - Intended to indicate when an incompatible type + -- argument is passed to a function, or an incompatible type operand + -- is used with an operator. For example, In the case of a function + -- argument, a number was expected, but text was provided. In the + -- case of @1+"ABC"@, the binary addition operator is not defined for + -- text. + deriving (Eq, Ord, Show, Generic) + +instance NFData ErrorType + +-- | Specifies date base used for conversion of serial values to and +-- from datetime values +-- +-- See Annex L, L.2.16.9.1 "Date Conversion for Serial Values" (p. 4765) +data DateBase + = DateBase1900 + -- ^ 1900 date base system, the lower limit is January 1, -9999 + -- 00:00:00, which has serial value -4346018. The upper-limit is + -- December 31, 9999, 23:59:59, which has serial value + -- 2,958,465.9999884. The base date for this date base system is + -- December 30, 1899, which has a serial value of 0. + | DateBase1904 + -- ^ 1904 backward compatibility date-base system, the lower limit + -- is January 1, 1904, 00:00:00, which has serial value 0. The upper + -- limit is December 31, 9999, 23:59:59, which has serial value + -- 2,957,003.9999884. The base date for this date base system is + -- January 1, 1904, which has a serial value of 0. + deriving (Eq, Show, Generic) +instance NFData DateBase + +baseDate :: DateBase -> Day +baseDate DateBase1900 = fromGregorian 1899 12 30 +baseDate DateBase1904 = fromGregorian 1904 1 1 + +-- | Converts serial value into datetime according to the specified +-- date base. Because Excel treats 1900 as a leap year even though it isn't, +-- this function converts any numbers that represent some time in /1900-02-29/ +-- in Excel to `UTCTime` /1900-03-01 00:00/. +-- See https://docs.microsoft.com/en-gb/office/troubleshoot/excel/wrongly-assumes-1900-is-leap-year for details. +-- +-- > show (dateFromNumber DateBase1900 42929.75) == "2017-07-13 18:00:00 UTC" +-- > show (dateFromNumber DateBase1900 60) == "1900-03-01 00:00:00 UTC" +-- > show (dateFromNumber DateBase1900 61) == "1900-03-01 00:00:00 UTC" +dateFromNumber :: forall t. RealFrac t => DateBase -> t -> UTCTime +dateFromNumber b d + -- 60 is Excel's 2020-02-29 00:00 and 61 is Excel's 2020-03-01 + | b == DateBase1900 && d < 60 = getUTCTime (d + 1) + | b == DateBase1900 && d >= 60 && d < 61 = getUTCTime (61 :: t) + | otherwise = getUTCTime d + where + getUTCTime n = + let + (numberOfDays, fractionOfOneDay) = properFraction n + day = addDays numberOfDays $ baseDate b + diffTime = picosecondsToDiffTime (round (fractionOfOneDay * 24*60*60*1E12)) + in + UTCTime day diffTime + +-- | Converts datetime into serial value. +-- Because Excel treats 1900 as a leap year even though it isn't, +-- the numbers that represent times in /1900-02-29/ in Excel, in the range /[60, 61[/, +-- are never generated by this function for `DateBase1900`. This means that +-- under those conditions this is not an inverse of `dateFromNumber`. +-- See https://docs.microsoft.com/en-gb/office/troubleshoot/excel/wrongly-assumes-1900-is-leap-year for details. +dateToNumber :: Fractional a => DateBase -> UTCTime -> a +dateToNumber b (UTCTime day diffTime) = numberOfDays + fractionOfOneDay + where + numberOfDays = fromIntegral (diffDays excel1900CorrectedDay $ baseDate b) + fractionOfOneDay = realToFrac diffTime / (24 * 60 * 60) + marchFirst1900 = fromGregorian 1900 3 1 + excel1900CorrectedDay = if day < marchFirst1900 + then addDays (-1) day + else day + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -147,8 +539,8 @@ instance FromCursor XlsxText where fromCursor cur = do let - ts = cur $/ element (n_ "t") >=> contentOrEmpty - rs = cur $/ element (n_ "r") >=> fromCursor + ts = cur $/ element (addSmlNamespace "t") >=> contentOrEmpty + rs = cur $/ element (addSmlNamespace "r") >=> fromCursor case (ts,rs) of ([t], []) -> return $ XlsxText t @@ -157,18 +549,70 @@ _ -> fail "invalid item" +instance FromXenoNode XlsxText where + fromXenoNode root = do + (mCh, rs) <- + collectChildren root $ (,) <$> maybeChild "t" <*> fromChildList "r" + mT <- mapM contentX mCh + case mT of + Just t -> return $ XlsxText t + Nothing -> + case rs of + [] -> Left $ "missing rich text subelements" + _ -> return $ XlsxRichText rs + instance FromAttrVal CellRef where fromAttrVal = fmap (first CellRef) . fromAttrVal +instance FromAttrBs CellRef where + -- we presume that cell references contain only latin letters, + -- numbers and colon + fromAttrBs = pure . CellRef . T.decodeLatin1 + instance FromAttrVal SqRef where fromAttrVal t = do rs <- mapM (fmap fst . fromAttrVal) $ T.split (== ' ') t readSuccess $ SqRef rs +instance FromAttrBs SqRef where + fromAttrBs bs = do + -- split on space + rs <- forM (BS.split 32 bs) fromAttrBs + return $ SqRef rs + -- | See @ST_Formula@, p. 3873 instance FromCursor Formula where fromCursor cur = [Formula . T.concat $ cur $/ content] +instance FromXenoNode Formula where + fromXenoNode = fmap Formula . contentX + +instance FromAttrVal Formula where + fromAttrVal t = readSuccess $ Formula t + +instance FromAttrBs Formula where + fromAttrBs = fmap Formula . fromAttrBs + +instance FromAttrVal ErrorType where + fromAttrVal "#DIV/0!" = readSuccess ErrorDiv0 + fromAttrVal "#N/A" = readSuccess ErrorNA + fromAttrVal "#NAME?" = readSuccess ErrorName + fromAttrVal "#NULL!" = readSuccess ErrorNull + fromAttrVal "#NUM!" = readSuccess ErrorNum + fromAttrVal "#REF!" = readSuccess ErrorRef + fromAttrVal "#VALUE!" = readSuccess ErrorValue + fromAttrVal t = invalidText "ErrorType" t + +instance FromAttrBs ErrorType where + fromAttrBs "#DIV/0!" = return ErrorDiv0 + fromAttrBs "#N/A" = return ErrorNA + fromAttrBs "#NAME?" = return ErrorName + fromAttrBs "#NULL!" = return ErrorNull + fromAttrBs "#NUM!" = return ErrorNum + fromAttrBs "#REF!" = return ErrorRef + fromAttrBs "#VALUE!" = return ErrorValue + fromAttrBs x = unexpectedAttrBs "ErrorType" x + {------------------------------------------------------------------------------- Rendering -------------------------------------------------------------------------------} @@ -194,3 +638,76 @@ -- | See @ST_Formula@, p. 3873 instance ToElement Formula where toElement nm (Formula txt) = elementContent nm txt + +instance ToAttrVal ErrorType where + toAttrVal ErrorDiv0 = "#DIV/0!" + toAttrVal ErrorNA = "#N/A" + toAttrVal ErrorName = "#NAME?" + toAttrVal ErrorNull = "#NULL!" + toAttrVal ErrorNum = "#NUM!" + toAttrVal ErrorRef = "#REF!" + toAttrVal ErrorValue = "#VALUE!" + +-- Since micro-lens denies the existence of prisms, +-- I pasted the splice that's generated from makePrisms, +-- then I copied over the definitions from Control.Lens for the prism +-- function as well. +-- Essentially this is doing the template haskell by hand. + +_CellText :: Prism' CellValue Text +_CellText + = (prism (\ x1_a1ZQv -> CellText x1_a1ZQv)) + (\ x_a1ZQw + -> case x_a1ZQw of + CellText y1_a1ZQx -> Right y1_a1ZQx + _ -> Left x_a1ZQw) +{-# INLINE _CellText #-} +_CellDouble :: Prism' CellValue Double +_CellDouble + = (prism (\ x1_a1ZQy -> CellDouble x1_a1ZQy)) + (\ x_a1ZQz + -> case x_a1ZQz of + CellDouble y1_a1ZQA -> Right y1_a1ZQA + _ -> Left x_a1ZQz) +{-# INLINE _CellDouble #-} +_CellBool :: Prism' CellValue Bool +_CellBool + = (prism (\ x1_a1ZQB -> CellBool x1_a1ZQB)) + (\ x_a1ZQC + -> case x_a1ZQC of + CellBool y1_a1ZQD -> Right y1_a1ZQD + _ -> Left x_a1ZQC) +{-# INLINE _CellBool #-} +_CellRich :: Prism' CellValue [RichTextRun] +_CellRich + = (prism (\ x1_a1ZQE -> CellRich x1_a1ZQE)) + (\ x_a1ZQF + -> case x_a1ZQF of + CellRich y1_a1ZQG -> Right y1_a1ZQG + _ -> Left x_a1ZQF) +{-# INLINE _CellRich #-} +_CellError :: Prism' CellValue ErrorType +_CellError + = (prism (\ x1_a1ZQH -> CellError x1_a1ZQH)) + (\ x_a1ZQI + -> case x_a1ZQI of + CellError y1_a1ZQJ -> Right y1_a1ZQJ + _ -> Left x_a1ZQI) +{-# INLINE _CellError #-} + +_XlsxText :: Prism' XlsxText Text +_XlsxText + = (prism (\ x1_a1ZzU -> XlsxText x1_a1ZzU)) + (\ x_a1ZzV + -> case x_a1ZzV of + XlsxText y1_a1ZzW -> Right y1_a1ZzW + _ -> Left x_a1ZzV) +{-# INLINE _XlsxText #-} +_XlsxRichText :: Prism' XlsxText [RichTextRun] +_XlsxRichText + = (prism (\ x1_a1ZzX -> XlsxRichText x1_a1ZzX)) + (\ x_a1ZzY + -> case x_a1ZzY of + XlsxRichText y1_a1ZzZ -> Right y1_a1ZzZ + _ -> Left x_a1ZzY) +{-# INLINE _XlsxRichText #-} diff --git a/src/Codec/Xlsx/Types/ConditionalFormatting.hs b/src/Codec/Xlsx/Types/ConditionalFormatting.hs --- a/src/Codec/Xlsx/Types/ConditionalFormatting.hs +++ b/src/Codec/Xlsx/Types/ConditionalFormatting.hs @@ -1,33 +1,66 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types.ConditionalFormatting - ( ConditionalFormatting - , CfRule(..) - , Condition(..) - , OperatorExpression (..) - , TimePeriod (..) + ( ConditionalFormatting + , CfRule(..) + , NStdDev(..) + , Inclusion(..) + , CfValue(..) + , MinCfValue(..) + , MaxCfValue(..) + , Condition(..) + , OperatorExpression(..) + , TimePeriod(..) + , IconSetOptions(..) + , IconSetType(..) + , DataBarOptions(..) + , dataBarWithColor -- * Lenses -- ** CfRule - , cfrCondition - , cfrDxfId - , cfrPriority - , cfrStopIfTrue + , cfrCondition + , cfrDxfId + , cfrPriority + , cfrStopIfTrue + -- ** IconSetOptions + , isoIconSet + , isoValues + , isoReverse + , isoShowValue + -- ** DataBarOptions + , dboMaxLength + , dboMinLength + , dboShowValue + , dboMinimum + , dboMaximum + , dboColor -- * Misc - , topCfPriority - ) where + , topCfPriority + ) where -import Control.Lens (makeLenses) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe -import Data.Text (Text) -import Text.XML -import Text.XML.Cursor +import Control.Arrow (first, right) +import Control.DeepSeq (NFData) +import Codec.Xlsx.LensCompat (makeLenses) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.Default +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor hiding (bool) +import qualified Xeno.DOM as Xeno -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Common -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.StyleSheet (Color) +import Codec.Xlsx.Writer.Internal -- | Logical operation used in 'CellIs' condition -- @@ -46,7 +79,8 @@ | OpNotBetween Formula Formula -- ^ 'Not between' operator | OpNotContains Formula -- ^ 'Does not contain' operator | OpNotEqual Formula -- ^ 'Not equal to' operator - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData OperatorExpression -- | Used in a "contains dates" conditional formatting rule. -- These are dynamic time periods, which change based on @@ -64,19 +98,56 @@ | PerToday -- ^ Today's date. | PerTomorrow -- ^ Tomorrow's date. | PerYesterday -- ^ Yesterday's date. - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData TimePeriod +-- | Flag indicating whether the 'aboveAverage' and 'belowAverage' +-- criteria is inclusive of the average itself, or exclusive of that +-- value. +data Inclusion + = Inclusive + | Exclusive + deriving (Eq, Ord, Show, Generic) +instance NFData Inclusion + +-- | The number of standard deviations to include above or below the +-- average in the conditional formatting rule. +newtype NStdDev = + NStdDev Int + deriving (Eq, Ord, Show, Generic) +instance NFData NStdDev + -- | Conditions which could be used for conditional formatting -- -- See 18.18.12 "ST_CfType (Conditional Format Type)" (p. 2443) data Condition + -- | This conditional formatting rule highlights cells that are + -- above (or maybe equal to) the average for all values in the range. + = AboveAverage Inclusion (Maybe NStdDev) -- | This conditional formatting rule highlights cells in the -- range that begin with the given text. Equivalent to -- using the LEFT() sheet function and comparing values. - = BeginsWith Text + | BeginsWith Text + -- | This conditional formatting rule highlights cells that are + -- below the average for all values in the range. + | BelowAverage Inclusion (Maybe NStdDev) + -- | This conditional formatting rule highlights cells whose + -- values fall in the bottom N percent bracket. + | BottomNPercent Int + -- | This conditional formatting rule highlights cells whose + -- values fall in the bottom N bracket. + | BottomNValues Int -- | This conditional formatting rule compares a cell value -- to a formula calculated result, using an operator. | CellIs OperatorExpression + -- | This conditional formatting rule creates a gradated color + -- scale on the cells with specified colors for specified minimum + -- and maximum. + | ColorScale2 MinCfValue Color MaxCfValue Color + -- | This conditional formatting rule creates a gradated color + -- scale on the cells with specified colors for specified minimum, + -- midpoint and maximum. + | ColorScale3 MinCfValue Color CfValue Color MaxCfValue Color -- | This conditional formatting rule highlights cells that -- are completely blank. Equivalent of using LEN(TRIM()). -- This means that if the cell contains only characters @@ -92,6 +163,9 @@ -- sheet function to determine whether the cell contains -- the text. | ContainsText Text + -- | This conditional formatting rule displays a gradated data bar + -- in the range of cells. + | DataBar DataBarOptions -- | This conditional formatting rule highlights cells -- without formula errors. Equivalent to using ISERROR() -- sheet function to determine if there is a formula error. @@ -106,6 +180,9 @@ -- not contain given text. Equivalent to using the -- SEARCH() sheet function. | DoesNotContainText Text + -- | This conditional formatting rule highlights duplicated + -- values. + | DuplicateValues -- | This conditional formatting rule highlights cells ending -- with given text. Equivalent to using the RIGHT() sheet -- function and comparing values. @@ -114,6 +191,9 @@ -- evaluate. When the formula result is true, the cell is -- highlighted. | Expression Formula + -- | This conditional formatting rule applies icons to cells + -- according to their values. + | IconSet IconSetOptions -- | This conditional formatting rule highlights cells -- containing dates in the specified time period. The -- underlying value of the cell is evaluated, therefore the @@ -122,15 +202,149 @@ -- value 38913 the conditional format shall be applied if -- the rule requires a value of 7/14/2006. | InTimePeriod TimePeriod - -- TODO: aboveAverage - -- TODO: colorScale - -- TODO: dataBar - -- TODO: iconSet - -- TODO: timePeriod - -- TODO: top10 - -- TODO: uniqueValues - deriving (Eq, Ord, Show) + -- | This conditional formatting rule highlights cells whose + -- values fall in the top N percent bracket. + | TopNPercent Int + -- | This conditional formatting rule highlights cells whose + -- values fall in the top N bracket. + | TopNValues Int + -- | This conditional formatting rule highlights unique values in the range. + | UniqueValues + deriving (Eq, Ord, Show, Generic) +instance NFData Condition +-- | Describes the values of the interpolation points in a color +-- scale, data bar or icon set conditional formatting rules. +-- +-- See 18.3.1.11 "cfvo (Conditional Format Value Object)" (p. 1604) +data CfValue + = CfValue Double + | CfPercent Double + | CfPercentile Double + | CfFormula Formula + deriving (Eq, Ord, Show, Generic) +instance NFData CfValue + +data MinCfValue + = CfvMin + | MinCfValue CfValue + deriving (Eq, Ord, Show, Generic) +instance NFData MinCfValue + +data MaxCfValue + = CfvMax + | MaxCfValue CfValue + deriving (Eq, Ord, Show, Generic) +instance NFData MaxCfValue + +-- | internal type for (de)serialization +-- +-- See 18.18.13 "ST_CfvoType (Conditional Format Value Object Type)" (p. 2445) +data CfvType = + CfvtFormula + -- ^ The minimum\/ midpoint \/ maximum value for the gradient is + -- determined by a formula. + | CfvtMax + -- ^ Indicates that the maximum value in the range shall be used as + -- the maximum value for the gradient. + | CfvtMin + -- ^ Indicates that the minimum value in the range shall be used as + -- the minimum value for the gradient. + | CfvtNum + -- ^ Indicates that the minimum \/ midpoint \/ maximum value for the + -- gradient is specified by a constant numeric value. + | CfvtPercent + -- ^ Value indicates a percentage between the minimum and maximum + -- values in the range shall be used as the minimum \/ midpoint \/ + -- maximum value for the gradient. + | CfvtPercentile + -- ^ Value indicates a percentile ranking in the range shall be used + -- as the minimum \/ midpoint \/ maximum value for the gradient. + deriving (Eq, Ord, Show, Generic) +instance NFData CfvType + +-- | Describes an icon set conditional formatting rule. +-- +-- See 18.3.1.49 "iconSet (Icon Set)" (p. 1645) +data IconSetOptions = IconSetOptions + { _isoIconSet :: IconSetType + -- ^ icon set used, default value is 'IconSet3Trafficlights1' + , _isoValues :: [CfValue] + -- ^ values describing per icon ranges + , _isoReverse :: Bool + -- ^ reverses the default order of the icons in the specified icon set + , _isoShowValue :: Bool + -- ^ indicates whether to show the values of the cells on which this + -- icon set is applied. + } deriving (Eq, Ord, Show, Generic) +instance NFData IconSetOptions + +-- | Icon set type for conditional formatting. 'CfValue' fields +-- determine lower range bounds. I.e. @IconSet3Signs (CfPercent 0) +-- (CfPercent 33) (CfPercent 67)@ say that 1st icon will be shown for +-- values ranging from 0 to 33 percents, 2nd for 33 to 67 percent and +-- the 3rd one for values from 67 to 100 percent. +-- +-- 18.18.42 "ST_IconSetType (Icon Set Type)" (p. 2463) +data IconSetType = + IconSet3Arrows -- CfValue CfValue CfValue + | IconSet3ArrowsGray -- CfValue CfValue CfValue + | IconSet3Flags -- CfValue CfValue CfValue + | IconSet3Signs -- CfValue CfValue CfValue + | IconSet3Symbols -- CfValue CfValue CfValue + | IconSet3Symbols2 -- CfValue CfValue CfValue + | IconSet3TrafficLights1 -- CfValue CfValue CfValue + | IconSet3TrafficLights2 -- CfValue CfValue CfValue + -- ^ 3 traffic lights icon set with thick black border. + | IconSet4Arrows -- CfValue CfValue CfValue CfValue + | IconSet4ArrowsGray -- CfValue CfValue CfValue CfValue + | IconSet4Rating -- CfValue CfValue CfValue CfValue + | IconSet4RedToBlack -- CfValue CfValue CfValue CfValue + | IconSet4TrafficLights -- CfValue CfValue CfValue CfValue + | IconSet5Arrows -- CfValue CfValue CfValue CfValue CfValue + | IconSet5ArrowsGray -- CfValue CfValue CfValue CfValue CfValue + | IconSet5Quarters -- CfValue CfValue CfValue CfValue CfValue + | IconSet5Rating -- CfValue CfValue CfValue CfValue CfValue + deriving (Eq, Ord, Show, Generic) +instance NFData IconSetType + +-- | Describes a data bar conditional formatting rule. +-- +-- See 18.3.1.28 "dataBar (Data Bar)" (p. 1621) +data DataBarOptions = DataBarOptions + { _dboMaxLength :: Int + -- ^ The maximum length of the data bar, as a percentage of the cell + -- width. + , _dboMinLength :: Int + -- ^ The minimum length of the data bar, as a percentage of the cell + -- width. + , _dboShowValue :: Bool + -- ^ Indicates whether to show the values of the cells on which this + -- data bar is applied. + , _dboMinimum :: MinCfValue + , _dboMaximum :: MaxCfValue + , _dboColor :: Color + } deriving (Eq, Ord, Show, Generic) +instance NFData DataBarOptions + +defaultDboMaxLength :: Int +defaultDboMaxLength = 90 + +defaultDboMinLength :: Int +defaultDboMinLength = 10 + +dataBarWithColor :: Color -> Condition +dataBarWithColor c = + DataBar + DataBarOptions + { _dboMaxLength = defaultDboMaxLength + , _dboMinLength = defaultDboMinLength + , _dboShowValue = True + , _dboMinimum = CfvMin + , _dboMaximum = CfvMax + , _dboColor = c + } + -- | This collection represents a description of a conditional formatting rule. -- -- See 18.3.1.10 "cfRule (Conditional Formatting Rule)" (p. 1602) @@ -149,9 +363,22 @@ -- be applied over this rule, when this rule -- evaluates to true. , _cfrStopIfTrue :: Maybe Bool - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Generic) +instance NFData CfRule +instance Default IconSetOptions where + def = + IconSetOptions + { _isoIconSet = IconSet3TrafficLights1 + , _isoValues = [CfPercent 0, CfPercent 33.33, CfPercent 66.67] +-- IconSet3TrafficLights1 (CfPercent 0) (CfPercent 33.33) (CfPercent 66.67) + , _isoReverse = False + , _isoShowValue = True + } + makeLenses ''CfRule +makeLenses ''IconSetOptions +makeLenses ''DataBarOptions type ConditionalFormatting = [CfRule] @@ -174,12 +401,39 @@ return CfRule{..} readCondition :: Text -> Cursor -> [Condition] -readCondition "beginsWith" cur = do - txt <- fromAttribute "text" cur - return $ BeginsWith txt +readCondition "aboveAverage" cur = do + above <- fromAttributeDef "aboveAverage" True cur + inclusion <- fromAttributeDef "equalAverage" Exclusive cur + nStdDev <- maybeAttribute "stdDev" cur + if above + then return $ AboveAverage inclusion nStdDev + else return $ BelowAverage inclusion nStdDev +readCondition "beginsWith" cur = do + txt <- fromAttribute "text" cur + return $ BeginsWith txt +readCondition "colorScale" cur = do + let cfvos = cur $/ element (addSmlNamespace "colorScale") &/ element (addSmlNamespace "cfvo") &| node + colors = cur $/ element (addSmlNamespace "colorScale") &/ element (addSmlNamespace "color") &| node + case (cfvos, colors) of + ([n1, n2], [cn1, cn2]) -> do + mincfv <- fromCursor $ fromNode n1 + minc <- fromCursor $ fromNode cn1 + maxcfv <- fromCursor $ fromNode n2 + maxc <- fromCursor $ fromNode cn2 + return $ ColorScale2 mincfv minc maxcfv maxc + ([n1, n2, n3], [cn1, cn2, cn3]) -> do + mincfv <- fromCursor $ fromNode n1 + minc <- fromCursor $ fromNode cn1 + midcfv <- fromCursor $ fromNode n2 + midc <- fromCursor $ fromNode cn2 + maxcfv <- fromCursor $ fromNode n3 + maxc <- fromCursor $ fromNode cn3 + return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc + _ -> + error "Malformed colorScale condition" readCondition "cellIs" cur = do operator <- fromAttribute "operator" cur - let formulas = cur $/ element (n_ "formula") >=> fromCursor + let formulas = cur $/ element (addSmlNamespace "formula") >=> fromCursor expr <- readOpExpression operator formulas return $ CellIs expr readCondition "containsBlanks" _ = return ContainsBlanks @@ -187,24 +441,37 @@ readCondition "containsText" cur = do txt <- fromAttribute "text" cur return $ ContainsText txt -readCondition "notContainsBlanks" _ = return DoesNotContainBlanks -readCondition "notContainsErrors" _ = return DoesNotContainErrors -readCondition "notContainsText" cur = do - txt <- fromAttribute "text" cur - return $ DoesNotContainText txt +readCondition "dataBar" cur = fmap DataBar $ cur $/ element (addSmlNamespace "dataBar") >=> fromCursor +readCondition "duplicateValues" _ = return DuplicateValues readCondition "endsWith" cur = do txt <- fromAttribute "text" cur return $ EndsWith txt readCondition "expression" cur = do - formula <- cur $/ element "formula" >=> fromCursor + formula <- cur $/ element (addSmlNamespace "formula") >=> fromCursor return $ Expression formula +readCondition "iconSet" cur = fmap IconSet $ cur $/ element (addSmlNamespace "iconSet") >=> fromCursor +readCondition "notContainsBlanks" _ = return DoesNotContainBlanks +readCondition "notContainsErrors" _ = return DoesNotContainErrors +readCondition "notContainsText" cur = do + txt <- fromAttribute "text" cur + return $ DoesNotContainText txt readCondition "timePeriod" cur = do period <- fromAttribute "timePeriod" cur return $ InTimePeriod period -readCondition _ _ = error "Unexpected conditional formatting type" +readCondition "top10" cur = do + bottom <- fromAttributeDef "bottom" False cur + percent <- fromAttributeDef "percent" False cur + rank <- fromAttribute "rank" cur + case (bottom, percent) of + (True, True) -> return $ BottomNPercent rank + (True, False) -> return $ BottomNValues rank + (False, True) -> return $ TopNPercent rank + (False, False) -> return $ TopNValues rank +readCondition "uniqueValues" _ = return UniqueValues +readCondition t _ = error $ "Unexpected conditional formatting type " ++ show t readOpExpression :: Text -> [Formula] -> [OperatorExpression] -readOpExpression "beginsWith" [f ] = [OpBeginsWith f ] +readOpExpression "beginsWith" [f] = [OpBeginsWith f ] readOpExpression "between" [f1, f2] = [OpBetween f1 f2] readOpExpression "containsText" [f] = [OpContainsText f] readOpExpression "endsWith" [f] = [OpEndsWith f] @@ -218,6 +485,92 @@ readOpExpression "notEqual" [f] = [OpNotEqual f] readOpExpression _ _ = [] +instance FromXenoNode CfRule where + fromXenoNode root = parseAttributes root $ do + _cfrDxfId <- maybeAttr "dxfId" + _cfrPriority <- fromAttr "priority" + _cfrStopIfTrue <- maybeAttr "stopIfTrue" + -- spec shows this attribute as optional but it's not clear why could + -- conditional formatting record be needed with no condition type set + cfType <- fromAttr "type" + _cfrCondition <- readConditionX cfType + return CfRule {..} + where + readConditionX ("aboveAverage" :: ByteString) = do + above <- fromAttrDef "aboveAverage" True + inclusion <- fromAttrDef "equalAverage" Exclusive + nStdDev <- maybeAttr "stdDev" + if above + then return $ AboveAverage inclusion nStdDev + else return $ BelowAverage inclusion nStdDev + readConditionX "beginsWith" = BeginsWith <$> fromAttr "text" + readConditionX "colorScale" = toAttrParser $ do + xs <- collectChildren root . maybeParse "colorScale" $ \node -> + collectChildren node $ (,) <$> childList "cfvo" + <*> childList "color" + case xs of + Just ([n1, n2], [cn1, cn2]) -> do + mincfv <- fromXenoNode n1 + minc <- fromXenoNode cn1 + maxcfv <- fromXenoNode n2 + maxc <- fromXenoNode cn2 + return $ ColorScale2 mincfv minc maxcfv maxc + Just ([n1, n2, n3], [cn1, cn2, cn3]) -> do + mincfv <- fromXenoNode n1 + minc <- fromXenoNode cn1 + midcfv <- fromXenoNode n2 + midc <- fromXenoNode cn2 + maxcfv <- fromXenoNode n3 + maxc <- fromXenoNode cn3 + return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc + _ -> + Left "Malformed colorScale condition" + readConditionX "cellIs" = do + operator <- fromAttr "operator" + formulas <- toAttrParser . collectChildren root $ fromChildList "formula" + case (operator, formulas) of + ("beginsWith" :: ByteString, [f]) -> return . CellIs $ OpBeginsWith f + ("between", [f1, f2]) -> return . CellIs $ OpBetween f1 f2 + ("containsText", [f]) -> return . CellIs $ OpContainsText f + ("endsWith", [f]) -> return . CellIs $ OpEndsWith f + ("equal", [f]) -> return . CellIs $ OpEqual f + ("greaterThan", [f]) -> return . CellIs $ OpGreaterThan f + ("greaterThanOrEqual", [f]) -> return . CellIs $ OpGreaterThanOrEqual f + ("lessThan", [f]) -> return . CellIs $ OpLessThan f + ("lessThanOrEqual", [f]) -> return . CellIs $ OpLessThanOrEqual f + ("notBetween", [f1, f2]) -> return . CellIs $ OpNotBetween f1 f2 + ("notContains", [f]) -> return . CellIs $ OpNotContains f + ("notEqual", [f]) -> return . CellIs $ OpNotEqual f + _ -> toAttrParser $ Left "Bad cellIs rule" + readConditionX "containsBlanks" = return ContainsBlanks + readConditionX "containsErrors" = return ContainsErrors + readConditionX "containsText" = ContainsText <$> fromAttr "text" + readConditionX "dataBar" = + fmap DataBar . toAttrParser . collectChildren root $ fromChild "dataBar" + readConditionX "duplicateValues" = return DuplicateValues + readConditionX "endsWith" = EndsWith <$> fromAttr "text" + readConditionX "expression" = + fmap Expression . toAttrParser . collectChildren root $ fromChild "formula" + readConditionX "iconSet" = + fmap IconSet . toAttrParser . collectChildren root $ fromChild "iconSet" + readConditionX "notContainsBlanks" = return DoesNotContainBlanks + readConditionX "notContainsErrors" = return DoesNotContainErrors + readConditionX "notContainsText" = + DoesNotContainText <$> fromAttr "text" + readConditionX "timePeriod" = InTimePeriod <$> fromAttr "timePeriod" + readConditionX "top10" = do + bottom <- fromAttrDef "bottom" False + percent <- fromAttrDef "percent" False + rank <- fromAttr "rank" + case (bottom, percent) of + (True, True) -> return $ BottomNPercent rank + (True, False) -> return $ BottomNValues rank + (False, True) -> return $ TopNPercent rank + (False, False) -> return $ TopNValues rank + readConditionX "uniqueValues" = return UniqueValues + readConditionX x = + toAttrParser . Left $ "Unexpected conditional formatting type " <> T.pack (show x) + instance FromAttrVal TimePeriod where fromAttrVal "last7Days" = readSuccess PerLast7Days fromAttrVal "lastMonth" = readSuccess PerLastMonth @@ -231,7 +584,213 @@ fromAttrVal "yesterday" = readSuccess PerYesterday fromAttrVal t = invalidText "TimePeriod" t +instance FromAttrBs TimePeriod where + fromAttrBs "last7Days" = return PerLast7Days + fromAttrBs "lastMonth" = return PerLastMonth + fromAttrBs "lastWeek" = return PerLastWeek + fromAttrBs "nextMonth" = return PerNextMonth + fromAttrBs "nextWeek" = return PerNextWeek + fromAttrBs "thisMonth" = return PerThisMonth + fromAttrBs "thisWeek" = return PerThisWeek + fromAttrBs "today" = return PerToday + fromAttrBs "tomorrow" = return PerTomorrow + fromAttrBs "yesterday" = return PerYesterday + fromAttrBs x = unexpectedAttrBs "TimePeriod" x +instance FromAttrVal CfvType where + fromAttrVal "num" = readSuccess CfvtNum + fromAttrVal "percent" = readSuccess CfvtPercent + fromAttrVal "max" = readSuccess CfvtMax + fromAttrVal "min" = readSuccess CfvtMin + fromAttrVal "formula" = readSuccess CfvtFormula + fromAttrVal "percentile" = readSuccess CfvtPercentile + fromAttrVal t = invalidText "CfvType" t + +instance FromAttrBs CfvType where + fromAttrBs "num" = return CfvtNum + fromAttrBs "percent" = return CfvtPercent + fromAttrBs "max" = return CfvtMax + fromAttrBs "min" = return CfvtMin + fromAttrBs "formula" = return CfvtFormula + fromAttrBs "percentile" = return CfvtPercentile + fromAttrBs x = unexpectedAttrBs "CfvType" x + +readCfValue :: (CfValue -> a) -> [a] -> [a] -> Cursor -> [a] +readCfValue f minVal maxVal c = do + vType <- fromAttribute "type" c + case vType of + CfvtNum -> do + v <- fromAttribute "val" c + return . f $ CfValue v + CfvtFormula -> do + v <- fromAttribute "val" c + return . f $ CfFormula v + CfvtPercent -> do + v <- fromAttribute "val" c + return . f $ CfPercent v + CfvtPercentile -> do + v <- fromAttribute "val" c + return . f $ CfPercentile v + CfvtMin -> minVal + CfvtMax -> maxVal + +readCfValueX :: + (CfValue -> a) + -> Either Text a + -> Either Text a + -> Xeno.Node + -> Either Text a +readCfValueX f minVal maxVal root = + parseAttributes root $ do + vType <- fromAttr "type" + case vType of + CfvtNum -> do + v <- fromAttr "val" + return . f $ CfValue v + CfvtFormula -> do + v <- fromAttr "val" + return . f $ CfFormula v + CfvtPercent -> do + v <- fromAttr "val" + return . f $ CfPercent v + CfvtPercentile -> do + v <- fromAttr "val" + return . f $ CfPercentile v + CfvtMin -> toAttrParser minVal + CfvtMax -> toAttrParser maxVal + +failMinCfvType :: [a] +failMinCfvType = fail "unexpected 'min' type" + +failMinCfvTypeX :: Either Text a +failMinCfvTypeX = Left "unexpected 'min' type" + +failMaxCfvType :: [a] +failMaxCfvType = fail "unexpected 'max' type" + +failMaxCfvTypeX :: Either Text a +failMaxCfvTypeX = Left "unexpected 'max' type" + +instance FromCursor CfValue where + fromCursor = readCfValue id failMinCfvType failMaxCfvType + +instance FromXenoNode CfValue where + fromXenoNode root = readCfValueX id failMinCfvTypeX failMaxCfvTypeX root + +instance FromCursor MinCfValue where + fromCursor = readCfValue MinCfValue (return CfvMin) failMaxCfvType + +instance FromXenoNode MinCfValue where + fromXenoNode root = + readCfValueX MinCfValue (return CfvMin) failMaxCfvTypeX root + +instance FromCursor MaxCfValue where + fromCursor = readCfValue MaxCfValue failMinCfvType (return CfvMax) + +instance FromXenoNode MaxCfValue where + fromXenoNode root = + readCfValueX MaxCfValue failMinCfvTypeX (return CfvMax) root + +defaultIconSet :: IconSetType +defaultIconSet = IconSet3TrafficLights1 + +instance FromCursor IconSetOptions where + fromCursor cur = do + _isoIconSet <- fromAttributeDef "iconSet" defaultIconSet cur + let _isoValues = cur $/ element (addSmlNamespace "cfvo") >=> fromCursor + _isoReverse <- fromAttributeDef "reverse" False cur + _isoShowValue <- fromAttributeDef "showValue" True cur + return IconSetOptions {..} + +instance FromXenoNode IconSetOptions where + fromXenoNode root = do + (_isoIconSet, _isoReverse, _isoShowValue) <- + parseAttributes root $ (,,) <$> fromAttrDef "iconSet" defaultIconSet + <*> fromAttrDef "reverse" False + <*> fromAttrDef "showValue" True + _isoValues <- collectChildren root $ fromChildList "cfvo" + return IconSetOptions {..} + +instance FromAttrVal IconSetType where + fromAttrVal "3Arrows" = readSuccess IconSet3Arrows + fromAttrVal "3ArrowsGray" = readSuccess IconSet3ArrowsGray + fromAttrVal "3Flags" = readSuccess IconSet3Flags + fromAttrVal "3Signs" = readSuccess IconSet3Signs + fromAttrVal "3Symbols" = readSuccess IconSet3Symbols + fromAttrVal "3Symbols2" = readSuccess IconSet3Symbols2 + fromAttrVal "3TrafficLights1" = readSuccess IconSet3TrafficLights1 + fromAttrVal "3TrafficLights2" = readSuccess IconSet3TrafficLights2 + fromAttrVal "4Arrows" = readSuccess IconSet4Arrows + fromAttrVal "4ArrowsGray" = readSuccess IconSet4ArrowsGray + fromAttrVal "4Rating" = readSuccess IconSet4Rating + fromAttrVal "4RedToBlack" = readSuccess IconSet4RedToBlack + fromAttrVal "4TrafficLights" = readSuccess IconSet4TrafficLights + fromAttrVal "5Arrows" = readSuccess IconSet5Arrows + fromAttrVal "5ArrowsGray" = readSuccess IconSet5ArrowsGray + fromAttrVal "5Quarters" = readSuccess IconSet5Quarters + fromAttrVal "5Rating" = readSuccess IconSet5Rating + fromAttrVal t = invalidText "IconSetType" t + +instance FromAttrBs IconSetType where + fromAttrBs "3Arrows" = return IconSet3Arrows + fromAttrBs "3ArrowsGray" = return IconSet3ArrowsGray + fromAttrBs "3Flags" = return IconSet3Flags + fromAttrBs "3Signs" = return IconSet3Signs + fromAttrBs "3Symbols" = return IconSet3Symbols + fromAttrBs "3Symbols2" = return IconSet3Symbols2 + fromAttrBs "3TrafficLights1" = return IconSet3TrafficLights1 + fromAttrBs "3TrafficLights2" = return IconSet3TrafficLights2 + fromAttrBs "4Arrows" = return IconSet4Arrows + fromAttrBs "4ArrowsGray" = return IconSet4ArrowsGray + fromAttrBs "4Rating" = return IconSet4Rating + fromAttrBs "4RedToBlack" = return IconSet4RedToBlack + fromAttrBs "4TrafficLights" = return IconSet4TrafficLights + fromAttrBs "5Arrows" = return IconSet5Arrows + fromAttrBs "5ArrowsGray" = return IconSet5ArrowsGray + fromAttrBs "5Quarters" = return IconSet5Quarters + fromAttrBs "5Rating" = return IconSet5Rating + fromAttrBs x = unexpectedAttrBs "IconSetType" x + +instance FromCursor DataBarOptions where + fromCursor cur = do + _dboMaxLength <- fromAttributeDef "maxLength" defaultDboMaxLength cur + _dboMinLength <- fromAttributeDef "minLength" defaultDboMinLength cur + _dboShowValue <- fromAttributeDef "showValue" True cur + let cfvos = cur $/ element (addSmlNamespace "cfvo") &| node + case cfvos of + [nMin, nMax] -> do + _dboMinimum <- fromCursor (fromNode nMin) + _dboMaximum <- fromCursor (fromNode nMax) + _dboColor <- cur $/ element (addSmlNamespace "color") >=> fromCursor + return DataBarOptions{..} + ns -> do + fail $ "expected minimum and maximum cfvo nodes but see instead " ++ + show (length ns) ++ " cfvo nodes" + +instance FromXenoNode DataBarOptions where + fromXenoNode root = do + (_dboMaxLength, _dboMinLength, _dboShowValue) <- + parseAttributes root $ (,,) <$> fromAttrDef "maxLength" defaultDboMaxLength + <*> fromAttrDef "minLength" defaultDboMinLength + <*> fromAttrDef "showValue" True + (_dboMinimum, _dboMaximum, _dboColor) <- + collectChildren root $ (,,) <$> fromChild "cfvo" + <*> fromChild "cfvo" + <*> fromChild "color" + return DataBarOptions{..} + +instance FromAttrVal Inclusion where + fromAttrVal = right (first $ bool Exclusive Inclusive) . fromAttrVal + +instance FromAttrBs Inclusion where + fromAttrBs = fmap (bool Exclusive Inclusive) . fromAttrBs + +instance FromAttrVal NStdDev where + fromAttrVal = right (first NStdDev) . fromAttrVal + +instance FromAttrBs NStdDev where + fromAttrBs = fmap NStdDev . fromAttrBs + {------------------------------------------------------------------------------- Rendering -------------------------------------------------------------------------------} @@ -252,18 +811,60 @@ } conditionData :: Condition -> (Text, Map Name Text, [Node]) +conditionData (AboveAverage i sDevs) = + ("aboveAverage", M.fromList $ ["aboveAverage" .= True] ++ + catMaybes [ "equalAverage" .=? justNonDef Exclusive i + , "stdDev" .=? sDevs], []) conditionData (BeginsWith t) = ("beginsWith", M.fromList [ "text" .= t], []) +conditionData (BelowAverage i sDevs) = + ("aboveAverage", M.fromList $ ["aboveAverage" .= False] ++ + catMaybes [ "equalAverage" .=? justNonDef Exclusive i + , "stdDev" .=? sDevs], []) +conditionData (BottomNPercent n) = ("top10", M.fromList [ "bottom" .= True, "rank" .= n, "percent" .= True ], []) +conditionData (BottomNValues n) = ("top10", M.fromList [ "bottom" .= True, "rank" .= n ], []) conditionData (CellIs opExpr) = ("cellIs", M.fromList [ "operator" .= op], formulas) where (op, formulas) = operatorExpressionData opExpr +conditionData (ColorScale2 minv minc maxv maxc) = + ( "colorScale" + , M.empty + , [ NodeElement $ + elementListSimple + "colorScale" + [ toElement "cfvo" minv + , toElement "cfvo" maxv + , toElement "color" minc + , toElement "color" maxc + ] + ]) +conditionData (ColorScale3 minv minc midv midc maxv maxc) = + ( "colorScale" + , M.empty + , [ NodeElement $ + elementListSimple + "colorScale" + [ toElement "cfvo" minv + , toElement "cfvo" midv + , toElement "cfvo" maxv + , toElement "color" minc + , toElement "color" midc + , toElement "color" maxc + ] + ]) conditionData ContainsBlanks = ("containsBlanks", M.empty, []) conditionData ContainsErrors = ("containsErrors", M.empty, []) conditionData (ContainsText t) = ("containsText", M.fromList [ "text" .= t], []) +conditionData (DataBar dbOpts) = ("dataBar", M.empty, [toNode "dataBar" dbOpts]) conditionData DoesNotContainBlanks = ("notContainsBlanks", M.empty, []) conditionData DoesNotContainErrors = ("notContainsErrors", M.empty, []) conditionData (DoesNotContainText t) = ("notContainsText", M.fromList [ "text" .= t], []) +conditionData DuplicateValues = ("duplicateValues", M.empty, []) conditionData (EndsWith t) = ("endsWith", M.fromList [ "text" .= t], []) conditionData (Expression formula) = ("expression", M.empty, [formulaNode formula]) conditionData (InTimePeriod period) = ("timePeriod", M.fromList [ "timePeriod" .= period ], []) +conditionData (IconSet isOptions) = ("iconSet", M.empty, [toNode "iconSet" isOptions]) +conditionData (TopNPercent n) = ("top10", M.fromList [ "rank" .= n, "percent" .= True ], []) +conditionData (TopNValues n) = ("top10", M.fromList [ "rank" .= n ], []) +conditionData UniqueValues = ("uniqueValues", M.empty, []) operatorExpressionData :: OperatorExpression -> (Text, [Node]) operatorExpressionData (OpBeginsWith f) = ("beginsWith", [formulaNode f]) @@ -279,8 +880,79 @@ operatorExpressionData (OpNotContains f) = ("notContains", [formulaNode f]) operatorExpressionData (OpNotEqual f) = ("notEqual", [formulaNode f]) +instance ToElement MinCfValue where + toElement nm CfvMin = leafElement nm ["type" .= CfvtMin] + toElement nm (MinCfValue cfv) = toElement nm cfv + +instance ToElement MaxCfValue where + toElement nm CfvMax = leafElement nm ["type" .= CfvtMax] + toElement nm (MaxCfValue cfv) = toElement nm cfv + +instance ToElement CfValue where + toElement nm (CfValue v) = leafElement nm ["type" .= CfvtNum, "val" .= v] + toElement nm (CfPercent v) = + leafElement nm ["type" .= CfvtPercent, "val" .= v] + toElement nm (CfPercentile v) = + leafElement nm ["type" .= CfvtPercentile, "val" .= v] + toElement nm (CfFormula f) = + leafElement nm ["type" .= CfvtFormula, "val" .= unFormula f] + +instance ToAttrVal CfvType where + toAttrVal CfvtNum = "num" + toAttrVal CfvtPercent = "percent" + toAttrVal CfvtMax = "max" + toAttrVal CfvtMin = "min" + toAttrVal CfvtFormula = "formula" + toAttrVal CfvtPercentile = "percentile" + +instance ToElement IconSetOptions where + toElement nm IconSetOptions {..} = + elementList nm attrs $ map (toElement "cfvo") _isoValues + where + attrs = catMaybes + [ "iconSet" .=? justNonDef defaultIconSet _isoIconSet + , "reverse" .=? justTrue _isoReverse + , "showValue" .=? justFalse _isoShowValue + ] + +instance ToAttrVal IconSetType where + toAttrVal IconSet3Arrows = "3Arrows" + toAttrVal IconSet3ArrowsGray = "3ArrowsGray" + toAttrVal IconSet3Flags = "3Flags" + toAttrVal IconSet3Signs = "3Signs" + toAttrVal IconSet3Symbols = "3Symbols" + toAttrVal IconSet3Symbols2 = "3Symbols2" + toAttrVal IconSet3TrafficLights1 = "3TrafficLights1" + toAttrVal IconSet3TrafficLights2 = "3TrafficLights2" + toAttrVal IconSet4Arrows = "4Arrows" + toAttrVal IconSet4ArrowsGray = "4ArrowsGray" + toAttrVal IconSet4Rating = "4Rating" + toAttrVal IconSet4RedToBlack = "4RedToBlack" + toAttrVal IconSet4TrafficLights = "4TrafficLights" + toAttrVal IconSet5Arrows = "5Arrows" + toAttrVal IconSet5ArrowsGray = "5ArrowsGray" + toAttrVal IconSet5Quarters = "5Quarters" + toAttrVal IconSet5Rating = "5Rating" + +instance ToElement DataBarOptions where + toElement nm DataBarOptions {..} = elementList nm attrs elements + where + attrs = catMaybes + [ "maxLength" .=? justNonDef defaultDboMaxLength _dboMaxLength + , "minLength" .=? justNonDef defaultDboMinLength _dboMinLength + , "showValue" .=? justFalse _dboShowValue + ] + elements = + [ toElement "cfvo" _dboMinimum + , toElement "cfvo" _dboMaximum + , toElement "color" _dboColor + ] + +toNode :: ToElement a => Name -> a -> Node +toNode nm = NodeElement . toElement nm + formulaNode :: Formula -> Node -formulaNode = NodeElement . toElement "formula" +formulaNode = toNode "formula" instance ToAttrVal TimePeriod where toAttrVal PerLast7Days = "last7Days" @@ -293,3 +965,9 @@ toAttrVal PerToday = "today" toAttrVal PerTomorrow = "tomorrow" toAttrVal PerYesterday = "yesterday" + +instance ToAttrVal Inclusion where + toAttrVal = toAttrVal . (== Inclusive) + +instance ToAttrVal NStdDev where + toAttrVal (NStdDev n) = toAttrVal n diff --git a/src/Codec/Xlsx/Types/DataValidation.hs b/src/Codec/Xlsx/Types/DataValidation.hs --- a/src/Codec/Xlsx/Types/DataValidation.hs +++ b/src/Codec/Xlsx/Types/DataValidation.hs @@ -1,23 +1,54 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Codec.Xlsx.Types.DataValidation where +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +module Codec.Xlsx.Types.DataValidation + ( ValidationExpression(..) + , ValidationType(..) + , dvAllowBlank + , dvError + , dvErrorStyle + , dvErrorTitle + , dvPrompt + , dvPromptTitle + , dvShowDropDown + , dvShowErrorMessage + , dvShowInputMessage + , dvValidationType + , ErrorStyle(..) + , DataValidation(..) + , ListOrRangeExpression(..) + , ValidationList + , maybePlainValidationList + , maybeValidationRange + , readValidationType + , readListFormulas + , readOpExpression2 + , readValidationTypeOpExp + , readValExpression + , viewValidationExpression + ) where -import Control.Lens.TH (makeLenses) -import Control.Monad ((>=>)) -import Data.Char (isSpace) -import Data.Default -import qualified Data.Map as M -import Data.Maybe (catMaybes) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Text.XML (Node (..), Element (..)) -import Text.XML.Cursor (Cursor, ($/), element) +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData) +import Codec.Xlsx.LensCompat (makeLenses) +import Control.Monad ((>=>), guard) +import Data.ByteString (ByteString) +import Data.Char (isSpace) +import Data.Default +import qualified Data.Map as M +import Data.Maybe (catMaybes, maybeToList) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Text.XML (Element(..), Node(..)) +import Text.XML.Cursor (Cursor, ($/), element) -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Common -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Writer.Internal -- See 18.18.20 "ST_DataValidationOperator (Data Validation Operator)" (p. 2439/2449) data ValidationExpression @@ -29,7 +60,8 @@ | ValLessThanOrEqual Formula -- ^ "Less than or equal to" operator | ValNotBetween Formula Formula -- ^ "Not between" operator | ValNotEqual Formula -- ^ "Not equal to" operator - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData ValidationExpression -- See 18.18.21 "ST_DataValidationType (Data Validation Type)" (p. 2440/2450) data ValidationType @@ -37,18 +69,28 @@ | ValidationTypeCustom Formula | ValidationTypeDate ValidationExpression | ValidationTypeDecimal ValidationExpression - | ValidationTypeList [Text] + | ValidationTypeList ListOrRangeExpression | ValidationTypeTextLength ValidationExpression | ValidationTypeTime ValidationExpression | ValidationTypeWhole ValidationExpression - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData ValidationType +type ValidationList = [Text] + +data ListOrRangeExpression + = ListExpression ValidationList -- ^ a plain list of elements + | RangeExpression Range -- ^ a cell or range reference + deriving (Eq, Show, Generic) +instance NFData ListOrRangeExpression + -- See 18.18.18 "ST_DataValidationErrorStyle (Data Validation Error Styles)" (p. 2438/2448) data ErrorStyle = ErrorStyleInformation | ErrorStyleStop | ErrorStyleWarning - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData ErrorStyle -- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624) data DataValidation = DataValidation @@ -59,10 +101,14 @@ , _dvPrompt :: Maybe Text , _dvPromptTitle :: Maybe Text , _dvShowDropDown :: Bool + -- ^ A boolean value indicating whether to display a dropdown combo box for a list type data validation. + -- Note that it has an inverted logic, false shows the dropdown list and true will render the dropdown as + -- plain text instead. , _dvShowErrorMessage :: Bool , _dvShowInputMessage :: Bool , _dvValidationType :: ValidationType - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData DataValidation makeLenses ''DataValidation @@ -80,6 +126,12 @@ fromAttrVal "warning" = readSuccess ErrorStyleWarning fromAttrVal t = invalidText "ErrorStyle" t +instance FromAttrBs ErrorStyle where + fromAttrBs "information" = return ErrorStyleInformation + fromAttrBs "stop" = return ErrorStyleStop + fromAttrBs "warning" = return ErrorStyleWarning + fromAttrBs x = unexpectedAttrBs "ErrorStyle" x + instance FromCursor DataValidation where fromCursor cur = do _dvAllowBlank <- fromAttributeDef "allowBlank" False cur @@ -96,42 +148,115 @@ _dvValidationType <- readValidationType mop mtype cur return DataValidation{..} +instance FromXenoNode DataValidation where + fromXenoNode root = do + (op, atype, genDV) <- parseAttributes root $ do + _dvAllowBlank <- fromAttrDef "allowBlank" False + _dvError <- maybeAttr "error" + _dvErrorStyle <- fromAttrDef "errorStyle" ErrorStyleStop + _dvErrorTitle <- maybeAttr "errorTitle" + _dvPrompt <- maybeAttr "prompt" + _dvPromptTitle <- maybeAttr "promptTitle" + _dvShowDropDown <- fromAttrDef "showDropDown" False + _dvShowErrorMessage <- fromAttrDef "showErrorMessage" False + _dvShowInputMessage <- fromAttrDef "showInputMessage" False + op <- fromAttrDef "operator" "between" + typ <- fromAttrDef "type" "none" + return (op, typ, \_dvValidationType -> DataValidation {..}) + valType <- parseValidationType op atype + return $ genDV valType + where + parseValidationType :: ByteString -> ByteString -> Either Text ValidationType + parseValidationType op atype = + case atype of + "none" -> return ValidationTypeNone + "custom" -> + ValidationTypeCustom <$> formula1 + "list" -> do + f <- formula1 + case readListFormulas f of + Nothing -> Left "validation of type \"list\" with empty formula list" + Just fs -> return $ ValidationTypeList fs + "date" -> + ValidationTypeDate <$> readOpExpression op + "decimal" -> + ValidationTypeDecimal <$> readOpExpression op + "textLength" -> + ValidationTypeTextLength <$> readOpExpression op + "time" -> + ValidationTypeTime <$> readOpExpression op + "whole" -> + ValidationTypeWhole <$> readOpExpression op + unexpected -> + Left $ "unexpected type of data validation " <> T.pack (show unexpected) + readOpExpression "between" = uncurry ValBetween <$> formulaPair + readOpExpression "notBetween" = uncurry ValNotBetween <$> formulaPair + readOpExpression "equal" = ValEqual <$> formula1 + readOpExpression "greaterThan" = ValGreaterThan <$> formula1 + readOpExpression "greaterThanOrEqual" = ValGreaterThanOrEqual <$> formula1 + readOpExpression "lessThan" = ValLessThan <$> formula1 + readOpExpression "lessThanOrEqual" = ValLessThanOrEqual <$> formula1 + readOpExpression "notEqual" = ValNotEqual <$> formula1 + readOpExpression op = Left $ "data validation, unexpected operator " <> T.pack (show op) + formula1 = collectChildren root $ fromChild "formula1" + formulaPair = + collectChildren root $ (,) <$> fromChild "formula1" <*> fromChild "formula2" + readValidationType :: Text -> Text -> Cursor -> [ValidationType] readValidationType _ "none" _ = return ValidationTypeNone readValidationType _ "custom" cur = do f <- fromCursor cur return $ ValidationTypeCustom f readValidationType _ "list" cur = do - f <- cur $/ element (n_ "formula1") >=> fromCursor - as <- readListFormula f + f <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor + as <- maybeToList $ readListFormulas f return $ ValidationTypeList as readValidationType op ty cur = do opExp <- readOpExpression2 op cur readValidationTypeOpExp ty opExp -readListFormula :: Formula -> [[Text]] -readListFormula (Formula f) = catMaybes [readQuotedList f] +-- | Attempt to obtain a plain list expression +maybePlainValidationList :: ValidationType -> Maybe ValidationList +maybePlainValidationList (ValidationTypeList (ListExpression le)) = Just le +maybePlainValidationList _ = Nothing + +-- | Attempt to obtain a range expression +maybeValidationRange :: ValidationType -> Maybe Range +maybeValidationRange (ValidationTypeList (RangeExpression re)) = Just re +maybeValidationRange _ = Nothing + +readListFormulas :: Formula -> Maybe ListOrRangeExpression +readListFormulas (Formula f) = readQuotedList f <|> readUnquotedCellRange f where readQuotedList t | Just t' <- T.stripPrefix "\"" (T.dropAround isSpace t) , Just t'' <- T.stripSuffix "\"" t' - = Just $ map (T.dropAround isSpace) $ T.splitOn "," t'' + = Just . ListExpression $ map (T.dropAround isSpace) $ T.splitOn "," t'' | otherwise = Nothing + readUnquotedCellRange t = + -- a CellRef expression of a range (this is not validated beyond the absence of quotes) + -- note that the foreign sheet name can be 'single-quoted' + let stripped = T.dropAround isSpace t + in RangeExpression (CellRef stripped) <$ guard (not (T.null stripped)) -- This parser expects a comma-separated list surrounded by quotation marks. -- Spaces around the quotation marks and commas are removed, but inner spaces -- are kept. -- -- The parser seems to be consistent with how Excel treats list formulas, but -- I wasn't able to find a specification of the format. + -- + -- Addendum: undescriminately designates an actual list or a cell range. + -- For a cell range validation, instead of a quoted list, it's an unquoted CellRef-like contents of the form: + -- ActualSheetName!$C$2:$C$18 readOpExpression2 :: Text -> Cursor -> [ValidationExpression] readOpExpression2 op cur | op `elem` ["between", "notBetween"] = do - f1 <- cur $/ element (n_ "formula1") >=> fromCursor - f2 <- cur $/ element (n_ "formula2") >=> fromCursor + f1 <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor + f2 <- cur $/ element (addSmlNamespace "formula2") >=> fromCursor readValExpression op [f1,f2] readOpExpression2 op cur = do - f <- cur $/ element (n_ "formula1") >=> fromCursor + f <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor readValExpression op [f] readValidationTypeOpExp :: Text -> ValidationExpression -> [ValidationType] @@ -207,7 +332,14 @@ ValidationTypeTime f -> opExp $ viewValidationExpression f ValidationTypeWhole f -> opExp $ viewValidationExpression f ValidationTypeList as -> - let f = Formula $ "\"" <> T.intercalate "," as <> "\"" + let renderPlainList l = + let csvFy = T.intercalate "," + reQuote x = '"' `T.cons` x `T.snoc` '"' + in reQuote (csvFy l) + f = Formula $ + case as of + RangeExpression re -> unCellRef re + ListExpression le -> renderPlainList le in (Nothing, Just f, Nothing) viewValidationExpression :: ValidationExpression -> (Text, Formula, Maybe Formula) @@ -219,4 +351,3 @@ viewValidationExpression (ValLessThanOrEqual f) = ("lessThanOrEqual", f, Nothing) viewValidationExpression (ValNotBetween f1 f2) = ("notBetween", f1, Just f2) viewValidationExpression (ValNotEqual f) = ("notEqual", f, Nothing) - diff --git a/src/Codec/Xlsx/Types/Drawing.hs b/src/Codec/Xlsx/Types/Drawing.hs --- a/src/Codec/Xlsx/Types/Drawing.hs +++ b/src/Codec/Xlsx/Types/Drawing.hs @@ -1,52 +1,54 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Drawing where -import Control.Lens.TH -import Data.ByteString.Lazy (ByteString) -import Data.Default -import qualified Data.Map as M -import Data.Maybe (catMaybes, - listToMaybe) -import Data.Text (Text) -import Text.XML -import Text.XML.Cursor - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Control.Arrow (first) +import Control.DeepSeq (NFData) +import Codec.Xlsx.LensCompat (makeLenses) +import Data.ByteString.Lazy (ByteString) +import Data.Default +import qualified Data.Map as M +import Data.Maybe (catMaybes, listToMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Drawing.Common -import Codec.Xlsx.Types.Drawing.Chart -import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Types.Internal.Relationships -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Drawing.Chart +import Codec.Xlsx.Types.Drawing.Common +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Types.Internal.Relationships +import Codec.Xlsx.Writer.Internal -- | information about image file as a par of a drawing data FileInfo = FileInfo { _fiFilename :: FilePath - -- ^ image filename, images are assumed to be stored under path "xl/media/" + -- ^ image filename, images are assumed to be stored under path "xl\/media\/" , _fiContentType :: Text - -- ^ image content type, ECMA-376 advises to use "image/png" or "image/jpeg" + -- ^ image content type, ECMA-376 advises to use "image\/png" or "image\/jpeg" -- if interoperability is wanted , _fiContents :: ByteString -- ^ image file contents - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData FileInfo data Marker = Marker { _mrkCol :: Int , _mrkColOff :: Coordinate , _mrkRow :: Int , _mrkRowOff :: Coordinate - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData Marker unqMarker :: (Int, Int) -> (Int, Int) -> Marker unqMarker (col, colOff) (row, rowOff) = @@ -56,7 +58,8 @@ = EditAsTwoCell | EditAsOneCell | EditAsAbsolute - deriving (Eq,Show) + deriving (Eq, Show, Generic) +instance NFData EditAs data Anchoring = AbsoluteAnchor @@ -72,7 +75,8 @@ , tcaTo :: Marker , tcaEditAs :: EditAs } - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData Anchoring data DrawingObject p g = Picture { _picMacro :: Maybe Text @@ -86,8 +90,55 @@ , _grChartSpace :: g , _grTransform :: Transform2D} -- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance (NFData p, NFData g) => NFData (DrawingObject p g) +-- | basic function to create picture drawing object +-- +-- /Note:/ specification says that drawing element ids need to be +-- unique within 1 document, otherwise /...document shall be +-- considered non-conformant/. +picture :: DrawingElementId -> FileInfo -> DrawingObject FileInfo c +picture dId fi = + Picture + { _picMacro = Nothing + , _picPublished = False + , _picNonVisual = nonVis + , _picBlipFill = bfProps + , _picShapeProperties = shProps + } + where + nonVis = + PicNonVisual $ + NonVisualDrawingProperties + { _nvdpId = dId + , _nvdpName = T.pack $ _fiFilename fi + , _nvdpDescription = Nothing + , _nvdpHidden = False + , _nvdpTitle = Nothing + } + bfProps = + BlipFillProperties + {_bfpImageInfo = Just fi, _bfpFillMode = Just FillStretch} + shProps = + ShapeProperties + { _spXfrm = Nothing + , _spGeometry = Nothing + , _spFill = Just NoFill + , _spOutline = Just $ def {_lnFill = Just NoFill} + } + +-- | helper to retrive information about all picture files in +-- particular drawing alongside with their anchorings (i.e. sizes and +-- positions) +extractPictures :: Drawing -> [(Anchoring, FileInfo)] +extractPictures dr = mapMaybe maybePictureInfo $ _xdrAnchors dr + where + maybePictureInfo Anchor {..} = + case _anchObject of + Picture {..} -> (_anchAnchoring,) <$> _bfpImageInfo _picBlipFill + _ -> Nothing + -- | This element is used to set certain properties related to a drawing -- element on the client spreadsheet application. -- @@ -99,21 +150,29 @@ , _cldPrintsWithSheet :: Bool -- ^ This attribute indicates whether to print drawing elements -- when printing the sheet. - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData ClientData data PicNonVisual = PicNonVisual { _pnvDrawingProps :: NonVisualDrawingProperties -- TODO: cNvPicPr - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData PicNonVisual data GraphNonVisual = GraphNonVisual { _gnvDrawingProps :: NonVisualDrawingProperties -- TODO cNvGraphicFramePr - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData GraphNonVisual +newtype DrawingElementId = DrawingElementId + { unDrawingElementId :: Int + } deriving (Eq, Show, Generic) +instance NFData DrawingElementId + -- see 20.1.2.2.8 "cNvPr (Non-Visual Drawing Properties)" (p. 2731) data NonVisualDrawingProperties = NonVisualDrawingProperties - { _nvdpId :: Int + { _nvdpId :: DrawingElementId -- ^ Specifies a unique identifier for the current -- DrawingML object within the current -- @@ -126,13 +185,15 @@ -- ^ Alternative Text for Object , _nvdpHidden :: Bool , _nvdpTitle :: Maybe Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData NonVisualDrawingProperties data BlipFillProperties a = BlipFillProperties { _bfpImageInfo :: Maybe a , _bfpFillMode :: Maybe FillMode -- TODO: dpi, rotWithShape, srcRect - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData a => NFData (BlipFillProperties a) -- see @a_EG_FillModeProperties@ (p. 4319) data FillMode @@ -140,18 +201,21 @@ = FillTile -- TODO: tx, ty, sx, sy, flip, algn -- See 20.1.8.56 "stretch (Stretch)" (p. 2879) | FillStretch -- TODO: srcRect - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData FillMode -- See @EG_Anchor@ (p. 4052) data Anchor p g = Anchor { _anchAnchoring :: Anchoring , _anchObject :: DrawingObject p g , _anchClientData :: ClientData - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance (NFData p, NFData g) => NFData (Anchor p g) data GenericDrawing p g = Drawing { _xdrAnchors :: [Anchor p g] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance (NFData p, NFData g) => NFData (GenericDrawing p g) -- See 20.5.2.35 "wsDr (Worksheet Drawing)" (p. 3176) type Drawing = GenericDrawing FileInfo ChartSpace @@ -163,6 +227,22 @@ makeLenses ''BlipFillProperties makeLenses ''GenericDrawing +-- | simple drawing object anchoring using one cell as a top lelft +-- corner and dimensions of that object +simpleAnchorXY :: (Int, Int) -- ^ x+y coordinates of a cell used as + -- top left anchoring corner + -> PositiveSize2D -- ^ size of drawing object to be + -- anchored + -> DrawingObject p g + -> Anchor p g +simpleAnchorXY (x, y) sz obj = + Anchor + { _anchAnchoring = + OneCellAnchor {onecaFrom = unqMarker (x, 0) (y, 0), onecaExt = sz} + , _anchObject = obj + , _anchClientData = def + } + {------------------------------------------------------------------------------- Default instances -------------------------------------------------------------------------------} @@ -256,6 +336,9 @@ _nvdpTitle <- maybeAttribute "title" cur return NonVisualDrawingProperties{..} +instance FromAttrVal DrawingElementId where + fromAttrVal = fmap (first DrawingElementId) . fromAttrVal + instance FromCursor (BlipFillProperties RefId) where fromCursor cur = do let _bfpImageInfo = listToMaybe $ cur $/ element (a_ "blip") >=> @@ -358,8 +441,10 @@ ] instance ToElement PicNonVisual where - toElement nm PicNonVisual{..} = - elementListSimple nm [toElement "cNvPr" _pnvDrawingProps] + toElement nm PicNonVisual {..} = + elementListSimple + nm + [toElement "cNvPr" _pnvDrawingProps, emptyElement "cNvPicPr"] instance ToElement GraphNonVisual where toElement nm GraphNonVisual {..} = @@ -376,6 +461,9 @@ catMaybes [ "descr" .=? _nvdpDescription , "hidden" .=? justTrue _nvdpHidden , "title" .=? _nvdpTitle ] + +instance ToAttrVal DrawingElementId where + toAttrVal = toAttrVal . unDrawingElementId instance ToElement (BlipFillProperties RefId) where toElement nm BlipFillProperties{..} = diff --git a/src/Codec/Xlsx/Types/Drawing/Chart.hs b/src/Codec/Xlsx/Types/Drawing/Chart.hs --- a/src/Codec/Xlsx/Types/Drawing/Chart.hs +++ b/src/Codec/Xlsx/Types/Drawing/Chart.hs @@ -1,22 +1,23 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} 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 GHC.Generics (Generic) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Codec.Xlsx.LensCompat (makeLenses) +import Control.DeepSeq (NFData) +import Data.Default +import Data.Maybe (catMaybes, listToMaybe, maybeToList) +import Data.Text (Text) +import Text.XML +import Text.XML.Cursor -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 @@ -27,14 +28,16 @@ , _chspLegend :: Maybe Legend , _chspPlotVisOnly :: Maybe Bool , _chspDispBlanksAs :: Maybe DispBlanksAs - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData ChartSpace -- | Chart title -- -- TODO: layout, overlay, spPr, txPr, extLst newtype ChartTitle = - ChartTitle TextBody - deriving (Eq, Show) + ChartTitle (Maybe TextBody) + deriving (Eq, Show, Generic) +instance NFData ChartTitle -- | This simple type specifies the possible ways to display blanks. -- @@ -46,13 +49,15 @@ -- ^ Specifies that blank values shall be spanned with a line. | DispBlanksAsZero -- ^ Specifies that blank values shall be treated as zero. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData DispBlanksAs -- TODO: legendEntry, layout, overlay, spPr, txPr, extLst data Legend = Legend { _legendPos :: Maybe LegendPos , _legendOverlay :: Maybe Bool - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData Legend -- See 21.2.3.24 "ST_LegendPos (Legend Position)" (p. 3449) data LegendPos @@ -71,24 +76,39 @@ | LegendTopRight -- ^ tr (Top Right) Specifies that the legend shall be drawn at -- the top right of the chart. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData LegendPos -- | 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 BarChartGrouping + , _brchSeries :: [BarSeries] + } + | PieChart { _pichSeries :: [PieSeries] + } + | ScatterChart { _scchStyle :: ScatterStyle + , _scchSeries :: [ScatterSeries] + } + deriving (Eq, Show, Generic) +instance NFData Chart --- | Possible groupings for a bar chart +-- | Possible groupings for a chart -- -- See 21.2.3.17 "ST_Grouping (Grouping)" (p. 3446) data ChartGrouping @@ -101,8 +121,65 @@ | StandardGrouping -- ^(Standard) Specifies that the chart series are drawn on the value -- axis. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData ChartGrouping +-- | Possible groupings for a bar chart +-- +-- See 21.2.3.4 "ST_BarGrouping (Bar Grouping)" (p. 3441) +data BarChartGrouping + = BarClusteredGrouping + -- ^ Specifies that the chart series are drawn next to each other + -- along the category axis. + | BarPercentStackedGrouping + -- ^ (100% Stacked) Specifies that the chart series are drawn next to each + -- other along the value axis and scaled to total 100%. + | BarStackedGrouping + -- ^ (Stacked) Specifies that the chart series are drawn next to each + -- other on the value axis. + | BarStandardGrouping + -- ^(Standard) Specifies that the chart series are drawn on the value + -- axis. + deriving (Eq, Show, Generic) +instance NFData BarChartGrouping + +-- | Possible directions for a bar chart +-- +-- See 21.2.3.3 "ST_BarDir (Bar Direction)" (p. 3441) +data BarDirection + = DirectionBar + | DirectionColumn + deriving (Eq, Show, Generic) +instance NFData BarDirection + +-- | 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, Generic) +instance NFData ScatterStyle + +-- | 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, Generic) +instance NFData DataPoint + -- | Specifies common series options -- TODO: spPr -- @@ -111,7 +188,9 @@ { _serTx :: Maybe Formula -- ^ specifies text for a series name, without rich text formatting -- currently only reference formula is supported - } deriving (Eq, Show) + , _serShapeProperties :: Maybe ShapeProperties + } deriving (Eq, Show, Generic) +instance NFData Series -- | A series on a line chart -- @@ -125,14 +204,71 @@ , _lnserVal :: Maybe Formula -- ^ currently only reference formula is supported , _lnserSmooth :: Maybe Bool - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData LineSeries +-- | 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, Generic) +instance NFData AreaSeries + +-- | 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, Generic) +instance NFData BarSeries + +-- | 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, Generic) +instance NFData PieSeries + +-- | 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, Generic) +instance NFData ScatterSeries + -- See @CT_Marker@ (p. 4061) data DataMarker = DataMarker { _dmrkSymbol :: Maybe DataMarkerSymbol , _dmrkSize :: Maybe Int -- ^ integer between 2 and 72, specifying a size in points - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData DataMarker data DataMarkerSymbol = DataMarkerCircle @@ -147,7 +283,8 @@ | DataMarkerTriangle | DataMarkerX | DataMarkerAuto - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData DataMarkerSymbol -- | Settings for the data labels for an entire series or the -- entire chart @@ -161,7 +298,8 @@ , _dlblShowCatName :: Maybe Bool , _dlblShowSerName :: Maybe Bool , _dlblShowPercent :: Maybe Bool - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData DataLblProps -- | Specifies the possible positions for tick marks. @@ -175,9 +313,19 @@ -- ^ (None) Specifies there shall be no tick marks. | TickMarkOut -- ^ (Outside) Specifies the tick marks shall be outside the plot area. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData TickMark +makeLenses ''DataPoint + {------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default DataPoint where + def = DataPoint Nothing Nothing + +{------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -200,6 +348,23 @@ _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 <- + maybeElementValueDef (c_ "grouping") BarClusteredGrouping 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 +380,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 +437,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 +458,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 @@ -259,9 +487,18 @@ fromAttrVal "stacked" = readSuccess StackedGrouping fromAttrVal t = invalidText "ChartGrouping" t +instance FromAttrVal BarChartGrouping where + fromAttrVal "clustered" = readSuccess BarClusteredGrouping + fromAttrVal "percentStacked" = readSuccess BarPercentStackedGrouping + fromAttrVal "standard" = readSuccess BarStandardGrouping + fromAttrVal "stacked" = readSuccess BarStackedGrouping + fromAttrVal t = invalidText "BarChartGrouping" t + instance FromCursor ChartTitle where - fromCursor cur = - cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fmap ChartTitle . fromCursor + fromCursor cur = do + let mTitle = listToMaybe $ + cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fromCursor + return $ ChartTitle mTitle instance FromCursor Legend where fromCursor cur = do @@ -305,7 +542,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 +554,155 @@ , 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" [] noGrouping _pichSeries [] [] + ScatterChart {..} -> + chartElement + "scatterChart" + xyAxes + noGrouping + _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 + noGrouping :: Maybe ChartGrouping + noGrouping = Nothing + chartElement + :: (ToElement s, ToAttrVal gr) + => Name + -> [Element] + -> Maybe gr + -> [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 BarChartGrouping where + toAttrVal BarClusteredGrouping = "clustered" + toAttrVal BarPercentStackedGrouping = "percentStacked" + toAttrVal BarStandardGrouping = "standard" + toAttrVal BarStackedGrouping = "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,21 +738,62 @@ , 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) = elementListSimple nm [txEl, elementValue "overlay" False] where - txEl = elementListSimple "tx" [toElement (c_ "rich") body] + txEl = elementListSimple "tx" $ catMaybes [toElement (c_ "rich") <$> body] instance ToElement Legend where toElement nm Legend{..} = elementListSimple nm elements @@ -459,10 +802,10 @@ , elementValue "overlay" <$>_legendOverlay] instance ToAttrVal LegendPos where - toAttrVal LegendBottom = "b" - toAttrVal LegendLeft = "l" - toAttrVal LegendRight = "r" - toAttrVal LegendTop = "t" + toAttrVal LegendBottom = "b" + toAttrVal LegendLeft = "l" + toAttrVal LegendRight = "r" + toAttrVal LegendTop = "t" toAttrVal LegendTopRight = "tr" instance ToAttrVal DispBlanksAs where diff --git a/src/Codec/Xlsx/Types/Drawing/Common.hs b/src/Codec/Xlsx/Types/Drawing/Common.hs --- a/src/Codec/Xlsx/Types/Drawing/Common.hs +++ b/src/Codec/Xlsx/Types/Drawing/Common.hs @@ -1,32 +1,35 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} 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 GHC.Generics (Generic) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Control.Arrow (first) +import Codec.Xlsx.LensCompat (makeLenses) +import Control.Monad (join) +import Control.Monad.Fail (MonadFail) +import Control.DeepSeq (NFData) +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 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 -- angles are counter-clockwise (i.e., towards the negative y axis). newtype Angle = Angle Int - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData Angle -- | A string with rich text formatting -- @@ -56,8 +59,10 @@ -- aligns the text within the "bounds box" for the text. , _txbdParagraphs :: [TextParagraph] -- ^ Paragraphs of text within the containing text body - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData TextBody + -- | Text vertical overflow -- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083) data TextVertOverflow @@ -69,7 +74,8 @@ -- there is text which is not visible. | TextVertOverflow -- ^ Overflow the text and pay no attention to top and bottom barriers. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData TextVertOverflow -- | If there is vertical text, determines what kind of vertical text is going to be used. -- @@ -98,7 +104,8 @@ | TextVerticalWordArtRtl -- ^ Specifies that vertical WordArt should be shown from right to left rather than -- left to right. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData TextVertical -- | Text wrapping types -- @@ -109,7 +116,8 @@ -- paying attention to the bounding rectangle boundaries. | TextWrapSquare -- ^ Determines whether we wrap words within the bounding rectangle. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData TextWrap -- | This type specifies a list of available anchoring types for text. -- @@ -135,13 +143,15 @@ -- text in a line, it does not justify. | TextAnchoringTop -- ^ Anchor the text at the top of the bounding rectangle. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData TextAnchoring -- See 21.1.2.2.6 "p (Text Paragraphs)" (p. 3211) data TextParagraph = TextParagraph { _txpaDefCharProps :: Maybe TextCharacterProperties , _txpaRuns :: [TextRun] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData TextParagraph -- | Text character properties -- @@ -156,7 +166,8 @@ { _txchBold :: Bool , _txchItalic :: Bool , _txchUnderline :: Bool - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData TextCharacterProperties -- | Text run -- @@ -164,7 +175,8 @@ data TextRun = RegularRun { _txrCharProps :: Maybe TextCharacterProperties , _txrText :: Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData TextRun -- | This simple type represents a one dimensional position or length -- @@ -175,7 +187,8 @@ | UniversalMeasure UnitIdentifier Double -- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData Coordinate -- | Units used in "Universal measure" coordinates -- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) @@ -186,13 +199,15 @@ | UnitPt -- "pt" 1 pt = 1/72 in (informative) | UnitPc -- "pc" 1 pc = 12 pt (informative) | UnitPi -- "pi" 1 pi = 12 pt (informative) - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData UnitIdentifier -- See @CT_Point2D@ (p. 3989) data Point2D = Point2D { _pt2dX :: Coordinate , _pt2dY :: Coordinate - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData Point2D unqPoint2D :: Int -> Int -> Point2D unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y) @@ -201,13 +216,25 @@ -- see 20.1.10.41 "ST_PositiveCoordinate (Positive Coordinate)" (p. 2942) newtype PositiveCoordinate = PositiveCoordinate Integer - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData PositiveCoordinate data PositiveSize2D = PositiveSize2D { _ps2dX :: PositiveCoordinate , _ps2dY :: PositiveCoordinate - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData PositiveSize2D +positiveSize2D :: Integer -> Integer -> PositiveSize2D +positiveSize2D x y = + PositiveSize2D (PositiveCoordinate x) (PositiveCoordinate y) + +cmSize2D :: Integer -> Integer -> PositiveSize2D +cmSize2D x y = positiveSize2D (cm2emu x) (cm2emu y) + +cm2emu :: Integer -> Integer +cm2emu cm = 360000 * cm + -- See 20.1.7.6 "xfrm (2D Transform for Individual Objects)" (p. 2849) data Transform2D = Transform2D { _trRot :: Angle @@ -223,14 +250,16 @@ , _trExtents :: Maybe PositiveSize2D -- ^ See 20.1.7.3 "ext (Extents)" (p. 2846) or -- 20.5.2.14 "ext (Shape Extent)" (p. 3165) - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData Transform2D -- TODO: custGeom data Geometry = PresetGeometry -- TODO: prst, avList -- currently uses "rect" with empty avList - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData Geometry -- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751) data ShapeProperties = ShapeProperties @@ -239,25 +268,56 @@ , _spFill :: Maybe FillProperties , _spOutline :: Maybe LineProperties -- TODO: bwMode, a_EG_EffectProperties, scene3d, sp3d, extLst - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData ShapeProperties +-- | 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 - } deriving (Eq, Show) + , _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, Generic) +instance NFData LineProperties +-- | 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, Generic) +instance NFData ColorChoice + -- 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) + deriving (Eq, Show, Generic) +instance NFData FillProperties +-- | solid fill with color specified by hexadecimal RGB color +solidRgb :: Text -> FillProperties +solidRgb t = SolidFill . Just $ RgbColor t + +makeLenses ''ShapeProperties + {------------------------------------------------------------------------------- Default instances -------------------------------------------------------------------------------} @@ -265,6 +325,9 @@ instance Default ShapeProperties where def = ShapeProperties Nothing Nothing Nothing Nothing +instance Default LineProperties where + def = LineProperties Nothing 0 + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -366,6 +429,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 @@ -384,11 +448,22 @@ 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" -coordinate :: Monad m => Text -> m Coordinate +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 :: MonadFail m => Text -> m Coordinate coordinate t = case T.decimal t of Right (d, leftover) | leftover == T.empty -> return $ UnqCoordinate d @@ -517,15 +592,23 @@ , toElement (a_ "ext") <$> _trExtents ] geometryToElement :: Geometry -> Element -geometryToElement PresetGeometry = emptyElement (a_ "prstGeom") +geometryToElement PresetGeometry = + leafElement (a_ "prstGeom") ["prst" .= ("rect" :: Text)] instance ToElement LineProperties where - toElement nm LineProperties{..} = - elementListSimple nm $ catMaybes [ fillPropsToElement <$> _lnFill ] + toElement nm LineProperties {..} = elementList nm attrs elements + where + attrs = catMaybes ["w" .=? justNonDef 0 _lnWidth] + elements = catMaybes [fillPropsToElement <$> _lnFill] fillPropsToElement :: FillProperties -> Element fillPropsToElement NoFill = emptyElement (a_ "noFill") -fillPropsToElement SolidFill = emptyElement (a_ "solidFill") +fillPropsToElement (SolidFill color) = + elementListSimple (a_ "solidFill") $ catMaybes [colorChoiceToElement <$> color] + +colorChoiceToElement :: ColorChoice -> Element +colorChoiceToElement (RgbColor color) = + leafElement (a_ "srgbClr") ["val" .= color] -- | Add DrawingML namespace to name a_ :: Text -> Name diff --git a/src/Codec/Xlsx/Types/Internal.hs b/src/Codec/Xlsx/Types/Internal.hs --- a/src/Codec/Xlsx/Types/Internal.hs +++ b/src/Codec/Xlsx/Types/Internal.hs @@ -1,20 +1,3 @@ -{-# LANGUAGE CPP #-} -module Codec.Xlsx.Types.Internal where - -import Control.Arrow -import Data.Text (Text) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Writer.Internal - -newtype RefId = RefId { unRefId :: Text } deriving (Show, Eq, Ord) - -instance ToAttrVal RefId where - toAttrVal = toAttrVal . unRefId +module Codec.Xlsx.Types.Internal (module Codec.Xlsx.Types.RefId) where -instance FromAttrVal RefId where - fromAttrVal t = first RefId <$> fromAttrVal t +import Codec.Xlsx.Types.RefId diff --git a/src/Codec/Xlsx/Types/Internal/CfPair.hs b/src/Codec/Xlsx/Types/Internal/CfPair.hs --- a/src/Codec/Xlsx/Types/Internal/CfPair.hs +++ b/src/Codec/Xlsx/Types/Internal/CfPair.hs @@ -1,13 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.CfPair where -import Text.XML.Cursor - -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Common -import Codec.Xlsx.Types.ConditionalFormatting -import Codec.Xlsx.Writer.Internal +import GHC.Generics (Generic) +import Text.XML.Cursor +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.ConditionalFormatting +import Codec.Xlsx.Writer.Internal -- | Internal helper type for parsing "conditionalFormatting recods -- TODO: pivot, extList @@ -16,13 +17,19 @@ -- See 18.3.1.18 "conditionalFormatting (Conditional Formatting)" (p. 1610) newtype CfPair = CfPair { unCfPair :: (SqRef, ConditionalFormatting) - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) instance FromCursor CfPair where fromCursor cur = do sqref <- fromAttribute "sqref" cur - let cfRules = cur $/ element (n_ "cfRule") >=> fromCursor + let cfRules = cur $/ element (addSmlNamespace "cfRule") >=> fromCursor return $ CfPair (sqref, cfRules) + +instance FromXenoNode CfPair where + fromXenoNode root = do + sqref <- parseAttributes root $ fromAttr "sqref" + cfRules <- collectChildren root $ fromChildList "cfRule" + return $ CfPair (sqref, cfRules) instance ToElement CfPair where toElement nm (CfPair (sqRef, cfRules)) = diff --git a/src/Codec/Xlsx/Types/Internal/CommentTable.hs b/src/Codec/Xlsx/Types/Internal/CommentTable.hs --- a/src/Codec/Xlsx/Types/Internal/CommentTable.hs +++ b/src/Codec/Xlsx/Types/Internal/CommentTable.hs @@ -1,33 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.CommentTable where -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LB +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Char8 as LBC8 -import Data.List.Extra (nubOrd) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Data.Text.Lazy (toStrict) -import qualified Data.Text.Lazy.Builder as B +import Data.List.Extra (nubOrd) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Lazy (toStrict) +import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.Builder.Int as B -import Safe -import Text.XML -import Text.XML.Cursor +import GHC.Generics (Generic) +import Safe +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 +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Comment +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Writer.Internal newtype CommentTable = CommentTable { _commentsTable :: Map CellRef Comment } - deriving (Show, Eq) + deriving (Eq, Show, Generic) +tshow :: Show a => a -> Text +tshow = Text.pack . show + fromList :: [(CellRef, Comment)] -> CommentTable fromList = CommentTable . M.fromList +toList :: CommentTable -> [(CellRef, Comment)] +toList = M.toList . _commentsTable + lookupComment :: CellRef -> CommentTable -> Maybe Comment lookupComment ref = M.lookup ref . _commentsTable @@ -46,7 +55,8 @@ commentToEl (ref, Comment{..}) = Element { elementName = "comment" , elementAttributes = M.fromList [ ("ref" .= ref) - , ("authorId" .= lookupAuthor _commentAuthor)] + , ("authorId" .= lookupAuthor _commentAuthor) + , ("visible" .= tshow _commentVisible)] , elementNodes = [NodeElement $ toElement "text" _commentText] } lookupAuthor a = fromJustNote "author lookup" $ M.lookup a authorIds @@ -58,18 +68,20 @@ instance FromCursor CommentTable where fromCursor cur = do - let authorNames = cur $/ element (n_ "authors") &/ element (n_ "author") >=> contentOrEmpty + let authorNames = cur $/ element (addSmlNamespace "authors") &/ element (addSmlNamespace "author") >=> contentOrEmpty authors = M.fromList $ zip [0..] authorNames - items = cur $/ element (n_ "commentList") &/ element (n_ "comment") >=> parseComment authors + items = cur $/ element (addSmlNamespace "commentList") &/ element (addSmlNamespace "comment") >=> parseComment authors return . CommentTable $ M.fromList items parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)] parseComment authors cur = do ref <- fromAttribute "ref" cur - txt <- cur $/ element (n_ "text") >=> fromCursor + txt <- cur $/ element (addSmlNamespace "text") >=> fromCursor authorId <- cur $| attribute "authorId" >=> decimal + visible <- (read . Text.unpack :: Text -> Bool) + <$> (fromAttribute "visible" cur :: [Text]) let author = fromJustNote "authorId" $ M.lookup authorId authors - return (ref, Comment txt author True) + return (ref, Comment txt author visible) -- | helper to render comment baloons vml file, -- currently uses fixed shape @@ -90,7 +102,8 @@ , "" , "" ] - fromRef = fromJustNote "Invalid comment ref" . fromSingleCellRef + fromRef cr = + fromJustNote ("Invalid comment ref: " <> show cr) $ fromSingleCellRef cr commentShapes = [ commentShape (fromRef ref) (_commentVisible cmnt) | (ref, cmnt) <- M.toList m ] commentShape (r, c) v = LB.concat diff --git a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs --- a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs +++ b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs @@ -1,38 +1,35 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.ContentTypes where -import Control.Arrow -import Data.Foldable (asum) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import System.FilePath.Posix (takeExtension) -import Text.XML -import Text.XML.Cursor - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Control.Arrow +import Data.Foldable (asum) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.FilePath.Posix (takeExtension) +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Parser.Internal data CtDefault = CtDefault { dfltExtension :: FilePath , dfltContentType :: Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) data Override = Override { ovrPartName :: FilePath , ovrContentType :: Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) data ContentTypes = ContentTypes { ctDefaults :: Map FilePath Text , ctTypes :: Map FilePath Text - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) lookup :: FilePath -> ContentTypes -> Maybe Text lookup path ContentTypes{..} = diff --git a/src/Codec/Xlsx/Types/Internal/CustomProperties.hs b/src/Codec/Xlsx/Types/Internal/CustomProperties.hs --- a/src/Codec/Xlsx/Types/Internal/CustomProperties.hs +++ b/src/Codec/Xlsx/Types/Internal/CustomProperties.hs @@ -1,18 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.CustomProperties where -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import Text.XML -import Text.XML.Cursor +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Variant -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Variant +import Codec.Xlsx.Writer.Internal newtype CustomProperties = CustomProperties (Map Text Variant) - deriving (Show, Eq) + deriving (Eq, Show, Generic) fromList :: [(Text, Variant)] -> CustomProperties fromList = CustomProperties . M.fromList diff --git a/src/Codec/Xlsx/Types/Internal/DvPair.hs b/src/Codec/Xlsx/Types/Internal/DvPair.hs --- a/src/Codec/Xlsx/Types/Internal/DvPair.hs +++ b/src/Codec/Xlsx/Types/Internal/DvPair.hs @@ -1,27 +1,34 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.DvPair where -import qualified Data.Map as M -import Text.XML (Element (..)) - -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Common -import Codec.Xlsx.Types.DataValidation -import Codec.Xlsx.Writer.Internal +import qualified Data.Map as M +import GHC.Generics (Generic) +import Text.XML (Element(..)) +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.DataValidation +import Codec.Xlsx.Writer.Internal -- | Internal helper type for parsing data validation records -- -- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624) newtype DvPair = DvPair { unDvPair :: (SqRef, DataValidation) - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) instance FromCursor DvPair where fromCursor cur = do sqref <- fromAttribute "sqref" cur dv <- fromCursor cur return $ DvPair (sqref, dv) + +instance FromXenoNode DvPair where + fromXenoNode root = do + sqref <- parseAttributes root $ fromAttr "sqref" + dv <- fromXenoNode root + return $ DvPair (sqref, dv) instance ToElement DvPair where toElement nm (DvPair (sqRef,dv)) = e diff --git a/src/Codec/Xlsx/Types/Internal/FormulaData.hs b/src/Codec/Xlsx/Types/Internal/FormulaData.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/FormulaData.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Types.Internal.FormulaData where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Cell +import Codec.Xlsx.Types.Common + +data FormulaData = FormulaData + { frmdFormula :: CellFormula + , frmdShared :: Maybe (SharedFormulaIndex, SharedFormulaOptions) + } deriving Generic + +defaultFormulaType :: Text +defaultFormulaType = "normal" + +instance FromXenoNode FormulaData where + fromXenoNode n = do + (bx, ca, t, mSi, mRef) <- + parseAttributes n $ + (,,,,) <$> fromAttrDef "bx" False + <*> fromAttrDef "ca" False + <*> fromAttrDef "t" defaultFormulaType + <*> maybeAttr "si" + <*> maybeAttr "ref" + (expr, shared) <- + case t of + d | d == defaultFormulaType -> do + formula <- contentX n + return (NormalFormula $ Formula formula, Nothing) + "shared" -> do + si <- + maybe + (Left "missing si attribute for shared formula") + return + mSi + formula <- Formula <$> contentX n + return + ( SharedFormula si + , mRef >>= \ref -> return (si, (SharedFormulaOptions ref formula))) + unexpected -> Left $ "Unexpected formula type" <> T.pack (show unexpected) + let f = + CellFormula + { _cellfAssignsToName = bx + , _cellfCalculate = ca + , _cellfExpression = expr + } + return $ FormulaData f shared diff --git a/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs b/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs deleted file mode 100644 --- a/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Codec.Xlsx.Types.Internal.NumFmtPair where - -import Data.Text (Text) - -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Writer.Internal - --- | Internal helper type for parsing "numFmt" recods --- --- See 18.8.30 "numFmt (Number Format)" (p. 1777) -newtype NumFmtPair = NumFmtPair - { unNumFmtPair :: (Int, Text) - } deriving (Eq, Show) - -instance FromCursor NumFmtPair where - fromCursor cur = do - fId <- fromAttribute "numFmtId" cur - fCode <- fromAttribute "formatCode" cur - return $ NumFmtPair (fId, fCode) - -instance ToElement NumFmtPair where - toElement nm (NumFmtPair (fId, fCode)) = - leafElement nm [ "numFmtId" .= toAttrVal fId - , "formatCode" .= toAttrVal fCode ] diff --git a/src/Codec/Xlsx/Types/Internal/Relationships.hs b/src/Codec/Xlsx/Types/Internal/Relationships.hs --- a/src/Codec/Xlsx/Types/Internal/Relationships.hs +++ b/src/Codec/Xlsx/Types/Internal/Relationships.hs @@ -1,32 +1,29 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.Relationships where -import Data.List (find) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as T -import Network.URI hiding (path) -import Prelude hiding (abs, lookup) -import Safe -import Text.XML -import Text.XML.Cursor - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Data.List (find) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Network.URI hiding (path) +import Prelude hiding (abs, lookup) +import Safe +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Writer.Internal data Relationship = Relationship { relType :: Text , relTarget :: FilePath - } deriving (Show, Eq) + } deriving (Eq, Show, Generic) -- | Describes relationships according to Open Packaging Convention -- @@ -34,7 +31,7 @@ -- Conventions newtype Relationships = Relationships { relMap :: Map RefId Relationship - } deriving (Show, Eq) + } deriving (Eq, Show, Generic) fromList :: [(RefId, Relationship)] -> Relationships fromList = Relationships . Map.fromList diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs --- a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.SharedStringTable ( -- * Main types SharedStringTable(..) @@ -10,22 +11,22 @@ , sstEmpty ) where -import Control.Monad - -import qualified Data.Map as Map -import Data.Maybe (mapMaybe) -import qualified Data.Set as Set -import Data.Text (Text) -import Data.Vector (Vector) -import qualified Data.Vector as V -import Numeric.Search.Range (searchFromTo) -import Safe (fromJustNote) -import Text.XML -import Text.XML.Cursor +import Control.Monad +import qualified Data.Map as Map +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Vector (Vector) +import qualified Data.Vector as V +import GHC.Generics (Generic) +import Numeric.Search.Range (searchFromTo) +import Safe (fromJustNote) +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types +import Codec.Xlsx.Writer.Internal -- | Shared string table -- @@ -36,7 +37,7 @@ -- reading and writing the repetitive information once. -- -- Relevant parts of the EMCA standard (2nd edition, part 1, --- ), +-- ), -- page numbers refer to the page in the PDF rather than the page number as -- printed on the page): -- @@ -47,7 +48,7 @@ newtype SharedStringTable = SharedStringTable { sstTable :: Vector XlsxText } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) sstEmpty :: SharedStringTable sstEmpty = SharedStringTable V.empty @@ -81,7 +82,7 @@ instance FromCursor SharedStringTable where fromCursor cur = do let - items = cur $/ element (n_ "si") >=> fromCursor + items = cur $/ element (addSmlNamespace "si") >=> fromCursor return (SharedStringTable (V.fromList items)) {------------------------------------------------------------------------------- @@ -116,5 +117,5 @@ fromJustNote ("SST entry for " ++ show si ++ " not found") $ searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1) -sstItem :: SharedStringTable -> Int -> XlsxText -sstItem (SharedStringTable shared) = (V.!) shared +sstItem :: SharedStringTable -> Int -> Maybe XlsxText +sstItem (SharedStringTable shared) = (V.!?) shared diff --git a/src/Codec/Xlsx/Types/PageSetup.hs b/src/Codec/Xlsx/Types/PageSetup.hs --- a/src/Codec/Xlsx/Types/PageSetup.hs +++ b/src/Codec/Xlsx/Types/PageSetup.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.PageSetup ( -- * Main types PageSetup(..) --- , renderPageSetup -- * Enumerations , CellComments(..) , PrintErrors(..) @@ -34,12 +34,14 @@ , pageSetupVerticalDpi ) where -import Control.Lens (makeLenses) +import Codec.Xlsx.LensCompat (makeLenses) +import Control.DeepSeq (NFData) import Data.Default +import qualified Data.Map as Map import Data.Maybe (catMaybes) import Data.Text (Text) +import GHC.Generics (Generic) import Text.XML -import qualified Data.Map as Map import Codec.Xlsx.Writer.Internal import Codec.Xlsx.Parser.Internal @@ -134,7 +136,8 @@ -- | Vertical print resolution of the device. , _pageSetupVerticalDpi :: Maybe Int } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData PageSetup {------------------------------------------------------------------------------- Enumerations @@ -155,7 +158,8 @@ -- | Do not print cell comments | CellCommentsNone - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData CellComments -- | Print errors -- @@ -173,14 +177,16 @@ -- | Display cell errors as @#N/A@ | PrintErrorsNA - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData PrintErrors -- | Print orientation for this sheet data Orientation = OrientationDefault | OrientationLandscape | OrientationPortrait - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Orientation -- | Specifies printed page order data PageOrder = @@ -189,7 +195,8 @@ -- | Order pages horizontally first, then move vertically | PageOrderOverThenDown - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData PageOrder -- | Paper size data PaperSize = @@ -259,7 +266,8 @@ | EnvelopeInvite -- ^ Invite envelope (220 mm by 220 mm) | EnvelopeItaly -- ^ Italy envelope (110 mm by 230 mm) | EnvelopeMonarch -- ^ Monarch envelope (3.875 in. by 7.5 in.). - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData PaperSize {------------------------------------------------------------------------------- Default instances @@ -298,10 +306,6 @@ Rendering -------------------------------------------------------------------------------} ----- | Render page setup ---renderPageSetup :: PageSetup -> RawPageSetup ---renderPageSetup = RawPageSetup . NodeElement . toElement "pageSetup" - -- | See @CT_PageSetup@, p. 3922 instance ToElement PageSetup where toElement nm PageSetup{..} = Element { @@ -450,6 +454,30 @@ _pageSetupId <- maybeAttribute "id" cur return PageSetup{..} +instance FromXenoNode PageSetup where + fromXenoNode root = + parseAttributes root $ do + _pageSetupPaperSize <- maybeAttr "paperSize" + _pageSetupPaperHeight <- maybeAttr "paperHeight" + _pageSetupPaperWidth <- maybeAttr "paperWidth" + _pageSetupScale <- maybeAttr "scale" + _pageSetupFirstPageNumber <- maybeAttr "firstPageNumber" + _pageSetupFitToWidth <- maybeAttr "fitToWidth" + _pageSetupFitToHeight <- maybeAttr "fitToHeight" + _pageSetupPageOrder <- maybeAttr "pageOrder" + _pageSetupOrientation <- maybeAttr "orientation" + _pageSetupUsePrinterDefaults <- maybeAttr "usePrinterDefaults" + _pageSetupBlackAndWhite <- maybeAttr "blackAndWhite" + _pageSetupDraft <- maybeAttr "draft" + _pageSetupCellComments <- maybeAttr "cellComments" + _pageSetupUseFirstPageNumber <- maybeAttr "useFirstPageNumber" + _pageSetupErrors <- maybeAttr "errors" + _pageSetupHorizontalDpi <- maybeAttr "horizontalDpi" + _pageSetupVerticalDpi <- maybeAttr "verticalDpi" + _pageSetupCopies <- maybeAttr "copies" + _pageSetupId <- maybeAttr "id" + return PageSetup {..} + -- | See @paperSize@ (attribute of @pageSetup@), p. 1659 instance FromAttrVal PaperSize where fromAttrVal "1" = readSuccess PaperLetter @@ -520,12 +548,86 @@ fromAttrVal "68" = readSuccess PaperA3ExtraTransverse fromAttrVal t = invalidText "PaperSize" t +instance FromAttrBs PaperSize where + fromAttrBs "1" = return PaperLetter + fromAttrBs "2" = return PaperLetterSmall + fromAttrBs "3" = return PaperTabloid + fromAttrBs "4" = return PaperLedger + fromAttrBs "5" = return PaperLegal + fromAttrBs "6" = return PaperStatement + fromAttrBs "7" = return PaperExecutive + fromAttrBs "8" = return PaperA3 + fromAttrBs "9" = return PaperA4 + fromAttrBs "10" = return PaperA4Small + fromAttrBs "11" = return PaperA5 + fromAttrBs "12" = return PaperB4 + fromAttrBs "13" = return PaperB5 + fromAttrBs "14" = return PaperFolio + fromAttrBs "15" = return PaperQuarto + fromAttrBs "16" = return PaperStandard10_14 + fromAttrBs "17" = return PaperStandard11_17 + fromAttrBs "18" = return PaperNote + fromAttrBs "19" = return Envelope9 + fromAttrBs "20" = return Envelope10 + fromAttrBs "21" = return Envelope11 + fromAttrBs "22" = return Envelope12 + fromAttrBs "23" = return Envelope14 + fromAttrBs "24" = return PaperC + fromAttrBs "25" = return PaperD + fromAttrBs "26" = return PaperE + fromAttrBs "27" = return EnvelopeDL + fromAttrBs "28" = return EnvelopeC5 + fromAttrBs "29" = return EnvelopeC3 + fromAttrBs "30" = return EnvelopeC4 + fromAttrBs "31" = return EnvelopeC6 + fromAttrBs "32" = return EnvelopeC65 + fromAttrBs "33" = return EnvelopeB4 + fromAttrBs "34" = return EnvelopeB5 + fromAttrBs "35" = return EnvelopeB6 + fromAttrBs "36" = return EnvelopeItaly + fromAttrBs "37" = return EnvelopeMonarch + fromAttrBs "38" = return Envelope6_3_4 + fromAttrBs "39" = return PaperFanfoldUsStandard + fromAttrBs "40" = return PaperFanfoldGermanStandard + fromAttrBs "41" = return PaperFanfoldGermanLegal + fromAttrBs "42" = return PaperIsoB4 + fromAttrBs "43" = return PaperJapaneseDoublePostcard + fromAttrBs "44" = return PaperStandard9_11 + fromAttrBs "45" = return PaperStandard10_11 + fromAttrBs "46" = return PaperStandard15_11 + fromAttrBs "47" = return EnvelopeInvite + fromAttrBs "50" = return PaperLetterExtra + fromAttrBs "51" = return PaperLegalExtra + fromAttrBs "52" = return PaperTabloidExtra + fromAttrBs "53" = return PaperA4Extra + fromAttrBs "54" = return PaperLetterTransverse + fromAttrBs "55" = return PaperA4Transverse + fromAttrBs "56" = return PaperLetterExtraTransverse + fromAttrBs "57" = return PaperSuperA + fromAttrBs "58" = return PaperSuperB + fromAttrBs "59" = return PaperLetterPlus + fromAttrBs "60" = return PaperA4Plus + fromAttrBs "61" = return PaperA5Transverse + fromAttrBs "62" = return PaperJisB5Transverse + fromAttrBs "63" = return PaperA3Extra + fromAttrBs "64" = return PaperA5Extra + fromAttrBs "65" = return PaperIsoB5Extra + fromAttrBs "66" = return PaperA2 + fromAttrBs "67" = return PaperA3Transverse + fromAttrBs "68" = return PaperA3ExtraTransverse + fromAttrBs x = unexpectedAttrBs "PaperSize" x + -- | See @ST_PageOrder@, p. 3923 instance FromAttrVal PageOrder where fromAttrVal "downThenOver" = readSuccess PageOrderDownThenOver fromAttrVal "overThenDown" = readSuccess PageOrderOverThenDown fromAttrVal t = invalidText "PageOrder" t +instance FromAttrBs PageOrder where + fromAttrBs "downThenOver" = return PageOrderDownThenOver + fromAttrBs "overThenDown" = return PageOrderOverThenDown + fromAttrBs x = unexpectedAttrBs "PageOrder" x + -- | See @ST_CellComments@, p. 3923 instance FromAttrVal CellComments where fromAttrVal "none" = readSuccess CellCommentsNone @@ -533,6 +635,12 @@ fromAttrVal "atEnd" = readSuccess CellCommentsAtEnd fromAttrVal t = invalidText "CellComments" t +instance FromAttrBs CellComments where + fromAttrBs "none" = return CellCommentsNone + fromAttrBs "asDisplayed" = return CellCommentsAsDisplayed + fromAttrBs "atEnd" = return CellCommentsAtEnd + fromAttrBs x = unexpectedAttrBs "CellComments" x + -- | See @ST_PrintError@, p. 3923 instance FromAttrVal PrintErrors where fromAttrVal "displayed" = readSuccess PrintErrorsDisplayed @@ -541,9 +649,22 @@ fromAttrVal "NA" = readSuccess PrintErrorsNA fromAttrVal t = invalidText "PrintErrors" t +instance FromAttrBs PrintErrors where + fromAttrBs "displayed" = return PrintErrorsDisplayed + fromAttrBs "blank" = return PrintErrorsBlank + fromAttrBs "dash" = return PrintErrorsDash + fromAttrBs "NA" = return PrintErrorsNA + fromAttrBs x = unexpectedAttrBs "PrintErrors" x + -- | See @ST_Orientation@, p. 3923 instance FromAttrVal Orientation where fromAttrVal "default" = readSuccess OrientationDefault fromAttrVal "portrait" = readSuccess OrientationPortrait fromAttrVal "landscape" = readSuccess OrientationLandscape fromAttrVal t = invalidText "Orientation" t + +instance FromAttrBs Orientation where + fromAttrBs "default" = return OrientationDefault + fromAttrBs "portrait" = return OrientationPortrait + fromAttrBs "landscape" = return OrientationLandscape + fromAttrBs x = unexpectedAttrBs "Orientation" x diff --git a/src/Codec/Xlsx/Types/PivotTable.hs b/src/Codec/Xlsx/Types/PivotTable.hs --- a/src/Codec/Xlsx/Types/PivotTable.hs +++ b/src/Codec/Xlsx/Types/PivotTable.hs @@ -1,16 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.PivotTable ( PivotTable(..) , PivotFieldName(..) , PivotFieldInfo(..) + , FieldSortType(..) , PositionedField(..) , DataField(..) , ConsolidateFunction(..) ) where import Control.Arrow (first) +import Control.DeepSeq (NFData) import Data.Text (Text) +import GHC.Generics (Generic) import Codec.Xlsx.Types.Common import Codec.Xlsx.Parser.Internal @@ -30,27 +34,44 @@ , _pvtLocation :: CellRef , _pvtSrcSheet :: Text , _pvtSrcRef :: Range - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData PivotTable data PivotFieldInfo = PivotFieldInfo - { _pfiName :: PivotFieldName + { _pfiName :: Maybe PivotFieldName , _pfiOutline :: Bool - } deriving (Eq, Show) + , _pfiSortType :: FieldSortType + , _pfiHiddenItems :: [CellValue] + } deriving (Eq, Show, Generic) +instance NFData PivotFieldInfo +-- | 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, Generic) +instance NFData FieldSortType + newtype PivotFieldName = PivotFieldName Text - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData PivotFieldName data PositionedField = DataPosition | FieldPosition PivotFieldName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData PositionedField data DataField = DataField { _dfField :: PivotFieldName , _dfName :: Text , _dfFunction :: ConsolidateFunction - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) +instance NFData DataField -- | Data consolidation functions specified by the user and used to -- consolidate ranges of data @@ -87,7 +108,8 @@ | ConsolidateVarP -- ^ The variance of a population, where the population is all of -- the data to be summarized. - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData ConsolidateFunction {------------------------------------------------------------------------------- Rendering @@ -109,6 +131,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 +156,9 @@ instance FromAttrVal PivotFieldName where fromAttrVal = fmap (first PivotFieldName) . fromAttrVal + +instance FromAttrVal FieldSortType where + fromAttrVal "manual" = readSuccess FieldSortManual + fromAttrVal "ascending" = readSuccess FieldSortAscending + fromAttrVal "descending" = readSuccess FieldSortDescending + fromAttrVal t = invalidText "FieldSortType" t diff --git a/src/Codec/Xlsx/Types/PivotTable/Internal.hs b/src/Codec/Xlsx/Types/PivotTable/Internal.hs --- a/src/Codec/Xlsx/Types/PivotTable/Internal.hs +++ b/src/Codec/Xlsx/Types/PivotTable/Internal.hs @@ -1,16 +1,102 @@ -module Codec.Xlsx.Types.PivotTable.Internal ( - CacheId(..) -) where +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.PivotTable.Internal + ( CacheId(..) + , CacheField(..) + , CacheRecordValue(..) + , CacheRecord + , recordValueFromNode + ) where +import GHC.Generics (Generic) + import Control.Arrow (first) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import Text.XML +import Text.XML.Cursor 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 +newtype CacheId = CacheId Int deriving (Eq, Generic) +data CacheField = CacheField + { cfName :: PivotFieldName + , cfItems :: [CellValue] + } deriving (Eq, Show, Generic) + +data CacheRecordValue + = CacheText Text + | CacheNumber Double + | CacheIndex Int + deriving (Eq, Show, Generic) + +type CacheRecord = [CacheRecordValue] + {------------------------------------------------------------------------------- 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 (addSmlNamespace "sharedItems") &/ anyElement >=> + cellValueFromNode . node + return CacheField {..} + +cellValueFromNode :: Node -> [CellValue] +cellValueFromNode n + | n `nodeElNameIs` (addSmlNamespace "s") = CellText <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "n") = CellDouble <$> attributeV + | otherwise = fail "no matching shared item" + where + cur = fromNode n + attributeV :: FromAttrVal a => [a] + attributeV = fromAttribute "v" cur + +recordValueFromNode :: Node -> [CacheRecordValue] +recordValueFromNode n + | n `nodeElNameIs` (addSmlNamespace "s") = CacheText <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "n") = CacheNumber <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "x") = CacheIndex <$> attributeV + | otherwise = fail "not valid cache record value" + 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 + -- Excel doesn't like embedded integer sharedImes in cache + sharedItems = elementList "sharedItems" typeAttrs $ + if containsString then map cvToItem cfItems else [] + cvToItem (CellText t) = leafElement "s" ["v" .= t] + cvToItem (CellDouble n) = leafElement "n" ["v" .= n] + cvToItem _ = error "Only string and number values are currently supported" + typeAttrs = + catMaybes + [ "containsNumber" .=? justTrue containsNumber + , "containsString" .=? justFalse containsString + , "containsSemiMixedTypes" .=? justFalse containsString + , "containsMixedTypes" .=? justTrue (containsNumber && containsString) + ] + containsNumber = any isNumber cfItems + isNumber (CellDouble _) = True + isNumber _ = False + containsString = any isString cfItems + isString (CellText _) = True + isString _ = False diff --git a/src/Codec/Xlsx/Types/Protection.hs b/src/Codec/Xlsx/Types/Protection.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Protection.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Protection + ( SheetProtection(..) + , fullSheetProtection + , noSheetProtection + , LegacyPassword + , legacyPassword + -- * Lenses + , sprLegacyPassword + , sprSheet + , sprObjects + , sprScenarios + , sprFormatCells + , sprFormatColumns + , sprFormatRows + , sprInsertColumns + , sprInsertRows + , sprInsertHyperlinks + , sprDeleteColumns + , sprDeleteRows + , sprSelectLockedCells + , sprSort + , sprAutoFilter + , sprPivotTables + , sprSelectUnlockedCells + ) where + +import GHC.Generics (Generic) + +import Control.Arrow (first) +import Codec.Xlsx.LensCompat (makeLenses) +import Control.DeepSeq (NFData) +import Data.Bits +import Data.Char +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int (hexadecimal) + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +newtype LegacyPassword = + LegacyPassword Text + deriving (Eq, Show, Generic) +instance NFData LegacyPassword + +-- | Creates legacy @XOR@ hashed password. +-- +-- /Note:/ The implementation is known to work only for ASCII symbols, +-- if you know how to encode properly others - an email or a PR will +-- be highly apperciated +-- +-- See Part 4, 14.7.1 "Legacy Password Hash Algorithm" (p. 73) and +-- Part 4, 15.2.3 "Additional attributes for workbookProtection +-- element (Part 1, §18.2.29)" (p. 220) and Par 4, 15.3.1.6 +-- "Additional attribute for sheetProtection element (Part 1, +-- §18.3.1.85)" (p. 229) +legacyPassword :: Text -> LegacyPassword +legacyPassword = LegacyPassword . hex . legacyHash . map ord . T.unpack + where + hex = toStrict . toLazyText . hexadecimal + legacyHash bs = + mutHash (foldr (\b hash -> b `xor` mutHash hash) 0 bs) `xor` (length bs) `xor` + 0xCE4B + mutHash ph = ((ph `shiftR` 14) .&. 1) .|. ((ph `shiftL` 1) .&. 0x7fff) + +-- | Sheet protection options to enforce and specify that it needs to +-- be protected +-- +-- TODO: algorithms specified in the spec with hashes, salts and spin +-- counts +-- +-- See 18.3.1.85 "sheetProtection (Sheet Protection Options)" (p. 1694) +data SheetProtection = SheetProtection + { _sprLegacyPassword :: Maybe LegacyPassword + -- ^ Specifies the legacy hash of the password required for editing + -- this worksheet. + -- + -- See Part 4, 15.3.1.6 "Additional attribute for sheetProtection + -- element (Part 1, §18.3.1.85)" (p. 229) + , _sprSheet :: Bool + -- ^ the value of this attribute dictates whether the other + -- attributes of 'SheetProtection' should be applied + , _sprAutoFilter :: Bool + -- ^ AutoFilters should not be allowed to operate when the sheet + -- is protected + , _sprDeleteColumns :: Bool + -- ^ deleting columns should not be allowed when the sheet is + -- protected + , _sprDeleteRows :: Bool + -- ^ deleting rows should not be allowed when the sheet is + -- protected + , _sprFormatCells :: Bool + -- ^ formatting cells should not be allowed when the sheet is + -- protected + , _sprFormatColumns :: Bool + -- ^ formatting columns should not be allowed when the sheet is + -- protected + , _sprFormatRows :: Bool + -- ^ formatting rows should not be allowed when the sheet is + -- protected + , _sprInsertColumns :: Bool + -- ^ inserting columns should not be allowed when the sheet is + -- protected + , _sprInsertHyperlinks :: Bool + -- ^ inserting hyperlinks should not be allowed when the sheet is + -- protected + , _sprInsertRows :: Bool + -- ^ inserting rows should not be allowed when the sheet is + -- protected + , _sprObjects :: Bool + -- ^ editing of objects should not be allowed when the sheet is + -- protected + , _sprPivotTables :: Bool + -- ^ PivotTables should not be allowed to operate when the sheet + -- is protected + , _sprScenarios :: Bool + -- ^ Scenarios should not be edited when the sheet is protected + , _sprSelectLockedCells :: Bool + -- ^ selection of locked cells should not be allowed when the + -- sheet is protected + , _sprSelectUnlockedCells :: Bool + -- ^ selection of unlocked cells should not be allowed when the + -- sheet is protected + , _sprSort :: Bool + -- ^ sorting should not be allowed when the sheet is protected + } deriving (Eq, Show, Generic) +instance NFData SheetProtection + +makeLenses ''SheetProtection + +{------------------------------------------------------------------------------- + Base instances +-------------------------------------------------------------------------------} + +-- | no sheet protection at all +noSheetProtection :: SheetProtection +noSheetProtection = + SheetProtection + { _sprLegacyPassword = Nothing + , _sprSheet = False + , _sprAutoFilter = False + , _sprDeleteColumns = False + , _sprDeleteRows = False + , _sprFormatCells = False + , _sprFormatColumns = False + , _sprFormatRows = False + , _sprInsertColumns = False + , _sprInsertHyperlinks = False + , _sprInsertRows = False + , _sprObjects = False + , _sprPivotTables = False + , _sprScenarios = False + , _sprSelectLockedCells = False + , _sprSelectUnlockedCells = False + , _sprSort = False + } + +-- | protection of all sheet features which could be protected +fullSheetProtection :: SheetProtection +fullSheetProtection = + SheetProtection + { _sprLegacyPassword = Nothing + , _sprSheet = True + , _sprAutoFilter = True + , _sprDeleteColumns = True + , _sprDeleteRows = True + , _sprFormatCells = True + , _sprFormatColumns = True + , _sprFormatRows = True + , _sprInsertColumns = True + , _sprInsertHyperlinks = True + , _sprInsertRows = True + , _sprObjects = True + , _sprPivotTables = True + , _sprScenarios = True + , _sprSelectLockedCells = True + , _sprSelectUnlockedCells = True + , _sprSort = True + } + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor SheetProtection where + fromCursor cur = do + _sprLegacyPassword <- maybeAttribute "password" cur + _sprSheet <- fromAttributeDef "sheet" False cur + _sprAutoFilter <- fromAttributeDef "autoFilter" True cur + _sprDeleteColumns <- fromAttributeDef "deleteColumns" True cur + _sprDeleteRows <- fromAttributeDef "deleteRows" True cur + _sprFormatCells <- fromAttributeDef "formatCells" True cur + _sprFormatColumns <- fromAttributeDef "formatColumns" True cur + _sprFormatRows <- fromAttributeDef "formatRows" True cur + _sprInsertColumns <- fromAttributeDef "insertColumns" True cur + _sprInsertHyperlinks <- fromAttributeDef "insertHyperlinks" True cur + _sprInsertRows <- fromAttributeDef "insertRows" True cur + _sprObjects <- fromAttributeDef "objects" False cur + _sprPivotTables <- fromAttributeDef "pivotTables" True cur + _sprScenarios <- fromAttributeDef "scenarios" False cur + _sprSelectLockedCells <- fromAttributeDef "selectLockedCells" False cur + _sprSelectUnlockedCells <- fromAttributeDef "selectUnlockedCells" False cur + _sprSort <- fromAttributeDef "sort" True cur + return SheetProtection {..} + +instance FromXenoNode SheetProtection where + fromXenoNode root = + parseAttributes root $ do + _sprLegacyPassword <- maybeAttr "password" + _sprSheet <- fromAttrDef "sheet" False + _sprAutoFilter <- fromAttrDef "autoFilter" True + _sprDeleteColumns <- fromAttrDef "deleteColumns" True + _sprDeleteRows <- fromAttrDef "deleteRows" True + _sprFormatCells <- fromAttrDef "formatCells" True + _sprFormatColumns <- fromAttrDef "formatColumns" True + _sprFormatRows <- fromAttrDef "formatRows" True + _sprInsertColumns <- fromAttrDef "insertColumns" True + _sprInsertHyperlinks <- fromAttrDef "insertHyperlinks" True + _sprInsertRows <- fromAttrDef "insertRows" True + _sprObjects <- fromAttrDef "objects" False + _sprPivotTables <- fromAttrDef "pivotTables" True + _sprScenarios <- fromAttrDef "scenarios" False + _sprSelectLockedCells <- fromAttrDef "selectLockedCells" False + _sprSelectUnlockedCells <- fromAttrDef "selectUnlockedCells" False + _sprSort <- fromAttrDef "sort" True + return SheetProtection {..} + +instance FromAttrVal LegacyPassword where + fromAttrVal = fmap (first LegacyPassword) . fromAttrVal + +instance FromAttrBs LegacyPassword where + fromAttrBs = fmap LegacyPassword . fromAttrBs + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement SheetProtection where + toElement nm SheetProtection {..} = + leafElement nm $ + catMaybes + [ "password" .=? _sprLegacyPassword + , "sheet" .=? justTrue _sprSheet + , "autoFilter" .=? justFalse _sprAutoFilter + , "deleteColumns" .=? justFalse _sprDeleteColumns + , "deleteRows" .=? justFalse _sprDeleteRows + , "formatCells" .=? justFalse _sprFormatCells + , "formatColumns" .=? justFalse _sprFormatColumns + , "formatRows" .=? justFalse _sprFormatRows + , "insertColumns" .=? justFalse _sprInsertColumns + , "insertHyperlinks" .=? justFalse _sprInsertHyperlinks + , "insertRows" .=? justFalse _sprInsertRows + , "objects" .=? justTrue _sprObjects + , "pivotTables" .=? justFalse _sprPivotTables + , "scenarios" .=? justTrue _sprScenarios + , "selectLockedCells" .=? justTrue _sprSelectLockedCells + , "selectUnlockedCells" .=? justTrue _sprSelectUnlockedCells + , "sort" .=? justFalse _sprSort + ] + +instance ToAttrVal LegacyPassword where + toAttrVal (LegacyPassword hash) = hash diff --git a/src/Codec/Xlsx/Types/RefId.hs b/src/Codec/Xlsx/Types/RefId.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/RefId.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Codec.Xlsx.Types.RefId where + +import Control.Arrow +import Data.Monoid ((<>)) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +newtype RefId = RefId { unRefId :: Text } deriving (Eq, Ord, Show, Generic) + +instance ToAttrVal RefId where + toAttrVal = toAttrVal . unRefId + +instance FromAttrVal RefId where + fromAttrVal t = first RefId <$> fromAttrVal t + +instance FromAttrBs RefId where + fromAttrBs = fmap RefId . fromAttrBs + +unsafeRefId :: Int -> RefId +unsafeRefId num = RefId $ "rId" <> txti num diff --git a/src/Codec/Xlsx/Types/RichText.hs b/src/Codec/Xlsx/Types/RichText.hs --- a/src/Codec/Xlsx/Types/RichText.hs +++ b/src/Codec/Xlsx/Types/RichText.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.RichText ( -- * Main types RichTextRun(..) @@ -29,8 +30,11 @@ , runPropertiesVertAlign ) where -import Control.Lens hiding (element) +import GHC.Generics (Generic) + +import Codec.Xlsx.LensCompat (makeLenses) import Control.Monad +import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes) import Data.Text (Text) @@ -42,11 +46,6 @@ import Codec.Xlsx.Types.StyleSheet import Codec.Xlsx.Writer.Internal -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Monoid -#endif - -- | Rich Text Run -- -- This element represents a run of rich text. A rich text run is a region of @@ -66,8 +65,10 @@ -- Section 18.4.12, "t (Text)" (p. 1727) , _richTextRunText :: Text } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData RichTextRun + -- | Run properties -- -- Section 18.4.7, "rPr (Run Properties)" (p. 1725) @@ -171,8 +172,10 @@ -- Section 18.4.14, "vertAlign (Vertical Alignment)" (p. 1728) , _runPropertiesVertAlign :: Maybe FontVerticalAlignment } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData RunProperties + {------------------------------------------------------------------------------- Lenses -------------------------------------------------------------------------------} @@ -242,7 +245,8 @@ , elementValue "extend" <$> _runPropertiesExtend , toElement "color" <$> _runPropertiesColor , elementValue "sz" <$> _runPropertiesSize - , elementValue "u" <$> _runPropertiesUnderline + , elementValueDef "u" FontUnderlineSingle + <$> _runPropertiesUnderline , elementValue "vertAlign" <$> _runPropertiesVertAlign , elementValue "scheme" <$> _runPropertiesScheme ] @@ -255,33 +259,84 @@ -- | See @CT_RElt@, p. 3903 instance FromCursor RichTextRun where fromCursor cur = do - _richTextRunText <- cur $/ element (n_ "t") &/ content - _richTextRunProperties <- maybeFromElement (n_ "rPr") cur + _richTextRunText <- cur $/ element (addSmlNamespace "t") &/ content + _richTextRunProperties <- maybeFromElement (addSmlNamespace "rPr") cur return RichTextRun{..} +instance FromXenoNode RichTextRun where + fromXenoNode root = do + (prNode, tNode) <- collectChildren root $ (,) <$> maybeChild "rPr" <*> requireChild "t" + _richTextRunProperties <- mapM fromXenoNode prNode + _richTextRunText <- contentX tNode + return RichTextRun {..} + -- | See @CT_RPrElt@, p. 3903 instance FromCursor RunProperties where fromCursor cur = do - _runPropertiesFont <- maybeElementValue (n_ "rFont") cur - _runPropertiesCharset <- maybeElementValue (n_ "charset") cur - _runPropertiesFontFamily <- maybeElementValue (n_ "family") cur - _runPropertiesBold <- maybeElementValue (n_ "b") cur - _runPropertiesItalic <- maybeElementValue (n_ "i") cur - _runPropertiesStrikeThrough <- maybeElementValue (n_ "strike") cur - _runPropertiesOutline <- maybeElementValue (n_ "outline") cur - _runPropertiesShadow <- maybeElementValue (n_ "shadow") cur - _runPropertiesCondense <- maybeElementValue (n_ "condense") cur - _runPropertiesExtend <- maybeElementValue (n_ "extend") cur - _runPropertiesColor <- maybeFromElement (n_ "color") cur - _runPropertiesSize <- maybeElementValue (n_ "sz") cur - _runPropertiesUnderline <- maybeElementValue (n_ "u") cur - _runPropertiesVertAlign <- maybeElementValue (n_ "vertAlign") cur - _runPropertiesScheme <- maybeElementValue (n_ "scheme") cur + _runPropertiesFont <- maybeElementValue (addSmlNamespace "rFont") cur + _runPropertiesCharset <- maybeElementValue (addSmlNamespace "charset") cur + _runPropertiesFontFamily <- maybeElementValue (addSmlNamespace "family") cur + _runPropertiesBold <- maybeBoolElementValue (addSmlNamespace "b") cur + _runPropertiesItalic <- maybeBoolElementValue (addSmlNamespace "i") cur + _runPropertiesStrikeThrough <- maybeBoolElementValue (addSmlNamespace "strike") cur + _runPropertiesOutline <- maybeBoolElementValue (addSmlNamespace "outline") cur + _runPropertiesShadow <- maybeBoolElementValue (addSmlNamespace "shadow") cur + _runPropertiesCondense <- maybeBoolElementValue (addSmlNamespace "condense") cur + _runPropertiesExtend <- maybeBoolElementValue (addSmlNamespace "extend") cur + _runPropertiesColor <- maybeFromElement (addSmlNamespace "color") cur + _runPropertiesSize <- maybeElementValue (addSmlNamespace "sz") cur + _runPropertiesUnderline <- maybeElementValueDef (addSmlNamespace "u") FontUnderlineSingle cur + _runPropertiesVertAlign <- maybeElementValue (addSmlNamespace "vertAlign") cur + _runPropertiesScheme <- maybeElementValue (addSmlNamespace "scheme") cur return RunProperties{..} +instance FromXenoNode RunProperties where + fromXenoNode root = collectChildren root $ do + _runPropertiesFont <- maybeElementVal "rFont" + _runPropertiesCharset <- maybeElementVal "charset" + _runPropertiesFontFamily <- maybeElementVal "family" + _runPropertiesBold <- maybeElementVal "b" + _runPropertiesItalic <- maybeElementVal "i" + _runPropertiesStrikeThrough <- maybeElementVal "strike" + _runPropertiesOutline <- maybeElementVal "outline" + _runPropertiesShadow <- maybeElementVal "shadow" + _runPropertiesCondense <- maybeElementVal "condense" + _runPropertiesExtend <- maybeElementVal "extend" + _runPropertiesColor <- maybeFromChild "color" + _runPropertiesSize <- maybeElementVal "sz" + _runPropertiesUnderline <- maybeElementVal "u" + _runPropertiesVertAlign <- maybeElementVal "vertAlign" + _runPropertiesScheme <- maybeElementVal "scheme" + return RunProperties{..} + {------------------------------------------------------------------------------- Applying formatting -------------------------------------------------------------------------------} + +#if (MIN_VERSION_base(4,11,0)) +instance Semigroup RunProperties where + a <> b = RunProperties { + _runPropertiesBold = override _runPropertiesBold + , _runPropertiesCharset = override _runPropertiesCharset + , _runPropertiesColor = override _runPropertiesColor + , _runPropertiesCondense = override _runPropertiesCondense + , _runPropertiesExtend = override _runPropertiesExtend + , _runPropertiesFontFamily = override _runPropertiesFontFamily + , _runPropertiesItalic = override _runPropertiesItalic + , _runPropertiesOutline = override _runPropertiesOutline + , _runPropertiesFont = override _runPropertiesFont + , _runPropertiesScheme = override _runPropertiesScheme + , _runPropertiesShadow = override _runPropertiesShadow + , _runPropertiesStrikeThrough = override _runPropertiesStrikeThrough + , _runPropertiesSize = override _runPropertiesSize + , _runPropertiesUnderline = override _runPropertiesUnderline + , _runPropertiesVertAlign = override _runPropertiesVertAlign + } + where + override :: (RunProperties -> Maybe x) -> Maybe x + override f = f b `mplus` f a + +#endif -- | The 'Monoid' instance for 'RunProperties' is biased: later properties -- override earlier ones. diff --git a/src/Codec/Xlsx/Types/SheetViews.hs b/src/Codec/Xlsx/Types/SheetViews.hs --- a/src/Codec/Xlsx/Types/SheetViews.hs +++ b/src/Codec/Xlsx/Types/SheetViews.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.SheetViews ( -- * Structured type to construct 'SheetViews' SheetView(..) @@ -46,17 +46,16 @@ , paneYSplit ) where -import Control.Lens (makeLenses) +import GHC.Generics (Generic) + +import Codec.Xlsx.LensCompat (makeLenses) +import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes, maybeToList, listToMaybe) import Text.XML import Text.XML.Cursor import qualified Data.Map as Map -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative () -#endif - import Codec.Xlsx.Types.Common import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Writer.Internal @@ -176,7 +175,8 @@ -- Minimum of 0, maximum of 4 elements , _sheetViewSelection :: [Selection] } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData SheetView -- | Worksheet view selection. -- @@ -199,7 +199,8 @@ -- | Range of the selection. Can be non-contiguous set of ranges. , _selectionSqref :: Maybe SqRef } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Selection -- | Worksheet view pane -- @@ -226,7 +227,8 @@ -- the left pane. , _paneYSplit :: Maybe Double } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Pane {------------------------------------------------------------------------------- Enumerations @@ -244,7 +246,8 @@ -- | Page layout view | SheetViewTypePageLayout - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData SheetViewType -- | Pane type -- @@ -277,7 +280,8 @@ -- dividing the pane into right and left regions. In that case, this value -- specifies the right pane. | PaneTypeTopRight - deriving (Eq, Show, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData PaneType -- | State of the sheet's pane. -- @@ -295,7 +299,8 @@ -- | Panes are split, but not frozen. In this state, the split bars are -- adjustable by the user. | PaneStateSplit - deriving (Eq, Show, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData PaneState {------------------------------------------------------------------------------- Lenses @@ -461,10 +466,36 @@ _sheetViewZoomScaleSheetLayoutView <- maybeAttribute "zoomScaleSheetLayoutView" cur _sheetViewZoomScalePageLayoutView <- maybeAttribute "zoomScalePageLayoutView" cur _sheetViewWorkbookViewId <- fromAttribute "workbookViewId" cur - let _sheetViewPane = listToMaybe $ cur $/ element (n_ "pane") >=> fromCursor - _sheetViewSelection = cur $/ element (n_ "selection") >=> fromCursor + let _sheetViewPane = listToMaybe $ cur $/ element (addSmlNamespace "pane") >=> fromCursor + _sheetViewSelection = cur $/ element (addSmlNamespace "selection") >=> fromCursor return SheetView{..} +instance FromXenoNode SheetView where + fromXenoNode root = parseAttributes root $ do + _sheetViewWindowProtection <- maybeAttr "windowProtection" + _sheetViewShowFormulas <- maybeAttr "showFormulas" + _sheetViewShowGridLines <- maybeAttr "showGridLines" + _sheetViewShowRowColHeaders <- maybeAttr "showRowColHeaders" + _sheetViewShowZeros <- maybeAttr "showZeros" + _sheetViewRightToLeft <- maybeAttr "rightToLeft" + _sheetViewTabSelected <- maybeAttr "tabSelected" + _sheetViewShowRuler <- maybeAttr "showRuler" + _sheetViewShowOutlineSymbols <- maybeAttr "showOutlineSymbols" + _sheetViewDefaultGridColor <- maybeAttr "defaultGridColor" + _sheetViewShowWhiteSpace <- maybeAttr "showWhiteSpace" + _sheetViewType <- maybeAttr "view" + _sheetViewTopLeftCell <- maybeAttr "topLeftCell" + _sheetViewColorId <- maybeAttr "colorId" + _sheetViewZoomScale <- maybeAttr "zoomScale" + _sheetViewZoomScaleNormal <- maybeAttr "zoomScaleNormal" + _sheetViewZoomScaleSheetLayoutView <- maybeAttr "zoomScaleSheetLayoutView" + _sheetViewZoomScalePageLayoutView <- maybeAttr "zoomScalePageLayoutView" + _sheetViewWorkbookViewId <- fromAttr "workbookViewId" + (_sheetViewPane, _sheetViewSelection) <- + toAttrParser . collectChildren root $ + (,) <$> maybeFromChild "pane" <*> fromChildList "selection" + return SheetView {..} + -- | See @CT_Pane@, p. 3913 instance FromCursor Pane where fromCursor cur = do @@ -475,6 +506,16 @@ _paneState <- maybeAttribute "state" cur return Pane{..} +instance FromXenoNode Pane where + fromXenoNode root = + parseAttributes root $ do + _paneXSplit <- maybeAttr "xSplit" + _paneYSplit <- maybeAttr "ySplit" + _paneTopLeftCell <- maybeAttr "topLeftCell" + _paneActivePane <- maybeAttr "activePane" + _paneState <- maybeAttr "state" + return Pane {..} + -- | See @CT_Selection@, p. 3914 instance FromCursor Selection where fromCursor cur = do @@ -484,6 +525,15 @@ _selectionSqref <- maybeAttribute "sqref" cur return Selection{..} +instance FromXenoNode Selection where + fromXenoNode root = + parseAttributes root $ do + _selectionPane <- maybeAttr "pane" + _selectionActiveCell <- maybeAttr "activeCell" + _selectionActiveCellId <- maybeAttr "activeCellId" + _selectionSqref <- maybeAttr "sqref" + return Selection {..} + -- | See @ST_SheetViewType@, p. 3913 instance FromAttrVal SheetViewType where fromAttrVal "normal" = readSuccess SheetViewTypeNormal @@ -491,6 +541,12 @@ fromAttrVal "pageLayout" = readSuccess SheetViewTypePageLayout fromAttrVal t = invalidText "SheetViewType" t +instance FromAttrBs SheetViewType where + fromAttrBs "normal" = return SheetViewTypeNormal + fromAttrBs "pageBreakPreview" = return SheetViewTypePageBreakPreview + fromAttrBs "pageLayout" = return SheetViewTypePageLayout + fromAttrBs x = unexpectedAttrBs "SheetViewType" x + -- | See @ST_Pane@, p. 3914 instance FromAttrVal PaneType where fromAttrVal "bottomRight" = readSuccess PaneTypeBottomRight @@ -499,9 +555,22 @@ fromAttrVal "topLeft" = readSuccess PaneTypeTopLeft fromAttrVal t = invalidText "PaneType" t +instance FromAttrBs PaneType where + fromAttrBs "bottomRight" = return PaneTypeBottomRight + fromAttrBs "topRight" = return PaneTypeTopRight + fromAttrBs "bottomLeft" = return PaneTypeBottomLeft + fromAttrBs "topLeft" = return PaneTypeTopLeft + fromAttrBs x = unexpectedAttrBs "PaneType" x + -- | See @ST_PaneState@, p. 3929 instance FromAttrVal PaneState where fromAttrVal "split" = readSuccess PaneStateSplit fromAttrVal "frozen" = readSuccess PaneStateFrozen fromAttrVal "frozenSplit" = readSuccess PaneStateFrozenSplit fromAttrVal t = invalidText "PaneState" t + +instance FromAttrBs PaneState where + fromAttrBs "split" = return PaneStateSplit + fromAttrBs "frozen" = return PaneStateFrozen + fromAttrBs "frozenSplit" = return PaneStateFrozenSplit + fromAttrBs x = unexpectedAttrBs "PaneState" x diff --git a/src/Codec/Xlsx/Types/StyleSheet.hs b/src/Codec/Xlsx/Types/StyleSheet.hs --- a/src/Codec/Xlsx/Types/StyleSheet.hs +++ b/src/Codec/Xlsx/Types/StyleSheet.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} -- | Support for writing (but not reading) style sheets module Codec.Xlsx.Types.StyleSheet ( -- * The main two types @@ -18,8 +18,9 @@ , FillPattern(..) , Font(..) , NumberFormat(..) + , NumFmt(..) , ImpliedNumberFormat (..) - , NumFmt + , FormatCode , Protection(..) -- * Supporting enumerations , CellHorizontalAlignment(..) @@ -60,6 +61,7 @@ , dxfBorder , dxfFill , dxfFont + , dxfNumFmt , dxfProtection -- ** Alignment , alignmentHorizontal @@ -126,26 +128,21 @@ , firstUserNumFmtId ) where -import Control.Lens hiding (element, elements, - (.=)) -import Data.Default -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.Maybe (catMaybes) -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import Text.XML -import Text.XML.Cursor - - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Codec.Xlsx.LensCompat (makeLenses, (&), (.~)) +import Control.DeepSeq (NFData) +import Data.Default +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (catMaybes, maybeToList) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Internal.NumFmtPair -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal {------------------------------------------------------------------------------- The main types @@ -154,15 +151,15 @@ -- | StyleSheet for an XML document -- -- Relevant parts of the EMCA standard (4th edition, part 1, --- ), +-- ), -- page numbers refer to the page in the PDF rather than the page number as -- printed on the page): -- --- * Chapter 12, "SpreadsheetML" (p. 74) +-- * Chapter 12, \"SpreadsheetML\" (p. 74) -- In particular Section 12.3.20, "Styles Part" (p. 104) --- * Chapter 18, "SpreadsheetML Reference Material" (p. 1528) --- In particular Section 18.8, "Styles" (p. 1754) and Section 18.8.39 --- "styleSheet" (Style Sheet)" (p. 1796); it is the latter section that +-- * Chapter 18, \"SpreadsheetML Reference Material\" (p. 1528) +-- In particular Section 18.8, \"Styles\" (p. 1754) and Section 18.8.39 +-- \"styleSheet\" (Style Sheet)\" (p. 1796); it is the latter section that -- specifies the top-level style sheet format. -- -- TODO: the following child elements: @@ -173,7 +170,13 @@ -- * extLst -- * tableStyles -- --- NOTE: You will probably want to base your style sheet on 'minimalStyleSheet'. +-- NOTE: Because of undocumented Excel requirements you will probably want to base +-- your style sheet on 'minimalStyleSheet' (a proper style sheet should have some +-- contents for details see +-- ). +-- 'def' for 'StyleSheet' includes no contents at all and this could be a problem +-- for Excel. +-- -- See also: -- -- * 'Codec.Xlsx.Types.renderStyleSheet' to translate a 'StyleSheet' to 'Styles' @@ -223,14 +226,16 @@ -- -- Section 18.8.15, "dxfs (Formats)" (p. 1765) - , _styleSheetNumFmts :: Map Int NumFmt + , _styleSheetNumFmts :: Map Int FormatCode -- ^ Number formats -- -- This element contains custom number formats defined in this style sheet -- -- Section 18.8.31, "numFmts (Number Formats)" (p. 1784) - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Generic) +instance NFData StyleSheet + -- | Cell formatting -- -- TODO: The @extLst@ field is currently unsupported. @@ -316,8 +321,10 @@ -- not take effect unless the sheet has been protected. , _cellXfProtection :: Maybe Protection } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData CellXf + {------------------------------------------------------------------------------- Supporting record types -------------------------------------------------------------------------------} @@ -365,8 +372,10 @@ -- within the cell. , _alignmentWrapText :: Maybe Bool } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Alignment + -- | Expresses a single set of cell border formats (left, right, top, bottom, -- diagonal). Color is optional. When missing, 'automatic' is implied. -- @@ -423,16 +432,20 @@ -- | Vertical inner border , _borderVertical :: Maybe BorderStyle } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Border + -- | Border style -- See @CT_BorderPr@ (p. 3934) data BorderStyle = BorderStyle { _borderStyleColor :: Maybe Color , _borderStyleLine :: Maybe LineStyle } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData BorderStyle + -- | One of the colors associated with the data bar or color scale. -- -- The 'indexed' attribute (used for backwards compatibility only) is not @@ -465,8 +478,10 @@ -- 100% darken and 1.0 means 100% lighten. Also, 0.0 means no change. , _colorTint :: Maybe Double } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Color + -- | This element specifies fill formatting. -- -- TODO: Gradient fills (18.8.4) are currently unsupported. If we add them, @@ -477,8 +492,10 @@ data Fill = Fill { _fillPattern :: Maybe FillPattern } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Fill + -- | This element is used to specify cell fill information for pattern and solid -- color cell fills. For solid cell fills (no pattern), fgColor is used. For -- cell fills with patterns specified, then the cell fill color is specified by @@ -490,8 +507,10 @@ , _fillPatternFgColor :: Maybe Color , _fillPatternType :: Maybe PatternType } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData FillPattern + -- | This element defines the properties for one of the fonts used in this -- workbook. -- @@ -592,32 +611,56 @@ -- is available) accordingly. , _fontVertAlign :: Maybe FontVerticalAlignment } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Font + -- | A single dxf record, expressing incremental formatting to be applied. -- -- Section 18.8.14, "dxf (Formatting)" (p. 1765) data Dxf = Dxf { _dxfFont :: Maybe Font - -- TODO: numFmt + -- | It seems to be required that this number format entry is duplicated + -- in '_styleSheetNumFmts' of the style sheet, though the spec says + -- nothing explicitly about it. + , _dxfNumFmt :: Maybe NumFmt , _dxfFill :: Maybe Fill , _dxfAlignment :: Maybe Alignment , _dxfBorder :: Maybe Border , _dxfProtection :: Maybe Protection -- TODO: extList - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord, Show, Generic) -type NumFmt = Text +instance NFData Dxf +-- | A number format code. +-- +-- Section 18.8.30, "numFmt (Number Format)" (p. 1777) +type FormatCode = Text + -- | This element specifies number format properties which indicate -- how to format and render the numeric value of a cell. -- --- Section 18.2.30 "numFmt (Number Format)" (p. 1777) +-- Section 18.8.30 "numFmt (Number Format)" (p. 1777) +data NumFmt = NumFmt + { _numFmtId :: Int + , _numFmtCode :: FormatCode + } deriving (Eq, Ord, Show, Generic) + +instance NFData NumFmt + +mkNumFmtPair :: NumFmt -> (Int, FormatCode) +mkNumFmtPair NumFmt{..} = (_numFmtId, _numFmtCode) + +-- | This type gives a high-level version of representation of number format +-- used in 'Codec.Xlsx.Formatted.Format'. data NumberFormat = StdNumberFormat ImpliedNumberFormat - | UserNumberFormat NumFmt - deriving (Eq, Ord, Show) + | UserNumberFormat FormatCode + deriving (Eq, Ord, Show, Generic) +instance NFData NumberFormat + -- | Basic number format with predefined number of decimals -- as format code of number format in xlsx should be less than 255 characters -- number of decimals shouldn't be more than 253 @@ -658,15 +701,17 @@ | NfThousandsNegativeParens -- ^> 37 #,##0 ;(#,##0) | NfThousandsNegativeRed -- ^> 38 #,##0 ;[Red](#,##0) | NfThousands2DecimalNegativeParens -- ^> 39 #,##0.00;(#,##0.00) - | NfTousands2DecimalNEgativeRed -- ^> 40 #,##0.00;[Red](#,##0.00) + | NfThousands2DecimalNegativeRed -- ^> 40 #,##0.00;[Red](#,##0.00) | NfMmSs -- ^> 45 mm:ss | NfOptHMmSs -- ^> 46 [h]:mm:ss | NfMmSs1Decimal -- ^> 47 mmss.0 | NfExponent1Decimal -- ^> 48 ##0.0E+0 | NfTextPlaceHolder -- ^> 49 @ | NfOtherImplied Int -- ^ other (non local-neutral?) built-in format (id < 164) - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData ImpliedNumberFormat + stdNumberFormatId :: ImpliedNumberFormat -> Int stdNumberFormatId NfGeneral = 0 -- General stdNumberFormatId NfZero = 1 -- 0 @@ -690,7 +735,7 @@ stdNumberFormatId NfThousandsNegativeParens = 37 -- #,##0 ;(#,##0) stdNumberFormatId NfThousandsNegativeRed = 38 -- #,##0 ;[Red](#,##0) stdNumberFormatId NfThousands2DecimalNegativeParens = 39 -- #,##0.00;(#,##0.00) -stdNumberFormatId NfTousands2DecimalNEgativeRed = 40 -- #,##0.00;[Red](#,##0.00) +stdNumberFormatId NfThousands2DecimalNegativeRed = 40 -- #,##0.00;[Red](#,##0.00) stdNumberFormatId NfMmSs = 45 -- mm:ss stdNumberFormatId NfOptHMmSs = 46 -- [h]:mm:ss stdNumberFormatId NfMmSs1Decimal = 47 -- mmss.0 @@ -721,7 +766,7 @@ idToStdNumberFormat 37 = Just NfThousandsNegativeParens -- #,##0 ;(#,##0) idToStdNumberFormat 38 = Just NfThousandsNegativeRed -- #,##0 ;[Red](#,##0) idToStdNumberFormat 39 = Just NfThousands2DecimalNegativeParens -- #,##0.00;(#,##0.00) -idToStdNumberFormat 40 = Just NfTousands2DecimalNEgativeRed -- #,##0.00;[Red](#,##0.00) +idToStdNumberFormat 40 = Just NfThousands2DecimalNegativeRed -- #,##0.00;[Red](#,##0.00) idToStdNumberFormat 45 = Just NfMmSs -- mm:ss idToStdNumberFormat 46 = Just NfOptHMmSs -- [h]:mm:ss idToStdNumberFormat 47 = Just NfMmSs1Decimal -- mmss.0 @@ -743,7 +788,8 @@ _protectionHidden :: Maybe Bool , _protectionLocked :: Maybe Bool } - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData Protection {------------------------------------------------------------------------------- Enumerations @@ -761,7 +807,8 @@ | CellHorizontalAlignmentJustify | CellHorizontalAlignmentLeft | CellHorizontalAlignmentRight - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData CellHorizontalAlignment -- | Vertical alignment in cells -- @@ -772,7 +819,8 @@ | CellVerticalAlignmentDistributed | CellVerticalAlignmentJustify | CellVerticalAlignmentTop - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData CellVerticalAlignment -- | Font family -- @@ -796,7 +844,8 @@ -- | Novelty font | FontFamilyDecorative - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData FontFamily -- | Font scheme -- @@ -810,7 +859,8 @@ -- | This font is not a theme font. | FontSchemeNone - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData FontScheme -- | Font underline property -- @@ -821,7 +871,8 @@ | FontUnderlineSingleAccounting | FontUnderlineDoubleAccounting | FontUnderlineNone - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData FontUnderline -- | Vertical alignment -- @@ -830,7 +881,8 @@ FontVerticalAlignmentBaseline | FontVerticalAlignmentSubscript | FontVerticalAlignmentSuperscript - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData FontVerticalAlignment data LineStyle = LineStyleDashDot @@ -847,7 +899,8 @@ | LineStyleSlantDashDot | LineStyleThick | LineStyleThin - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData LineStyle -- | Indicates the style of fill pattern being used for a cell format. -- @@ -872,7 +925,8 @@ | PatternTypeMediumGray | PatternTypeNone | PatternTypeSolid - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData PatternType -- | Reading order -- @@ -881,7 +935,8 @@ ReadingOrderContextDependent | ReadingOrderLeftToRight | ReadingOrderRightToLeft - deriving (Show, Eq, Ord) + deriving (Eq, Ord, Show, Generic) +instance NFData ReadingOrder {------------------------------------------------------------------------------- Lenses @@ -982,6 +1037,7 @@ instance Default Dxf where def = Dxf { _dxfFont = Nothing + , _dxfNumFmt = Nothing , _dxfFill = Nothing , _dxfAlignment = Nothing , _dxfBorder = Nothing @@ -1086,19 +1142,19 @@ instance ToElement StyleSheet where toElement nm StyleSheet{..} = elementListSimple nm elements where - elements = [ countedElementList "numFmts" $ map (toElement "numFmt") numFmts - , countedElementList "fonts" $ map (toElement "font") _styleSheetFonts - , countedElementList "fills" $ map (toElement "fill") _styleSheetFills - , countedElementList "borders" $ map (toElement "border") _styleSheetBorders + countedElementList' nm' xs = maybeToList $ nonEmptyCountedElementList nm' xs + elements = countedElementList' "numFmts" (map (toElement "numFmt") numFmts) ++ + countedElementList' "fonts" (map (toElement "font") _styleSheetFonts) ++ + countedElementList' "fills" (map (toElement "fill") _styleSheetFills) ++ + countedElementList' "borders" (map (toElement "border") _styleSheetBorders) ++ -- TODO: cellStyleXfs - , countedElementList "cellXfs" $ map (toElement "xf") _styleSheetCellXfs + countedElementList' "cellXfs" (map (toElement "xf") _styleSheetCellXfs) ++ -- TODO: cellStyles - , countedElementList "dxfs" $ map (toElement "dxf") _styleSheetDxfs + countedElementList' "dxfs" (map (toElement "dxf") _styleSheetDxfs) -- TODO: tableStyles -- TODO: colors -- TODO: extLst - ] - numFmts = map NumFmtPair $ M.toList _styleSheetNumFmts + numFmts = map (uncurry NumFmt) $ M.toList _styleSheetNumFmts -- | See @CT_Xf@, p. 4486 instance ToElement CellXf where @@ -1132,6 +1188,7 @@ { elementName = nm , elementNodes = map NodeElement $ catMaybes [ toElement "font" <$> _dxfFont + , toElement "numFmt" <$> _dxfNumFmt , toElement "fill" <$> _dxfFill , toElement "alignment" <$> _dxfAlignment , toElement "border" <$> _dxfBorder @@ -1252,6 +1309,14 @@ ] } +-- | See @CT_NumFmt@, p. 3936 +instance ToElement NumFmt where + toElement nm (NumFmt {..}) = + leafElement nm + [ "numFmtId" .= toAttrVal _numFmtId + , "formatCode" .= toAttrVal _numFmtCode + ] + -- | See @CT_CellProtection@, p. 4484 instance ToElement Protection where toElement nm Protection{..} = Element { @@ -1359,15 +1424,15 @@ instance FromCursor StyleSheet where fromCursor cur = do let - _styleSheetFonts = cur $/ element (n_ "fonts") &/ element (n_ "font") >=> fromCursor - _styleSheetFills = cur $/ element (n_ "fills") &/ element (n_ "fill") >=> fromCursor - _styleSheetBorders = cur $/ element (n_ "borders") &/ element (n_ "border") >=> fromCursor + _styleSheetFonts = cur $/ element (addSmlNamespace "fonts") &/ element (addSmlNamespace "font") >=> fromCursor + _styleSheetFills = cur $/ element (addSmlNamespace "fills") &/ element (addSmlNamespace "fill") >=> fromCursor + _styleSheetBorders = cur $/ element (addSmlNamespace "borders") &/ element (addSmlNamespace "border") >=> fromCursor -- TODO: cellStyleXfs - _styleSheetCellXfs = cur $/ element (n_ "cellXfs") &/ element (n_ "xf") >=> fromCursor + _styleSheetCellXfs = cur $/ element (addSmlNamespace "cellXfs") &/ element (addSmlNamespace "xf") >=> fromCursor -- TODO: cellStyles - _styleSheetDxfs = cur $/ element (n_ "dxfs") &/ element (n_ "dxf") >=> fromCursor - _styleSheetNumFmts = M.fromList . map unNumFmtPair $ - cur $/ element (n_ "numFmts")&/ element (n_ "numFmt") >=> fromCursor + _styleSheetDxfs = cur $/ element (addSmlNamespace "dxfs") &/ element (addSmlNamespace "dxf") >=> fromCursor + _styleSheetNumFmts = M.fromList . map mkNumFmtPair $ + cur $/ element (addSmlNamespace "numFmts")&/ element (addSmlNamespace "numFmt") >=> fromCursor -- TODO: tableStyles -- TODO: colors -- TODO: extLst @@ -1376,21 +1441,21 @@ -- | See @CT_Font@, p. 4489 instance FromCursor Font where fromCursor cur = do - _fontName <- maybeElementValue (n_ "name") cur - _fontCharset <- maybeElementValue (n_ "charset") cur - _fontFamily <- maybeElementValue (n_ "family") cur - _fontBold <- maybeBoolElementValue (n_ "b") cur - _fontItalic <- maybeBoolElementValue (n_ "i") cur - _fontStrikeThrough<- maybeBoolElementValue (n_ "strike") cur - _fontOutline <- maybeBoolElementValue (n_ "outline") cur - _fontShadow <- maybeBoolElementValue (n_ "shadow") cur - _fontCondense <- maybeBoolElementValue (n_ "condense") cur - _fontExtend <- maybeBoolElementValue (n_ "extend") cur - _fontColor <- maybeFromElement (n_ "color") cur - _fontSize <- maybeElementValue (n_ "sz") cur - _fontUnderline <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur - _fontVertAlign <- maybeElementValue (n_ "vertAlign") cur - _fontScheme <- maybeElementValue (n_ "scheme") cur + _fontName <- maybeElementValue (addSmlNamespace "name") cur + _fontCharset <- maybeElementValue (addSmlNamespace "charset") cur + _fontFamily <- maybeElementValue (addSmlNamespace "family") cur + _fontBold <- maybeBoolElementValue (addSmlNamespace "b") cur + _fontItalic <- maybeBoolElementValue (addSmlNamespace "i") cur + _fontStrikeThrough<- maybeBoolElementValue (addSmlNamespace "strike") cur + _fontOutline <- maybeBoolElementValue (addSmlNamespace "outline") cur + _fontShadow <- maybeBoolElementValue (addSmlNamespace "shadow") cur + _fontCondense <- maybeBoolElementValue (addSmlNamespace "condense") cur + _fontExtend <- maybeBoolElementValue (addSmlNamespace "extend") cur + _fontColor <- maybeFromElement (addSmlNamespace "color") cur + _fontSize <- maybeElementValue (addSmlNamespace "sz") cur + _fontUnderline <- maybeElementValueDef (addSmlNamespace "u") FontUnderlineSingle cur + _fontVertAlign <- maybeElementValue (addSmlNamespace "vertAlign") cur + _fontScheme <- maybeElementValue (addSmlNamespace "scheme") cur return Font{..} -- | See 18.18.94 "ST_FontFamily (Font Family)" (p. 2517) @@ -1403,6 +1468,15 @@ fromAttrVal "5" = readSuccess FontFamilyDecorative fromAttrVal t = invalidText "FontFamily" t +instance FromAttrBs FontFamily where + fromAttrBs "0" = return FontFamilyNotApplicable + fromAttrBs "1" = return FontFamilyRoman + fromAttrBs "2" = return FontFamilySwiss + fromAttrBs "3" = return FontFamilyModern + fromAttrBs "4" = return FontFamilyScript + fromAttrBs "5" = return FontFamilyDecorative + fromAttrBs x = unexpectedAttrBs "FontFamily" x + -- | See @CT_Color@, p. 4484 instance FromCursor Color where fromCursor cur = do @@ -1412,6 +1486,15 @@ _colorTint <- maybeAttribute "tint" cur return Color{..} +instance FromXenoNode Color where + fromXenoNode root = + parseAttributes root $ do + _colorAutomatic <- maybeAttr "auto" + _colorARGB <- maybeAttr "rgb" + _colorTheme <- maybeAttr "theme" + _colorTint <- maybeAttr "tint" + return Color {..} + -- See @ST_UnderlineValues@, p. 3940 instance FromAttrVal FontUnderline where fromAttrVal "single" = readSuccess FontUnderlineSingle @@ -1421,30 +1504,50 @@ fromAttrVal "none" = readSuccess FontUnderlineNone fromAttrVal t = invalidText "FontUnderline" t +instance FromAttrBs FontUnderline where + fromAttrBs "single" = return FontUnderlineSingle + fromAttrBs "double" = return FontUnderlineDouble + fromAttrBs "singleAccounting" = return FontUnderlineSingleAccounting + fromAttrBs "doubleAccounting" = return FontUnderlineDoubleAccounting + fromAttrBs "none" = return FontUnderlineNone + fromAttrBs x = unexpectedAttrBs "FontUnderline" x + instance FromAttrVal FontVerticalAlignment where fromAttrVal "baseline" = readSuccess FontVerticalAlignmentBaseline fromAttrVal "subscript" = readSuccess FontVerticalAlignmentSubscript fromAttrVal "superscript" = readSuccess FontVerticalAlignmentSuperscript fromAttrVal t = invalidText "FontVerticalAlignment" t +instance FromAttrBs FontVerticalAlignment where + fromAttrBs "baseline" = return FontVerticalAlignmentBaseline + fromAttrBs "subscript" = return FontVerticalAlignmentSubscript + fromAttrBs "superscript" = return FontVerticalAlignmentSuperscript + fromAttrBs x = unexpectedAttrBs "FontVerticalAlignment" x + instance FromAttrVal FontScheme where fromAttrVal "major" = readSuccess FontSchemeMajor fromAttrVal "minor" = readSuccess FontSchemeMinor fromAttrVal "none" = readSuccess FontSchemeNone fromAttrVal t = invalidText "FontScheme" t +instance FromAttrBs FontScheme where + fromAttrBs "major" = return FontSchemeMajor + fromAttrBs "minor" = return FontSchemeMinor + fromAttrBs "none" = return FontSchemeNone + fromAttrBs x = unexpectedAttrBs "FontScheme" x + -- | See @CT_Fill@, p. 4484 instance FromCursor Fill where fromCursor cur = do - _fillPattern <- maybeFromElement (n_ "patternFill") cur + _fillPattern <- maybeFromElement (addSmlNamespace "patternFill") cur return Fill{..} -- | See @CT_PatternFill@, p. 4484 instance FromCursor FillPattern where fromCursor cur = do _fillPatternType <- maybeAttribute "patternType" cur - _fillPatternFgColor <- maybeFromElement (n_ "fgColor") cur - _fillPatternBgColor <- maybeFromElement (n_ "bgColor") cur + _fillPatternFgColor <- maybeFromElement (addSmlNamespace "fgColor") cur + _fillPatternBgColor <- maybeFromElement (addSmlNamespace "bgColor") cur return FillPattern{..} instance FromAttrVal PatternType where @@ -1475,21 +1578,21 @@ _borderDiagonalUp <- maybeAttribute "diagonalUp" cur _borderDiagonalDown <- maybeAttribute "diagonalDown" cur _borderOutline <- maybeAttribute "outline" cur - _borderStart <- maybeFromElement (n_ "start") cur - _borderEnd <- maybeFromElement (n_ "end") cur - _borderLeft <- maybeFromElement (n_ "left") cur - _borderRight <- maybeFromElement (n_ "right") cur - _borderTop <- maybeFromElement (n_ "top") cur - _borderBottom <- maybeFromElement (n_ "bottom") cur - _borderDiagonal <- maybeFromElement (n_ "diagonal") cur - _borderVertical <- maybeFromElement (n_ "vertical") cur - _borderHorizontal <- maybeFromElement (n_ "horizontal") cur + _borderStart <- maybeFromElement (addSmlNamespace "start") cur + _borderEnd <- maybeFromElement (addSmlNamespace "end") cur + _borderLeft <- maybeFromElement (addSmlNamespace "left") cur + _borderRight <- maybeFromElement (addSmlNamespace "right") cur + _borderTop <- maybeFromElement (addSmlNamespace "top") cur + _borderBottom <- maybeFromElement (addSmlNamespace "bottom") cur + _borderDiagonal <- maybeFromElement (addSmlNamespace "diagonal") cur + _borderVertical <- maybeFromElement (addSmlNamespace "vertical") cur + _borderHorizontal <- maybeFromElement (addSmlNamespace "horizontal") cur return Border{..} instance FromCursor BorderStyle where fromCursor cur = do _borderStyleLine <- maybeAttribute "style" cur - _borderStyleColor <- maybeFromElement (n_ "color") cur + _borderStyleColor <- maybeFromElement (addSmlNamespace "color") cur return BorderStyle{..} instance FromAttrVal LineStyle where @@ -1512,8 +1615,8 @@ -- | See @CT_Xf@, p. 4486 instance FromCursor CellXf where fromCursor cur = do - _cellXfAlignment <- maybeFromElement (n_ "alignment") cur - _cellXfProtection <- maybeFromElement (n_ "protection") cur + _cellXfAlignment <- maybeFromElement (addSmlNamespace "alignment") cur + _cellXfProtection <- maybeFromElement (addSmlNamespace "protection") cur _cellXfNumFmtId <- maybeAttribute "numFmtId" cur _cellXfFontId <- maybeAttribute "fontId" cur _cellXfFillId <- maybeAttribute "fillId" cur @@ -1532,12 +1635,20 @@ -- | See @CT_Dxf@, p. 3937 instance FromCursor Dxf where fromCursor cur = do - _dxfFont <- maybeFromElement (n_ "font") cur - _dxfFill <- maybeFromElement (n_ "fill") cur - _dxfAlignment <- maybeFromElement (n_ "alignment") cur - _dxfBorder <- maybeFromElement (n_ "border") cur - _dxfProtection <- maybeFromElement (n_ "protection") cur + _dxfFont <- maybeFromElement (addSmlNamespace "font") cur + _dxfNumFmt <- maybeFromElement (addSmlNamespace "numFmt") cur + _dxfFill <- maybeFromElement (addSmlNamespace "fill") cur + _dxfAlignment <- maybeFromElement (addSmlNamespace "alignment") cur + _dxfBorder <- maybeFromElement (addSmlNamespace "border") cur + _dxfProtection <- maybeFromElement (addSmlNamespace "protection") cur return Dxf{..} + +-- | See @CT_NumFmt@, p. 3936 +instance FromCursor NumFmt where + fromCursor cur = do + _numFmtCode <- fromAttribute "formatCode" cur + _numFmtId <- fromAttribute "numFmtId" cur + return NumFmt{..} -- | See @CT_CellAlignment@, p. 4482 instance FromCursor Alignment where diff --git a/src/Codec/Xlsx/Types/Table.hs b/src/Codec/Xlsx/Types/Table.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Table.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Table where + +import Codec.Xlsx.LensCompat (makeLenses) +import Control.DeepSeq (NFData) +import Data.Maybe (catMaybes, maybeToList) +import Data.Text (Text) +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.AutoFilter +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Writer.Internal + +-- | Tables are ranges of data in the worksheet that have special +-- behavior applied which allow users to better sort, analyze, format, +-- manage, add, and delete data. Tables and table columns can also be +-- referenced through formulas by the spreadsheet application using +-- friendly names, making formula calculations that use tables much +-- easier to understand and maintain. Tables provide a natural way for +-- working with large sets of tabular data. +-- +-- NOTE: as @headerRowCount@ property isn't yet supported it's +-- supposed that it's library user liability to guarantee that the 1st +-- row of 'tblRef' range contains cells with names specified in +-- `tblColumns` +-- +-- Section 18.5 \"Tables\" (p. 1728) +-- Section 18.5.1 \"Tables\" (p. 1729) +-- Section 18.5.1.2 "table (Table)" (p. 1730) +data Table = Table + { tblDisplayName :: Text + -- ^ A string representing the name of the table. This is the name + -- that shall be used in formula references, and displayed in the UI + -- to the spreadsheet user. This name shall not have any spaces in + -- it, and it shall be unique amongst all other displayNames and + -- definedNames in the workbook. The character lengths and + -- restrictions are the same as for definedNames . + , tblName :: Maybe Text + -- ^ A string representing the name of the table that is used to + -- reference the table programmatically through the spreadsheet + -- applications object model. This string shall be unique per table + -- per sheet. It has the same length and character restrictions as + -- for displayName. By default this should be the same as the + -- table's 'tblDisplayName' . This name should also be kept in synch with + -- the displayName when the displayName is updated in the UI by the + -- spreadsheet user. + , tblRef :: CellRef + -- ^ The range on the relevant sheet that the table occupies + -- expressed using A1 style referencing. + , tblColumns :: [TableColumn] + -- ^ columns of this table, specification requires any table to + -- include at least 1 column + , tblAutoFilter :: Maybe AutoFilter + } deriving (Eq, Show, Generic) +instance NFData Table + +-- | Single table column +-- +-- TODO: styling information +-- +-- Section 18.5.1.3 "tableColumn (Table Column)" (p. 1735) +data TableColumn = TableColumn + { tblcName :: Text + -- ^ A string representing the unique caption of the table + -- column. This is what shall be displayed in the header row in the + -- UI, and is referenced through functions. This name shall be + -- unique per table. + } deriving (Eq, Show, Generic) +instance NFData TableColumn + +makeLenses ''Table + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor Table where + fromCursor c = do + tblDisplayName <- fromAttribute "displayName" c + tblName <- maybeAttribute "name" c + tblRef <- fromAttribute "ref" c + tblAutoFilter <- maybeFromElement (addSmlNamespace "autoFilter") c + let tblColumns = + c $/ element (addSmlNamespace "tableColumns") &/ element (addSmlNamespace "tableColumn") >=> + fmap TableColumn . fromAttribute "name" + return Table {..} + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +tableToDocument :: Table -> Int -> Document +tableToDocument tbl i = + documentFromElement "Table generated by xlsx" $ + tableToElement "table" tbl i + +tableToElement :: Name -> Table -> Int -> Element +tableToElement nm Table {..} i = elementList nm attrs subElements + where + attrs = + [ "id" .= i + , "displayName" .= tblDisplayName + , "ref" .= tblRef + ] ++ + catMaybes + [ "name" .=? tblName + ] + subElements = + maybeToList (toElement "autoFilter" <$> tblAutoFilter) ++ + maybeToList (nonEmptyCountedElementList + "tableColumns" + [ leafElement "tableColumn" ["id" .= i', "name" .= tblcName c] + | (i', c) <- zip [(1 :: Int) ..] tblColumns + ] + ) diff --git a/src/Codec/Xlsx/Types/Variant.hs b/src/Codec/Xlsx/Types/Variant.hs --- a/src/Codec/Xlsx/Types/Variant.hs +++ b/src/Codec/Xlsx/Types/Variant.hs @@ -1,16 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Variant where -import Data.ByteString (ByteString) -import Data.ByteString.Base64 as B64 -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Text.XML -import Text.XML.Cursor +import Control.DeepSeq (NFData) +import Control.Monad.Fail (MonadFail) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 as B64 +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import GHC.Generics (Generic) +import Text.XML +import Text.XML.Cursor -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal data Variant = VtBlob ByteString @@ -22,8 +26,10 @@ -- vt_i4, vt_i8, vt_ui1, vt_ui2, vt_ui4, vt_ui8, vt_uint, vt_r4, vt_r8, -- vt_lpstr, vt_bstr, vt_date, vt_filetime, vt_cy, vt_error, vt_stream, -- vt_ostream, vt_storage, vt_ostorage, vt_vstream, vt_clsid - deriving (Eq, Show) + deriving (Eq, Show, Generic) +instance NFData Variant + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -47,7 +53,7 @@ killWhitespace :: Text -> Text killWhitespace = T.filter (/=' ') -decodeBase64 :: Monad m => Text -> m ByteString +decodeBase64 :: MonadFail m => Text -> m ByteString decodeBase64 t = case B64.decode (T.encodeUtf8 t) of Right bs -> return bs Left err -> fail $ "invalid base64 value: " ++ err diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs --- a/src/Codec/Xlsx/Writer.hs +++ b/src/Codec/Xlsx/Writer.hs @@ -1,54 +1,53 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} -- | This module provides a function for serializing structured `Xlsx` into lazy bytestring module Codec.Xlsx.Writer - ( fromXlsx - ) where + ( fromXlsx + ) where -import qualified Codec.Archive.Zip as Zip -import Control.Arrow (second) -import Control.Lens hiding (transform, (.=)) -import Control.Monad (forM) -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Char8 () -import Data.List (foldl', mapAccumL) -import Data.Map (Map) -import Data.STRef -import Control.Monad.ST -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid ((<>)) -import Data.Text (Text) +import qualified "zip-archive" Codec.Archive.Zip as Zip +import Control.Arrow (second) +import Codec.Xlsx.LensCompat ((^.), mapped, (%~), (&), (?~)) +import Control.Monad (forM) +import Control.Monad.ST +import Control.Monad.State (evalState, get, put) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Char8 () +import Data.List (foldl', mapAccumL) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid ((<>)) +import Data.STRef +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) +import Data.Time.Format (formatTime) +import Data.Time.Format (defaultTimeLocale) import Data.Tuple.Extra (fst3, snd3, thd3) -import qualified Data.Text as T -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) -import Data.Time.Format (formatTime) -#if MIN_VERSION_time(1,5,0) -import Data.Time.Format (defaultTimeLocale) -#else -import System.Locale (defaultTimeLocale) -#endif -import Safe -import Text.XML - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import GHC.Generics (Generic) +import Safe +import Text.XML -import Codec.Xlsx.Types -import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Types.Internal.CfPair -import qualified Codec.Xlsx.Types.Internal.CommentTable as CommentTable -import Codec.Xlsx.Types.Internal.CustomProperties -import Codec.Xlsx.Types.Internal.DvPair -import Codec.Xlsx.Types.Internal.Relationships as Relationships hiding (lookup) -import Codec.Xlsx.Types.Internal.SharedStringTable -import Codec.Xlsx.Types.PivotTable.Internal -import Codec.Xlsx.Writer.Internal -import Codec.Xlsx.Writer.Internal.PivotTable +import Codec.Xlsx.Types +import Codec.Xlsx.Types.Cell (applySharedFormulaOpts) +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Types.Internal.CfPair +import qualified Codec.Xlsx.Types.Internal.CommentTable + as CommentTable +import Codec.Xlsx.Types.Internal.CustomProperties +import Codec.Xlsx.Types.Internal.DvPair +import Codec.Xlsx.Types.Internal.Relationships as Relationships + hiding (lookup) +import Codec.Xlsx.Types.Internal.SharedStringTable +import Codec.Xlsx.Types.PivotTable.Internal +import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Writer.Internal.PivotTable -- | Writes `Xlsx' to raw data (lazy bytestring) fromXlsx :: POSIXTime -> Xlsx -> L.ByteString @@ -85,16 +84,26 @@ (customPropsXml (CustomProperties customProps)) ], [ ("custom-properties", "docProps/custom.xml") ]) workbookFiles = bookFiles xlsx - sheetNames = xlsx ^. xlSheets . to (map fst) + sheetNames = xlsx ^. xlSheets & mapped %~ fst -singleSheetFiles :: Int -> Cells -> [FileData] -> Worksheet -> (FileData, [FileData]) -singleSheetFiles n cells pivFileDatas ws = runST $ do +singleSheetFiles :: Int + -> Cells + -> [FileData] + -> Worksheet + -> STRef s Int + -> ST s (FileData, [FileData]) +singleSheetFiles n cells pivFileDatas ws tblIdRef = do ref <- newSTRef 1 mCmntData <- genComments n cells ref mDrawingData <- maybe (return Nothing) (fmap Just . genDrawing n ref) (ws ^. wsDrawing) pivRefs <- forM pivFileDatas $ \fd -> do refId <- nextRefId ref return (refId, fd) + refTables <- forM (_wsTables ws) $ \tbl -> do + refId <- nextRefId ref + tblId <- readSTRef tblIdRef + modifySTRef' tblIdRef (+1) + return (refId, genTable tbl tblId) let sheetFilePath = "xl/worksheets/sheet" <> show n <> ".xml" sheetFile = FileData sheetFilePath "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" @@ -106,21 +115,22 @@ elementListSimple "worksheet" rootEls rootEls = catMaybes $ [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews - , nonEmptyElListSimple "cols" . map cwEl $ ws ^. wsColumns - , Just . elementListSimple "sheetData" $ sheetDataXml cells (ws ^. wsRowPropertiesMap) + , nonEmptyElListSimple "cols" . map (toElement "col") $ ws ^. wsColumnsProperties + , Just . elementListSimple "sheetData" $ + sheetDataXml cells (ws ^. wsRowPropertiesMap) (ws ^. wsSharedFormulas) + , toElement "sheetProtection" <$> (ws ^. wsProtection) + , toElement "autoFilter" <$> (ws ^. wsAutoFilter) , nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges ] ++ map (Just . toElement "conditionalFormatting") cfPairs ++ [ nonEmptyElListSimple "dataValidations" $ map (toElement "dataValidation") dvPairs , toElement "pageSetup" <$> ws ^. wsPageSetup , fst3 <$> mDrawingData , fst <$> mCmntData + , nonEmptyElListSimple "tableParts" + [leafElement "tablePart" [odr "id" .= rId] | (rId, _) <- refTables] ] cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings dvPairs = map DvPair . M.toList $ ws ^. wsDataValidations - cwEl cw = leafElement "col" [ ("min", txti $ cwMin cw) - , ("max", txti $ cwMax cw) - , ("width", txtd $ cwWidth cw) - , ("style", txti $ cwStyle cw)] mergeE1 r = leafElement "mergeCell" [("ref" .= r)] sheetRels = if null referencedFiles @@ -133,7 +143,8 @@ | (i, FileData{..}) <- referenced ] referenced = fromMaybe [] (snd <$> mCmntData) ++ catMaybes [ snd3 <$> mDrawingData ] ++ - pivRefs + pivRefs ++ + refTables referencedFiles = map snd referenced extraFiles = maybe [] thd3 mDrawingData otherFiles = sheetRels ++ referencedFiles ++ extraFiles @@ -146,31 +157,57 @@ modifySTRef' r (+1) return (unsafeRefId num) -unsafeRefId :: Int -> RefId -unsafeRefId num = RefId $ "rId" <> txti num - -sheetDataXml :: Cells -> Map Int RowProperties -> [Element] -sheetDataXml rows rh = map rowEl rows +sheetDataXml :: + Cells + -> Map RowIndex RowProperties + -> Map SharedFormulaIndex SharedFormulaOptions + -> [Element] +sheetDataXml rows rh sharedFormulas = + evalState (mapM rowEl rows) sharedFormulas where - rowEl (r, cells) = elementList "row" - (ht ++ s ++ [("r", txti r) ,("hidden", "false"), ("outlineLevel", "0"), - ("collapsed", "false"), ("customFormat", "true"), - ("customHeight", txtb hasHeight)]) - $ map (cellEl r) cells - where - (ht, hasHeight, s) = case M.lookup r rh of - Just (RowProps (Just h) (Just st)) -> ([("ht", txtd h)], True,[("s", txti st)]) - Just (RowProps Nothing (Just st)) -> ([], True, [("s", txti st)]) - Just (RowProps (Just h) Nothing ) -> ([("ht", txtd h)], True,[]) - _ -> ([], False,[]) - cellEl r (icol, cell) = - elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) - (catMaybes [ elementContent "v" . value <$> xlsxCellValue cell - , toElement "f" <$> xlsxCellFormula cell - ]) - cellAttrs ref cell = cellStyleAttr cell ++ [("r" .= ref), ("t" .= xlsxCellType cell)] - cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] - cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] + rowEl (r, cells) = do + let mProps = M.lookup r rh + hasHeight = case rowHeight =<< mProps of + Just CustomHeight{} -> True + _ -> False + ht = do Just height <- [rowHeight =<< mProps] + let h = case height of CustomHeight x -> x + AutomaticHeight x -> x + return ("ht", txtd h) + s = do Just st <- [rowStyle =<< mProps] + return ("s", txti st) + hidden = fromMaybe False $ rowHidden <$> mProps + attrs = ht ++ + s ++ + [ ("r", txti r) + , ("hidden", txtb hidden) + , ("outlineLevel", "0") + , ("collapsed", "false") + , ("customFormat", "true") + , ("customHeight", txtb hasHeight) + ] + cellEls <- mapM (cellEl r) cells + return $ elementList "row" attrs cellEls + cellEl r (icol, cell) = do + let cellAttrs ref c = + cellStyleAttr c ++ [("r" .= ref), ("t" .= xlsxCellType c)] + cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] + cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] + formula = xlsxCellFormula cell + fEl0 = toElement "f" <$> formula + fEl <- case formula of + Just CellFormula{_cellfExpression=SharedFormula si} -> do + shared <- get + case M.lookup si shared of + Just fOpts -> do + put $ M.delete si shared + return $ applySharedFormulaOpts fOpts <$> fEl0 + Nothing -> + return fEl0 + _ -> + return fEl0 + return $ elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) $ + catMaybes [fEl, elementContent "v" . value <$> xlsxCellValue cell] genComments :: Int -> Cells -> STRef s Int -> ST s (Maybe (Element, [ReferencedFileData])) genComments n cells ref = @@ -208,7 +245,8 @@ return (el, (rId, drawingFile), referenced) where drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml" - drawingFile = FileData drawingFilePath (smlCT "drawing") "drawing" drawingXml + drawingCT = "application/vnd.openxmlformats-officedocument.drawing+xml" + drawingFile = FileData drawingFilePath drawingCT "drawing" drawingXml drawingXml = renderLBS def{rsNamespaces=nss} $ toDocument dr' nss = [ ("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing") , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") @@ -285,8 +323,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 @@ -295,11 +333,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 = @@ -310,6 +348,20 @@ (smlCT "pivotCacheDefinition") "pivotCacheDefinition" pvtfCacheDefinition + recordsPath = + "xl/pivotCache/pivotCacheRecords" <> cacheIdStr <> ".xml" + recordsFile = + FileData + recordsPath + (smlCT "pivotCacheRecords") + "pivotCacheRecords" + pvtfCacheRecords + cacheRelsFile = + FileData + ("xl/pivotCache/_rels/pivotCacheDefinition" <> cacheIdStr <> ".xml.rels") + relsCT + "relationships" $ + renderRels [refFileDataToRel cachePath (unsafeRefId 1, recordsFile)] renderRels = renderLBS def . toDocument . Relationships.fromList tablePath = "xl/pivotTables/pivotTable" <> cacheIdStr <> ".xml" tableFile = @@ -320,8 +372,16 @@ relsCT "relationships" $ renderRels [refFileDataToRel tablePath (unsafeRefId 1, cacheFile)] - in ((cacheId, cacheFile), tableFile, [tableRels]) + in ((cacheId, cacheFile), tableFile, [tableRels, cacheRelsFile, recordsFile]) +genTable :: Table -> Int -> FileData +genTable tbl tblId = FileData{..} + where + fdPath = "xl/tables/table" <> show tblId <> ".xml" + fdContentType = smlCT "table" + fdRelType = "table" + fdContents = renderLBS def $ tableToDocument tbl tblId + data FileData = FileData { fdPath :: FilePath , fdContentType :: Text , fdRelType :: Text @@ -333,7 +393,7 @@ refFileDataToRel basePath (i, FileData {..}) = relEntry i fdRelType (fdPath `relFrom` basePath) -type Cells = [(Int, [(Int, XlsxCell)])] +type Cells = [(RowIndex, [(ColumnIndex, XlsxCell)])] coreXml :: UTCTime -> Text -> L.ByteString coreXml created creator = @@ -381,20 +441,24 @@ vTypeEl0 n = vTypeEl n M.empty vTypeEl = nEl . nm "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" -data XlsxCellData = XlsxSS Int - | XlsxDouble Double - | XlsxBool Bool - deriving (Show, Eq) +data XlsxCellData + = XlsxSS Int + | XlsxDouble Double + | XlsxBool Bool + | XlsxError ErrorType + deriving (Eq, Show, Generic) + data XlsxCell = XlsxCell { xlsxCellStyle :: Maybe Int , xlsxCellValue :: Maybe XlsxCellData , xlsxComment :: Maybe Comment , xlsxCellFormula :: Maybe CellFormula - } deriving (Show, Eq) + } deriving (Eq, Show, Generic) xlsxCellType :: XlsxCell -> Text xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxSS _)} = "s" xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxBool _)} = "b" +xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxError _)} = "e" xlsxCellType _ = "n" -- default in SpreadsheetML schema, TODO: add other types value :: XlsxCellData -> Text @@ -402,6 +466,7 @@ value (XlsxDouble d) = txtd d value (XlsxBool True) = "1" value (XlsxBool False) = "0" +value (XlsxError eType) = toAttrVal eType transformSheetData :: SharedStringTable -> Worksheet -> Cells transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells) @@ -413,12 +478,13 @@ transformValue (CellDouble dbl) = XlsxDouble dbl transformValue (CellBool b) = XlsxBool b transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) + transformValue (CellError e) = XlsxError e bookFiles :: Xlsx -> [FileData] bookFiles xlsx = runST $ do ref <- newSTRef 1 ssRId <- nextRefId ref - let sheets = xlsx ^. xlSheets . to (map snd) + let sheets = xlsx ^. xlSheets & mapped %~ snd shared = sstConstruct sheets sharedStrings = (ssRId, FileData "xl/sharedStrings.xml" (smlCT "sharedStrings") "sharedStrings" $ @@ -427,19 +493,26 @@ 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 allSheetFiles <- forM (zip [1..] sheetInputs) $ \(i, (cells, pvTables, sheet)) -> do rId <- nextRefId ref - let (sheetFile, others) = singleSheetFiles i cells pvTables sheet + (sheetFile, others) <- singleSheetFiles i cells pvTables sheet tblIdRef return ((rId, sheetFile), others) let sheetFiles = map fst allSheetFiles - sheetNameByRId = zip (map fst sheetFiles) (xlsx ^. xlSheets . to (map fst)) + sheetAttrsByRId = + zipWith (\(rId, _) (name, sheet) -> (rId, name, sheet ^. wsState)) + sheetFiles + (xlsx ^. xlSheets) sheetOthers = concatMap snd allSheetFiles cacheRefFDsById <- forM cacheIdFiles $ \(cacheId, fd) -> do refId <- nextRefId ref @@ -447,7 +520,7 @@ let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ] cacheRefs = map snd cacheRefFDsById bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $ - bookXml sheetNameByRId (xlsx ^. xlDefinedNames) cacheRefsById + bookXml sheetAttrsByRId (xlsx ^. xlDefinedNames) cacheRefsById (xlsx ^. xlDateBase) rels = FileData "xl/_rels/workbook.xml.rels" "application/vnd.openxmlformats-package.relationships+xml" "relationships" relsXml @@ -458,13 +531,15 @@ otherFiles = concat [rels:(map snd referenced), pivotOtherFiles, sheetOthers] return $ bookFile:otherFiles -bookXml :: [(RefId, Text)] +bookXml :: [(RefId, Text, SheetState)] -> DefinedNames -> [(CacheId, RefId)] + -> DateBase -> L.ByteString -bookXml rIdNames (DefinedNames names) cacheIdRefs = - renderLBS def $ Document (Prologue [] Nothing []) root [] +bookXml rIdAttrs (DefinedNames names) cacheIdRefs dateBase = + renderLBS def {rsNamespaces = nss} $ Document (Prologue [] Nothing []) root [] where + nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] -- The @bookViews@ element is not required according to the schema, but its -- absence can cause Excel to crash when opening the print preview -- (see ). It suffices however @@ -474,22 +549,24 @@ addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ elementListSimple "workbook" - ([ elementListSimple "bookViews" [emptyElement "workbookView"] - , elementListSimple - "sheets" - [ leafElement - "sheet" - ["name" .= name, "sheetId" .= i, (odr "id") .= rId] - | (i, (rId, name)) <- zip [(1 :: Int) ..] rIdNames - ] - , elementListSimple - "definedNames" - [ elementContent0 "definedName" (definedName name lsId) val - | (name, lsId, val) <- names - ] - ] ++ - maybeToList - (nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs)) + ( [ leafElement "workbookPr" (catMaybes ["date1904" .=? justTrue (dateBase == DateBase1904) ]) + , elementListSimple "bookViews" [emptyElement "workbookView"] + , elementListSimple + "sheets" + [ leafElement + "sheet" + ["name" .= name, "sheetId" .= i, "state" .= state, (odr "id") .= rId] + | (i, (rId, name, state)) <- zip [(1 :: Int) ..] rIdAttrs + ] + , elementListSimple + "definedNames" + [ elementContent0 "definedName" (definedName name lsId) val + | (name, lsId, val) <- names + ] + ] ++ + maybeToList + (nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs) + ) pivotCacheEl (CacheId cId, refId) = leafElement "pivotCache" ["cacheId" .= cId, (odr "id") .= refId] diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs --- a/src/Codec/Xlsx/Writer/Internal.hs +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} + module Codec.Xlsx.Writer.Internal ( -- * Rendering documents ToDocument(..) @@ -11,6 +13,7 @@ -- * Rendering elements , ToElement(..) , countedElementList + , nonEmptyCountedElementList , elementList , elementListSimple , nonEmptyElListSimple @@ -20,6 +23,7 @@ , elementContent , elementContentPreserved , elementValue + , elementValueDef -- * Rendering attributes , ToAttrVal(..) , (.=) @@ -37,16 +41,16 @@ , justFalse ) where -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Lazy (toStrict) -import Data.Text.Lazy.Builder (toLazyText) -import Data.Text.Lazy.Builder.Int -import Data.Text.Lazy.Builder.RealFloat - -import qualified Data.Map as Map -import Data.String (fromString) -import Text.XML +import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int +import Data.Text.Lazy.Builder.RealFloat +import Text.XML {------------------------------------------------------------------------------- Rendering documents @@ -84,6 +88,11 @@ countedElementList :: Name -> [Element] -> Element countedElementList nm as = elementList nm [ "count" .= length as ] as +nonEmptyCountedElementList :: Name -> [Element] -> Maybe Element +nonEmptyCountedElementList nm as = case as of + [] -> Nothing + _ -> Just $ countedElementList nm as + elementList :: Name -> [(Name, Text)] -> [Element] -> Element elementList nm attrs els = Element { elementName = nm @@ -136,19 +145,19 @@ 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" toAttrVal False = "0" elementValue :: ToAttrVal a => Name -> a -> Element -elementValue nm a = Element { - elementName = nm - , elementAttributes = Map.fromList [ "val" .= a ] - , elementNodes = [] - } +elementValue nm a = leafElement nm [ "val" .= a ] +elementValueDef :: (Eq a, ToAttrVal a) => Name -> a -> a -> Element +elementValueDef nm defVal a = + leafElement nm $ catMaybes [ "val" .=? justNonDef defVal a ] + (.=) :: ToAttrVal a => Name -> a -> (Name, Text) nm .= a = (nm, toAttrVal a) @@ -195,8 +204,11 @@ txtd :: Double -> Text -txtd v | v - fromInteger (floor v) == 0 = toStrict . toLazyText $ formatRealFloat Generic (Just 0) v - | otherwise = toStrict . toLazyText $ realFloat v +txtd v + | v - fromInteger v' == 0 = txti v' + | otherwise = toStrict . toLazyText $ realFloat v + where + v' = floor v txtb :: Bool -> Text txtb = T.toLower . T.pack . show diff --git a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs --- a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs @@ -1,50 +1,57 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Writer.Internal.PivotTable ( PivotTableFiles(..) , renderPivotTableFiles ) where import Data.ByteString.Lazy (ByteString) +import Data.List (elemIndex, transpose) +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 GHC.Generics (Generic) import Safe (fromJustNote) import Text.XML +import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Types.Internal.Relationships (odr) import Codec.Xlsx.Types.PivotTable +import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Writer.Internal data PivotTableFiles = PivotTableFiles { pvtfTable :: ByteString , pvtfCacheDefinition :: ByteString - } deriving (Eq, Show) - -newtype CacheField = - CacheField Text - deriving (Eq, Show) + , pvtfCacheRecords :: ByteString + } deriving (Eq, Show, Generic) data CacheDefinition = CacheDefinition { cdSourceRef :: CellRef , cdSourceSheet :: Text , cdFields :: [CacheField] - } deriving (Eq, Show) + } deriving (Eq, Show, Generic) -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 + (cacheDoc, cacheRecordsDoc) = writeCache cache + pvtfCacheDefinition = renderLBS def cacheDoc + pvtfCacheRecords = renderLBS def cacheRecordsDoc -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 +59,7 @@ [ "colGrandTotals" .=? justFalse _pvtColumnGrandTotals , "rowGrandTotals" .=? justFalse _pvtRowGrandTotals , "outline" .=? justTrue _pvtOutline - , "outlineData" .=? justTrue _pvtOutlineData + , "outlineData" .=? justTrue _pvtOutlineData ] ++ [ "name" .= _pvtName , "dataCaption" .= _pvtDataCaption @@ -69,34 +76,49 @@ , "firstDataRow" .= (2 :: Int) , "firstDataCol" .= (1 :: Int) ] - name2x = M.fromList $ zip (map _pfiName _pvtFields) [0 ..] + name2x = M.fromList $ zip (mapMaybe _pfiName _pvtFields) [0 ..] mapFieldToX f = fromJustNote "no field" $ M.lookup f name2x - pivotFields = - elementListSimple "pivotFields" $ map pFieldEl _pvtFields - pFieldEl PivotFieldInfo{_pfiName=fName, _pfiOutline=outline} - | FieldPosition fName `elem` _pvtRowFields = - pFieldEl' fName outline ("axisRow" :: Text) - | FieldPosition fName `elem` _pvtColumnFields = - pFieldEl' fName outline ("axisCol" :: Text) + pivotFields = elementListSimple "pivotFields" $ map pFieldEl _pvtFields + maybeFieldIn Nothing _ = False + maybeFieldIn (Just name) positions = FieldPosition name `elem` positions + pFieldEl PivotFieldInfo { _pfiName = fName + , _pfiOutline = outline + , _pfiSortType = sortType + , _pfiHiddenItems = hidden + } + | fName `maybeFieldIn` _pvtRowFields = + pFieldEl' fName outline ("axisRow" :: Text) hidden sortType + | fName `maybeFieldIn` _pvtColumnFields = + pFieldEl' fName outline ("axisCol" :: Text) hidden sortType | otherwise = - leafElement - "pivotField" - [ "name" .= fName - , "dataField" .= True - , "showAll" .= False - , "outline" .= outline - ] - pFieldEl' fName outline axis = + leafElement "pivotField" $ + [ "dataField" .= True + , "showAll" .= False + , "outline" .= outline] ++ + catMaybes ["name" .=? fName] + pFieldEl' fName outline axis hidden sortType = elementList "pivotField" - [ "name" .= fName - , "axis" .= axis - , "showAll" .= False - , "outline" .= outline - ] + ([ "axis" .= axis + , "showAll" .= False + , "outline" .= outline + ] ++ + catMaybes [ "name" .=? fName + , "sortType" .=? justNonDef FieldSortManual sortType]) [ elementListSimple "items" $ + items fName hidden ++ [leafElement "item" ["t" .= ("default" :: Text)]] ] + items Nothing _ = [] + items (Just 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,26 +137,39 @@ , "subtotal" .=? justNonDef ConsolidateSum _dfFunction ] -generateCache :: PivotTable -> CacheDefinition -generateCache PivotTable {..} = +generateCache :: CellMap -> PivotTable -> CacheDefinition +generateCache cm PivotTable {..} = CacheDefinition { cdSourceRef = _pvtSrcRef , cdSourceSheet = _pvtSrcSheet , cdFields = cachedFields } where - cachedFields = map (cache . _pfiName) _pvtFields - cache (PivotFieldName name) = CacheField name - -instance ToDocument CacheDefinition where - toDocument = - documentFromElement "Pivot cache definition generated by xlsx" . - toElement "pivotCacheDefinition" + cachedFields = mapMaybe (fmap cache . _pfiName) _pvtFields + 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 ToElement CacheDefinition where - toElement nm CacheDefinition {..} = elementList nm attrs elements +writeCache :: CacheDefinition -> (Document, Document) +writeCache CacheDefinition {..} = (cacheDefDoc, cacheRecordsDoc) where - attrs = ["invalid" .= True, "refreshOnLoad" .= True] + cacheDefDoc = + documentFromElement "Pivot cache definition generated by xlsx" $ + elementList "pivotCacheDefinition" attrs elements + attrs = ["invalid" .= True, "refreshOnLoad" .= True, odr "id" .= unsafeRefId 1] elements = [worksheetSource, cacheFields] worksheetSource = elementList @@ -146,7 +181,24 @@ ] cacheFields = elementListSimple "cacheFields" $ map (toElement "cacheField") cdFields - -instance ToElement CacheField where - toElement nm (CacheField fieldName) = leafElement nm ["name" .= fieldName] - + cacheRecordsDoc = + documentFromElement "Pivot cache records generated by xlsx" . + elementListSimple "pivotCacheRecords" $ + map (elementListSimple "r" . map recordValueToEl) cacheRecords + recordValueToEl (CacheText t) = leafElement "s" ["v" .= t] + recordValueToEl (CacheNumber n) = leafElement "n" ["v" .= n] + recordValueToEl (CacheIndex i) = leafElement "x" ["v" .= i] + cacheRecords = transpose $ map (itemsToRecordValues . cfItems) cdFields + itemsToRecordValues vals = + if all isText vals + then indexes vals + else map itemToRecordValue vals + isText (CellText _) = True + isText _ = False + indexes vals = + [ CacheIndex . fromJustNote "inconsistend definition" $ elemIndex v vals + | v <- vals + ] + itemToRecordValue (CellDouble d) = CacheNumber d + itemToRecordValue (CellText t) = CacheText t + itemToRecordValue v = error $ "Unsupported value for pivot tables: " ++ show v diff --git a/src/Codec/Xlsx/Writer/Internal/Stream.hs b/src/Codec/Xlsx/Writer/Internal/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Writer/Internal/Stream.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Internal stream related functions. +-- These are exported because they're tested like this. +-- It's not expected a user would need this. +module Codec.Xlsx.Writer.Internal.Stream + ( upsertSharedString + , initialSharedString + , string_map + , SharedStringState(..) + ) where + + +import Codec.Xlsx.LensCompat +import Control.Monad.State.Strict +import Data.Map.Strict (Map) +import Data.Maybe +import Data.Text (Text) + +newtype SharedStringState = MkSharedStringState + { _string_map :: Map Text Int + } +makeLenses 'MkSharedStringState + +initialSharedString :: SharedStringState +initialSharedString = MkSharedStringState mempty + +-- properties: +-- for a list of [text], every unique text gets a unique number. +upsertSharedString :: MonadState SharedStringState m => Text -> m (Text,Int) +upsertSharedString current = do + strings <- use string_map + + let mIdx :: Maybe Int + mIdx = strings ^? ix current + + idx :: Int + idx = fromMaybe (length strings) mIdx + + newMap :: Map Text Int + newMap = at current ?~ idx $ strings + + string_map .= newMap + pure (current, idx) + diff --git a/src/Codec/Xlsx/Writer/Stream.hs b/src/Codec/Xlsx/Writer/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Writer/Stream.hs @@ -0,0 +1,429 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Writes Excel files from a stream, which allows creation of +-- large Excel files while remaining in constant memory. +module Codec.Xlsx.Writer.Stream + ( writeXlsx + , writeXlsxMultipleSheets + , writeXlsxWithSharedStrings + , writeXlsxWithConfig + , SheetWriteSettings(..) + , defaultSettings + , wsSheetView + , wsZip + , wsColumnProperties + , wsRowProperties + , wsStyles + , WriteXlsxConfig + , defWriteXlsxConfig + , setWriteSettings + , setSharedStringsMap + , setNamesAndConduits + , setNameInfosAndConduits + -- *** Shared strings + , sharedStrings + , sharedStringsStream + ) where + +import Codec.Archive.Zip.Conduit.UnZip +import Codec.Archive.Zip.Conduit.Zip +import Codec.Xlsx.Parser.Internal (addSmlNamespace) +import Codec.Xlsx.Parser.Stream +import Codec.Xlsx.Types (ColumnsProperties (..), RowProperties (..), + Styles (..), _AutomaticHeight, _CustomHeight, + emptyStyles, rowHeightLens, SheetState (..)) +import Codec.Xlsx.Types.Cell +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.Internal.Relationships (odr, pr, odRelNs) +import Codec.Xlsx.Types.SheetViews +import Codec.Xlsx.Writer.Internal (nonEmptyElListSimple, toAttrVal, toElement, + txtd, txti) +import Codec.Xlsx.Writer.Internal.Stream +import Conduit (PrimMonad, yield, (.|)) +import qualified Conduit as C +import Codec.Xlsx.LensCompat +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Reader.Class +import Control.Monad.State.Strict +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Data.Coerce +import Data.Conduit (ConduitT) +import qualified Data.Conduit.List as CL +import Data.Foldable (fold, traverse_) +import Data.List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time +import Data.Word +import Data.XML.Types +import Text.Printf +import Text.XML (toXMLElement) +import qualified Text.XML as TXML +import Text.XML.Stream.Render +import Text.XML.Unresolved (elementToEvents) +import Data.Bifunctor (Bifunctor(second)) + + +upsertSharedStrings :: MonadState SharedStringState m => Row -> m [(Text,Int)] +upsertSharedStrings row = + traverse upsertSharedString items + where + items :: [Text] + items = row ^.. ri_cell_row . traversed . cellValue . _Just . _CellText + +-- | Process sheetItems into shared strings structure to be put into +-- 'writeXlsxWithSharedStrings' +sharedStrings :: Monad m => ConduitT Row b m (Map Text Int) +sharedStrings = void sharedStringsStream .| CL.foldMap (uncurry Map.singleton) + +-- | creates a unique number for every encountered string in the stream +-- This is used for creating a required structure in the xlsx format +-- called shared strings. Every string get's transformed into a number +-- +-- exposed to allow further processing, we also know the map after processing +-- but I don't think conduit provides a way of getting that out. +-- use 'sharedStrings' to just get the map +sharedStringsStream :: Monad m => + ConduitT Row (Text, Int) m (Map Text Int) +sharedStringsStream = fmap (view string_map) $ C.execStateC initialSharedString $ + CL.mapFoldableM upsertSharedStrings + +-- | Settings for writing a single sheet. +data SheetWriteSettings = MkSheetWriteSettings + { _wsSheetView :: [SheetView] + , _wsZip :: ZipOptions -- ^ Enable zipOpt64=True if you intend writing large xlsx files, zip needs 64bit for files over 4gb. + , _wsColumnProperties :: [ColumnsProperties] + , _wsRowProperties :: Map Int RowProperties + , _wsStyles :: Styles + } +instance Show SheetWriteSettings where + -- ZipOptions lacks a show instance-} + show (MkSheetWriteSettings s _ y r _) = printf "MkSheetWriteSettings{ _wsSheetView=%s, _wsColumnProperties=%s, _wsZip=defaultZipOptions, _wsRowProperties=%s }" (show s) (show y) (show r) +makeLenses ''SheetWriteSettings + +defaultSettings :: SheetWriteSettings +defaultSettings = MkSheetWriteSettings + { _wsSheetView = [] + , _wsColumnProperties = [] + , _wsRowProperties = mempty + , _wsStyles = emptyStyles + , _wsZip = defaultZipOptions { + zipOpt64 = False + -- There is a magick number in the zip archive package, + -- https://hackage.haskell.org/package/zip-archive-0.4.1/docs/src/Codec.Archive.Zip.html#local-6989586621679055672 + -- if we enable 64bit the number doesn't align causing the test to fail. + } + } + + + +-- | Transform a 'Row' stream into a stream that creates the xlsx file format +-- (to be consumed by sinkfile for example) +-- This first runs 'sharedStrings' and then 'writeXlsxWithSharedStrings'. +-- If you want xlsx files this is the most obvious function to use. +-- the others are exposed in case you can cache the shared strings for example. +-- See also 'writeXlsxMultipleSheets'. +writeXlsx :: MonadThrow m + => PrimMonad m + => SheetWriteSettings -- ^ use 'defaultSettings' + -> ConduitT () Row m () -- ^ the conduit producing sheetitems + -> ConduitT () ByteString m Word64 -- ^ result conduit producing xlsx files +writeXlsx settings sheetC = do + writeXlsxWithConfig (defWriteXlsxConfig + & setWriteSettings settings + & setNamesAndConduits [("Sheet1", sheetC)]) + +-- | Same as 'writeXlsx' but write to multiple sheets. +writeXlsxMultipleSheets :: MonadThrow m + => PrimMonad m + => SheetWriteSettings + -- ^ use 'defaultSettings'. + -- Currently, all sheets will use the same setting. + -> [(Text, ConduitT () Row m ())] + -- ^ the conduits producing sheetitems for each sheet + -> ConduitT () ByteString m Word64 -- ^ result conduit producing xlsx files +writeXlsxMultipleSheets settings sheets = do + writeXlsxWithConfig (defWriteXlsxConfig + & setWriteSettings settings + & setNamesAndConduits sheets) + +-- TODO maybe should use bimap instead: https://hackage.haskell.org/package/bimap-0.4.0/docs/Data-Bimap.html +-- it guarantees uniqueness of both text and int +-- | This write Excel file with a shared strings lookup table. +-- It appears that it is optional. +-- Failed lookups will result in valid xlsx. +-- There are several conditions on shared strings, +-- +-- 1. Every text to int is unique on both text and int. +-- 2. Every Int should have a gap no greater than 1. [("xx", 3), ("yy", 4)] is okay, whereas [("xx", 3), ("yy", 5)] is not. +-- 3. It's expected this starts from 0. +-- +-- Use 'sharedStringsStream' to get a good shared strings table. +-- This is provided because the user may have a more efficient way of +-- constructing this table than the library can provide, +-- for example through database operations. +writeXlsxWithSharedStrings :: MonadThrow m => PrimMonad m + => SheetWriteSettings + -> Map Text Int -- ^ shared strings table + -> [(Text, ConduitT () Row m ())] + -> ConduitT () ByteString m Word64 +writeXlsxWithSharedStrings settings sharedStrings' sheets = + writeXlsxWithConfig (defWriteXlsxConfig + & setWriteSettings settings + & setSharedStringsMap (Just sharedStrings') + & setNamesAndConduits sheets) + +-- | Configure how to write to an xlsx. Provides setters but no getters to +-- hide internals for future compatibility +data WriteXlsxConfig m = MkWriteXlsxConfig + { _writeSettings :: SheetWriteSettings + , _sharedStringsMap :: Maybe (Map Text Int) + , _infosAndConduits :: [((Text, SheetState), ConduitT () Row m ())] + } + +-- | Create a blank config. Uses the default write setting config, derives shared +-- strings from the conduits and has no conduits or sheet informations within. +defWriteXlsxConfig :: WriteXlsxConfig m +defWriteXlsxConfig = MkWriteXlsxConfig defaultSettings mempty [] + +-- | Overwrite the existing sheet write settings. +setWriteSettings :: SheetWriteSettings -> WriteXlsxConfig m -> WriteXlsxConfig m +setWriteSettings ws (MkWriteXlsxConfig _ ssm iac) = MkWriteXlsxConfig ws ssm iac + +-- | Set the shared strings map. If set to Nothing, derives the shared strings +-- from the conduits. +setSharedStringsMap :: Maybe (Map Text Int) -> WriteXlsxConfig m -> WriteXlsxConfig m +setSharedStringsMap ssm (MkWriteXlsxConfig ws _ iac) = MkWriteXlsxConfig ws ssm iac + +-- | Set the sheet infos and conduits for each sheet. +setNameInfosAndConduits :: [((Text, SheetState), ConduitT () Row m ())] -> WriteXlsxConfig m -> WriteXlsxConfig m +setNameInfosAndConduits iac (MkWriteXlsxConfig ws ssm _) = MkWriteXlsxConfig ws ssm iac + +-- | Set the names and conduits for each sheet. The sheet info is derived from +-- the ordering. +setNamesAndConduits :: [(Text, ConduitT () Row m ())] -> WriteXlsxConfig m -> WriteXlsxConfig m +setNamesAndConduits nacs (MkWriteXlsxConfig ws ssm _) = MkWriteXlsxConfig ws ssm infosAndConduits' + where + infosAndConduits' = nacs <&> \(n, c) -> ((n, Visible), c) + +-- | Write to an XLSX using the 'WriteXlsxConfig' structure. +writeXlsxWithConfig :: MonadThrow m => PrimMonad m + => WriteXlsxConfig m + -> ConduitT () ByteString m Word64 +writeXlsxWithConfig (MkWriteXlsxConfig ws ssm iac) = do + let rowConduits = foldr ((>>) . snd) mempty iac + sstrings <- maybe (rowConduits .| sharedStrings) pure ssm + combinedFiles ws sstrings iac .| zipStream (ws ^. wsZip) + +combinedFiles :: PrimMonad m + => SheetWriteSettings + -> Map Text Int + -> [((Text, SheetState), ConduitT () Row m ())] + -> ConduitT () (ZipEntry, ZipData m) m () +combinedFiles settings sharedStrings' sheets = + let indicesAndSheets = zip [1..] sheets + zippedSheets = map (\(sheetId, (_, rowConduit)) -> + ( zipEntry ("xl/worksheets/sheet" <> Text.pack (show sheetId) <> ".xml") + , ZipDataSource $ rowConduit .| C.runReaderC settings (writeWorkSheet sharedStrings') .| eventsToBS + )) indicesAndSheets + in + C.yieldMany $ + [ (zipEntry "xl/sharedStrings.xml", ZipDataSource $ writeSst sharedStrings' .| eventsToBS) + , (zipEntry "[Content_Types].xml", ZipDataSource $ writeContentTypes .| eventsToBS) + , (zipEntry "xl/workbook.xml", ZipDataSource $ writeWorkbook (map (second fst) indicesAndSheets) + .| renderBuilder ( def {rsNamespaces=[("r", odRelNs)]}) + .| C.builderToByteString) + , (zipEntry "xl/styles.xml", ZipDataByteString $ coerce $ settings ^. wsStyles) + , (zipEntry "xl/_rels/workbook.xml.rels", ZipDataSource $ writeWorkbookRels (length sheets) .| eventsToBS) + , (zipEntry "_rels/.rels", ZipDataSource $ writeRootRels .| eventsToBS) + ] <> zippedSheets + +el :: Monad m => Name -> Monad m => forall i. ConduitT i Event m () -> ConduitT i Event m () +el x = tag x mempty + +-- Clark notation is used a lot for xml namespaces in this module: +-- +-- Name has an IsString instance which parses it +override :: Monad m => Text -> Text -> forall i. ConduitT i Event m () +override content' part = + tag "{http://schemas.openxmlformats.org/package/2006/content-types}Override" + (attr "ContentType" content' + <> attr "PartName" part) $ pure () + +-- | required by Excel. +writeContentTypes :: Monad m => forall i. ConduitT i Event m () +writeContentTypes = doc "{http://schemas.openxmlformats.org/package/2006/content-types}Types" $ do + override "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" "/xl/workbook.xml" + override "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" "/xl/sharedStrings.xml" + override "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" "/xl/styles.xml" + override "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" "/xl/worksheets/sheet1.xml" + override "application/vnd.openxmlformats-package.relationships+xml" "/xl/_rels/workbook.xml.rels" + override "application/vnd.openxmlformats-package.relationships+xml" "/_rels/.rels" + +-- | required by Excel. +writeWorkbook :: Monad m => [(Int, (Text, SheetState))] -> forall i. ConduitT i Event m () +writeWorkbook sheetInfos = + let addSheet (sheetId, (sheetName, visibility)) = tag (addSmlNamespace "sheet") + (attr "name" sheetName + <> attr "sheetId" (Text.pack $ show sheetId) + <> attr (odr "id") ("rId" <> (Text.pack $ show (sheetId + 2))) + <> attr "state" (case visibility of + Visible -> "visible" + Hidden -> "hidden" + VeryHidden -> "veryHidden") + ) $ pure () + in doc (addSmlNamespace "workbook") $ + el (addSmlNamespace "sheets") $ mapM_ addSheet sheetInfos + +doc :: Monad m => Name -> forall i. ConduitT i Event m () -> ConduitT i Event m () +doc root docM = do + yield EventBeginDocument + el root docM + yield EventEndDocument + +relationship :: Monad m => Text -> Int -> Text -> forall i. ConduitT i Event m () +relationship target id' type' = + tag (pr "Relationship") + (attr "Type" type' + <> attr "Id" (Text.pack $ "rId" <> show id') + <> attr "Target" target + ) $ pure () + +writeWorkbookRels :: Monad m => forall i. Int -> ConduitT i Event m () +writeWorkbookRels sheetCount = doc (pr "Relationships") $ do + relationship "sharedStrings.xml" 1 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings" + relationship "styles.xml" 2 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles" + let schema = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet" + mapM_ (\sheetId -> relationship ("worksheets/sheet" <> (Text.pack (show sheetId)) <> ".xml") (sheetId + 2) schema) [1..sheetCount] + +writeRootRels :: Monad m => forall i. ConduitT i Event m () +writeRootRels = doc (pr "Relationships") $ + relationship "xl/workbook.xml" 1 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" + + +zipEntry :: Text -> ZipEntry +zipEntry x = ZipEntry + { zipEntryName = Left x + , zipEntryTime = LocalTime (toEnum 0) midnight + , zipEntrySize = Nothing + , zipEntryExternalAttributes = Nothing + } + +eventsToBS :: PrimMonad m => ConduitT Event ByteString m () +eventsToBS = writeEvents .| C.builderToByteString + +writeSst :: Monad m => Map Text Int -> forall i. ConduitT i Event m () +writeSst sharedStrings' = doc (addSmlNamespace "sst") $ + void $ traverse (el (addSmlNamespace "si") . el (addSmlNamespace "t") . content . fst + ) $ sortBy (\(_, i) (_, y :: Int) -> compare i y) $ Map.toList sharedStrings' + +writeEvents :: PrimMonad m => ConduitT Event Builder m () +writeEvents = renderBuilder def + +sheetViews :: forall m . MonadReader SheetWriteSettings m => forall i . ConduitT i Event m () +sheetViews = do + sheetView <- view wsSheetView + + unless (null sheetView) $ el (addSmlNamespace "sheetViews") $ do + let + view' :: [Element] + view' = setNameSpaceRec spreadSheetNS . toXMLElement . toElement (addSmlNamespace "sheetView") <$> sheetView + + C.yieldMany $ elementToEvents =<< view' + +spreadSheetNS :: Text +spreadSheetNS = fold $ nameNamespace $ addSmlNamespace "" + +setNameSpaceRec :: Text -> Element -> Element +setNameSpaceRec space xelm = + xelm {elementName = ((elementName xelm ){nameNamespace = + Just space }) + , elementNodes = elementNodes xelm <&> \case + NodeElement x -> NodeElement (setNameSpaceRec space x) + y -> y + } + +columns :: MonadReader SheetWriteSettings m => ConduitT Row Event m () +columns = do + colProps <- view wsColumnProperties + let cols :: Maybe TXML.Element + cols = nonEmptyElListSimple (addSmlNamespace "cols") $ map (toElement (addSmlNamespace "col")) colProps + traverse_ (C.yieldMany . elementToEvents . toXMLElement) cols + +writeWorkSheet :: MonadReader SheetWriteSettings m => Map Text Int -> ConduitT Row Event m () +writeWorkSheet sharedStrings' = doc (addSmlNamespace "worksheet") $ do + sheetViews + columns + el (addSmlNamespace "sheetData") $ C.awaitForever (mapRow sharedStrings') + +mapRow :: MonadReader SheetWriteSettings m => Map Text Int -> Row -> ConduitT Row Event m () +mapRow sharedStrings' sheetItem = do + mRowProp <- preview $ wsRowProperties . ix (unRowIndex rowIx) . rowHeightLens . _Just . failing _CustomHeight _AutomaticHeight + let rowAttr :: Attributes + rowAttr = ixAttr <> fold (attr "ht" . txtd <$> mRowProp) + tag (addSmlNamespace "row") rowAttr $ + void $ itraverse (mapCell sharedStrings' rowIx) (sheetItem ^. ri_cell_row) + where + rowIx = sheetItem ^. ri_row_index + ixAttr = attr "r" $ toAttrVal rowIx + +mapCell :: + Monad m => Map Text Int -> RowIndex -> Int -> Cell -> ConduitT Row Event m () +mapCell sharedStrings' rix cix' cell = + when (has (cellValue . _Just) cell || has (cellStyle . _Just) cell) $ + tag (addSmlNamespace "c") celAttr $ + when (has (cellValue . _Just) cell) $ + el (addSmlNamespace "v") $ + content $ renderCell sharedStrings' cell + where + cix = ColumnIndex cix' + celAttr = attr "r" ref <> + renderCellType sharedStrings' cell + <> foldMap (attr "s" . txti) (cell ^. cellStyle) + ref :: Text + ref = coerce $ singleCellRef (rix, cix) + +renderCellType :: Map Text Int -> Cell -> Attributes +renderCellType sharedStrings' cell = + maybe mempty + (attr "t" . renderType sharedStrings') + $ cell ^? cellValue . _Just + +renderCell :: Map Text Int -> Cell -> Text +renderCell sharedStrings' cell = renderValue sharedStrings' val + where + val :: CellValue + val = fromMaybe (CellText mempty) $ cell ^? cellValue . _Just + +renderValue :: Map Text Int -> CellValue -> Text +renderValue sharedStrings' = \case + CellText x -> + -- if we can't find it in the sst, print the string + maybe x toAttrVal $ sharedStrings' ^? ix x + CellDouble x -> toAttrVal x + CellBool b -> toAttrVal b + CellRich _ -> error "rich text is not supported yet" + CellError err -> toAttrVal err + + +renderType :: Map Text Int -> CellValue -> Text +renderType sharedStrings' = \case + CellText x -> + maybe "str" (const "s") $ sharedStrings' ^? ix x + CellDouble _ -> "n" + CellBool _ -> "b" + CellRich _ -> "r" + CellError _ -> "e" diff --git a/test/AutoFilterTests.hs b/test/AutoFilterTests.hs new file mode 100644 --- /dev/null +++ b/test/AutoFilterTests.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module AutoFilterTests + ( tests + ) where + +import Test.SmallCheck.Series +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.SmallCheck (testProperty) + +import Codec.Xlsx +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +import Common +import Test.SmallCheck.Series.Instances () + +tests :: TestTree +tests = + testGroup + "Types.AutFilter tests" + [ testProperty "fromCursor . toElement == id" $ \(autoFilter :: AutoFilter) -> + [autoFilter] == fromCursor (cursorFromElement $ toElement (addSmlNamespace "autoFilter") autoFilter) + ] diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Common + ( parseBS + , cursorFromElement + ) where +import Data.ByteString.Lazy (ByteString) +import Text.XML +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types (SheetState (..)) +import Codec.Xlsx.Writer.Internal + +import Test.SmallCheck.Series (Serial) + +parseBS :: FromCursor a => ByteString -> [a] +parseBS = fromCursor . fromDocument . parseLBS_ def + +cursorFromElement :: Element -> Cursor +cursorFromElement = fromNode . NodeElement . addNS mainNamespace Nothing + +instance Monad m => Serial m SheetState diff --git a/test/CommonTests.hs b/test/CommonTests.hs new file mode 100644 --- /dev/null +++ b/test/CommonTests.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module CommonTests + ( tests + ) where + +import Data.Fixed (Pico, Fixed(..), E12) +import Data.Time.Calendar (fromGregorian) +import Data.Time.Clock (UTCTime(..)) +import Test.Tasty.SmallCheck (testProperty) +import Test.SmallCheck.Series as Series + ( Positive(..) + , Serial(..) + , newtypeCons + , cons0 + , (\/) + ) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Codec.Xlsx.Types.Common + +import qualified CommonTests.CellRefTests as CellRefTests + +tests :: TestTree +tests = + testGroup + "Types.Common tests" + [ testCase "date conversions" $ do + dateFromNumber DateBase1900 (- 2338.0) @?= read "1893-08-06 00:00:00 UTC" + dateFromNumber DateBase1900 2.0 @?= read "1900-01-02 00:00:00 UTC" + dateFromNumber DateBase1900 3687.0 @?= read "1910-02-03 00:00:00 UTC" + dateFromNumber DateBase1900 38749.0 @?= read "2006-02-01 00:00:00 UTC" + dateFromNumber DateBase1900 2958465.0 @?= read "9999-12-31 00:00:00 UTC" + dateFromNumber DateBase1900 59.0 @?= read "1900-02-28 00:00:00 UTC" + dateFromNumber DateBase1900 59.5 @?= read "1900-02-28 12:00:00 UTC" + dateFromNumber DateBase1900 60.0 @?= read "1900-03-01 00:00:00 UTC" + dateFromNumber DateBase1900 60.5 @?= read "1900-03-01 00:00:00 UTC" + dateFromNumber DateBase1900 61 @?= read "1900-03-01 00:00:00 UTC" + dateFromNumber DateBase1900 61.5 @?= read "1900-03-01 12:00:00 UTC" + dateFromNumber DateBase1900 62 @?= read "1900-03-02 00:00:00 UTC" + dateFromNumber DateBase1904 (-3800.0) @?= read "1893-08-05 00:00:00 UTC" + dateFromNumber DateBase1904 0.0 @?= read "1904-01-01 00:00:00 UTC" + dateFromNumber DateBase1904 2225.0 @?= read "1910-02-03 00:00:00 UTC" + dateFromNumber DateBase1904 37287.0 @?= read "2006-02-01 00:00:00 UTC" + dateFromNumber DateBase1904 2957003.0 @?= read "9999-12-31 00:00:00 UTC" + , testCase "Converting dates in the vicinity of 1900-03-01 to numbers" $ do + -- Note how the fact that 1900-02-29 exists for Excel forces us to skip 60 + dateToNumber DateBase1900 (UTCTime (fromGregorian 1900 2 28) 0) @?= (59 :: Double) + dateToNumber DateBase1900 (UTCTime (fromGregorian 1900 3 1) 0) @?= (61 :: Double) + , testProperty "dateToNumber . dateFromNumber == id" $ + -- Because excel treats 1900 as a leap year, dateToNumber and dateFromNumber + -- aren't inverses of each other in the range n E [60, 61[ for DateBase1900 + \b (n :: Pico) -> (n >= 60 && n < 61 && b == DateBase1900) || n == dateToNumber b (dateFromNumber b $ n) + , CellRefTests.tests + ] + +instance Monad m => Serial m (Fixed E12) where + series = newtypeCons MkFixed + +instance Monad m => Serial m DateBase where + series = cons0 DateBase1900 \/ cons0 DateBase1904 diff --git a/test/CommonTests/CellRefTests.hs b/test/CommonTests/CellRefTests.hs new file mode 100644 --- /dev/null +++ b/test/CommonTests/CellRefTests.hs @@ -0,0 +1,182 @@ + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module CommonTests.CellRefTests + ( tests + ) where + +import qualified Control.Applicative as Alt +import Control.Monad +import Data.Char (chr, isPrint) +import qualified Data.List as L +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word (Word8) +import Test.SmallCheck.Series as Series (NonEmpty (..), Positive (..), + Serial (..), cons1, cons2, generate, + (\/)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.SmallCheck (testProperty) + +import Codec.Xlsx.Types.Common + +tests :: TestTree +tests = + testGroup + "Types.Common CellRef tests" + [ testProperty "textToColumnIndex . columnIndexToText == id" $ + \(Positive i) -> i == textToColumnIndex (columnIndexToText i) + + , testProperty "row2coord . coord2row = id" $ + \(r :: RowCoord) -> r == row2coord (coord2row r) + + , testProperty "col2coord . coord2col = id" $ + \(c :: ColumnCoord) -> c == col2coord (coord2col c) + + , testProperty "fromSingleCellRef' . singleCellRef' = pure" $ + \(cellCoord :: CellCoord) -> pure cellCoord == fromSingleCellRef' (singleCellRef' cellCoord) + + , testProperty "fromRange' . mkRange' = pure" $ + \(range :: RangeCoord) -> pure range == fromRange' (uncurry mkRange' range) + + , testProperty "fromForeignSingleCellRef . mkForeignSingleCellRef = pure" $ + \(viewForeignCellParams -> params) -> + pure params == fromForeignSingleCellRef (uncurry mkForeignSingleCellRef params) + + , testProperty "fromSingleCellRef' . mkForeignSingleCellRef = pure . snd" $ + \(viewForeignCellParams -> (nStr, cellCoord)) -> + pure cellCoord == fromSingleCellRef' (mkForeignSingleCellRef nStr cellCoord) + + , testProperty "fromForeignSingleCellRef . singleCellRef' = const empty" $ + \(cellCoord :: CellCoord) -> + Alt.empty == fromForeignSingleCellRef (singleCellRef' cellCoord) + + , testProperty "fromForeignRange . mkForeignRange = pure" $ + \(viewForeignRangeParams -> params@(nStr, (start, end))) -> + pure params == fromForeignRange (mkForeignRange nStr start end) + + , testProperty "fromRange' . mkForeignRange = pure . snd" $ + \(viewForeignRangeParams -> (nStr, range@(start, end))) -> + pure range == fromRange' (mkForeignRange nStr start end) + + , testProperty "fromForeignRange . mkRange' = const empty" $ + \(range :: RangeCoord) -> + Alt.empty == fromForeignRange (uncurry mkRange' range) + + , testCase "building single CellRefs" $ do + singleCellRef' (RowRel 5, ColumnRel 25) @?= CellRef "Y5" + singleCellRef' (RowRel 5, ColumnAbs 25) @?= CellRef "$Y5" + singleCellRef' (RowAbs 5, ColumnRel 25) @?= CellRef "Y$5" + singleCellRef' (RowAbs 5, ColumnAbs 25) @?= CellRef "$Y$5" + singleCellRef (5, 25) @?= CellRef "Y5" + , testCase "parsing single CellRefs as abstract coordinates" $ do + fromSingleCellRef (CellRef "Y5") @?= Just (5, 25) + fromSingleCellRef (CellRef "$Y5") @?= Just (5, 25) + fromSingleCellRef (CellRef "Y$5") @?= Just (5, 25) + fromSingleCellRef (CellRef "$Y$5") @?= Just (5, 25) + , testCase "parsing single CellRefs as potentially absolute coordinates" $ do + fromSingleCellRef' (CellRef "Y5") @?= Just (RowRel 5, ColumnRel 25) + fromSingleCellRef' (CellRef "$Y5") @?= Just (RowRel 5, ColumnAbs 25) + fromSingleCellRef' (CellRef "Y$5") @?= Just (RowAbs 5, ColumnRel 25) + fromSingleCellRef' (CellRef "$Y$5") @?= Just (RowAbs 5, ColumnAbs 25) + fromSingleCellRef' (CellRef "$Y$50") @?= Just (RowAbs 50, ColumnAbs 25) + fromSingleCellRef' (CellRef "$Y$5$0") @?= Nothing + fromSingleCellRef' (CellRef "Y5:Z10") @?= Nothing + , testCase "building ranges" $ do + mkRange (5, 25) (10, 26) @?= CellRef "Y5:Z10" + mkRange' (RowRel 5, ColumnRel 25) (RowRel 10, ColumnRel 26) @?= CellRef "Y5:Z10" + mkRange' (RowAbs 5, ColumnAbs 25) (RowAbs 10, ColumnAbs 26) @?= CellRef "$Y$5:$Z$10" + mkRange' (RowRel 5, ColumnAbs 25) (RowAbs 10, ColumnRel 26) @?= CellRef "$Y5:Z$10" + mkForeignRange "myWorksheet" (RowRel 5, ColumnAbs 25) (RowAbs 10, ColumnRel 26) @?= CellRef "'myWorksheet'!$Y5:Z$10" + mkForeignRange "my sheet" (RowRel 5, ColumnAbs 25) (RowAbs 10, ColumnRel 26) @?= CellRef "'my sheet'!$Y5:Z$10" + , testCase "parsing ranges CellRefs as abstract coordinates" $ do + fromRange (CellRef "Y5:Z10") @?= Just ((5, 25), (10, 26)) + fromRange (CellRef "$Y$5:$Z$10") @?= Just ((5, 25), (10, 26)) + fromRange (CellRef "myWorksheet!$Y5:Z$10") @?= Just ((5, 25), (10, 26)) + , testCase "parsing ranges CellRefs as potentially absolute coordinates" $ do + fromRange' (CellRef "Y5:Z10") @?= Just ((RowRel 5, ColumnRel 25), (RowRel 10, ColumnRel 26)) + fromRange' (CellRef "$Y$5:$Z$10") @?= Just ((RowAbs 5, ColumnAbs 25), (RowAbs 10, ColumnAbs 26)) + fromRange' (CellRef "myWorksheet!$Y5:Z$10") @?= Just ((RowRel 5, ColumnAbs 25), (RowAbs 10, ColumnRel 26)) + fromForeignRange (CellRef "myWorksheet!$Y5:Z$10") @?= Just ("myWorksheet", ((RowRel 5, ColumnAbs 25), (RowAbs 10, ColumnRel 26))) + fromForeignRange (CellRef "'myWorksheet'!Y5:Z10") @?= Just ("myWorksheet", ((RowRel 5, ColumnRel 25), (RowRel 10, ColumnRel 26))) + fromForeignRange (CellRef "'my sheet'!Y5:Z10") @?= Just ("my sheet", ((RowRel 5, ColumnRel 25), (RowRel 10, ColumnRel 26))) + fromForeignRange (CellRef "$Y5:Z$10") @?= Nothing + ] + +instance Monad m => Serial m RowIndex where + series = cons1 (RowIndex . getPositive) + +instance Monad m => Serial m ColumnIndex where + series = cons1 (ColumnIndex . getPositive) + +instance Monad m => Serial m RowCoord where + series = cons1 (RowAbs . getPositive) \/ cons1 (RowRel . getPositive) + +instance Monad m => Serial m ColumnCoord where + series = cons1 (ColumnAbs . getPositive) \/ cons1 (ColumnRel . getPositive) + +-- | Allow defining an instance to generate valid foreign range params +data MkForeignRangeRef = + MkForeignRangeRef NameString RangeCoord + deriving (Show) + +viewForeignRangeParams :: MkForeignRangeRef -> (Text, RangeCoord) +viewForeignRangeParams (MkForeignRangeRef nameStr range) = (nameString nameStr, range) + +instance Monad m => Serial m MkForeignRangeRef where + series = cons2 MkForeignRangeRef + +-- | Allow defining an instance to generate valid foreign cellref params +data MkForeignCellRef = + MkForeignCellRef NameString CellCoord + deriving (Show) + +viewForeignCellParams :: MkForeignCellRef -> (Text, CellCoord) +viewForeignCellParams (MkForeignCellRef nameStr coord) = (nameString nameStr, coord) + +instance Monad m => Serial m MkForeignCellRef where + series = cons2 MkForeignCellRef + +-- | Overload an instance for allowed sheet name chars +newtype NameChar = + NameChar { _unNCh :: Char } + deriving (Show, Eq) + +-- | Instance for Char which broadens the pool to permitted ascii and some wchars +-- as @Serial m Char@ is only @[ 'A' .. 'Z' ]@ +instance Monad m => Serial m NameChar where + series = + fmap NameChar $ + let wChars = ['é', '€', '愛'] + startSeq = "ab cd'" -- single quote is permitted as long as it's not 1st or last + authorizedAscii = + let asciiRange = L.map (chr . fromIntegral) [minBound @Word8 .. maxBound `div` 2] + forbiddenClass = "[]*:?/\\" :: String + isAuthorized c = isPrint c && not (c `L.elem` forbiddenClass) + isPlanned c = isAuthorized c && not (c `L.elem` startSeq) + in L.filter isPlanned asciiRange + in generate $ \d -> take (d + 1) $ startSeq ++ wChars ++ authorizedAscii + +-- | Allow defining an instance to generate valid sheetnames (non-empty, valid char set, squote rule) +newtype NameString = + NameString { _unNS :: Series.NonEmpty NameChar } + deriving (Show) + +nameString :: NameString -> Text +nameString = T.pack . L.map _unNCh . getNonEmpty . _unNS + +instance Monad m => Serial m NameString where + series = fmap NameString $ + series @m @(Series.NonEmpty NameChar) >>= \t -> t <$ guard (isOk t) + where + -- squote isn't permitted at the beginning and the end of a sheet's name + isOk (getNonEmpty -> s) = + head s /= NameChar '\'' && + last s /= NameChar '\'' diff --git a/test/CondFmtTests.hs b/test/CondFmtTests.hs new file mode 100644 --- /dev/null +++ b/test/CondFmtTests.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module CondFmtTests + ( tests + ) where + +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.SmallCheck (testProperty) + +import Codec.Xlsx +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +import Common +import Test.SmallCheck.Series.Instances () + +tests :: TestTree +tests = + testGroup + "Types.ConditionalFormatting tests" + [ testProperty "fromCursor . toElement == id" $ \(cFmt :: CfRule) -> + [cFmt] == fromCursor (cursorFromElement $ toElement (addSmlNamespace "cfRule") cFmt) + ] diff --git a/test/DataTest.hs b/test/DataTest.hs deleted file mode 100644 --- a/test/DataTest.hs +++ /dev/null @@ -1,850 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -module Main (main) where - -import Control.Lens -import Control.Monad.State.Lazy -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LB -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.Vector as V -import Text.RawString.QQ -import Text.XML -import Text.XML.Cursor - -import Test.Tasty (defaultMain, - testGroup) -import Test.Tasty.HUnit (testCase) -import Test.Tasty.SmallCheck (testProperty) - -import Test.SmallCheck.Series (Positive (..)) -import Test.Tasty.HUnit (HUnitFailure (..), - (@=?)) - -import Codec.Xlsx -import Codec.Xlsx.Formatted -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Parser.Internal.PivotTable -import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Types.Internal.CommentTable -import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties -import Codec.Xlsx.Types.Internal.SharedStringTable -import Codec.Xlsx.Types.PivotTable.Internal -import Codec.Xlsx.Types.StyleSheet -import Codec.Xlsx.Writer.Internal -import Codec.Xlsx.Writer.Internal.PivotTable - -import Diff - -main :: IO () -main = defaultMain $ - testGroup "Tests" - [ testProperty "col2int . int2col == id" $ - \(Positive i) -> i == col2int (int2col i) - , testCase "write . read == id" $ do - let bs = fromXlsx testTime testXlsx - LB.writeFile "data-test.xlsx" bs - testXlsx @==? toXlsx (fromXlsx testTime testXlsx) - , testCase "fromRows . toRows == id" $ - testCellMap1 @=? fromRows (toRows testCellMap1) - , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $ - testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet)) - , testCase "correct shared strings parsing" $ - [testSharedStringTable] @=? parseBS testStrings - , testCase "correct shared strings parsing even when one of the shared strings entry is just " $ - [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty - , testCase "correct comments parsing" $ - [testCommentTable] @=? parseBS testComments - , testCase "correct drawing parsing" $ - [testDrawing] @==? parseBS testDrawingFile - , testCase "write . read == id for Drawings" $ - [testDrawing] @==? parseBS testWrittenDrawing - , testCase "correct chart parsing" $ - [testChartSpace] @==? parseBS testChartFile - , testCase "write . read == id for Charts" $ - [testChartSpace] @==? parseBS testWrittenChartSpace - , testCase "correct custom properties parsing" $ - [testCustomProperties] @==? parseBS testCustomPropertiesXml - , testCase "proper results from `formatted`" $ - testFormattedResult @==? testRunFormatted - , testCase "formatted . toFormattedCells = id" $ do - let fmtd = formatted testFormattedCells minimalStyleSheet - testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd) - (formattedStyleSheet fmtd) - , testCase "proper results from `conditionalltyFormatted`" $ - testCondFormattedResult @==? testRunCondFormatted - , testCase "toXlsxEither: properly formatted" $ - Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) - , testCase "toXlsxEither: invalid format" $ - Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file" - , testCase "proper pivot table rendering" $ do - let ptFiles = renderPivotTableFiles 3 testPivotTable - parseLBS_ def (pvtfTable ptFiles) @==? - stripContentSpaces (parseLBS_ def testPivotTableDefinition) - parseLBS_ def (pvtfCacheDefinition ptFiles) @==? - stripContentSpaces (parseLBS_ def testPivotCacheDefinition) - , testCase "proper pivot table parsing" $ do - let sheetName = "Sheet1" - ref = CellRef "A1:D5" - fields = - [ PivotFieldName "Color" - , PivotFieldName "Year" - , PivotFieldName "Price" - , PivotFieldName "Count" - ] - forCacheId (CacheId 3) = Just (sheetName, ref, fields) - forCacheId _ = Nothing - Just (sheetName, ref, fields) @==? parseCache testPivotCacheDefinition - Just testPivotTable @==? parsePivotTable forCacheId testPivotTableDefinition - ] - -parseBS :: FromCursor a => ByteString -> [a] -parseBS = fromCursor . fromDocument . parseLBS_ def - -testXlsx :: Xlsx -testXlsx = Xlsx sheets minimalStyles definedNames customProperties - where - sheets = - [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)] - sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges sheetViews pageSetup cFormatting validations [] - 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 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 - ) - ] - where - comment1 = Comment (XlsxText "simple comment") "bob" True - comment2 = Comment (XlsxRichText [rich1, rich2]) "alice" False - 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 & runPropertiesCharset ?~ 1 - & runPropertiesColor ?~ def -- TODO: why not Nothing here? - & runPropertiesFont ?~ "Calibri" - & runPropertiesScheme ?~ FontSchemeMinor - & runPropertiesSize ?~ 8.0 - , _richTextRunText = "Bob:"} - , RichTextRun - { _richTextRunProperties = - Just $ def & runPropertiesCharset ?~ 1 - & runPropertiesColor ?~ def - & runPropertiesFont ?~ "Calibri" - & runPropertiesScheme ?~ FontSchemeMinor - & runPropertiesSize ?~ 8.0 - , _richTextRunText = "Why such high expense?"}] - -testStrings :: ByteString -testStrings = "\ - \\ - \plain text\ - \Just \ - \example\ - \" - -testStringsWithEmpty :: ByteString -testStringsWithEmpty = "\ - \\ - \\ - \" - -testComments :: ByteString -testComments = [r| - - - - Bob - CBR - - - - - - - - - - Bob: - - - - - - - Why such high expense? - - - - - Some comment here - - - -|] - -testDrawing :: UnresolvedDrawing -testDrawing = Drawing [anchor1, anchor2] - where - anchor1 = - Anchor - {_anchAnchoring = anchoring1, _anchObject = pic, _anchClientData = def} - anchoring1 = - TwoCellAnchor - { tcaFrom = unqMarker (0, 0) (0, 0) - , tcaTo = unqMarker (12, 320760) (33, 38160) - , tcaEditAs = EditAsAbsolute - } - pic = - Picture - { _picMacro = Nothing - , _picPublished = False - , _picNonVisual = nonVis1 - , _picBlipFill = bfProps - , _picShapeProperties = shProps - } - nonVis1 = - PicNonVisual $ - NonVisualDrawingProperties - { _nvdpId = 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 = 1 - , _nvdpName = "" - , _nvdpDescription = Nothing - , _nvdpHidden = False - , _nvdpTitle = Nothing - } - transform = - Transform2D - { _trRot = Angle 0 - , _trFlipH = False - , _trFlipV = False - , _trOffset = Just (unqPoint2D 0 0) - , _trExtents = - Just - (PositiveSize2D - (PositiveCoordinate 10074240) - (PositiveCoordinate 5402520)) - } - - -testDrawingFile :: ByteString -testDrawingFile = [r| - - - - - 00 - 00 - - - 12320760 - 3338160 - - - - - - - - - - - - - - 087840 - 21131040 - - - 7580320 - 38132480 - - - - - - - - - - - - - -|] - -testWrittenDrawing :: ByteString -testWrittenDrawing = renderLBS def $ toDocument testDrawing - -testCustomProperties :: CustomProperties -testCustomProperties = CustomProperties.fromList - [ ("testTextProp", VtLpwstr "test text property value") - , ("prop2", VtLpwstr "222") - , ("bool", VtBool False) - , ("prop333", VtInt 1) - , ("decimal", VtDecimal 1.234) ] - -testCustomPropertiesXml :: ByteString -testCustomPropertiesXml = [r| - - - - 222 - - - 1 - - - test text property value - - - 1.234 - - - false - - - - ZXhhbXBs - ZSBibG9i - IGNvbnRl - bnRz - - - -|] - -testFormattedResult :: Formatted -testFormattedResult = Formatted cm styleSheet merges - where - cm = M.fromList [ ((1, 1), cell11) - , ((1, 2), cell12) - , ((2, 5), cell25) ] - cell11 = Cell - { _cellStyle = Just 1 - , _cellValue = Just (CellText "text at A1") - , _cellComment = Nothing - , _cellFormula = Nothing } - cell12 = Cell - { _cellStyle = Just 2 - , _cellValue = Just (CellDouble 1.23) - , _cellComment = Nothing - , _cellFormula = Nothing } - cell25 = Cell - { _cellStyle = Just 3 - , _cellValue = Just (CellDouble 1.23456) - , _cellComment = Nothing - , _cellFormula = Nothing } - merges = [] - styleSheet = - minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3]) - & styleSheetFonts %~ (++ [font1, font2]) - & styleSheetNumFmts .~ numFmts - nextFontId = length (minimalStyleSheet ^. styleSheetFonts) - cellXf1 = def - { _cellXfApplyFont = Just True - , _cellXfFontId = Just nextFontId } - font1 = def - { _fontName = Just "Calibri" - , _fontBold = Just True } - cellXf2 = def - { _cellXfApplyFont = Just True - , _cellXfFontId = Just (nextFontId + 1) - , _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 164 } - font2 = def - { _fontItalic = Just True } - cellXf3 = def - { _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 2 } - numFmts = M.fromList [(164, "0.0000")] - -testRunFormatted :: Formatted -testRunFormatted = formatted formattedCellMap minimalStyleSheet - where - formattedCellMap = flip execState def $ do - let font1 = def & fontBold ?~ True - & fontName ?~ "Calibri" - at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1" - & formattedFormat . formatFont ?~ font1) - at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23 - & formattedFormat . formatFont . non def . fontItalic ?~ True - & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4) - at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456 - & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) - -testCondFormattedResult :: CondFormatted -testCondFormattedResult = CondFormatted styleSheet formattings - where - styleSheet = - minimalStyleSheet & styleSheetDxfs .~ dxfs - dxfs = [ def & dxfFont ?~ (def & fontUnderline ?~ FontUnderlineSingle) - , def & dxfFont ?~ (def & fontStrikeThrough ?~ True) - , def & dxfFont ?~ (def & fontBold ?~ True) ] - formattings = M.fromList [ (SqRef [CellRef "A1:A2", CellRef "B2:B3"], [cfRule1, cfRule2]) - , (SqRef [CellRef "C3:E10"], [cfRule1]) - , (SqRef [CellRef "F1:G10"], [cfRule3]) ] - cfRule1 = CfRule - { _cfrCondition = ContainsBlanks - , _cfrDxfId = Just 0 - , _cfrPriority = 1 - , _cfrStopIfTrue = Nothing } - cfRule2 = CfRule - { _cfrCondition = BeginsWith "foo" - , _cfrDxfId = Just 1 - , _cfrPriority = 1 - , _cfrStopIfTrue = Nothing } - cfRule3 = CfRule - { _cfrCondition = CellIs (OpGreaterThan (Formula "A1")) - , _cfrDxfId = Just 2 - , _cfrPriority = 1 - , _cfrStopIfTrue = Nothing } - -testFormattedCells :: Map (Int, Int) FormattedCell -testFormattedCells = flip execState def $ do - at (1,1) ?= (def & formattedRowSpan .~ 5 - & formattedColSpan .~ 5 - & formattedFormat . formatBorder . non def . borderTop . - non def . borderStyleLine ?~ LineStyleDashed - & formattedFormat . formatBorder . non def . borderBottom . - non def . borderStyleLine ?~ LineStyleDashed) - at (10,2) ?= (def & formattedFormat . formatFont . non def . fontBold ?~ True) - -testRunCondFormatted :: CondFormatted -testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet - where - condFmts = flip execState def $ do - let cfRule1 = def & condfmtCondition .~ ContainsBlanks - & condfmtDxf . dxfFont . non def . fontUnderline ?~ FontUnderlineSingle - cfRule2 = def & condfmtCondition .~ BeginsWith "foo" - & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True - cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1")) - & condfmtDxf . dxfFont . non def . fontBold ?~ True - at (CellRef "A1:A2") ?= [cfRule1, cfRule2] - at (CellRef "B2:B3") ?= [cfRule1, cfRule2] - at (CellRef "C3:E10") ?= [cfRule1] - at (CellRef "F1:G10") ?= [cfRule3] - -testChartFile :: ByteString -testChartFile = [r| - - - - - Line chart title - - - - - - - Sheet1!$A$1 - - Sheet1!$B$1:$D$1 - - - - - Sheet1!$A$2 - - Sheet1!$B$2:$D$2 - - - - - - - - - - -|] - -testChartSpace :: ChartSpace -testChartSpace = - ChartSpace - { _chspTitle = Just $ ChartTitle titleBody - , _chspCharts = charts - , _chspLegend = Nothing - , _chspPlotVisOnly = Just True - , _chspDispBlanksAs = Just DispBlanksAsGap - } - where - titleBody = - TextBody - { _txbdRotation = Angle 0 - , _txbdSpcFirstLastPara = False - , _txbdVertOverflow = TextVertOverflow - , _txbdVertical = TextVerticalHorz - , _txbdWrap = TextWrapSquare - , _txbdAnchor = TextAnchoringBottom - , _txbdAnchorCenter = False - , _txbdParagraphs = - [TextParagraph Nothing [RegularRun Nothing "Line chart title"]] - } - charts = - [ LineChart - { _lnchGrouping = StandardGrouping - , _lnchSeries = series - , _lnchMarker = Just False - , _lnchSmooth = Just False - } - ] - series = - [ LineSeries - { _lnserShared = Series . Just $ Formula "Sheet1!$A$1" - , _lnserMarker = Just markerNone - , _lnserDataLblProps = Nothing - , _lnserVal = Just $ Formula "Sheet1!$B$1:$D$1" - , _lnserSmooth = Just False - } - , LineSeries - { _lnserShared = Series . Just $ Formula "Sheet1!$A$2" - , _lnserMarker = Just markerNone - , _lnserDataLblProps = Nothing - , _lnserVal = Just $ Formula "Sheet1!$B$2:$D$2" - , _lnserSmooth = Just False - } - ] - markerNone = - DataMarker {_dmrkSymbol = Just DataMarkerNone, _dmrkSize = Nothing} - -testWrittenChartSpace :: ByteString -testWrittenChartSpace = renderLBS def{rsNamespaces=nss} $ toDocument testChartSpace - where - nss = [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart") - , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") ] - - -validations :: Map SqRef DataValidation -validations = M.fromList - [ ( SqRef [CellRef "A1"], def - ) - , ( SqRef [CellRef "A1", CellRef "B2:C3"], def - { _dvAllowBlank = True - , _dvError = Just "incorrect data" - , _dvErrorStyle = ErrorStyleInformation - , _dvErrorTitle = Just "error title" - , _dvPrompt = Just "enter data" - , _dvPromptTitle = Just "prompt title" - , _dvShowDropDown = True - , _dvShowErrorMessage = True - , _dvShowInputMessage = True - , _dvValidationType = ValidationTypeList ["aaaa","bbbb","cccc"] - } - ) - , ( SqRef [CellRef "A6", CellRef "I2"], def - { _dvAllowBlank = False - , _dvError = Just "aaa" - , _dvErrorStyle = ErrorStyleWarning - , _dvErrorTitle = Just "bbb" - , _dvPrompt = Just "ccc" - , _dvPromptTitle = Just "ddd" - , _dvShowDropDown = False - , _dvShowErrorMessage = False - , _dvShowInputMessage = False - , _dvValidationType = ValidationTypeDecimal $ ValGreaterThan $ Formula "10" - } - ) - , ( SqRef [CellRef "A7"], def - { _dvAllowBlank = False - , _dvError = Just "aaa" - , _dvErrorStyle = ErrorStyleStop - , _dvErrorTitle = Just "bbb" - , _dvPrompt = Just "ccc" - , _dvPromptTitle = Just "ddd" - , _dvShowDropDown = False - , _dvShowErrorMessage = False - , _dvShowInputMessage = False - , _dvValidationType = ValidationTypeWhole $ ValNotBetween (Formula "10") (Formula "12") - } - ) - ] - -testPivotTable :: PivotTable -testPivotTable = - PivotTable - { _pvtName = "PivotTable1" - , _pvtDataCaption = "Values" - , _pvtLocation = CellRef "A3:D12" - , _pvtSrcRef = CellRef "A1:D5" - , _pvtSrcSheet = "Sheet1" - , _pvtRowFields = [FieldPosition colorField, DataPosition] - , _pvtColumnFields = [FieldPosition yearField] - , _pvtDataFields = - [ DataField - { _dfName = "Sum of field Price" - , _dfField = priceField - , _dfFunction = ConsolidateSum - } - , DataField - { _dfName = "Sum of field Count" - , _dfField = countField - , _dfFunction = ConsolidateSum - } - ] - , _pvtFields = - [ PivotFieldInfo colorField False - , PivotFieldInfo yearField True - , PivotFieldInfo priceField False - , PivotFieldInfo countField False - ] - , _pvtRowGrandTotals = True - , _pvtColumnGrandTotals = False - , _pvtOutline = False - , _pvtOutlineData = False - } - where - colorField = PivotFieldName "Color" - yearField = PivotFieldName "Year" - priceField = PivotFieldName "Price" - countField = PivotFieldName "Count" - -testPivotTableDefinition :: ByteString -testPivotTableDefinition = [r| - - - - - - - - - - - - - - - - - - - - - - - - -|] - -testPivotCacheDefinition :: ByteString -testPivotCacheDefinition = [r| - - - - - - - - - - - - -|] - -stripContentSpaces :: Document -> Document -stripContentSpaces doc@Document {documentRoot = root} = - doc {documentRoot = go root} - where - go e@Element {elementNodes = nodes} = - e {elementNodes = mapMaybe goNode nodes} - goNode (NodeElement el) = Just $ NodeElement (go el) - goNode t@(NodeContent txt) = - if T.strip txt == T.empty - then Nothing - else Just t - goNode other = Just $ other diff --git a/test/Diff.hs b/test/Diff.hs --- a/test/Diff.hs +++ b/test/Diff.hs @@ -3,11 +3,11 @@ import Data.Algorithm.Diff (Diff (..), getGroupedDiff) import Data.Algorithm.DiffOutput (ppDiff) import Data.Monoid ((<>)) -import Test.Tasty.HUnit (Assertion, assertBool) +import Test.Tasty.HUnit (Assertion, HasCallStack, assertBool) import Text.Groom (groom) -- | Like '@=?' but producing a diff on failure. -(@==?) :: (Eq a, Show a) => a -> a -> Assertion +(@==?) :: HasCallStack => (Eq a, Show a) => a -> a -> Assertion x @==? y = assertBool ("Expected:\n" <> groom x <> "\nDifference:\n" <> msg) (x == y) where diff --git a/test/DrawingTests.hs b/test/DrawingTests.hs new file mode 100644 --- /dev/null +++ b/test/DrawingTests.hs @@ -0,0 +1,398 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module DrawingTests + ( tests + , testDrawing + , testLineChartSpace + ) where + +#ifdef USE_MICROLENS +import Lens.Micro +#else +import Control.Lens +#endif +import Data.ByteString.Lazy (ByteString) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.HUnit (testCase) +import Text.RawString.QQ +import Text.XML + +import Codec.Xlsx +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Writer.Internal + +import Common +import Diff + +tests :: TestTree +tests = + testGroup + "Drawing tests" + [ testCase "correct drawing parsing" $ + [testDrawing] @==? parseBS testDrawingFile + , testCase "write . read == id for Drawings" $ + [testDrawing] @==? parseBS testWrittenDrawing + , testCase "correct chart parsing" $ + [testLineChartSpace] @==? parseBS testLineChartFile + , testCase "parse . render == id for line Charts" $ + [testLineChartSpace] @==? parseBS (renderChartSpace testLineChartSpace) + , testCase "parse . render == id for area Charts" $ + [testAreaChartSpace] @==? parseBS (renderChartSpace testAreaChartSpace) + , testCase "parse . render == id for bar Charts" $ + [testBarChartSpace] @==? parseBS (renderChartSpace testBarChartSpace) + , testCase "parse . render == id for pie Charts" $ + [testPieChartSpace] @==? parseBS (renderChartSpace testPieChartSpace) + , testCase "parse . render == id for scatter Charts" $ + [testScatterChartSpace] @==? parseBS (renderChartSpace testScatterChartSpace) + ] + +testDrawing :: UnresolvedDrawing +testDrawing = Drawing [anchor1, anchor2] + where + anchor1 = + Anchor + {_anchAnchoring = anchoring1, _anchObject = pic, _anchClientData = def} + anchoring1 = + TwoCellAnchor + { tcaFrom = unqMarker (0, 0) (0, 0) + , tcaTo = unqMarker (12, 320760) (33, 38160) + , tcaEditAs = EditAsAbsolute + } + pic = + Picture + { _picMacro = Nothing + , _picPublished = False + , _picNonVisual = nonVis1 + , _picBlipFill = bfProps + , _picShapeProperties = shProps + } + nonVis1 = + PicNonVisual $ + NonVisualDrawingProperties + { _nvdpId = DrawingElementId 0 + , _nvdpName = "Picture 1" + , _nvdpDescription = Just "" + , _nvdpHidden = False + , _nvdpTitle = Nothing + } + bfProps = + BlipFillProperties + {_bfpImageInfo = Just (RefId "rId1"), _bfpFillMode = Just FillStretch} + shProps = + ShapeProperties + { _spXfrm = Just trnsfrm + , _spGeometry = Just PresetGeometry + , _spFill = Nothing + , _spOutline = Just $ def {_lnFill = Just NoFill} + } + trnsfrm = + Transform2D + { _trRot = Angle 0 + , _trFlipH = False + , _trFlipV = False + , _trOffset = Just (unqPoint2D 0 0) + , _trExtents = + Just + (PositiveSize2D + (PositiveCoordinate 10074240) + (PositiveCoordinate 5402520)) + } + anchor2 = + Anchor + { _anchAnchoring = anchoring2 + , _anchObject = graphic + , _anchClientData = def + } + anchoring2 = + TwoCellAnchor + { tcaFrom = unqMarker (0, 87840) (21, 131040) + , tcaTo = unqMarker (7, 580320) (38, 132480) + , tcaEditAs = EditAsOneCell + } + graphic = + Graphic + { _grNonVisual = nonVis2 + , _grChartSpace = RefId "rId2" + , _grTransform = transform + } + nonVis2 = + GraphNonVisual $ + NonVisualDrawingProperties + { _nvdpId = DrawingElementId 1 + , _nvdpName = "" + , _nvdpDescription = Nothing + , _nvdpHidden = False + , _nvdpTitle = Nothing + } + transform = + Transform2D + { _trRot = Angle 0 + , _trFlipH = False + , _trFlipV = False + , _trOffset = Just (unqPoint2D 0 0) + , _trExtents = + Just + (PositiveSize2D + (PositiveCoordinate 10074240) + (PositiveCoordinate 5402520)) + } + +testDrawingFile :: ByteString +testDrawingFile = [r| + + + + + 00 + 00 + + + 12320760 + 3338160 + + + + + + + + + + + + + + 087840 + 21131040 + + + 7580320 + 38132480 + + + + + + + + + + + + + +|] + +testWrittenDrawing :: ByteString +testWrittenDrawing = renderLBS def $ toDocument testDrawing + +testLineChartFile :: ByteString +testLineChartFile = [r| + + + + + Line chart title + + + + + + + Sheet1!$A$1 + + + + + + Sheet1!$B$1:$D$1 + + + + + Sheet1!$A$2 + + + + + + Sheet1!$B$2:$D$2 + + + + + + + + + + +|] + +oneChartChartSpace :: Chart -> ChartSpace +oneChartChartSpace chart = + ChartSpace + { _chspTitle = Just $ ChartTitle (Just 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 BarStandardGrouping + , _brchSeries = + [ BarSeries + { _brserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$1" + , _serShapeProperties = + Just $ + def + { _spFill = Just $ solidRgb "000088" + , _spOutline = Just $ def {_lnFill = Just NoFill} + } + } + , _brserDataLblProps = Nothing + , _brserVal = Just $ Formula "Sheet1!$B$1:$D$1" + } + ] + } + +testPieChartSpace :: ChartSpace +testPieChartSpace = + oneChartChartSpace + PieChart + { _pichSeries = + [ PieSeries + { _piserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$1" + , _serShapeProperties = Nothing + } + , _piserDataPoints = + [ def & dpShapeProperties ?~ solidFill "000088" + , def & dpShapeProperties ?~ solidFill "008800" + , def & dpShapeProperties ?~ solidFill "880000" + ] + , _piserDataLblProps = Nothing + , _piserVal = Just $ Formula "Sheet1!$B$1:$D$1" + } + ] + } + where + solidFill color = def & spFill ?~ solidRgb color + +testScatterChartSpace :: ChartSpace +testScatterChartSpace = + oneChartChartSpace + ScatterChart + { _scchStyle = ScatterMarker + , _scchSeries = + [ ScatterSeries + { _scserShared = + Series + { _serTx = Just $ Formula "Sheet1!$A$2" + , _serShapeProperties = + Just $ def {_spOutline = Just $ def {_lnFill = Just NoFill}} + } + , _scserMarker = Just $ DataMarker (Just DataMarkerSquare) Nothing + , _scserDataLblProps = Nothing + , _scserXVal = Just $ Formula "Sheet1!$B$1:$D$1" + , _scserYVal = Just $ Formula "Sheet1!$B$2:$D$2" + , _scserSmooth = Nothing + } + ] + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +module Main + ( main + ) where + +#ifdef USE_MICROLENS +import Lens.Micro +#else +import Control.Lens +#endif +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LB +import qualified Data.Map as M +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified StreamTests +import Text.XML + +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.HUnit (testCase, (@=?)) +import Test.Tasty.SmallCheck (testProperty) + +import TestXlsx + +import Codec.Xlsx +import Codec.Xlsx.Formatted + +import AutoFilterTests +import Common +import CommonTests +import CondFmtTests +import Diff +import DrawingTests +import PivotTableTests + +main :: IO () +main = defaultMain $ + testGroup "Tests" + [ + testCase "write . read == id" $ do + let bs = fromXlsx testTime testXlsx + LB.writeFile "data-test.xlsx" bs + testXlsx @==? toXlsx (fromXlsx testTime testXlsx) + , testCase "write . fast-read == id" $ do + let bs = fromXlsx testTime testXlsx + LB.writeFile "data-test.xlsx" bs + testXlsx @==? toXlsxFast (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: single underline" $ + [withSingleUnderline testSharedStringTable] @=? parseBS testStringsWithSingleUnderline + , testCase "correct shared strings parsing: double underline" $ + [withDoubleUnderline testSharedStringTable] @=? parseBS testStringsWithDoubleUnderline + , testCase "correct shared strings parsing even when one of the shared strings entry is just " $ + [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty + , testCase "correct comments parsing" $ + [testCommentTable] @=? parseBS testComments + , testCase "correct custom properties parsing" $ + [testCustomProperties] @==? parseBS testCustomPropertiesXml + , testCase "proper results from `formatted`" $ + testFormattedResult @==? testRunFormatted + , testCase "proper results from `formatWorkbook`" $ + testFormatWorkbookResult @==? testFormatWorkbook + , testCase "formatted . toFormattedCells = id" $ do + let fmtd = formatted testFormattedCells minimalStyleSheet + testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd) + (formattedStyleSheet fmtd) + , testCase "proper results from `conditionallyFormatted`" $ + testCondFormattedResult @==? testRunCondFormatted + , testCase "toXlsxEither: properly formatted" $ + Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) + , testCase "toXlsxEither: invalid format" $ + Left (InvalidZipArchive "Did not find end of central directory signature") @==? toXlsxEither "this is not a valid XLSX file" + , testCase "toXlsx: correct floats parsing (typed and untyped cells are floats by default)" + $ floatsParsingTests toXlsx + , testCase "toXlsxFast: correct floats parsing (typed and untyped cells are floats by default)" + $ floatsParsingTests toXlsxFast + , testCase "toXlsx: correct resolving of absolute relationship targets" + $ absoluteRelationshipsTest toXlsx + , testCase "toXlsxFast: correct resolving of absolute relationship targets" + $ absoluteRelationshipsTest toXlsxFast + , testGroup "Codec: sheet state visibility" + [ testGroup "toXlsxEitherFast" + [ testProperty "pure state == toXlsxEitherFast (fromXlsx (defXlsxWithState state))" $ + \state -> + (Right (Just state) ==) $ + fmap sheetStateOfDefXlsx $ + toXlsxEitherFast . fromXlsx testTime $ + defXlsxWithState state + , testCase "should otherwise infer visible state by default" $ + Right (Just Visible) @=? (fmap sheetStateOfDefXlsx . toXlsxEitherFast) (fromXlsx testTime defXlsx) + ] + , testGroup "toXlsxEither" + [ testProperty "pure state == toXlsxEither (fromXlsx (defXlsxWithState state))" $ + \state -> + (Right (Just state) ==) $ + fmap sheetStateOfDefXlsx $ + toXlsxEither . fromXlsx testTime $ + defXlsxWithState state + , testCase "should otherwise infer visible state by default" $ + Right (Just Visible) @=? (fmap sheetStateOfDefXlsx . toXlsxEither) (fromXlsx testTime defXlsx) + ] + ] + , CommonTests.tests + , CondFmtTests.tests + , PivotTableTests.tests + , DrawingTests.tests + , AutoFilterTests.tests + , StreamTests.tests + ] + +floatsParsingTests :: (ByteString -> Xlsx) -> IO () +floatsParsingTests parser = do + bs <- LB.readFile "data/floats.xlsx" + let xlsx = parser bs + parsedCells = maybe mempty (_wsCells . snd) $ listToMaybe $ xlsx ^. xlSheets + expectedCells = M.fromList + [ ((1,1), def & cellValue ?~ CellDouble 12.0) + , ((2,1), def & cellValue ?~ CellDouble 13.0) + , ((3,1), def & cellValue ?~ CellDouble 14.0 & cellStyle ?~ 1) + , ((4,1), def & cellValue ?~ CellDouble 15.0) + ] + expectedCells @==? parsedCells + +-- Test whether absolute logical item names are correctly mapped to ZIP item names. +-- absolute_relationships.xlsx contains relationships of worksheet, comment, +-- drawing and pivot table types with absolute paths in their targets. +absoluteRelationshipsTest :: (ByteString -> Xlsx) -> IO () +absoluteRelationshipsTest parser = do + bs <- LB.readFile "data/absolute_relationships.xlsx" + let xlsx = parser bs + expectedComment = Just $ Comment (XlsxText "test comment") "author" False + parsedComment = xlsx ^? ixSheet "Test" . ixCell (2, 1) . cellComment . _Just + expectedComment @==? parsedComment + +constSheetName :: Text +constSheetName = "sheet1" + +defXlsx :: Xlsx +defXlsx = def & atSheet constSheetName ?~ def + +defXlsxWithState :: SheetState -> Xlsx +defXlsxWithState state = + def & atSheet constSheetName ?~ (wsState .~ state $ def) + +sheetStateOfDefXlsx :: Xlsx -> Maybe SheetState +sheetStateOfDefXlsx xlsx = + xlsx ^. atSheet constSheetName & mapped %~ _wsState diff --git a/test/PivotTableTests.hs b/test/PivotTableTests.hs new file mode 100644 --- /dev/null +++ b/test/PivotTableTests.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module PivotTableTests + ( tests + , testPivotTable + , testPivotSrcCells + ) where + +#ifdef USE_MICROLENS +import Lens.Micro +#else +import Control.Lens +#endif +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.Internal (unsafeRefId) +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 + -- fields with numeric values go into cache records + testPivotCacheFields' = + [ if cfName cf == PivotFieldName "Color" + then cf + else cf {cfItems = []} + | cf <- testPivotCacheFields + ] + Just (sheetName, ref, testPivotCacheFields', Just (unsafeRefId 1)) @==? + 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 (Just $ colorField) False FieldSortAscending [CellText "green"] + , PivotFieldInfo (Just $ yearField) True FieldSortManual [] + , PivotFieldInfo (Just $ priceField) False FieldSortManual [] + , PivotFieldInfo (Just $ countField) False FieldSortManual [] + ] + , _pvtRowGrandTotals = True + , _pvtColumnGrandTotals = False + , _pvtOutline = False + , _pvtOutlineData = False + } + where + colorField = PivotFieldName "Color" + yearField = PivotFieldName "Year" + priceField = PivotFieldName "Price" + countField = PivotFieldName "Count" + +testPivotSrcCells :: CellMap +testPivotSrcCells = + M.fromList $ + concat + [ [((row, col), def & cellValue ?~ v) | (col, v) <- zip [1 ..] cells] + | (row, cells) <- zip [1 ..] cellMap + ] + where + cellMap = + [ [CellText "Color", CellText "Year", CellText "Price", CellText "Count"] + , [CellText "green", CellDouble 2012, CellDouble 12.23, CellDouble 17] + , [CellText "white", CellDouble 2011, CellDouble 73.99, CellDouble 21] + , [CellText "red", CellDouble 2012, CellDouble 10.19, CellDouble 172] + , [CellText "white", CellDouble 2012, CellDouble 34.99, CellDouble 49] + ] + +testPivotCacheFields :: [CacheField] +testPivotCacheFields = + [ CacheField + (PivotFieldName "Color") + [CellText "green", CellText "white", CellText "red"] + , CacheField (PivotFieldName "Year") [CellDouble 2012, CellDouble 2011] + , CacheField + (PivotFieldName "Price") + [CellDouble 12.23, CellDouble 73.99, CellDouble 10.19, CellDouble 34.99] + , CacheField + (PivotFieldName "Count") + [CellDouble 17, CellDouble 21, CellDouble 172, CellDouble 49] + ] + +testPivotTableDefinition :: ByteString +testPivotTableDefinition = [r| + + + + + + + + + + + + + + + + + + + + + + + + +|] + +testPivotCacheDefinition :: ByteString +testPivotCacheDefinition = [r| + + + + + + + + + + + + + + + + + + + + + + +|] + +stripContentSpaces :: Document -> Document +stripContentSpaces doc@Document {documentRoot = root} = + doc {documentRoot = go root} + where + go e@Element {elementNodes = nodes} = + e {elementNodes = mapMaybe goNode nodes} + goNode (NodeElement el) = Just $ NodeElement (go el) + goNode t@(NodeContent txt) = + if T.strip txt == T.empty + then Nothing + else Just t + goNode other = Just $ other diff --git a/test/StreamTests.hs b/test/StreamTests.hs new file mode 100644 --- /dev/null +++ b/test/StreamTests.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE CPP #-} + +module StreamTests + ( tests + ) where + +#ifdef USE_MICROLENS + +import Test.Tasty (TestName, TestTree, testGroup) +tests :: TestTree +tests = testGroup + "I stubbed out the tests module for microlens \ + because it doesn't understand setOf. \ + Volunteers are welcome to fix this!" + [] +#else + +import Control.Exception +import Codec.Archive.Zip as Zip +import Codec.Xlsx +import Codec.Xlsx.Parser.Stream +import Conduit ((.|)) +import qualified Conduit as C +import Control.Lens hiding (indexed) +import Control.Monad (void) +import Data.Set.Lens +import qualified Data.ByteString.Lazy as LB +import qualified Data.ByteString as BS +import Data.Map (Map) +import qualified Data.Conduit.Combinators as C +import qualified Data.Map as M +import qualified Data.IntMap.Strict as IM +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as V +import Diff +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import TestXlsx +import qualified Codec.Xlsx.Writer.Stream as SW +import qualified Codec.Xlsx.Writer.Internal.Stream as SW +import Control.Monad (void) +import Control.Monad.State.Lazy +import Test.Tasty.SmallCheck +import Test.SmallCheck.Series.Instances () +import qualified Data.Set as Set +import Data.Set (Set) +import Text.Printf +import Data.Conduit +import Control.Arrow ((&&&)) +import Data.Maybe (fromJust) + +tshow :: Show a => a -> Text +tshow = Text.pack . show + +toBs :: Xlsx -> BS.ByteString +toBs = LB.toStrict . fromXlsx testTime + +tests :: TestTree +tests = + testGroup "Stream tests" + [ + testGroup "Writer/shared strings" + [ testProperty "Input same as the output" sharedStringInputSameAsOutput + , testProperty "Set of input texts is same as map length" sharedStringInputTextsIsSameAsMapLength + , testProperty "Set of input texts is as value set length" sharedStringInputTextsIsSameAsValueSetLength + ], + + testGroup "Reader/shared strings" + [ testCase "Can parse RichText values" richCellTextIsParsed + ], + + + testGroup "Reader/Writer" + [ testCase "Write as stream, see if memory based implementation can read it" $ readWrite simpleWorkbook + , testCase "Write as stream, see if memory based implementation can read it" $ readWrite simpleWorkbookRow + , testCase "Test a small workbook which has a fullblown square" $ readWrite smallWorkbook + , testCase "Test a big workbook as a full square which caused issues with zipstream \ + The buffer of zipstream maybe 1kb, this workbook is big enough \ + to be more than that. \ + So if this encodes/decodes we know we can handle those sizes. \ + In some older version the bytestring got cut off resulting in a corrupt xlsx file" + $ readWrite bigWorkbook + , testCase "Test a workbook containing multiple sheets" + $ readWriteMultipleSheets multipleSheetsWorkbook + -- , testCase "Write as stream, see if memory based implementation can read it" $ readWrite testXlsx + -- TODO forall SheetItem write that can be read + ], + + testGroup "Reader/inline strings" + [ testCase "Can parse row with inline strings" inlineStringsAreParsed + ], + + testGroup "Reader/floats parsing" + [ testCase "Can parse untyped values as floats" untypedCellsAreParsedAsFloats + ] + ] + +readWrite :: Xlsx -> IO () +readWrite input = do + BS.writeFile "testinput.xlsx" (toBs input) + items <- runXlsxM "testinput.xlsx" $ collectItemsIdentifier . fromJust =<< makeIdentifierFromName "Sheet1" + bs <- runConduitRes $ void (SW.writeXlsx SW.defaultSettings $ C.yieldMany items) .| C.foldC + case toXlsxEither $ LB.fromStrict bs of + Right result -> + input @==? result + Left x -> do + throwIO x + +readWriteMultipleSheets :: Xlsx -> IO () +readWriteMultipleSheets input = do + BS.writeFile "testinput.xlsx" $ toBs input + sheetsAndConduits <- runXlsxM "testinput.xlsx" $ do + sheets <- reverse . _wiSheets <$> getWorkbookInfo + let sheetCount = length sheets + let sheetNamesAndStates = map (sheetInfoName &&& sheetInfoState) sheets + sheetConduits <- map C.yieldMany + <$> mapM (collectItemsIdentifier . getSheetIdentifier) sheets + pure $ zip sheetNamesAndStates sheetConduits + + bs <- runConduitRes $ void (SW.writeXlsxWithConfig $ SW.defWriteXlsxConfig & SW.setNameInfosAndConduits sheetsAndConduits) .| C.foldC + case toXlsxEither $ LB.fromStrict bs of + Right result -> input @==? result + Left x -> throwIO x + +-- test if the input text is also the result (a property we use for convenience) +sharedStringInputSameAsOutput :: Text -> Either String String +sharedStringInputSameAsOutput someText = + if someText == out then Right msg else Left msg + where + out = fst $ evalState (SW.upsertSharedString someText) SW.initialSharedString + msg = printf "'%s' = '%s'" (Text.unpack out) (Text.unpack someText) + +-- test if unique strings actually get set in the map as keys +sharedStringInputTextsIsSameAsMapLength :: [Text] -> Bool +sharedStringInputTextsIsSameAsMapLength someTexts = + length result == length unqTexts + where + result :: Map Text Int + result = view SW.string_map $ traverse SW.upsertSharedString someTexts `execState` SW.initialSharedString + unqTexts :: Set Text + unqTexts = Set.fromList someTexts + +-- test for every unique string we get a unique number +sharedStringInputTextsIsSameAsValueSetLength :: [Text] -> Bool +sharedStringInputTextsIsSameAsValueSetLength someTexts = + length result == length unqTexts + where + result :: Set Int + result = setOf (SW.string_map . traversed) $ traverse SW.upsertSharedString someTexts `execState` SW.initialSharedString + unqTexts :: Set Text + unqTexts = Set.fromList someTexts + +-- can we do xx +simpleWorkbook :: Xlsx +simpleWorkbook = def & atSheet "Sheet1" ?~ sheet + where + sheet = toWs [ ((RowIndex 1, ColumnIndex 1), a1) + , ((RowIndex 1, ColumnIndex 2), cellValue ?~ CellText "text at B1 Sheet1" $ def) ] + +a1 :: Cell +a1 = cellValue ?~ CellText "text at A1 Sheet1" $ cellStyle ?~ 1 $ def + +-- can we do x +-- x +simpleWorkbookRow :: Xlsx +simpleWorkbookRow = def & atSheet "Sheet1" ?~ sheet + where + sheet = toWs [ ((RowIndex 1, ColumnIndex 1), a1) + , ((RowIndex 2, ColumnIndex 1), cellValue ?~ CellText "text at A2 Sheet1" $ def) ] + +toWs :: [((RowIndex, ColumnIndex), Cell)] -> Worksheet +toWs x = set wsCells (M.fromList x) def + +-- can we do xxx +-- xxx +-- . +-- . +smallWorkbook :: Xlsx +smallWorkbook = def & atSheet "Sheet1" ?~ sheet + where + sheet = toWs $ [1..2] >>= \row -> + [((row,1), a1) + , ((row,2), def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) + , ((row,3), def & cellValue ?~ CellText "text at C1 Sheet1") + , ((row,4), def & cellValue ?~ CellDouble (0.2 + 0.1)) + , ((row,5), def & cellValue ?~ CellBool False) + ] +-- sheets = [("Sheet1" , toWs $ [1..2] >>= \row -> +-- [ ((RowIndex row, ColumnIndex 1), a1) +-- , ((RowIndex row, ColumnIndex 2), +-- def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) +-- , ((RowIndex row, ColumnIndex 3), +-- def & cellValue ?~ CellText "text at C1 Sheet1") +-- , ((RowIndex row, ColumnIndex 4), +-- def & cellValue ?~ CellDouble (0.2 + 0.1)) +-- , ((RowIndex row, ColumnIndex 5), +-- def & cellValue ?~ CellBool False) +-- ] +-- )] + +bigWorkbook :: Xlsx +bigWorkbook = def & atSheet "Sheet1" ?~ sheet + where + sheet = toWs $ [1..512] >>= \row -> + [((row,1), a1) + ,((row,2), def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) + ,((row,3), def & cellValue ?~ CellText "text at C1 Sheet1") + ] +-- sheets = [("Sheet1" , toWs $ [1..512] >>= \row -> +-- [((RowIndex row, ColumnIndex 1), a1) +-- ,((RowIndex row, ColumnIndex 2), +-- def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1")) +-- ,((RowIndex row, ColumnIndex 3), +-- def & cellValue ?~ CellText "text at C1 Sheet1") +-- ] +-- )] + +multipleSheetsWorkbook :: Xlsx +multipleSheetsWorkbook = simpleWorkbook + & atSheet "my Sheet 2" ?~ sheet2 + & atSheet "my Sheet 3" ?~ sheet3 + where + sheet2 = toWs [ ((RowIndex 1, ColumnIndex 1), cellValue ?~ CellText "text at A1 Sheet2" $ def) + , ((RowIndex 1, ColumnIndex 2), cellValue ?~ CellText "text at B1 Sheet2" $ def) ] + sheet3 = toWs [ ((RowIndex 1, ColumnIndex 1), cellValue ?~ CellText "text at A1 Sheet3" $ def) + , ((RowIndex 1, ColumnIndex 2), cellValue ?~ CellText "text at B1 Sheet3" $ def) ] + & wsState .~ Hidden + +inlineStringsAreParsed :: IO () +inlineStringsAreParsed = do + items <- runXlsxM "data/inline-strings.xlsx" $ collectItemsIdentifier . fromJust =<< makeIdentifierFromName "Sheet1" + let expected = + [ IM.fromList + [ ( 1, + Cell + { _cellStyle = Nothing, + _cellValue = Just (CellText "My Inline String"), + _cellComment = Nothing, + _cellFormula = Nothing + } + ), + ( 2, + Cell + { _cellStyle = Nothing, + _cellValue = Just (CellText "two"), + _cellComment = Nothing, + _cellFormula = Nothing + } + ) + ] + ] + expected @==? (items ^.. traversed . ri_cell_row) + +untypedCellsAreParsedAsFloats :: IO () +untypedCellsAreParsedAsFloats = do + -- values in that file are under `General` cell-type and are not marked + -- as numbers explicitly in `t` attribute. + items <- runXlsxM "data/floats.xlsx" $ collectItemsIdentifier . fromJust =<< makeIdentifierFromName "Лист1" + let expected = + [ IM.fromList [ (1, def & cellValue ?~ CellDouble 12.0) ] + , IM.fromList [ (1, def & cellValue ?~ CellDouble 13.0) ] + -- cell below has explicit `Numeric` type, while others are all `General`, + -- but sometimes excel does not add a `t="n"` attr even to numeric cells + -- but it should be default as number in any cases if `t` is missing + , IM.fromList [ (1, def & cellValue ?~ CellDouble 14.0 & cellStyle ?~ 1 ) ] + , IM.fromList [ (1, def & cellValue ?~ CellDouble 15.0) ] + ] + expected @==? (_ri_cell_row <$> items) + + +richCellTextIsParsed :: IO () +richCellTextIsParsed = do + BS.writeFile "testinput.xlsx" (toBs richWorkbook) + runXlsxM "testinput.xlsx" $ do + sharedStrings <- getOrParseSharedStringss + let result = Set.fromList $ V.toList sharedStrings + liftIO $ expected @==? result + + where + expected :: Set.Set Text + expected = Set.fromList + [ textA1 + , firstClauseB1 <> secondClauseB1 + , firstClauseB2 <> secondClauseB2 + ] + + textA1 = "Text at A1" + firstClauseB1 = "First clause at B1;" + firstClauseB2 = "First clause at B2;" + secondClauseB1 = "Second clause at B1" + secondClauseB2 = "Second clause at B2" + + richWorkbook :: Xlsx + richWorkbook = def & atSheet "Sheet1" ?~ toWs + [ ((RowIndex 1, ColumnIndex 1), cellValue ?~ CellText textA1 $ def) + , ((RowIndex 2, ColumnIndex 1), cellValue ?~ cellRich firstClauseB1 secondClauseB1 $ def) + , ((RowIndex 2, ColumnIndex 2), cellValue ?~ cellRich firstClauseB2 secondClauseB2 $ def) + ] + +cellRich :: Text -> Text -> CellValue +cellRich firstClause secondClause = CellRich + [ RichTextRun + { _richTextRunProperties = Just RunProperties + { _runPropertiesBold = Nothing + , _runPropertiesCharset = Just 1 + , _runPropertiesColor = Just Color + { _colorAutomatic = Nothing + , _colorARGB = Nothing + , _colorTheme = Just 1 + , _colorTint = Nothing + } + , _runPropertiesCondense = Nothing + , _runPropertiesExtend = Nothing + , _runPropertiesFontFamily = Just FontFamilySwiss + , _runPropertiesItalic = Nothing + , _runPropertiesOutline = Nothing + , _runPropertiesFont = Just "Aptos Narrow" + , _runPropertiesScheme = Nothing + , _runPropertiesShadow = Nothing + , _runPropertiesStrikeThrough = Nothing + , _runPropertiesSize = Just 11.0 + , _runPropertiesUnderline = Nothing + , _runPropertiesVertAlign = Nothing + } + , _richTextRunText = firstClause + } + , RichTextRun + { _richTextRunProperties = Just RunProperties + { _runPropertiesBold = Just True + , _runPropertiesCharset = Just 1 + , _runPropertiesColor = Just Color + { _colorAutomatic = Nothing + , _colorARGB = Just "FFFF0000" + , _colorTheme = Nothing + , _colorTint = Nothing + } + , _runPropertiesCondense = Nothing + , _runPropertiesExtend = Nothing + , _runPropertiesFontFamily = Just FontFamilySwiss + , _runPropertiesItalic = Nothing + , _runPropertiesOutline = Nothing + , _runPropertiesFont = Just "Arial" + , _runPropertiesScheme = Nothing + , _runPropertiesShadow = Nothing + , _runPropertiesStrikeThrough = Nothing + , _runPropertiesSize = Just 8.0 + , _runPropertiesUnderline = Nothing + , _runPropertiesVertAlign = Nothing + } + , _richTextRunText = secondClause + } + ] + +#endif diff --git a/test/Test/SmallCheck/Series/Instances.hs b/test/Test/SmallCheck/Series/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Test/SmallCheck/Series/Instances.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.SmallCheck.Series.Instances + ( + ) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import Test.SmallCheck.Series + +import Codec.Xlsx + +#if !MIN_VERSION_smallcheck(1,2,0) +cons6 :: + ( Serial m a6 + , Serial m a5 + , Serial m a4 + , Serial m a3 + , Serial m a2 + , Serial m a1 + ) + => (a6 -> a5 -> a4 -> a3 -> a2 -> a1 -> a) + -> Test.SmallCheck.Series.Series m a +cons6 f = decDepth $ + f <$> series + <~> series + <~> series + <~> series + <~> series + <~> series +#endif + +instance Monad m => Serial m Text where + series = T.pack <$> series + +instance (Serial m k, Serial m v) => Serial m (Map k v) where + series = Map.singleton <$> series <~> series + +{------------------------------------------------------------------------------- + Conditional formatting +-------------------------------------------------------------------------------} + +instance Monad m => Serial m CfRule + +instance Monad m => Serial m Condition where + series = localDepth (const 2) $ cons2 AboveAverage + \/ cons1 BeginsWith + \/ cons2 BelowAverage + \/ cons1 BottomNPercent + \/ cons1 BottomNValues + \/ cons1 CellIs + \/ cons4 ColorScale2 + \/ cons6 ColorScale3 + \/ cons0 ContainsBlanks + \/ cons0 ContainsErrors + \/ cons1 ContainsText + \/ cons1 DataBar + \/ cons0 DoesNotContainErrors + \/ cons0 DoesNotContainBlanks + \/ cons1 DoesNotContainText + \/ cons0 DuplicateValues + \/ cons1 EndsWith + \/ cons1 Expression + \/ cons1 IconSet + \/ cons1 InTimePeriod + \/ cons1 TopNPercent + \/ cons1 TopNValues + \/ cons0 UniqueValues + +instance Monad m => Serial m NStdDev + +instance Monad m => Serial m Inclusion + +instance Monad m => Serial m OperatorExpression + +instance Monad m => Serial m DataBarOptions + +instance Monad m => Serial m MaxCfValue + +instance Monad m => Serial m MinCfValue + +instance Monad m => Serial m Color + +-- TODO: proper formula generator (?) +instance Monad m => Serial m Formula + +instance Monad m => Serial m IconSetOptions + +instance Monad m => Serial m IconSetType + +instance Monad m => Serial m CfValue + +instance Monad m => Serial m TimePeriod + +{------------------------------------------------------------------------------- + Autofilter +-------------------------------------------------------------------------------} + +instance Monad m => Serial m AutoFilter where + series = localDepth (const 4) $ cons2 AutoFilter + +instance Monad m => Serial m CellRef + +instance Monad m => Serial m FilterColumn + +instance Monad m => Serial m EdgeFilterOptions + +instance Monad m => Serial m CustomFilter + +instance Monad m => Serial m CustomFilterOperator + +instance Monad m => Serial m FilterCriterion + +instance Monad m => Serial m DateGroup + +instance Monad m => Serial m FilterByBlank + +instance Monad m => Serial m ColorFilterOptions + +instance Monad m => Serial m DynFilterOptions + +instance Monad m => Serial m DynFilterType diff --git a/test/TestXlsx.hs b/test/TestXlsx.hs new file mode 100644 --- /dev/null +++ b/test/TestXlsx.hs @@ -0,0 +1,599 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} + +module TestXlsx where + +#ifdef USE_MICROLENS +import Lens.Micro.Platform +#else +import Control.Lens +#endif +import Control.Monad.State.Lazy +import Data.ByteString.Lazy (ByteString) +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 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 PivotTableTests +import DrawingTests + +testXlsx :: Xlsx +testXlsx = Xlsx sheets minimalStyles definedNames customProperties DateBase1904 + where + sheets = + [ ("List1", sheet1) + , ("Another sheet", sheet2) + , ("with pivot table", pvSheet) + , ("cellrange DV source", foreignDvSourceSheet) -- "foreign" sheet holding validation data + , ("cellrange DV test", foreignDvTestSheet) -- applies validation using foreign cell ranges + , ("hidden sheet", def & wsState .~ Hidden & cellValueAt (1,1) ?~ CellText "I'm hidden!") + , ("VERY hidden sheet", def & wsState .~ VeryHidden & cellValueAt (1,1) ?~ CellText "I'm VERY hidden!!") + ] + sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges + sheetViews pageSetup cFormatting validations [] (Just autoFilter) + tables (Just protection) sharedFormulas def + sharedFormulas = + M.fromList + [ (SharedFormulaIndex 0, SharedFormulaOptions (CellRef "A5:C5") (Formula "A4")) + , (SharedFormulaIndex 1, SharedFormulaOptions (CellRef "B6:C6") (Formula "B3+12")) + ] + autoFilter = def & afRef ?~ CellRef "A1:E10" + & afFilterColumns .~ fCols + fCols = M.fromList [ (1, Filters DontFilterByBlank + [FilterValue "a", FilterValue "b",FilterValue "ZZZ"]) + , (2, CustomFiltersAnd (CustomFilter FltrGreaterThanOrEqual "0") + (CustomFilter FltrLessThan "42"))] + tables = + [ Table + { tblName = Just "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 + foreignDvSourceSheet = def & wsCells .~ cellRangeDvSourceMap + foreignDvTestSheet = def & wsDataValidations .~ foreignValidations & + wsCells . at (1, 1) ?~ + (def & cellValue ?~ CellText ("Hi! try " <> unCellRef testForeignDvRange)) + pvSheet = sheetWithPvCells & wsPivotTables .~ [testPivotTable] + sheetWithPvCells = def & wsCells .~ testPivotSrcCells + rowProps = M.fromList [(1, RowProps { rowHeight = Just (CustomHeight 50) + , rowStyle = Just 3 + , rowHidden = False + })] + 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), ((1, 10), cd1_10) + , ((3, 1), cd3_1), ((3, 2), cd3_2), ((3, 3), cd3_3), ((3, 7), cd3_7) + , ((4, 1), cd4_1), ((4, 2), cd4_2), ((4, 3), cd4_3) + , ((5, 1), cd5_1), ((5, 2), cd5_2), ((5, 3), cd5_3) + , ((6, 2), cd6_2), ((6, 3), cd6_3) + ] + where + cd v = def {_cellValue=Just v} + cd1_2 = cd (CellText "just a text, fließen, русский <> и & \"in quotes\"") + cd1_5 = cd (CellDouble 42.4567) + cd1_10 = cd (CellText "") + cd3_1 = cd (CellText "another text") + cd3_2 = def -- shouldn't it be skipped? + cd3_3 = def & cellValue ?~ CellError ErrorDiv0 + & cellFormula ?~ simpleCellFormula "1/0" + cd3_7 = cd (CellBool True) + cd4_1 = cd (CellDouble 1) + cd4_2 = cd (CellDouble 123456789012345) + cd4_3 = (cd (CellDouble (1+2))) { _cellFormula = + Just $ simpleCellFormula "A4+B4<>11" + } + cd5_1 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 0) + cd5_2 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 0) + cd5_3 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 0) + cd6_2 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 1) + cd6_3 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 1) + +cellRangeDvSourceMap :: CellMap +cellRangeDvSourceMap = M.fromList [ ((1, 1), def & cellValue ?~ CellText "A-A-A") + , ((2, 1), def & cellValue ?~ CellText "B-B-B") + , ((1, 2), def & cellValue ?~ CellText "C-C-C") + , ((2, 2), def & cellValue ?~ CellText "D-D-D") + , ((1, 3), def & cellValue ?~ CellDouble 6) + , ((2, 3), def & cellValue ?~ CellDouble 7) + , ((3, 1), def & cellValue ?~ CellDouble 5) + , ((3, 2), def & cellValue ?~ CellText "numbers!") + , ((3, 3), def & cellValue ?~ CellDouble 5) + ] + +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, dxf3] + & 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)) + dxf3 = def & dxfNumFmt ?~ NumFmt 164 "0.000" + red = def & colorARGB ?~ "FFFF0000" + cellXf1 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 2 } + cellXf2 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 164 } + + +withSingleUnderline :: SharedStringTable -> SharedStringTable +withSingleUnderline = withUnderline FontUnderlineSingle + +withDoubleUnderline :: SharedStringTable -> SharedStringTable +withDoubleUnderline = withUnderline FontUnderlineDouble + +withUnderline :: FontUnderline -> SharedStringTable -> SharedStringTable +withUnderline u (SharedStringTable [text, XlsxRichText [rich1, RichTextRun (Just props) val]]) = + let newprops = props & runPropertiesUnderline .~ Just u + in SharedStringTable [text, XlsxRichText [rich1, RichTextRun (Just newprops) val]] + +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 + & runPropertiesItalic .~ Just True + & 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" False) + , (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 = [r| + + + plain text + Just + example + +|] + +testStringsWithSingleUnderline :: ByteString +testStringsWithSingleUnderline = [r| + + + plain text + Just + example + +|] + +testStringsWithDoubleUnderline :: ByteString +testStringsWithDoubleUnderline = [r| + + + plain text + Just + example + +|] + +testStringsWithEmpty :: ByteString +testStringsWithEmpty = [r| + + + + +|] + +testComments :: ByteString +testComments = [r| + + + + Bob + CBR + + + + + + + + + + Bob: + + + + + + + Why such high expense? + + + + + Some comment here + + + +|] + +testCustomProperties :: CustomProperties +testCustomProperties = CustomProperties.fromList + [ ("testTextProp", VtLpwstr "test text property value") + , ("prop2", VtLpwstr "222") + , ("bool", VtBool False) + , ("prop333", VtInt 1) + , ("decimal", VtDecimal 1.234) ] + +testCustomPropertiesXml :: ByteString +testCustomPropertiesXml = [r| + + + + 222 + + + 1 + + + test text property value + + + 1.234 + + + false + + + + ZXhhbXBs + ZSBibG9i + IGNvbnRl + bnRz + + + +|] + +testFormattedResult :: Formatted +testFormattedResult = Formatted cm styleSheet merges + where + cm = M.fromList [ ((1, 1), cell11) + , ((1, 2), cell12) + , ((2, 5), cell25) ] + cell11 = Cell + { _cellStyle = Just 1 + , _cellValue = Just (CellText "text at A1") + , _cellComment = Nothing + , _cellFormula = Nothing } + cell12 = Cell + { _cellStyle = Just 2 + , _cellValue = Just (CellDouble 1.23) + , _cellComment = Nothing + , _cellFormula = Nothing } + cell25 = Cell + { _cellStyle = Just 3 + , _cellValue = Just (CellDouble 1.23456) + , _cellComment = Nothing + , _cellFormula = Nothing } + merges = [] + styleSheet = + minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3]) + & styleSheetFonts %~ (++ [font1, font2]) + & styleSheetNumFmts .~ numFmts + nextFontId = length (minimalStyleSheet ^. styleSheetFonts) + cellXf1 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just nextFontId } + font1 = def + { _fontName = Just "Calibri" + , _fontBold = Just True } + cellXf2 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just (nextFontId + 1) + , _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 164 } + font2 = def + { _fontItalic = Just True } + cellXf3 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 2 } + numFmts = M.fromList [(164, "0.0000")] + +testRunFormatted :: Formatted +testRunFormatted = formatted formattedCellMap minimalStyleSheet + where + formattedCellMap = flip execState def $ do + let font1 = def & fontBold ?~ True + & fontName ?~ "Calibri" + at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1" + & formattedFormat . formatFont ?~ font1) + at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23 + & formattedFormat . formatFont . non def . fontItalic ?~ True + & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4) + at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456 + & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) + +testFormatWorkbookResult :: Xlsx +testFormatWorkbookResult = def & xlSheets .~ sheets + & xlStyles .~ renderStyleSheet style + where + cellMap1 = M.fromList [((1, 1), Cell { _cellStyle = Nothing + , _cellValue = Just (CellText "text at A1 Sheet1") + , _cellComment = Nothing + , _cellFormula = Nothing })] + cellMap2 = M.fromList [((2, 3), Cell { _cellStyle = Just 1 + , _cellValue = Just (CellDouble 1.23456) + , _cellComment = Nothing + , _cellFormula = Nothing })] + sheets = [ ("Sheet1", def & wsCells .~ cellMap1) , ("Sheet2", def & wsCells .~ cellMap2) ] + style = minimalStyleSheet & styleSheetNumFmts .~ M.fromList [(164, "DD.MM.YYYY")] + & styleSheetCellXfs .~ [cellXf1, cellXf2] + cellXf1 = def + & cellXfBorderId .~ Just 0 + & cellXfFillId .~ Just 0 + & cellXfFontId .~ Just 0 + cellXf2 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 164 } + +testFormatWorkbook :: Xlsx +testFormatWorkbook = formatWorkbook sheets minimalStyleSheet + where + sheetNames = ["Sheet1", "Sheet2"] + testFormattedCellMap1 = M.fromList [((1,1), (def & formattedCell . cellValue ?~ CellText "text at A1 Sheet1"))] + + testFormattedCellMap2 = M.fromList [((2,3), (def & formattedCell . cellValue ?~ CellDouble 1.23456 + & formattedFormat . formatNumberFormat ?~ (UserNumberFormat "DD.MM.YYYY")))] + sheets = zip sheetNames [testFormattedCellMap1, testFormattedCellMap2] + +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 (RowIndex, ColumnIndex) 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 $ ListExpression ["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") + } + ) + ] + +testForeignDvRange :: Range +testForeignDvRange = CellRef "B2:B7" + +foreignValidations :: Map SqRef DataValidation +foreignValidations = M.fromList + [ ( SqRef [testForeignDvRange], def + { _dvAllowBlank = True + , _dvError = Just "incorrect data" + , _dvErrorStyle = ErrorStyleInformation + , _dvErrorTitle = Just "error title" + , _dvPrompt = Just "Input kebab string" + , _dvPromptTitle = Just "I love kebab-case" + , _dvShowDropDown = True + , _dvShowErrorMessage = True + , _dvShowInputMessage = True + , _dvValidationType = ValidationTypeList $ RangeExpression $ CellRef "'cellrange DV source'!$A$1:$B$2" + } + ) + ] diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.4.1 +Version: 1.2.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -10,12 +10,14 @@ For examples look into "Codec.Xlsx". . Format is covered by ECMA-376 standard: - + . 4th edition of the standard with the transitional schema is used for this library. Extra-source-files: CHANGELOG.markdown - + data/inline-strings.xlsx + data/floats.xlsx + data/absolute_relationships.xlsx Homepage: https://github.com/qrilka/xlsx Bug-Reports: https://github.com/qrilka/xlsx/issues @@ -26,15 +28,28 @@ Category: Codec Build-type: Simple -Tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +Tested-with: GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4 Cabal-version: >=1.10 +Flag microlens + default: False + description: Use microlens instead of lens + Library Hs-source-dirs: src ghc-options: -Wall Exposed-modules: Codec.Xlsx , Codec.Xlsx.Types + , Codec.Xlsx.Formatted + , Codec.Xlsx.Lens + , Codec.Xlsx.Parser + , Codec.Xlsx.Parser.Internal + , Codec.Xlsx.Parser.Internal.Fast + , Codec.Xlsx.Parser.Internal.Util + , 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 @@ -48,37 +63,53 @@ , Codec.Xlsx.Types.Internal.ContentTypes , Codec.Xlsx.Types.Internal.CustomProperties , Codec.Xlsx.Types.Internal.DvPair - , Codec.Xlsx.Types.Internal.NumFmtPair + , Codec.Xlsx.Types.Internal.FormulaData , Codec.Xlsx.Types.Internal.Relationships , Codec.Xlsx.Types.Internal.SharedStringTable + , Codec.Xlsx.Types.PageSetup , Codec.Xlsx.Types.PivotTable , Codec.Xlsx.Types.PivotTable.Internal + , Codec.Xlsx.Types.Protection + , Codec.Xlsx.Types.RefId , Codec.Xlsx.Types.RichText , Codec.Xlsx.Types.SheetViews - , Codec.Xlsx.Types.PageSetup , Codec.Xlsx.Types.StyleSheet + , Codec.Xlsx.Types.Table , Codec.Xlsx.Types.Variant - , Codec.Xlsx.Lens - , Codec.Xlsx.Parser - , Codec.Xlsx.Parser.Internal - , Codec.Xlsx.Parser.Internal.PivotTable - , Codec.Xlsx.Formatted , Codec.Xlsx.Writer , Codec.Xlsx.Writer.Internal , Codec.Xlsx.Writer.Internal.PivotTable + , Codec.Xlsx.Parser.Stream + , Codec.Xlsx.Writer.Stream + , Codec.Xlsx.Parser.Stream.Row + , Codec.Xlsx.Parser.Stream.SheetInfo + , Codec.Xlsx.Parser.Stream.SheetItem + , Codec.Xlsx.Writer.Internal.Stream - Build-depends: base == 4.* + -- The only function it exports is also hidden by the upstream library: https://github.com/the-real-blackh/hexpat/blob/master/Text/XML/Expat/SAX.hs#L227 + -- We could expose it but then this function is in the xlsx API for a long time. + -- It be better to expose it in the upstream library instead I think. It was copied here so the parser can use it. + Other-modules: Codec.Xlsx.Parser.Stream.HexpatInternal + , Codec.Xlsx.Parser.Internal.Memoize + , Codec.Xlsx.Parser.Stream.SheetIdentifier + , Codec.Xlsx.Parser.Stream.SheetIndex + , Codec.Xlsx.LensCompat + + Build-depends: base >= 4.9.0.0 && < 5.0 + , attoparsec + , base64-bytestring , binary-search - , bytestring >= 0.10.0.2 + , bytestring >= 0.10.8.0 , conduit >= 1.0.0 , containers >= 0.5.0.0 , data-default + , deepseq >= 1.4 + , dlist , errors , extra , filepath - , lens >= 3.8 && < 5 + , hexpat , mtl >= 2.1 - , mtl-compat , network-uri , old-locale >= 1.0.0.5 , safe >= 0.3 @@ -86,13 +117,30 @@ , time >= 1.4.0.1 , transformers >= 0.3.0.0 , vector >= 0.10 + , xeno >= 0.3.2 , xml-conduit >= 1.1.0 , zip-archive >= 0.2 , zlib >= 0.5.4.0 - , base64-bytestring + , zip + , zip-stream >= 0.2.0.1 + , xml-types + , exceptions + , transformers-base + , monad-control + if flag(microlens) + Build-depends: microlens >= 0.4 && < 0.5 + , microlens-mtl + , microlens-ghc + , microlens-th + , profunctors + , microlens-platform + , indexed-traversable + cpp-options: -DUSE_MICROLENS + else + Build-depends: lens >= 3.8 && < 5.4 + Default-Language: Haskell2010 - Other-Extensions: CPP - DeriveDataTypeable + Other-Extensions: DeriveDataTypeable FlexibleInstances NoMonomorphismRestriction OverloadedStrings @@ -103,15 +151,25 @@ 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: AutoFilterTests + , Common + , CommonTests + , CommonTests.CellRefTests + , CondFmtTests + , Diff + , DrawingTests + , PivotTableTests + , StreamTests + , Test.SmallCheck.Series.Instances + , TestXlsx Build-Depends: base , bytestring , containers , Diff >= 0.3.0 + , directory , groom - , lens , mtl , raw-strings-qq , smallcheck @@ -123,8 +181,33 @@ , vector , xlsx , xml-conduit >= 1.1.0 + , conduit + , filepath + , deepseq + , zip + if flag(microlens) + Build-depends: microlens >= 0.4 && < 0.5 + , microlens-mtl + , microlens-platform + , microlens-th + cpp-options: -DUSE_MICROLENS + else + Build-depends: lens >= 3.8 && < 5.4 Default-Language: Haskell2010 source-repository head type: git location: git://github.com/qrilka/xlsx.git + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Main.hs + build-depends: base + , bytestring + , criterion + , xlsx + , deepseq + , conduit + , lens + default-language: Haskell2010