diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,245 @@ +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 + (thanks laurent stephane for reporting) + +0.4.0 +----- +* implemented basic charts support with only line charts currently +* added data validation support (thanks Emil Axelsson ) +* fixed reading comments with empty author names (thanks Aleksey + Khudyakov for reporting) +* implemented basic pivot table support +* started using `hindent` to format library code + +0.3.0 +----- +* implemented number formats +* fixed error of parsing "Default"s in content types (thanks Steve Bigham for reporting) +* fixed parsing workbooks with no shared strings (thanks Steve Bigham for reporting) +* changed the way sheets are stored to allow abitrary sheet order in a workbook +* separated format information from other cell data in `FormattedCell` +* implemented comment visibility (throught legacy vml drawings) + +0.2.4 +----- +* added basic images support +* added "normal" cell formula support +* added basic xlsx parsing error reporting (thanks to Brad Ediger ) + +0.2.3 +----- +* added conditional formatting support +* fixed reading empty subelements with defaults (thanks Steve Bigham ) + +0.2.2.2 +----- +* fixed missing from parsing code font family value 0 (Not applicable) (thanks Steve Bigham ) +* fixed time type used in haddock example (thanks Manoj ) + +0.2.2.1 +----- +* fixed comments data type names and modules/imports + +0.2.2 +----- +* added cell comments support +* added custom file properties + +0.2.1.2 +------- +* loosened dependency on data-default package + +0.2.1.1 +------- +* fixed parsing shared string table entries with no content (thanks to Yuji Yamamoto ) + +0.2.1 +------- +* added number formats (thanks to Alan Zimmerman ) +* loosened dependency on zip-archive package + +0.2.0 +----- +* added style sheet support (thanks to Edsko de Vries ) +* added high level interface for styling (thanks to Edsko de Vries ) +* added sheet views support (thanks to Edsko de Vries ) +* added page setup support (thanks to Edsko de Vries ) +* switched from `System.Time` to `Data.Time` +* added rich text support (thanks to Edsko de Vries ) including shared strings +* added a bit better internals for rendering (thanks to Edsko de Vries ) and parsing + +0.1.2 +----- +* added lenses to access cells both using RC and XY style coordinates, RC is used by default + +0.1.1.1 +------- +* fixed use of internal function for parsing shared strings, previous change was unused in practice + +0.1.1 +----- +* added support for rich text shared strings (thanks to Steve Bigham ) + +0.1.0.5 +------- +* loosened dependency on zlib package + +0.1.0.4 +------- +* fixed generated xml so it gets read by MS Excel with no warnings (thanks Dmitriy Nikitinskiy ) +* improved shared strings collection by using Vector (thanks Dmitriy Nikitinskiy ) +* empty xml elements don't get emmitted anymore (thanks Philipp Hausmann ) +* imporoved and cleaned up core.xml generation + +0.1.0.3 +------- +* added "str" cells content extraction as text +* added a notice that formulas in are not yet supported + +0.1.0 +----- +* better tests and documentation +* lenses for worksheets/cells +* removed streaming support as it needs better API and improved implementaion +* removed CellLocalTime as ambiguous, added CellBool + +0.0.1 +----- +* initial release 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/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,23 +0,0 @@ -0.1.2 - * added lenses to access cells both using RC and XY style coordinates, RC is used by default -0.1.1.1 - * fixed use of internal function for parsing shared strings, previous change was unused in practice -0.1.1 - * added support for rich text shared strings (thanks to Steve Bigham ) -0.1.0.5 - * loosened dependency on zlib package -0.1.0.4 - * fixed generated xml so it gets read by MS Excel with no warnings (thanks Dmitriy Nikitinskiy ) - * improved shared strings collection by using Vector (thanks Dmitriy Nikitinskiy ) - * empty xml elements don't get emmitted anymore (thanks Philipp Hausmann ) - * imporoved and cleaned up core.xml generation -0.1.0.3 - * added "str" cells content extraction as text - * added a notice that formulas in are not yet supported -0.1.0 - * better tests and documentation - * lenses for worksheets/cells - * removed streaming support as it needs better API and improved implementaion - * removed CellLocalTime as ambiguous, added CellBool -0.0.1 - * initial release 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.hs b/src/Codec/Xlsx.hs --- a/src/Codec/Xlsx.hs +++ b/src/Codec/Xlsx.hs @@ -24,11 +24,11 @@ -- > import Codec.Xlsx -- > import Control.Lens -- > import qualified Data.ByteString.Lazy as L --- > import System.Time +-- > import Data.Time.Clock.POSIX -- > -- > main :: IO () -- > main = do --- > ct <- getClockTime +-- > ct <- getPOSIXTime -- > let -- > sheet = def & cellValueAt (1,2) ?~ CellDouble 42.0 -- > & cellValueAt (3,2) ?~ CellText "foo" diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Formatted.hs @@ -0,0 +1,444 @@ +-- | Higher level interface for creating styled worksheets +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Formatted + ( FormattedCell(..) + , Formatted(..) + , Format(..) + , formatted + , formatWorkbook + , toFormattedCells + , CondFormatted(..) + , conditionallyFormatted + -- * Lenses + -- ** Format + , formatAlignment + , formatBorder + , formatFill + , formatFont + , formatNumberFormat + , formatProtection + , formatPivotButton + , formatQuotePrefix + -- ** FormattedCell + , formattedCell + , formattedFormat + , formattedColSpan + , formattedRowSpan + -- ** FormattedCondFmt + , condfmtCondition + , condfmtDxf + , condfmtPriority + , condfmtStopIfTrue + ) where + +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 + +{------------------------------------------------------------------------------- + Internal: formatting state +-------------------------------------------------------------------------------} + +data FormattingState = FormattingState { + _formattingBorders :: Map Border Int + , _formattingCellXfs :: Map CellXf Int + , _formattingFills :: Map Fill Int + , _formattingFonts :: Map Font Int + , _formattingNumFmts :: Map Text Int + , _formattingMerges :: [Range] -- ^ In reverse order + } + +makeLenses ''FormattingState + +stateFromStyleSheet :: StyleSheet -> FormattingState +stateFromStyleSheet StyleSheet{..} = FormattingState{ + _formattingBorders = fromValueList _styleSheetBorders + , _formattingCellXfs = fromValueList _styleSheetCellXfs + , _formattingFills = fromValueList _styleSheetFills + , _formattingFonts = fromValueList _styleSheetFonts + , _formattingNumFmts = M.fromList . map swap $ M.toList _styleSheetNumFmts + , _formattingMerges = [] + } + +fromValueList :: Ord a => [a] -> Map a Int +fromValueList = M.fromList . (`zip` [0..]) + +toValueList :: Map a Int -> [a] +toValueList = map snd . sortBy (comparing fst) . map swap . M.toList + +updateStyleSheetFromState :: StyleSheet -> FormattingState -> StyleSheet +updateStyleSheetFromState sSheet FormattingState{..} = sSheet + { _styleSheetBorders = toValueList _formattingBorders + , _styleSheetCellXfs = toValueList _formattingCellXfs + , _styleSheetFills = toValueList _formattingFills + , _styleSheetFonts = toValueList _formattingFonts + , _styleSheetNumFmts = M.fromList . map swap $ M.toList _formattingNumFmts + } + +getId :: Ord a => Lens' FormattingState (Map a Int) -> a -> State FormattingState Int +getId = getId' 0 + +getId' :: Ord a + => Int + -> Lens' FormattingState (Map a Int) + -> a + -> State FormattingState Int +getId' k f v = do + aMap <- use f + case M.lookup v aMap of + Just anId -> return anId + Nothing -> do let anId = k + M.size aMap + f %= M.insert v anId + return anId + +{------------------------------------------------------------------------------- + Unwrapped cell conditional formatting +-------------------------------------------------------------------------------} + +data FormattedCondFmt = FormattedCondFmt + { _condfmtCondition :: Condition + , _condfmtDxf :: Dxf + , _condfmtPriority :: Int + , _condfmtStopIfTrue :: Maybe Bool + } deriving (Eq, Show, Generic) + +makeLenses ''FormattedCondFmt + +{------------------------------------------------------------------------------- + Cell with formatting +-------------------------------------------------------------------------------} + +-- | Formatting options used to format cells +-- +-- TODOs: +-- +-- * Add a number format ('_cellXfApplyNumberFormat', '_cellXfNumFmtId') +-- * Add references to the named style sheets ('_cellXfId') +data Format = Format + { _formatAlignment :: Maybe Alignment + , _formatBorder :: Maybe Border + , _formatFill :: Maybe Fill + , _formatFont :: Maybe Font + , _formatNumberFormat :: Maybe NumberFormat + , _formatProtection :: Maybe Protection + , _formatPivotButton :: Maybe Bool + , _formatQuotePrefix :: Maybe Bool + } deriving (Eq, Show, Generic) + +makeLenses ''Format + +-- | Cell with formatting. '_cellStyle' property of '_formattedCell' is ignored +-- +-- See 'formatted' for more details. +data FormattedCell = FormattedCell + { _formattedCell :: Cell + , _formattedFormat :: Format + , _formattedColSpan :: Int + , _formattedRowSpan :: Int + } deriving (Eq, Show, Generic) + +makeLenses ''FormattedCell + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default FormattedCell where + def = FormattedCell + { _formattedCell = def + , _formattedFormat = def + , _formattedColSpan = 1 + , _formattedRowSpan = 1 + } + +instance Default Format where + def = Format + { _formatAlignment = Nothing + , _formatBorder = Nothing + , _formatFill = Nothing + , _formatFont = Nothing + , _formatNumberFormat = Nothing + , _formatProtection = Nothing + , _formatPivotButton = Nothing + , _formatQuotePrefix = Nothing + } + +instance Default FormattedCondFmt where + def = FormattedCondFmt ContainsBlanks def topCfPriority Nothing + +{------------------------------------------------------------------------------- + Client-facing API +-------------------------------------------------------------------------------} + +-- | Result of formatting +-- +-- See 'formatted' +data Formatted = Formatted { + -- | The final 'CellMap'; see '_wsCells' + formattedCellMap :: CellMap + + -- | The final stylesheet; see '_xlStyles' (and 'renderStyleSheet') + , formattedStyleSheet :: StyleSheet + + -- | The final list of cell merges; see '_wsMerges' + , formattedMerges :: [Range] + } deriving (Eq, Show, Generic) + +-- | Higher level API for creating formatted documents +-- +-- Creating formatted Excel spreadsheets using the 'Cell' datatype directly, +-- even with the support for the 'StyleSheet' datatype, is fairly painful. +-- This has a number of causes: +-- +-- * The 'Cell' datatype wants an 'Int' for the style, which is supposed to +-- point into the '_styleSheetCellXfs' part of a stylesheet. However, this can +-- be difficult to work with, as it requires manual tracking of cell style +-- IDs, which in turns requires manual tracking of font IDs, border IDs, etc. +-- * Row-span and column-span properties are set on the worksheet as a whole +-- ('wsMerges') rather than on individual cells. +-- * Excel does not correctly deal with borders on cells that span multiple +-- columns or rows. Instead, these rows must be set on all the edge cells +-- in the block. Again, this means that this becomes a global property of +-- the spreadsheet rather than properties of individual cells. +-- +-- This function deals with all these problems. Given a map of 'FormattedCell's, +-- which refer directly to 'Font's, 'Border's, etc. (rather than font IDs, +-- border IDs, etc.), and an initial stylesheet, it recovers all possible +-- sharing, constructs IDs, and then constructs the final 'CellMap', as well as +-- the final stylesheet and list of merges. +-- +-- If you don't already have a 'StyleSheet' you want to use as starting point +-- then 'minimalStyleSheet' is a good choice. +formatted :: Map (RowIndex, ColumnIndex) FormattedCell -> StyleSheet -> Formatted +formatted cs styleSheet = + let initSt = stateFromStyleSheet styleSheet + (cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt + styleSheet' = updateStyleSheetFromState styleSheet finalSt + in Formatted { + formattedCellMap = M.fromList (concat cs') + , formattedStyleSheet = styleSheet' + , 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 (RowIndex, ColumnIndex) FormattedCell +toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m + where + toFormattedCell cell@Cell{..} = + FormattedCell + { _formattedCell = cell{ _cellStyle = Nothing } -- just to remove confusion + , _formattedFormat = maybe def formatFromStyle $ flip M.lookup cellXfs =<< _cellStyle + , _formattedColSpan = 1 + , _formattedRowSpan = 1 } + formatFromStyle cellXf = + Format + { _formatAlignment = applied _cellXfApplyAlignment _cellXfAlignment cellXf + , _formatBorder = flip M.lookup borders =<< + applied _cellXfApplyBorder _cellXfBorderId cellXf + , _formatFill = flip M.lookup fills =<< + applied _cellXfApplyFill _cellXfFillId cellXf + , _formatFont = flip M.lookup fonts =<< + applied _cellXfApplyFont _cellXfFontId cellXf + , _formatNumberFormat = lookupNumFmt =<< + applied _cellXfApplyNumberFormat _cellXfNumFmtId cellXf + , _formatProtection = _cellXfProtection cellXf + , _formatPivotButton = _cellXfPivotButton cellXf + , _formatQuotePrefix = _cellXfQuotePrefix cellXf } + idMapped :: [a] -> Map Int a + idMapped = M.fromList . zip [0..] + cellXfs = idMapped _styleSheetCellXfs + borders = idMapped _styleSheetBorders + fills = idMapped _styleSheetFills + fonts = idMapped _styleSheetFonts + lookupNumFmt fId = asum + [ StdNumberFormat <$> idToStdNumberFormat fId + , UserNumberFormat <$> M.lookup fId _styleSheetNumFmts] + applied :: (CellXf -> Maybe Bool) -> (CellXf -> Maybe a) -> CellXf -> Maybe a + applied applyProp prop cXf = do + apply <- applyProp cXf + 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 + nonTopLeft = tail [(r, c) | r<-[r1..r2], c<-[c1..c2]] + forM_ nonTopLeft (modify . M.delete) + 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, Generic) + +conditionallyFormatted :: Map CellRef [FormattedCondFmt] -> StyleSheet -> CondFormatted +conditionallyFormatted cfs styleSheet = CondFormatted + { condformattedStyleSheet = styleSheet & styleSheetDxfs .~ finalDxfs + , condformattedFormattings = fmts + } + where + (cellFmts, dxf2id) = runState (mapM (mapM mapDxf) cfs) dxf2id0 + dxf2id0 = fromValueList (styleSheet ^. styleSheetDxfs) + fmts = M.fromList . map mergeSqRef . groupBy ((==) `on` snd) . + sortBy (comparing snd) $ M.toList cellFmts + mergeSqRef cellRefs2fmt = + (SqRef (map fst cellRefs2fmt), + headNote "fmt group should not be empty" (map snd cellRefs2fmt)) + finalDxfs = toValueList dxf2id + +{------------------------------------------------------------------------------- + Implementation details +-------------------------------------------------------------------------------} + +-- | Format a cell with (potentially) rowspan or colspan +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 :: ((RowIndex, ColumnIndex), FormattedCell) + -> State FormattingState ((RowIndex, ColumnIndex), Cell) + go (pos, c@FormattedCell{..}) = do + styleId <- cellStyleId c + return (pos, _formattedCell{_cellStyle = styleId}) + +-- | Cell block corresponding to a single 'FormattedCell' +-- +-- A single 'FormattedCell' might have a colspan or rowspan greater than 1. +-- Although Excel obviously supports cell merges, it does not correctly apply +-- borders to the cells covered by the rowspan or colspan. Therefore we create +-- a block of cells in this function; the top-left is the cell proper, and the +-- remaining cells are the cells covered by the rowspan/colspan. +-- +-- Also returns the cell merge instruction, if any. +cellBlock :: (RowIndex, ColumnIndex) -> FormattedCell + -> ([((RowIndex, ColumnIndex), FormattedCell)], Maybe Range) +cellBlock (row, col) cell@FormattedCell{..} = (block, merge) + where + block :: [((RowIndex, ColumnIndex), FormattedCell)] + block = [ ((row', col'), cellAt (row', col')) + | row' <- [topRow .. bottomRow] + , col' <- [leftCol .. rightCol] + ] + + merge :: Maybe Range + merge = do guard (topRow /= bottomRow || leftCol /= rightCol) + return $ mkRange (topRow, leftCol) (bottomRow, rightCol) + + cellAt :: (RowIndex, ColumnIndex) -> FormattedCell + cellAt (row', col') = + if row' == row && col == col' + then cell + else def & formattedFormat . formatBorder ?~ borderAt (row', col') + + border = _formatBorder _formattedFormat + + 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 :: RowIndex + leftCol, rightCol :: ColumnIndex + topRow = row + bottomRow = RowIndex $ unRowIndex row + _formattedRowSpan - 1 + leftCol = col + rightCol = ColumnIndex $ unColumnIndex col + _formattedColSpan - 1 + +cellStyleId :: FormattedCell -> State FormattingState (Maybe Int) +cellStyleId c = mapM (getId formattingCellXfs) =<< constructCellXf c + +constructCellXf :: FormattedCell -> State FormattingState (Maybe CellXf) +constructCellXf FormattedCell{_formattedFormat=Format{..}} = do + mBorderId <- getId formattingBorders `mapM` _formatBorder + mFillId <- getId formattingFills `mapM` _formatFill + mFontId <- getId formattingFonts `mapM` _formatFont + let getFmtId :: Lens' FormattingState (Map Text Int) -> NumberFormat -> State FormattingState Int + getFmtId _ (StdNumberFormat fmt) = return (stdNumberFormatId fmt) + getFmtId l (UserNumberFormat fmt) = getId' firstUserNumFmtId l fmt + mNumFmtId <- getFmtId formattingNumFmts `mapM` _formatNumberFormat + let xf = CellXf { + _cellXfApplyAlignment = apply _formatAlignment + , _cellXfApplyBorder = apply mBorderId + , _cellXfApplyFill = apply mFillId + , _cellXfApplyFont = apply mFontId + , _cellXfApplyNumberFormat = apply _formatNumberFormat + , _cellXfApplyProtection = apply _formatProtection + , _cellXfBorderId = mBorderId + , _cellXfFillId = mFillId + , _cellXfFontId = mFontId + , _cellXfNumFmtId = mNumFmtId + , _cellXfPivotButton = _formatPivotButton + , _cellXfQuotePrefix = _formatQuotePrefix + , _cellXfId = Nothing -- TODO + , _cellXfAlignment = _formatAlignment + , _cellXfProtection = _formatProtection + } + return $ if xf == def then Nothing else Just xf + where + -- If we have formatting instructions, we want to set the corresponding + -- applyXXX properties + apply :: Maybe a -> Maybe Bool + apply Nothing = Nothing + apply (Just _) = Just True + +mapDxf :: FormattedCondFmt -> State (Map Dxf Int) CfRule +mapDxf FormattedCondFmt{..} = do + dxf2id <- get + dxfId <- case M.lookup _condfmtDxf dxf2id of + Just i -> + return i + Nothing -> do + let newId = M.size dxf2id + modify $ M.insert _condfmtDxf newId + return newId + return CfRule + { _cfrCondition = _condfmtCondition + , _cfrDxfId = Just dxfId + , _cfrPriority = _condfmtPriority + , _cfrStopIfTrue = _condfmtStopIfTrue + } 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,73 +1,109 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveGeneric #-} + -- | lenses to access sheets, cells and values of 'Xlsx' -{-# LANGUAGE RankNTypes #-} module Codec.Xlsx.Lens - ( ixSheet - , atSheet - , ixCell - , ixCellRC - , ixCellXY - , atCell - , atCellRC - , atCellXY - , cellValueAt - , cellValueAtRC - , cellValueAtXY - ) where + ( ixSheet + , atSheet + , ixCell + , ixCellRC + , ixCellXY + , atCell + , atCellRC + , atCellXY + , cellValueAt + , cellValueAtRC + , cellValueAtXY + ) where import Codec.Xlsx.Types -import Control.Lens +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, Generic) + +type instance IxValue (SheetList) = Worksheet +type instance Index (SheetList) = Text + +instance Ixed SheetList where + ix k f sl@(SheetList l) = case lookup k l of + Just v -> f v <&> \v' -> SheetList (upsert k v' l) + Nothing -> pure sl + {-# INLINE ix #-} + +instance At SheetList where + at k f (SheetList l) = f mv <&> \r -> case r of + Nothing -> SheetList $ maybe l (\v -> deleteBy ((==) `on` fst) (k,v) l) mv + Just v' -> SheetList $ upsert k v' l + where + mv = lookup k l + {-# INLINE at #-} + +upsert :: (Eq k) => k -> v -> [(k,v)] -> [(k,v)] +upsert k v [] = [(k,v)] +upsert k v ((k1,v1):r) = + if k == k1 + then (k,v):r + else (k1,v1):upsert k v r + -- | lens giving access to a worksheet from 'Xlsx' object -- by its name ixSheet :: Text -> Traversal' Xlsx Worksheet -ixSheet s = xlSheets . 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 . 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,178 +1,715 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + -- | This module provides a function for reading .xlsx files module Codec.Xlsx.Parser - ( toXlsx - ) where + ( toXlsx + , toXlsxEither + , toXlsxFast + , toXlsxEitherFast + , ParseError(..) + , Parser + ) where -import qualified Codec.Archive.Zip as Zip -import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad (liftM4) -import Control.Monad.IO.Class() +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 Data.ByteString.Lazy.Char8() -import Data.IntMap (IntMap) -import qualified Data.IntMap as IM -import Data.List +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.Ord -import Data.Text (Text) +import Data.Maybe +import Data.Monoid +import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Read as T -import Data.XML.Types -import Prelude hiding (sequence) -import Text.XML as X -import Text.XML.Cursor - -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types +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.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 bs = Xlsx sheets styles - where - ar = Zip.toArchive bs - ss = getSharedStrings ar - styles = getStyles ar - wfs = getWorksheetFiles ar - sheets = M.fromList $ map (wfName &&& extractSheet ar ss) wfs +toXlsx = either (error . show) id . toXlsxEither +data ParseError = InvalidZipArchive String + | MissingFile FilePath + | InvalidFile FilePath Text + | InvalidRef FilePath RefId + | InconsistentXlsx Text + deriving (Eq, Show, Generic) + +instance Exception ParseError + +type Parser = Either ParseError + +-- | 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 = 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, dateBase) <- readWorkbook ar + sheets <- forM wfs $ \wf -> do + 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 dateBase + data WorksheetFile = WorksheetFile { wfName :: Text + , wfSheetId :: Int + , wfState :: SheetState , wfPath :: FilePath } - deriving Show - -decimal :: Monad m => Text -> m Int -decimal t = case T.decimal t of - Right (d, _) -> return d - _ -> fail "invalid decimal" + deriving (Show, Generic) -rational :: Monad m => Text -> m Double -rational t = case T.rational t of - Right (r, _) -> return r - _ -> fail "invalid rational" +type Caches = [(CacheId, (Text, CellRef, [CacheField]))] -extractSheet :: Zip.Archive - -> IM.IntMap Text - -> WorksheetFile - -> Worksheet -extractSheet ar ss wf = Worksheet cws rowProps cells merges +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 - file = fromJust $ Zip.fromEntry <$> Zip.findEntryByPath (wfPath wf) ar - cur = case parseLBS def file of - Left _ -> error "could not read file" - Right d -> fromDocument d + 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") - cws = cur $/ element (n"cols") &/ element (n"col") >=> - liftM4 ColumnsWidth <$> - (attribute "min" >=> decimal) <*> - (attribute "max" >=> decimal) <*> - (attribute "width" >=> rational) <*> - (attribute "style" >=> decimal) + -- all explicitly assigned fields filled below + return ( + Worksheet + { _wsDrawing = Nothing + , _wsPivotTables = [] + , _wsTables = [] + , _wsState = wfState wf + , .. + } + , tableIds + , drawingRId + , legacyDrRId) - (rowProps, cells) = collect $ cur $/ element (n"sheetData") &/ element (n"row") >=> parseRow - 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 = if attribute "s" c /= [] - then listToMaybe $ c $| attribute "s" >=> decimal - else Nothing - 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)] + 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 - let - s = listToMaybe $ cell $| attribute "s" >=> decimal - t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" - d = listToMaybe $ cell $/ element (n"v") &/ content >=> extractCellValue ss t - (c, r) <- T.span (>'9') <$> (cell $| attribute "r") - return (int r, col2int c, Cell s d) - 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 + (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) - merges = cur $/ parseMerges - parseMerges :: Cursor -> [Text] - parseMerges = element (n"mergeCells") &/ element (n"mergeCell") >=> parseMerge - parseMerge c = c $| attribute "ref" +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 (\ex -> InvalidFile filePath (T.pack $ show ex)) $ + parseLBS def file + sheetRels <- getRels ar filePath -extractCellValue :: IntMap Text -> Text -> Text -> [CellValue] -extractCellValue ss "s" v = - case T.decimal v of - Right (d, _) -> maybeToList $ fmap CellText $ IM.lookup d ss - _ -> [] -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 _ _ _ = [] + -- 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 (addSmlNamespace "sheetViews") &/ element (addSmlNamespace "sheetView") >=> fromCursor + sheetViews = case sheetViewList of + [] -> Nothing + views -> Just views --- | Add office document relationship namespace to name -odr :: Text -> Name -odr x = Name - { nameLocalName = x - , nameNamespace = Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships" - , namePrefix = Nothing - } + let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" + commentTarget :: Maybe FilePath + commentTarget = logicalNameToZipItemName . relTarget <$> findRelByType commentsType sheetRels + legacyDrRId = cur $/ element (addSmlNamespace "legacyDrawing") >=> fromAttribute (odr"id") + legacyDrPath = fmap (logicalNameToZipItemName . relTarget) . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId --- | Add package relationship namespace to name -pr :: Text -> Name -pr x = Name - { nameLocalName = x - , nameNamespace = Just "http://schemas.openxmlformats.org/package/2006/relationships" - , namePrefix = Nothing - } + commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget + -- Likewise, @pageSetup@ also occurs either 0 or 1 times + let pageSetup = listToMaybe $ cur $/ element (addSmlNamespace "pageSetup") >=> fromCursor + + cws = cur $/ element (addSmlNamespace "cols") &/ element (addSmlNamespace "col") >=> fromCursor + + (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 <- 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 + -- 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) + + 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 (addSmlNamespace "mergeCells") &/ element (addSmlNamespace "mergeCell") >=> fromAttribute "ref" + + condFormtattings = M.fromList . map unCfPair $ cur $/ element (addSmlNamespace "conditionalFormatting") >=> fromCursor + + validations = M.fromList . map unDvPair $ + 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 + 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 = 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 + + tables <- forM tableIds $ \rId -> do + fp <- lookupRelPath filePath sheetRels rId + getTable ar fp + + 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. -xmlCursor :: Zip.Archive -> FilePath -> Maybe Cursor -xmlCursor ar fname = parse <$> Zip.findEntryByPath fname ar +xmlCursorOptional :: Zip.Archive -> FilePath -> Parser (Maybe Cursor) +xmlCursorOptional ar fname = + (Just <$> xmlCursorRequired ar fname) `catchError` missingToNothing where - parse entry = case parseLBS def (Zip.fromEntry entry) of - Left _ -> error "could not read file" - Right d -> fromDocument d + missingToNothing :: ParseError -> Either ParseError (Maybe a) + missingToNothing (MissingFile _) = return Nothing + missingToNothing other = throwError other --- | Get shared strings (if there are some) into IntMap. -getSharedStrings :: Zip.Archive -> IM.IntMap Text -getSharedStrings x = case xmlCursor x "xl/sharedStrings.xml" of - Nothing -> IM.empty - Just c -> parseSharedStrings c +-- | Get xml cursor from the given file, failing with MissingFile if not found. +xmlCursorRequired :: Zip.Archive -> FilePath -> Parser Cursor +xmlCursorRequired ar fname = do + entry <- note (MissingFile fname) $ Zip.findEntryByPath fname ar + 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 = + fromFileCursorDef x "xl/sharedStrings.xml" "shared strings" sstEmpty + +getContentTypes :: Zip.Archive -> Parser ContentTypes +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 Nothing -> Styles L.empty Just xml -> Styles xml --- | getWorksheetFiles pulls the names of the sheets -getWorksheetFiles :: Zip.Archive -> [WorksheetFile] -getWorksheetFiles ar = case xmlCursor ar "xl/workbook.xml" of - Nothing -> - error "invalid workbook" - Just c -> - let - sheetData = c $/ element (n"sheets") &/ element (n"sheet") >=> - liftA2 (,) <$> attribute "name" <*> attribute (odr"id") - wbRels = getWbRels ar - in [WorksheetFile name ("xl/" ++ T.unpack (fromJust $ lookup rId wbRels)) | (name, rId) <- sheetData] +getComments :: Zip.Archive -> Maybe FilePath -> FilePath -> Parser (Maybe CommentTable) +getComments ar drp fp = do + mCurComments <- xmlCursorOptional ar fp + mCurDr <- maybe (return Nothing) (xmlCursorOptional ar) drp + return (liftA2 hide (hidden <$> mCurDr) . listToMaybe . fromCursor =<< mCurComments) + where + hide refs (CommentTable m) = CommentTable $ foldl' hideComment m refs + hideComment m r = M.adjust (\c->c{_commentVisible = False}) r m + v nm = Name nm (Just "urn:schemas-microsoft-com:vml") Nothing + x nm = Name nm (Just "urn:schemas-microsoft-com:office:excel") Nothing + hidden :: Cursor -> [CellRef] + hidden cur = cur $/ checkElement visibleShape &/ + element (x"ClientData") >=> shapeCellRef + visibleShape Element{..} = elementName == (v"shape") && + maybe False (any ("visibility:hidden"==) . T.split (==';')) (M.lookup "style" elementAttributes) + shapeCellRef :: Cursor -> [CellRef] + shapeCellRef c = do + r0 <- c $/ element (x"Row") &/ content >=> decimal + c0 <- c $/ element (x"Column") &/ content >=> decimal + return $ singleCellRef (r0 + 1, c0 + 1) -getWbRels :: Zip.Archive -> [(Text, Text)] -getWbRels ar = case xmlCursor ar "xl/_rels/workbook.xml.rels" of - Nothing -> [] - Just c -> c $/ element (pr"Relationship") >=> - liftA2 (,) <$> attribute "Id" <*> attribute "Target" +getCustomProperties :: Zip.Archive -> Parser CustomProperties +getCustomProperties ar = + fromFileCursorDef ar "docProps/custom.xml" "custom properties" CustomProperties.empty -int :: Text -> Int -int = either error fst . T.decimal +getDrawing :: Zip.Archive -> ContentTypes -> FilePath -> Parser Drawing +getDrawing ar contentTypes fp = do + cur <- xmlCursorRequired ar fp + drawingRels <- getRels ar fp + unresolved <- headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) + anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels + return $ Drawing anchors + where + resolveFileInfo :: Relationships -> Anchor RefId RefId -> Parser (Anchor FileInfo ChartSpace) + resolveFileInfo rels uAnch = + case uAnch ^. anchObject of + Picture {..} -> do + let mRefId = _picBlipFill ^. bfpImageInfo + mFI <- lookupFI rels mRefId + let pic' = + Picture + { _picMacro = _picMacro + , _picPublished = _picPublished + , _picNonVisual = _picNonVisual + , _picBlipFill = (_picBlipFill & bfpImageInfo .~ mFI) + , _picShapeProperties = _picShapeProperties + } + return uAnch {_anchObject = pic'} + Graphic nv rId tr -> do + chartPath <- lookupRelPath fp rels rId + chart <- readChart ar chartPath + return uAnch {_anchObject = Graphic nv chart tr} + lookupFI _ Nothing = return Nothing + lookupFI rels (Just rId) = do + path <- lookupRelPath fp rels rId + -- content types use paths starting with / + 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 = fromFileCursor ar path "chart" + +-- | readWorkbook pulls the names of the sheets and the defined names +readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches, DateBase) +readWorkbook ar = do + let wbPath = "xl/workbook.xml" + cur <- xmlCursorRequired ar wbPath + wbRels <- getRels ar wbPath + -- Specification says the 'name' is required. + let mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)] + mkDefinedName c = + return + ( headNote "Missing name attribute" $ attribute "name" c + , listToMaybe $ attribute "localSheetId" c + , T.concat $ c $/ content) + names = + cur $/ element (addSmlNamespace "definedNames") &/ element (addSmlNamespace "definedName") >=> + mkDefinedName + sheets <- + sequence $ + 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 (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 + (sheet, ref, fields0, mRecRId) <- + note (InconsistentXlsx $ "Bad pivot table cache in " <> T.pack path) $ + parseCache bs + 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 -> 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 . 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 = + 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,26 +1,162 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Codec.Xlsx.Parser.Internal - ( n - , parseSharedStrings - ) 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 qualified Data.IntMap as IM +import Control.Exception (Exception) +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T -import Data.XML.Types +import qualified Data.Text.Read as T +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Text.XML import Text.XML.Cursor +import Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal.Fast +import Codec.Xlsx.Parser.Internal.Util +data ParseException = ParseException String + deriving (Show, Typeable, Generic) + +instance Exception ParseException + +nodeElNameIs :: Node -> Name -> Bool +nodeElNameIs (NodeElement el) name = elementName el == name +nodeElNameIs _ _ = False + +class FromCursor a where + fromCursor :: Cursor -> [a] + +class FromAttrVal a where + fromAttrVal :: T.Reader a + +instance FromAttrVal Text where + fromAttrVal = readSuccess + +instance FromAttrVal Int where + fromAttrVal = T.signed T.decimal + +instance FromAttrVal Integer where + fromAttrVal = T.signed T.decimal + +instance FromAttrVal Double where + fromAttrVal = T.rational + +instance FromAttrVal Bool where + fromAttrVal x | x == "1" || x == "true" = readSuccess True + | x == "0" || x == "false" = readSuccess False + | otherwise = defaultReadFailure + +-- | required attribute parsing +fromAttribute :: FromAttrVal a => Name -> Cursor -> [a] +fromAttribute name cursor = + attribute name cursor >>= runReader fromAttrVal + +-- | parsing optional attributes with defaults +fromAttributeDef :: FromAttrVal a => Name -> a -> Cursor -> [a] +fromAttributeDef name defVal cursor = + case attribute name cursor of + [attr] -> runReader fromAttrVal attr + _ -> [defVal] + +-- | parsing optional attributes +maybeAttribute :: FromAttrVal a => Name -> Cursor -> [Maybe a] +maybeAttribute name cursor = + case attribute name cursor of + [attr] -> Just <$> runReader fromAttrVal attr + _ -> [Nothing] + +fromElementValue :: FromAttrVal a => Name -> Cursor -> [a] +fromElementValue name cursor = + cursor $/ element name >=> fromAttribute "val" + +maybeElementValue :: FromAttrVal a => Name -> Cursor -> [Maybe a] +maybeElementValue name cursor = + case cursor $/ element name of + [cursor'] -> maybeAttribute "val" cursor' + _ -> [Nothing] + +maybeElementValueDef :: FromAttrVal a => Name -> a -> Cursor -> [Maybe a] +maybeElementValueDef name defVal cursor = + case cursor $/ element name of + [cursor'] -> Just . fromMaybe defVal <$> maybeAttribute "val" cursor' + _ -> [Nothing] + +maybeBoolElementValue :: Name -> Cursor -> [Maybe Bool] +maybeBoolElementValue name cursor = maybeElementValueDef name True cursor + +maybeFromElement :: FromCursor a => Name -> Cursor -> [Maybe a] +maybeFromElement name cursor = case cursor $/ element name of + [cursor'] -> Just <$> fromCursor cursor' + _ -> [Nothing] + +attrValIs :: (Eq a, FromAttrVal a) => Name -> a -> Axis +attrValIs n v c = + case fromAttribute n c of + [x] | x == v -> [c] + _ -> [] + +contentOrEmpty :: Cursor -> [Text] +contentOrEmpty c = + case c $/ content of + [t] -> [t] + [] -> [""] + _ -> error "invalid item: more than one text node encountered" + +readSuccess :: a -> Either String (a, Text) +readSuccess x = Right (x, T.empty) + +readFailure :: Text -> Either String (a, Text) +readFailure = Left . T.unpack + +invalidText :: Text -> Text -> Either String (a, Text) +invalidText what txt = readFailure $ T.concat ["Invalid ", what, ": '", txt , "'"] + +defaultReadFailure :: Either String (a, Text) +defaultReadFailure = Left "invalid text" + +runReader :: T.Reader a -> Text -> [a] +runReader reader t = case reader t of + Right (r, leftover) | T.null leftover -> [r] + _ -> [] + + +{-# DEPRECATED n_ "Renamed to addSmlNamespace" #-} +n_ :: Text -> Name +n_ = addSmlNamespace + -- | Add sml namespace to name -n :: Text -> Name -n x = Name +addSmlNamespace :: Text -> Name +addSmlNamespace x = Name { nameLocalName = x - , nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main" + , nameNamespace = Just mainNamespace , namePrefix = Nothing } - -parseSharedStrings :: Cursor -> IM.IntMap Text -parseSharedStrings c = IM.fromAscList $ zip [0..] (c $/ element (n"si") >=> parseT) - where - -- it's either or s with inside - parseT c' = [T.concat $ c' $| orSelf (child >=> (element (n"r"))) &/ element (n"t") &/ content] 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Parser.Internal.PivotTable + ( parsePivotTable + , parseCache + , fillCacheFieldsFromRecords + ) where + +import Control.Applicative +import Data.ByteString.Lazy (ByteString) +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, [CacheField])) + -> ByteString + -> Maybe PivotTable +parsePivotTable srcByCacheId bs = + listToMaybe . parse . fromDocument $ parseLBS_ def bs + where + parse cur = do + cacheId <- fromAttribute "cacheId" cur + case srcByCacheId cacheId of + Nothing -> fail "no such cache" + Just (_pvtSrcSheet, _pvtSrcRef, cacheFields) -> do + _pvtDataCaption <- attribute "dataCaption" cur + _pvtName <- attribute "name" cur + _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 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 (addSmlNamespace "rowFields") &/ element (addSmlNamespace "field") >=> + fromAttribute "x" >=> fieldPosition + _pvtColumnFields = + cur $/ element (addSmlNamespace "colFields") &/ element (addSmlNamespace "field") >=> + fromAttribute "x" >=> fieldPosition + _pvtDataFields = + cur $/ element (addSmlNamespace "dataFields") &/ element (addSmlNamespace "dataField") >=> \c -> do + fld <- fromAttribute "fld" c + _dfField <- fieldNameList fld + -- TOFIX + _dfName <- fromAttributeDef "name" "" c + _dfFunction <- fromAttributeDef "subtotal" ConsolidateSum c + return DataField {..} + fieldPosition :: Int -> [PositionedField] + fieldPosition (-2) = return DataPosition + fieldPosition n = + FieldPosition <$> fieldNameList n + return PivotTable {..} + +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 (addSmlNamespace "cacheSource") &/ element (addSmlNamespace "worksheetSource") >=> + liftA2 (,) <$> attribute "sheet" <*> fromAttribute "ref" + 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 @@ -1,124 +1,368 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module Codec.Xlsx.Types - ( Xlsx(..), xlSheets, xlStyles - , def +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} + +module Codec.Xlsx.Types ( + -- * The main types + Xlsx(..) , Styles(..) - , emptyStyles - , ColumnsWidth(..) - , Worksheet(..), wsColumns, wsRowPropertiesMap, wsCells, wsMerges + , DefinedNames(..) + , ColumnsProperties(..) + , PageSetup(..) + , Worksheet(..) + , SheetState(..) , CellMap , CellValue(..) - , Cell(..), cellValue, cellStyle + , CellFormula(..) + , FormulaExpression(..) + , Cell.SharedFormulaIndex(..) + , Cell.SharedFormulaOptions(..) + , Cell(..) + , RowHeight(..) , RowProperties (..) - , int2col - , col2int + -- * Lenses + -- ** Workbook + , xlSheets + , xlStyles + , xlDefinedNames + , xlCustomProperties + , xlDateBase + -- ** Worksheet + , wsColumnsProperties + , wsRowPropertiesMap + , wsCells + , wsDrawing + , wsMerges + , wsSheetViews + , wsPageSetup + , wsConditionalFormattings + , wsDataValidations + , wsPivotTables + , wsAutoFilter + , wsTables + , wsProtection + , wsSharedFormulas + , wsState + -- ** Cells + , 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.Lens.TH +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.Char -import Data.Default -import Data.Function (on) -import Data.List (groupBy) -import Data.Map (Map) +import Data.Default +import Data.Function (on) +import Data.List (groupBy) +import Data.Map (Map) import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T +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.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 --- | 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 -data CellValue = CellText Text - | CellDouble Double - | CellBool Bool - 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 --- | 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 - } deriving (Eq, Show) +_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 #-} -makeLenses ''Cell +_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 #-} -instance Default Cell where - def = Cell Nothing Nothing +-- | 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 --- | 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 +rowHeightLens :: Lens' RowProperties (Maybe RowHeight) +rowHeightLens = lens rowHeight $ \x y -> x{rowHeight=y} -data RowProperties = RowProps { rowHeight :: Maybe Double, rowStyle::Maybe Int} - deriving (Read,Eq,Show,Ord) +instance Default RowProperties where + def = RowProps { rowHeight = Nothing + , rowStyle = Nothing + , rowHidden = False + } --- | Column range (from cwMin to cwMax) width -data ColumnsWidth = ColumnsWidth - { cwMin :: Int - , cwMax :: Int - , cwWidth :: Double - , cwStyle :: Int - } deriving (Eq, Show) +-- | 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 +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 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 - , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs - , _wsMerges :: [Text] -- ^ list of cell merges (entries of the form @D13:H14@) - } deriving (Eq, Show) + { _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 + , _wsSheetViews :: Maybe [SheetView] + , _wsPageSetup :: Maybe PageSetup + , _wsConditionalFormattings :: Map SqRef ConditionalFormatting + , _wsDataValidations :: Map SqRef DataValidation + , _wsPivotTables :: [PivotTable] + , _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 [] + 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 :: Map Text Worksheet - , _xlStyles :: Styles - } 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. +-- +-- This element defines the collection of defined names for this workbook. +-- Defined names are descriptive names to represent cells, ranges of cells, +-- formulas, or constant values. Defined names can be used to represent a range +-- on any worksheet. +-- +-- Excel also defines a number of reserved names with a special interpretation: +-- +-- * @_xlnm.Print_Area@ specifies the workbook's print area. +-- Example value: @SheetName!$A:$A,SheetName!$1:$4@ +-- * @_xlnm.Print_Titles@ specifies the row(s) or column(s) to repeat +-- at the top of each printed page. +-- * @_xlnm.Sheet_Title@:refers to a sheet title. +-- +-- and others. See Section 18.2.6, "definedNames (Defined Names)" (p. 1728) of +-- the spec (second edition). +-- +-- NOTE: Right now this is only a minimal implementation of defined names. +newtype DefinedNames = DefinedNames [(Text, Maybe Text, Text)] + deriving (Eq, Show, Generic) +instance NFData DefinedNames + makeLenses ''Xlsx instance Default Xlsx where - def = Xlsx M.empty emptyStyles + def = Xlsx [] emptyStyles def M.empty DateBase1900 +instance Default DefinedNames where + def = DefinedNames [] + emptyStyles :: Styles -emptyStyles = Styles "\ -\" +emptyStyles = Styles "" --- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\") -int2col :: Int -> Text -int2col = T.pack . reverse . map int2let . base26 - where - int2let 0 = 'Z' - int2let x = chr $ (x - 1) + ord 'A' - base26 0 = [] - base26 i = let i' = (i `mod` 26) - i'' = if i' == 0 then 26 else i' - in seq i' (i' : base26 ((i - i'') `div` 26)) +-- | Render 'StyleSheet' +-- +-- This is used to render a structured 'StyleSheet' into a raw XML 'Styles' +-- document. Actually /replacing/ 'Styles' with 'StyleSheet' would mean we +-- would need to write a /parser/ for 'StyleSheet' as well (and would moreover +-- require that we support the full style sheet specification, which is still +-- quite a bit of work). +renderStyleSheet :: StyleSheet -> Styles +renderStyleSheet = Styles . renderLBS def . toDocument --- | reverse to 'int2col' -col2int :: Text -> Int -col2int = T.foldl' (\i c -> i * 26 + let2int c) 0 - where - let2int c = 1 + ord c - ord 'A' +-- | Parse 'StyleSheet' +-- +-- This is used to parse raw 'Styles' into structured 'StyleSheet' +-- currently not all of the style sheet specification is supported +-- so parser (and the data model) is to be completed +parseStyleSheet :: Styles -> Either SomeException StyleSheet +parseStyleSheet (Styles bs) = parseLBS def bs >>= parseDoc + where + parseDoc doc = case fromCursor (fromDocument doc) of + [stylesheet] -> Right stylesheet + _ -> Left . toException $ ParseException "Could not parse style sheets" -- | 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 @@ -127,7 +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 + + +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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Comment.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Comment where + +import Control.DeepSeq (NFData) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Codec.Xlsx.Types.Common + +-- | User comment for a cell +-- +-- TODO: the following child elements: +-- guid, shapeId, commentPr +-- +-- Section 18.7.3 "comment (Comment)" (p. 1749) +data Comment = Comment + { _commentText :: XlsxText + -- ^ cell comment text, maybe formatted + -- Section 18.7.7 "text (Comment Text)" (p. 1754) + , _commentAuthor :: Text + -- ^ comment author + , _commentVisible :: Bool + } deriving (Eq, Show, Generic) +instance NFData Comment diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Common.hs @@ -0,0 +1,713 @@ +{-# 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.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 + +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\") +columnIndexToText :: ColumnIndex -> Text +columnIndexToText = T.pack . reverse . map int2let . base26 . unColumnIndex + where + int2let 0 = 'Z' + int2let x = chr $ (x - 1) + ord 'A' + base26 0 = [] + base26 i = let i' = (i `mod` 26) + i'' = if i' == 0 then 26 else i' + in seq i' (i' : base26 ((i - i'') `div` 26)) + +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' + +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, 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. +-- +-- > singleCellRef (RowIndex 2, ColumnIndex 4) == CellRef "D2" +singleCellRef :: (RowIndex, ColumnIndex) -> CellRef +singleCellRef = CellRef . singleCellRefRaw + +-- | Allow specifying whether a coordinate parameter is relative or absolute. +-- +-- > singleCellRef' (Rel 5, Abs 1) == CellRef "$A5" +singleCellRef' :: CellCoord -> CellRef +singleCellRef' = CellRef . singleCellRefRaw' + +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 + +-- | 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 (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] + +-- | 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 = + 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, Generic) + +instance NFData SqRef + +-- | Common type containing either simple string or rich formatted text. +-- Used in @si@, @comment@ and @is@ elements +-- +-- E.g. @si@ spec says: "If the string is just a simple string with formatting applied +-- at the cell level, then the String Item (si) should contain a single text +-- element used to express the string. However, if the string in the cell is +-- more complex - i.e., has formatting applied at the character level - then the +-- string item shall consist of multiple rich text runs which collectively are +-- used to express the string.". So we have either a single "Text" field, or +-- else a list of "RichTextRun"s, each of which is some "Text" with layout +-- properties. +-- +-- TODO: Currently we do not support @phoneticPr@ (Phonetic Properties, 18.4.3, +-- p. 1723) or @rPh@ (Phonetic Run, 18.4.6, p. 1725). +-- +-- Section 18.4.8, "si (String Item)" (p. 1725) +-- +-- See @CT_Rst@, p. 3903 +data XlsxText = XlsxText Text + | XlsxRichText [RichTextRun] + 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, 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] + | 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 +-------------------------------------------------------------------------------} + +-- | See @CT_Rst@, p. 3903 +instance FromCursor XlsxText where + fromCursor cur = do + let + ts = cur $/ element (addSmlNamespace "t") >=> contentOrEmpty + rs = cur $/ element (addSmlNamespace "r") >=> fromCursor + case (ts,rs) of + ([t], []) -> + return $ XlsxText t + ([], _:_) -> + return $ XlsxRichText rs + _ -> + 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 +-------------------------------------------------------------------------------} + +-- | See @CT_Rst@, p. 3903 +instance ToElement XlsxText where + toElement nm si = Element { + elementName = nm + , elementAttributes = Map.empty + , elementNodes = map NodeElement $ + case si of + XlsxText text -> [elementContent "t" text] + XlsxRichText rich -> map (toElement "r") rich + } + +instance ToAttrVal CellRef where + toAttrVal = toAttrVal . unCellRef + +-- See 18.18.76, "ST_Sqref (Reference Sequence)", p. 2488. +instance ToAttrVal SqRef where + toAttrVal (SqRef refs) = T.intercalate " " $ map toAttrVal refs + +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/ConditionalFormatting.hs @@ -0,0 +1,973 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +module Codec.Xlsx.Types.ConditionalFormatting + ( ConditionalFormatting + , CfRule(..) + , NStdDev(..) + , Inclusion(..) + , CfValue(..) + , MinCfValue(..) + , MaxCfValue(..) + , Condition(..) + , OperatorExpression(..) + , TimePeriod(..) + , IconSetOptions(..) + , IconSetType(..) + , DataBarOptions(..) + , dataBarWithColor + -- * Lenses + -- ** CfRule + , cfrCondition + , cfrDxfId + , cfrPriority + , cfrStopIfTrue + -- ** IconSetOptions + , isoIconSet + , isoValues + , isoReverse + , isoShowValue + -- ** DataBarOptions + , dboMaxLength + , dboMinLength + , dboShowValue + , dboMinimum + , dboMaximum + , dboColor + -- * Misc + , topCfPriority + ) where + +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.Types.StyleSheet (Color) +import Codec.Xlsx.Writer.Internal + +-- | Logical operation used in 'CellIs' condition +-- +-- See 18.18.15 "ST_ConditionalFormattingOperator +-- (Conditional Format Operators)" (p. 2446) +data OperatorExpression + = OpBeginsWith Formula -- ^ 'Begins with' operator + | OpBetween Formula Formula -- ^ 'Between' operator + | OpContainsText Formula -- ^ 'Contains' operator + | OpEndsWith Formula -- ^ 'Ends with' operator + | OpEqual Formula -- ^ 'Equal to' operator + | OpGreaterThan Formula -- ^ 'Greater than' operator + | OpGreaterThanOrEqual Formula -- ^ 'Greater than or equal to' operator + | OpLessThan Formula -- ^ 'Less than' operator + | OpLessThanOrEqual Formula -- ^ 'Less than or equal to' operator + | OpNotBetween Formula Formula -- ^ 'Not between' operator + | OpNotContains Formula -- ^ 'Does not contain' operator + | OpNotEqual Formula -- ^ 'Not equal to' operator + 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 +-- the date the conditional formatting is refreshed / applied. +-- +-- See 18.18.82 "ST_TimePeriod (Time Period Types)" (p. 2508) +data TimePeriod + = PerLast7Days -- ^ A date in the last seven days. + | PerLastMonth -- ^ A date occuring in the last calendar month. + | PerLastWeek -- ^ A date occuring last week. + | PerNextMonth -- ^ A date occuring in the next calendar month. + | PerNextWeek -- ^ A date occuring next week. + | PerThisMonth -- ^ A date occuring in this calendar month. + | PerThisWeek -- ^ A date occuring this week. + | PerToday -- ^ Today's date. + | PerTomorrow -- ^ Tomorrow's date. + | PerYesterday -- ^ Yesterday's date. + 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 + -- | 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 + -- that TRIM() would remove, then it is considered blank. + -- An empty cell is also considered blank. + | ContainsBlanks + -- | This conditional formatting rule highlights cells with + -- formula errors. Equivalent to using ISERROR() sheet + -- function to determine if there is a formula error. + | ContainsErrors + -- | This conditional formatting rule highlights cells + -- containing given text. Equivalent to using the SEARCH() + -- 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. + | DoesNotContainErrors + -- | This conditional formatting rule highlights cells that + -- are not blank. Equivalent of using LEN(TRIM()). This + -- means that if the cell contains only characters that + -- TRIM() would remove, then it is considered blank. An + -- empty cell is also considered blank. + | DoesNotContainBlanks + -- | This conditional formatting rule highlights cells that do + -- 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. + | EndsWith Text + -- | This conditional formatting rule contains a formula to + -- 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 + -- cell does not need to be formatted as a date to be + -- evaluated. For example, with a cell containing the + -- value 38913 the conditional format shall be applied if + -- the rule requires a value of 7/14/2006. + | InTimePeriod TimePeriod + -- | 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) +data CfRule = CfRule + { _cfrCondition :: Condition + -- | This is an index to a dxf element in the Styles Part + -- indicating which cell formatting to + -- apply when the conditional formatting rule criteria is met. + , _cfrDxfId :: Maybe Int + -- | The priority of this conditional formatting rule. This value + -- is used to determine which format should be evaluated and + -- rendered. Lower numeric values are higher priority than + -- higher numeric values, where 1 is the highest priority. + , _cfrPriority :: Int + -- | If this flag is set, no rules with lower priority shall + -- be applied over this rule, when this rule + -- evaluates to true. + , _cfrStopIfTrue :: Maybe Bool + } 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] + +topCfPriority :: Int +topCfPriority = 1 + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor CfRule where + fromCursor cur = do + _cfrDxfId <- maybeAttribute "dxfId" cur + _cfrPriority <- fromAttribute "priority" cur + _cfrStopIfTrue <- maybeAttribute "stopIfTrue" cur + -- spec shows this attribute as optional but it's not clear why could + -- conditional formatting record be needed with no condition type set + cfType <- fromAttribute "type" cur + _cfrCondition <- readCondition cfType cur + return CfRule{..} + +readCondition :: Text -> Cursor -> [Condition] +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 (addSmlNamespace "formula") >=> fromCursor + expr <- readOpExpression operator formulas + return $ CellIs expr +readCondition "containsBlanks" _ = return ContainsBlanks +readCondition "containsErrors" _ = return ContainsErrors +readCondition "containsText" cur = do + txt <- fromAttribute "text" cur + return $ ContainsText 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 (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 "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 "between" [f1, f2] = [OpBetween f1 f2] +readOpExpression "containsText" [f] = [OpContainsText f] +readOpExpression "endsWith" [f] = [OpEndsWith f] +readOpExpression "equal" [f] = [OpEqual f] +readOpExpression "greaterThan" [f] = [OpGreaterThan f] +readOpExpression "greaterThanOrEqual" [f] = [OpGreaterThanOrEqual f] +readOpExpression "lessThan" [f] = [OpLessThan f] +readOpExpression "lessThanOrEqual" [f] = [OpLessThanOrEqual f] +readOpExpression "notBetween" [f1, f2] = [OpNotBetween f1 f2] +readOpExpression "notContains" [f] = [OpNotContains f] +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 + fromAttrVal "lastWeek" = readSuccess PerLastWeek + fromAttrVal "nextMonth" = readSuccess PerNextMonth + fromAttrVal "nextWeek" = readSuccess PerNextWeek + fromAttrVal "thisMonth" = readSuccess PerThisMonth + fromAttrVal "thisWeek" = readSuccess PerThisWeek + fromAttrVal "today" = readSuccess PerToday + fromAttrVal "tomorrow" = readSuccess PerTomorrow + 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 +-------------------------------------------------------------------------------} + +instance ToElement CfRule where + toElement nm CfRule{..} = + let (condType, condAttrs, condNodes) = conditionData _cfrCondition + baseAttrs = M.fromList . catMaybes $ + [ Just $ "type" .= condType + , "dxfId" .=? _cfrDxfId + , Just $ "priority" .= _cfrPriority + , "stopIfTrue" .=? _cfrStopIfTrue + ] + in Element + { elementName = nm + , elementAttributes = M.union baseAttrs condAttrs + , elementNodes = condNodes + } + +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]) +operatorExpressionData (OpBetween f1 f2) = ("between", [formulaNode f1, formulaNode f2]) +operatorExpressionData (OpContainsText f) = ("containsText", [formulaNode f]) +operatorExpressionData (OpEndsWith f) = ("endsWith", [formulaNode f]) +operatorExpressionData (OpEqual f) = ("equal", [formulaNode f]) +operatorExpressionData (OpGreaterThan f) = ("greaterThan", [formulaNode f]) +operatorExpressionData (OpGreaterThanOrEqual f) = ("greaterThanOrEqual", [formulaNode f]) +operatorExpressionData (OpLessThan f) = ("lessThan", [formulaNode f]) +operatorExpressionData (OpLessThanOrEqual f) = ("lessThanOrEqual", [formulaNode f]) +operatorExpressionData (OpNotBetween f1 f2) = ("notBetween", [formulaNode f1, formulaNode f2]) +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 = toNode "formula" + +instance ToAttrVal TimePeriod where + toAttrVal PerLast7Days = "last7Days" + toAttrVal PerLastMonth = "lastMonth" + toAttrVal PerLastWeek = "lastWeek" + toAttrVal PerNextMonth = "nextMonth" + toAttrVal PerNextWeek = "nextWeek" + toAttrVal PerThisMonth = "thisMonth" + toAttrVal PerThisWeek = "thisWeek" + 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/DataValidation.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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.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 + +-- See 18.18.20 "ST_DataValidationOperator (Data Validation Operator)" (p. 2439/2449) +data ValidationExpression + = ValBetween Formula Formula -- ^ "Between" operator + | ValEqual Formula -- ^ "Equal to" operator + | ValGreaterThan Formula -- ^ "Greater than" operator + | ValGreaterThanOrEqual Formula -- ^ "Greater than or equal to" operator + | ValLessThan Formula -- ^ "Less than" operator + | ValLessThanOrEqual Formula -- ^ "Less than or equal to" operator + | ValNotBetween Formula Formula -- ^ "Not between" operator + | ValNotEqual Formula -- ^ "Not equal to" operator + deriving (Eq, Show, Generic) +instance NFData ValidationExpression + +-- See 18.18.21 "ST_DataValidationType (Data Validation Type)" (p. 2440/2450) +data ValidationType + = ValidationTypeNone + | ValidationTypeCustom Formula + | ValidationTypeDate ValidationExpression + | ValidationTypeDecimal ValidationExpression + | ValidationTypeList ListOrRangeExpression + | ValidationTypeTextLength ValidationExpression + | ValidationTypeTime ValidationExpression + | ValidationTypeWhole ValidationExpression + 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, Generic) +instance NFData ErrorStyle + +-- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624) +data DataValidation = DataValidation + { _dvAllowBlank :: Bool + , _dvError :: Maybe Text + , _dvErrorStyle :: ErrorStyle + , _dvErrorTitle :: Maybe Text + , _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, Generic) +instance NFData DataValidation + +makeLenses ''DataValidation + +instance Default DataValidation where + def = DataValidation + False Nothing ErrorStyleStop Nothing Nothing Nothing False False False ValidationTypeNone + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromAttrVal ErrorStyle where + fromAttrVal "information" = readSuccess ErrorStyleInformation + fromAttrVal "stop" = readSuccess ErrorStyleStop + 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 + _dvError <- maybeAttribute "error" cur + _dvErrorStyle <- fromAttributeDef "errorStyle" ErrorStyleStop cur + _dvErrorTitle <- maybeAttribute "errorTitle" cur + mop <- fromAttributeDef "operator" "between" cur + _dvPrompt <- maybeAttribute "prompt" cur + _dvPromptTitle <- maybeAttribute "promptTitle" cur + _dvShowDropDown <- fromAttributeDef "showDropDown" False cur + _dvShowErrorMessage <- fromAttributeDef "showErrorMessage" False cur + _dvShowInputMessage <- fromAttributeDef "showInputMessage" False cur + mtype <- fromAttributeDef "type" "none" cur + _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 (addSmlNamespace "formula1") >=> fromCursor + as <- maybeToList $ readListFormulas f + return $ ValidationTypeList as +readValidationType op ty cur = do + opExp <- readOpExpression2 op cur + readValidationTypeOpExp ty opExp + +-- | 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 . 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 (addSmlNamespace "formula1") >=> fromCursor + f2 <- cur $/ element (addSmlNamespace "formula2") >=> fromCursor + readValExpression op [f1,f2] +readOpExpression2 op cur = do + f <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor + readValExpression op [f] + +readValidationTypeOpExp :: Text -> ValidationExpression -> [ValidationType] +readValidationTypeOpExp "date" oe = [ValidationTypeDate oe] +readValidationTypeOpExp "decimal" oe = [ValidationTypeDecimal oe] +readValidationTypeOpExp "textLength" oe = [ValidationTypeTextLength oe] +readValidationTypeOpExp "time" oe = [ValidationTypeTime oe] +readValidationTypeOpExp "whole" oe = [ValidationTypeWhole oe] +readValidationTypeOpExp _ _ = [] + +readValExpression :: Text -> [Formula] -> [ValidationExpression] +readValExpression "between" [f1, f2] = [ValBetween f1 f2] +readValExpression "equal" [f] = [ValEqual f] +readValExpression "greaterThan" [f] = [ValGreaterThan f] +readValExpression "greaterThanOrEqual" [f] = [ValGreaterThanOrEqual f] +readValExpression "lessThan" [f] = [ValLessThan f] +readValExpression "lessThanOrEqual" [f] = [ValLessThanOrEqual f] +readValExpression "notBetween" [f1, f2] = [ValNotBetween f1 f2] +readValExpression "notEqual" [f] = [ValNotEqual f] +readValExpression _ _ = [] + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToAttrVal ValidationType where + toAttrVal ValidationTypeNone = "none" + toAttrVal (ValidationTypeCustom _) = "custom" + toAttrVal (ValidationTypeDate _) = "date" + toAttrVal (ValidationTypeDecimal _) = "decimal" + toAttrVal (ValidationTypeList _) = "list" + toAttrVal (ValidationTypeTextLength _) = "textLength" + toAttrVal (ValidationTypeTime _) = "time" + toAttrVal (ValidationTypeWhole _) = "whole" + +instance ToAttrVal ErrorStyle where + toAttrVal ErrorStyleInformation = "information" + toAttrVal ErrorStyleStop = "stop" + toAttrVal ErrorStyleWarning = "warning" + +instance ToElement DataValidation where + toElement nm DataValidation{..} = Element + { elementName = nm + , elementAttributes = M.fromList . catMaybes $ + [ Just $ "allowBlank" .= _dvAllowBlank + , "error" .=? _dvError + , Just $ "errorStyle" .= _dvErrorStyle + , "errorTitle" .=? _dvErrorTitle + , "operator" .=? op + , "prompt" .=? _dvPrompt + , "promptTitle" .=? _dvPromptTitle + , Just $ "showDropDown" .= _dvShowDropDown + , Just $ "showErrorMessage" .= _dvShowErrorMessage + , Just $ "showInputMessage" .= _dvShowInputMessage + , Just $ "type" .= _dvValidationType + ] + , elementNodes = catMaybes + [ fmap (NodeElement . toElement "formula1") f1 + , fmap (NodeElement . toElement "formula2") f2 + ] + } + where + opExp (o,f1',f2') = (Just o, Just f1', f2') + + op :: Maybe Text + f1,f2 :: Maybe Formula + (op,f1,f2) = case _dvValidationType of + ValidationTypeNone -> (Nothing, Nothing, Nothing) + ValidationTypeCustom f -> (Nothing, Just f, Nothing) + ValidationTypeDate f -> opExp $ viewValidationExpression f + ValidationTypeDecimal f -> opExp $ viewValidationExpression f + ValidationTypeTextLength f -> opExp $ viewValidationExpression f + ValidationTypeTime f -> opExp $ viewValidationExpression f + ValidationTypeWhole f -> opExp $ viewValidationExpression f + ValidationTypeList 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) +viewValidationExpression (ValBetween f1 f2) = ("between", f1, Just f2) +viewValidationExpression (ValEqual f) = ("equal", f, Nothing) +viewValidationExpression (ValGreaterThan f) = ("greaterThan", f, Nothing) +viewValidationExpression (ValGreaterThanOrEqual f) = ("greaterThanOrEqual", f, Nothing) +viewValidationExpression (ValLessThan f) = ("lessThan", f, Nothing) +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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Drawing.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Drawing where + +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.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\/" + , _fiContentType :: Text + -- ^ 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, Generic) +instance NFData FileInfo + +data Marker = Marker + { _mrkCol :: Int + , _mrkColOff :: Coordinate + , _mrkRow :: Int + , _mrkRowOff :: Coordinate + } deriving (Eq, Show, Generic) +instance NFData Marker + +unqMarker :: (Int, Int) -> (Int, Int) -> Marker +unqMarker (col, colOff) (row, rowOff) = + Marker col (UnqCoordinate colOff) row (UnqCoordinate rowOff) + +data EditAs + = EditAsTwoCell + | EditAsOneCell + | EditAsAbsolute + deriving (Eq, Show, Generic) +instance NFData EditAs + +data Anchoring + = AbsoluteAnchor + { absaPos :: Point2D + , absaExt :: PositiveSize2D + } + | OneCellAnchor + { onecaFrom :: Marker + , onecaExt :: PositiveSize2D + } + | TwoCellAnchor + { tcaFrom :: Marker + , tcaTo :: Marker + , tcaEditAs :: EditAs + } + deriving (Eq, Show, Generic) +instance NFData Anchoring + +data DrawingObject p g + = Picture { _picMacro :: Maybe Text + , _picPublished :: Bool + , _picNonVisual :: PicNonVisual + , _picBlipFill :: BlipFillProperties p + , _picShapeProperties :: ShapeProperties + -- TODO: style + } + | Graphic { _grNonVisual :: GraphNonVisual + , _grChartSpace :: g + , _grTransform :: Transform2D} + -- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart + 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. +-- +-- see 20.5.2.3 "clientData (Client Data)" (p. 3156) +data ClientData = ClientData + { _cldLcksWithSheet :: Bool + -- ^ This attribute indicates whether to disable selection on + -- drawing elements when the sheet is protected. + , _cldPrintsWithSheet :: Bool + -- ^ This attribute indicates whether to print drawing elements + -- when printing the sheet. + } deriving (Eq, Show, Generic) +instance NFData ClientData + +data PicNonVisual = PicNonVisual + { _pnvDrawingProps :: NonVisualDrawingProperties + -- TODO: cNvPicPr + } deriving (Eq, Show, Generic) +instance NFData PicNonVisual + +data GraphNonVisual = GraphNonVisual + { _gnvDrawingProps :: NonVisualDrawingProperties + -- TODO cNvGraphicFramePr + } 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 :: DrawingElementId + -- ^ Specifies a unique identifier for the current + -- DrawingML object within the current + -- + -- TODO: make ids internal and consistent by construction + , _nvdpName :: Text + -- ^ Specifies the name of the object. + -- Typically, this is used to store the original file + -- name of a picture object. + , _nvdpDescription :: Maybe Text + -- ^ Alternative Text for Object + , _nvdpHidden :: Bool + , _nvdpTitle :: Maybe Text + } deriving (Eq, Show, Generic) +instance NFData NonVisualDrawingProperties + +data BlipFillProperties a = BlipFillProperties + { _bfpImageInfo :: Maybe a + , _bfpFillMode :: Maybe FillMode + -- TODO: dpi, rotWithShape, srcRect + } deriving (Eq, Show, Generic) +instance NFData a => NFData (BlipFillProperties a) + +-- see @a_EG_FillModeProperties@ (p. 4319) +data FillMode + -- See 20.1.8.58 "tile (Tile)" (p. 2880) + = FillTile -- TODO: tx, ty, sx, sy, flip, algn + -- See 20.1.8.56 "stretch (Stretch)" (p. 2879) + | FillStretch -- TODO: srcRect + 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, Generic) +instance (NFData p, NFData g) => NFData (Anchor p g) + +data GenericDrawing p g = Drawing + { _xdrAnchors :: [Anchor p g] + } 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 + +type UnresolvedDrawing = GenericDrawing RefId RefId + +makeLenses ''Anchor +makeLenses ''DrawingObject +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 +-------------------------------------------------------------------------------} + +instance Default ClientData where + def = ClientData True True + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor UnresolvedDrawing where + fromCursor cur = [Drawing $ cur $/ anyElement >=> fromCursor] + +instance FromCursor (Anchor RefId RefId) where + fromCursor cur = do + _anchAnchoring <- fromCursor cur + _anchObject <- cur $/ anyElement >=> fromCursor + _anchClientData <- cur $/ element (xdr"clientData") >=> fromCursor + return Anchor{..} + +instance FromCursor Anchoring where + fromCursor = anchoringFromNode . node + +anchoringFromNode :: Node -> [Anchoring] +anchoringFromNode n | n `nodeElNameIs` xdr "twoCellAnchor" = do + tcaEditAs <- fromAttributeDef "editAs" EditAsTwoCell cur + tcaFrom <- cur $/ element (xdr"from") >=> fromCursor + tcaTo <- cur $/ element (xdr"to") >=> fromCursor + return TwoCellAnchor{..} + | n `nodeElNameIs` xdr "oneCellAnchor" = do + onecaFrom <- cur $/ element (xdr"from") >=> fromCursor + onecaExt <- cur $/ element (xdr"ext") >=> fromCursor + return OneCellAnchor{..} + | n `nodeElNameIs` xdr "absolueAnchor" = do + absaPos <- cur $/ element (xdr"pos") >=> fromCursor + absaExt <- cur $/ element (xdr"ext") >=> fromCursor + return AbsoluteAnchor{..} + | otherwise = fail "no matching anchoring node" + where + cur = fromNode n + +instance FromCursor Marker where + fromCursor cur = do + _mrkCol <- cur $/ element (xdr"col") &/ content >=> decimal + _mrkColOff <- cur $/ element (xdr"colOff") &/ content >=> coordinate + _mrkRow <- cur $/ element (xdr"row") &/ content >=> decimal + _mrkRowOff <- cur $/ element (xdr"rowOff") &/ content >=> coordinate + return Marker{..} + +instance FromCursor (DrawingObject RefId RefId) where + fromCursor = drawingObjectFromNode . node + +drawingObjectFromNode :: Node -> [DrawingObject RefId RefId] +drawingObjectFromNode n + | n `nodeElNameIs` xdr "pic" = do + _picMacro <- maybeAttribute "macro" cur + _picPublished <- fromAttributeDef "fPublished" False cur + _picNonVisual <- cur $/ element (xdr "nvPicPr") >=> fromCursor + _picBlipFill <- cur $/ element (xdr "blipFill") >=> fromCursor + _picShapeProperties <- cur $/ element (xdr "spPr") >=> fromCursor + return Picture {..} + | n `nodeElNameIs` xdr "graphicFrame" = do + _grNonVisual <- + cur $/ element (xdr "nvGraphicFramePr") >=> fromCursor + _grTransform <- cur $/ element (xdr "xfrm") >=> fromCursor + _grChartSpace <- + cur $/ element (a_ "graphic") &/ element (a_ "graphicData") &/ + element (c_ "chart") >=> fmap RefId . attribute (odr "id") + return Graphic {..} + | otherwise = fail "no matching drawing object node" + where + cur = fromNode n + +instance FromCursor PicNonVisual where + fromCursor cur = do + _pnvDrawingProps <- cur $/ element (xdr"cNvPr") >=> fromCursor + return PicNonVisual{..} + +instance FromCursor GraphNonVisual where + fromCursor cur = do + _gnvDrawingProps <- cur $/ element (xdr "cNvPr") >=> fromCursor + return GraphNonVisual {..} + +instance FromCursor NonVisualDrawingProperties where + fromCursor cur = do + _nvdpId <- fromAttribute "id" cur + _nvdpName <- fromAttribute "name" cur + _nvdpDescription <- maybeAttribute "descr" cur + _nvdpHidden <- fromAttributeDef "hidden" False cur + _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") >=> + fmap RefId . attribute (odr"embed") + _bfpFillMode = listToMaybe $ cur $/ anyElement >=> fromCursor + return BlipFillProperties{..} + +instance FromCursor FillMode where + fromCursor = fillModeFromNode . node + +fillModeFromNode :: Node -> [FillMode] +fillModeFromNode n | n `nodeElNameIs` a_ "stretch" = return FillStretch + | n `nodeElNameIs` a_ "stretch" = return FillTile + | otherwise = fail "no matching fill mode node" + +-- see 20.5.3.2 "ST_EditAs (Resizing Behaviors)" (p. 3177) +instance FromAttrVal EditAs where + fromAttrVal "absolute" = readSuccess EditAsAbsolute + fromAttrVal "oneCell" = readSuccess EditAsOneCell + fromAttrVal "twoCell" = readSuccess EditAsTwoCell + fromAttrVal t = invalidText "EditAs" t + +instance FromCursor ClientData where + fromCursor cur = do + _cldLcksWithSheet <- fromAttributeDef "fLocksWithSheet" True cur + _cldPrintsWithSheet <- fromAttributeDef "fPrintsWithSheet" True cur + return ClientData{..} + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToDocument UnresolvedDrawing where + toDocument = documentFromNsElement "Drawing generated by xlsx" xlDrawingNs + . toElement "wsDr" + +instance ToElement UnresolvedDrawing where + toElement nm (Drawing anchors) = Element + { elementName = nm + , elementAttributes = M.empty + , elementNodes = map NodeElement $ + map anchorToElement anchors + } + +anchorToElement :: Anchor RefId RefId -> Element +anchorToElement Anchor{..} = el + { elementNodes = elementNodes el ++ + map NodeElement [ drawingObjEl, cdEl ] } + where + el = anchoringToElement _anchAnchoring + drawingObjEl = drawingObjToElement _anchObject + cdEl = toElement "clientData" _anchClientData + +anchoringToElement :: Anchoring -> Element +anchoringToElement anchoring = elementList nm attrs elements + where + (nm, attrs, elements) = case anchoring of + AbsoluteAnchor{..} -> + ("absoluteAnchor", [], + [ toElement "pos" absaPos, toElement "ext" absaExt ]) + OneCellAnchor{..} -> + ("oneCellAnchor", [], + [ toElement "from" onecaFrom, toElement "ext" onecaExt ]) + TwoCellAnchor{..} -> + ("twoCellAnchor", [ "editAs" .= tcaEditAs ], + [ toElement "from" tcaFrom, toElement "to" tcaTo ]) + +instance ToElement Marker where + toElement nm Marker{..} = elementListSimple nm elements + where + elements = [ elementContent "col" (toAttrVal _mrkCol) + , elementContent "colOff" (toAttrVal _mrkColOff) + , elementContent "row" (toAttrVal _mrkRow) + , elementContent "rowOff" (toAttrVal _mrkRowOff)] + +drawingObjToElement :: DrawingObject RefId RefId -> Element +drawingObjToElement Picture {..} = elementList "pic" attrs elements + where + attrs = + catMaybes ["macro" .=? _picMacro, "fPublished" .=? justTrue _picPublished] + elements = + [ toElement "nvPicPr" _picNonVisual + , toElement "blipFill" _picBlipFill + , toElement "spPr" _picShapeProperties + ] +drawingObjToElement Graphic {..} = elementListSimple "graphicFrame" elements + where + elements = + [ toElement "nvGraphicFramePr" _grNonVisual + , toElement "xfrm" _grTransform + , graphicEl + ] + graphicEl = + elementListSimple + (a_ "graphic") + [ elementList + (a_ "graphicData") + ["uri" .= chartNs] + [leafElement (c_ "chart") [odr "id" .= _grChartSpace]] + ] + +instance ToElement PicNonVisual where + toElement nm PicNonVisual {..} = + elementListSimple + nm + [toElement "cNvPr" _pnvDrawingProps, emptyElement "cNvPicPr"] + +instance ToElement GraphNonVisual where + toElement nm GraphNonVisual {..} = + elementListSimple + nm + [toElement "cNvPr" _gnvDrawingProps, emptyElement "cNvGraphicFramePr"] + +instance ToElement NonVisualDrawingProperties where + toElement nm NonVisualDrawingProperties{..} = + leafElement nm attrs + where + attrs = [ "id" .= _nvdpId + , "name" .= _nvdpName ] ++ + catMaybes [ "descr" .=? _nvdpDescription + , "hidden" .=? justTrue _nvdpHidden + , "title" .=? _nvdpTitle ] + +instance ToAttrVal DrawingElementId where + toAttrVal = toAttrVal . unDrawingElementId + +instance ToElement (BlipFillProperties RefId) where + toElement nm BlipFillProperties{..} = + elementListSimple nm elements + where + elements = catMaybes [ (\rId -> leafElement (a_ "blip") [ odr "embed" .= rId ]) <$> _bfpImageInfo + , fillModeToElement <$> _bfpFillMode ] + +fillModeToElement :: FillMode -> Element +fillModeToElement FillStretch = emptyElement (a_ "stretch") +fillModeToElement FillTile = emptyElement (a_ "stretch") + +instance ToElement ClientData where + toElement nm ClientData{..} = leafElement nm attrs + where + attrs = catMaybes [ "fLocksWithSheet" .=? justFalse _cldLcksWithSheet + , "fPrintsWithSheet" .=? justFalse _cldPrintsWithSheet + ] + +instance ToAttrVal EditAs where + toAttrVal EditAsAbsolute = "absolute" + toAttrVal EditAsOneCell = "oneCell" + toAttrVal EditAsTwoCell = "twoCell" + +-- | Add Spreadsheet DrawingML namespace to name +xdr :: Text -> Name +xdr x = Name + { nameLocalName = x + , nameNamespace = Just xlDrawingNs + , namePrefix = Nothing + } + +xlDrawingNs :: Text +xlDrawingNs = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" diff --git a/src/Codec/Xlsx/Types/Drawing/Chart.hs b/src/Codec/Xlsx/Types/Drawing/Chart.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Drawing/Chart.hs @@ -0,0 +1,828 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Drawing.Chart where + +import GHC.Generics (Generic) + +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 + +-- | Main Chart holder, combines +-- TODO: title, autoTitleDeleted, pivotFmts +-- view3D, floor, sideWall, backWall, showDLblsOverMax, extLst +data ChartSpace = ChartSpace + { _chspTitle :: Maybe ChartTitle + , _chspCharts :: [Chart] + , _chspLegend :: Maybe Legend + , _chspPlotVisOnly :: Maybe Bool + , _chspDispBlanksAs :: Maybe DispBlanksAs + } deriving (Eq, Show, Generic) +instance NFData ChartSpace + +-- | Chart title +-- +-- TODO: layout, overlay, spPr, txPr, extLst +newtype ChartTitle = + ChartTitle (Maybe TextBody) + deriving (Eq, Show, Generic) +instance NFData ChartTitle + +-- | This simple type specifies the possible ways to display blanks. +-- +-- See 21.2.3.10 "ST_DispBlanksAs (Display Blanks As)" (p. 3444) +data DispBlanksAs + = DispBlanksAsGap + -- ^ Specifies that blank values shall be left as a gap. + | DispBlanksAsSpan + -- ^ Specifies that blank values shall be spanned with a line. + | DispBlanksAsZero + -- ^ Specifies that blank values shall be treated as zero. + 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, Generic) +instance NFData Legend + +-- See 21.2.3.24 "ST_LegendPos (Legend Position)" (p. 3449) +data LegendPos + = LegendBottom + -- ^ b (Bottom) Specifies that the legend shall be drawn at the + -- bottom of the chart. + | LegendLeft + -- ^ l (Left) Specifies that the legend shall be drawn at the left + -- of the chart. + | LegendRight + -- ^ r (Right) Specifies that the legend shall be drawn at the + -- right of the chart. + | LegendTop + -- ^ t (Top) Specifies that the legend shall be drawn at the top + -- of the chart. + | LegendTopRight + -- ^ tr (Top Right) Specifies that the legend shall be drawn at + -- the top right of the chart. + deriving (Eq, Show, Generic) +instance NFData LegendPos + +-- | Specific Chart +-- TODO: +-- 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 + } + | 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 chart +-- +-- See 21.2.3.17 "ST_Grouping (Grouping)" (p. 3446) +data ChartGrouping + = PercentStackedGrouping + -- ^ (100% Stacked) Specifies that the chart series are drawn next to each + -- other along the value axis and scaled to total 100%. + | StackedGrouping + -- ^ (Stacked) Specifies that the chart series are drawn next to each + -- other on the value axis. + | StandardGrouping + -- ^(Standard) Specifies that the chart series are drawn on the value + -- axis. + 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 +-- +-- See @EG_SerShared@ (p. 4063) +data Series = Series + { _serTx :: Maybe Formula + -- ^ specifies text for a series name, without rich text formatting + -- currently only reference formula is supported + , _serShapeProperties :: Maybe ShapeProperties + } deriving (Eq, Show, Generic) +instance NFData Series + +-- | A series on a line chart +-- +-- TODO: dPt, trendline, errBars, cat, extLst +-- +-- See @CT_LineSer@ (p. 4064) +data LineSeries = LineSeries + { _lnserShared :: Series + , _lnserMarker :: Maybe DataMarker + , _lnserDataLblProps :: Maybe DataLblProps + , _lnserVal :: Maybe Formula + -- ^ currently only reference formula is supported + , _lnserSmooth :: Maybe Bool + } 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, Generic) +instance NFData DataMarker + +data DataMarkerSymbol + = DataMarkerCircle + | DataMarkerDash + | DataMarkerDiamond + | DataMarkerDot + | DataMarkerNone + | DataMarkerPicture + | DataMarkerPlus + | DataMarkerSquare + | DataMarkerStar + | DataMarkerTriangle + | DataMarkerX + | DataMarkerAuto + deriving (Eq, Show, Generic) +instance NFData DataMarkerSymbol + +-- | Settings for the data labels for an entire series or the +-- entire chart +-- +-- TODO: numFmt, spPr, txPr, dLblPos, showBubbleSize, +-- separator, showLeaderLines, leaderLines +-- See 21.2.2.49 "dLbls (Data Labels)" (p. 3384) +data DataLblProps = DataLblProps + { _dlblShowLegendKey :: Maybe Bool + , _dlblShowVal :: Maybe Bool + , _dlblShowCatName :: Maybe Bool + , _dlblShowSerName :: Maybe Bool + , _dlblShowPercent :: Maybe Bool + } deriving (Eq, Show, Generic) +instance NFData DataLblProps + +-- | Specifies the possible positions for tick marks. + +-- See 21.2.3.48 "ST_TickMark (Tick Mark)" (p. 3467) +data TickMark + = TickMarkCross + -- ^ (Cross) Specifies the tick marks shall cross the axis. + | TickMarkIn + -- ^ (Inside) Specifies the tick marks shall be inside the plot area. + | TickMarkNone + -- ^ (None) Specifies there shall be no tick marks. + | TickMarkOut + -- ^ (Outside) Specifies the tick marks shall be outside the plot area. + deriving (Eq, Show, Generic) +instance NFData TickMark + +makeLenses ''DataPoint + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default DataPoint where + def = DataPoint Nothing Nothing + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor ChartSpace where + fromCursor cur = do + cur' <- cur $/ element (c_ "chart") + _chspTitle <- maybeFromElement (c_ "title") cur' + let _chspCharts = + cur' $/ element (c_ "plotArea") &/ anyElement >=> chartFromNode . node + _chspLegend <- maybeFromElement (c_ "legend") cur' + _chspPlotVisOnly <- maybeBoolElementValue (c_ "plotVisOnly") cur' + _chspDispBlanksAs <- maybeElementValue (c_ "dispBlanksAs") cur' + return ChartSpace {..} + +chartFromNode :: Node -> [Chart] +chartFromNode n + | n `nodeElNameIs` (c_ "lineChart") = do + _lnchGrouping <- fromElementValue (c_ "grouping") cur + let _lnchSeries = cur $/ element (c_ "ser") >=> fromCursor + _lnchMarker <- maybeBoolElementValue (c_ "marker") cur + _lnchSmooth <- maybeBoolElementValue (c_ "smooth") cur + return LineChart {..} + | n `nodeElNameIs` (c_ "areaChart") = do + _archGrouping <- maybeElementValue (c_ "grouping") cur + let _archSeries = cur $/ element (c_ "ser") >=> fromCursor + return AreaChart {..} + | n `nodeElNameIs` (c_ "barChart") = do + _brchDirection <- fromElementValue (c_ "barDir") cur + _brchGrouping <- + 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 + +instance FromCursor LineSeries where + fromCursor cur = do + _lnserShared <- fromCursor cur + _lnserMarker <- maybeFromElement (c_ "marker") cur + _lnserDataLblProps <- maybeFromElement (c_ "dLbls") cur + _lnserVal <- + cur $/ element (c_ "val") &/ element (c_ "numRef") >=> + maybeFromElement (c_ "f") + _lnserSmooth <- maybeElementValueDef (c_ "smooth") True cur + return LineSeries {..} + +instance FromCursor AreaSeries where + fromCursor cur = do + _arserShared <- fromCursor cur + _arserDataLblProps <- maybeFromElement (c_ "dLbls") cur + _arserVal <- + cur $/ element (c_ "val") &/ element (c_ "numRef") >=> + maybeFromElement (c_ "f") + return AreaSeries {..} + +instance FromCursor BarSeries where + fromCursor cur = do + _brserShared <- fromCursor cur + _brserDataLblProps <- maybeFromElement (c_ "dLbls") cur + _brserVal <- + cur $/ element (c_ "val") &/ element (c_ "numRef") >=> + maybeFromElement (c_ "f") + return BarSeries {..} + +instance FromCursor PieSeries where + fromCursor cur = do + _piserShared <- fromCursor cur + let _piserDataPoints = cur $/ element (c_ "dPt") >=> fromCursor + _piserDataLblProps <- maybeFromElement (c_ "dLbls") cur + _piserVal <- + cur $/ element (c_ "val") &/ element (c_ "numRef") >=> + maybeFromElement (c_ "f") + return PieSeries {..} + +instance FromCursor ScatterSeries where + fromCursor cur = do + _scserShared <- fromCursor cur + _scserMarker <- maybeFromElement (c_ "marker") cur + _scserDataLblProps <- maybeFromElement (c_ "dLbls") cur + _scserXVal <- + cur $/ element (c_ "xVal") &/ element (c_ "numRef") >=> + maybeFromElement (c_ "f") + _scserYVal <- + cur $/ element (c_ "yVal") &/ element (c_ "numRef") >=> + maybeFromElement (c_ "f") + _scserSmooth <- maybeElementValueDef (c_ "smooth") True cur + return ScatterSeries {..} + +-- 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 + fromCursor cur = do + _dmrkSymbol <- maybeElementValue (c_ "symbol") cur + _dmrkSize <- maybeElementValue (c_ "size") cur + return DataMarker {..} + +instance FromCursor DataPoint where + fromCursor cur = do + _dpMarker <- maybeFromElement (c_ "marker") cur + _dpShapeProperties <- maybeFromElement (c_ "spPr") cur + return DataPoint {..} + +instance FromAttrVal DataMarkerSymbol where + fromAttrVal "circle" = readSuccess DataMarkerCircle + fromAttrVal "dash" = readSuccess DataMarkerDash + fromAttrVal "diamond" = readSuccess DataMarkerDiamond + fromAttrVal "dot" = readSuccess DataMarkerDot + fromAttrVal "none" = readSuccess DataMarkerNone + fromAttrVal "picture" = readSuccess DataMarkerPicture + fromAttrVal "plus" = readSuccess DataMarkerPlus + fromAttrVal "square" = readSuccess DataMarkerSquare + fromAttrVal "star" = readSuccess DataMarkerStar + fromAttrVal "triangle" = readSuccess DataMarkerTriangle + fromAttrVal "x" = readSuccess DataMarkerX + fromAttrVal "auto" = readSuccess DataMarkerAuto + fromAttrVal t = invalidText "DataMarkerSymbol" t + +instance FromAttrVal BarDirection where + fromAttrVal "bar" = readSuccess DirectionBar + fromAttrVal "col" = readSuccess DirectionColumn + fromAttrVal t = invalidText "BarDirection" t + +instance FromAttrVal ScatterStyle where + fromAttrVal "none" = readSuccess ScatterNone + fromAttrVal "line" = readSuccess ScatterLine + fromAttrVal "lineMarker" = readSuccess ScatterLineMarker + fromAttrVal "marker" = readSuccess ScatterMarker + fromAttrVal "smooth" = readSuccess ScatterSmooth + fromAttrVal "smoothMarker" = readSuccess ScatterSmoothMarker + fromAttrVal t = invalidText "ScatterStyle" t + +instance FromCursor DataLblProps where + fromCursor cur = do + _dlblShowLegendKey <- maybeBoolElementValue (c_ "showLegendKey") cur + _dlblShowVal <- maybeBoolElementValue (c_ "showVal") cur + _dlblShowCatName <- maybeBoolElementValue (c_ "showCatName") cur + _dlblShowSerName <- maybeBoolElementValue (c_ "showSerName") cur + _dlblShowPercent <- maybeBoolElementValue (c_ "showPercent") cur + return DataLblProps {..} + +instance FromAttrVal ChartGrouping where + fromAttrVal "percentStacked" = readSuccess PercentStackedGrouping + fromAttrVal "standard" = readSuccess StandardGrouping + fromAttrVal "stacked" = readSuccess StackedGrouping + fromAttrVal t = invalidText "ChartGrouping" t + +instance 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 = do + let mTitle = listToMaybe $ + cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fromCursor + return $ ChartTitle mTitle + +instance FromCursor Legend where + fromCursor cur = do + _legendPos <- maybeElementValue (c_ "legendPos") cur + _legendOverlay <- maybeElementValueDef (c_ "overlay") True cur + return Legend {..} + +instance FromAttrVal LegendPos where + fromAttrVal "b" = readSuccess LegendBottom + fromAttrVal "l" = readSuccess LegendLeft + fromAttrVal "r" = readSuccess LegendRight + fromAttrVal "t" = readSuccess LegendTop + fromAttrVal "tr" = readSuccess LegendTopRight + fromAttrVal t = invalidText "LegendPos" t + +instance FromAttrVal DispBlanksAs where + fromAttrVal "gap" = readSuccess DispBlanksAsGap + fromAttrVal "span" = readSuccess DispBlanksAsSpan + fromAttrVal "zero" = readSuccess DispBlanksAsZero + fromAttrVal t = invalidText "DispBlanksAs" t + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default Legend where + def = Legend {_legendPos = Just LegendBottom, _legendOverlay = Just False} + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToDocument ChartSpace where + toDocument = + documentFromNsPrefElement "Charts generated by xlsx" chartNs (Just "c") . + toElement "chartSpace" + +instance ToElement ChartSpace where + toElement nm ChartSpace {..} = + elementListSimple nm [nonRounded, chartEl, chSpPr] + where + -- no such element gives a chart space with rounded corners + nonRounded = elementValue "roundedCorners" False + chSpPr = toElement "spPr" $ def {_spFill = Just $ solidRgb "ffffff"} + chartEl = elementListSimple "chart" elements + elements = + catMaybes + [ toElement "title" <$> _chspTitle + -- LO? + , Just $ elementValue "autoTitleDeleted" False + , Just $ elementListSimple "plotArea" areaEls + , toElement "legend" <$> _chspLegend + , elementValue "plotVisOnly" <$> _chspPlotVisOnly + , elementValue "dispBlanksAs" <$> _chspDispBlanksAs + ] + areaEls = charts ++ axes + (_, charts, axes) = foldr addChart (1, [], []) _chspCharts + addChart ch (i, cs, as) = + let (c, as') = chartToElements ch i + in (i + length as', c : cs, as' ++ as) + +chartToElements :: Chart -> Int -> (Element, [Element]) +chartToElements chart axId = + case chart of + LineChart {..} -> + chartElement + "lineChart" + stdAxes + (Just _lnchGrouping) + _lnchSeries + [] + (catMaybes + [ elementValue "marker" <$> _lnchMarker + , elementValue "smooth" <$> _lnchSmooth + ]) + AreaChart {..} -> + chartElement "areaChart" stdAxes _archGrouping _archSeries [] [] + BarChart {..} -> + chartElement + "barChart" + stdAxes + _brchGrouping + _brchSeries + [elementValue "barDir" _brchDirection] + [] + PieChart {..} -> chartElement "pieChart" [] noGrouping _pichSeries [] [] + ScatterChart {..} -> + chartElement + "scatterChart" + xyAxes + noGrouping + _scchSeries + [elementValue "scatterStyle" _scchStyle] + [] + where + 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 + 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 {..} = simpleSeries nm _lnserShared _lnserVal pr ap + where + pr = + catMaybes + [ toElement "marker" <$> _lnserMarker + , toElement "dLbls" <$> _lnserDataLblProps + ] + ap = maybeToList $ elementValue "smooth" <$> _lnserSmooth + +simpleSeries :: Name + -> Series + -> Maybe Formula + -> [Element] + -> [Element] + -> Element +simpleSeries nm shared val prepended appended = + serEl {elementNodes = elementNodes serEl ++ map NodeElement elements} + where + serEl = toElement nm shared + elements = prepended ++ (valEl val : appended) + valEl v = + elementListSimple + "val" + [elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)] + +instance ToElement DataMarker where + toElement nm DataMarker {..} = elementListSimple nm elements + where + elements = + catMaybes + [ elementValue "symbol" <$> _dmrkSymbol + , elementValue "size" <$> _dmrkSize + ] + +instance ToAttrVal DataMarkerSymbol where + toAttrVal DataMarkerCircle = "circle" + toAttrVal DataMarkerDash = "dash" + toAttrVal DataMarkerDiamond = "diamond" + toAttrVal DataMarkerDot = "dot" + toAttrVal DataMarkerNone = "none" + toAttrVal DataMarkerPicture = "picture" + toAttrVal DataMarkerPlus = "plus" + toAttrVal DataMarkerSquare = "square" + toAttrVal DataMarkerStar = "star" + toAttrVal DataMarkerTriangle = "triangle" + toAttrVal DataMarkerX = "x" + toAttrVal DataMarkerAuto = "auto" + +instance ToElement DataLblProps where + toElement nm DataLblProps {..} = elementListSimple nm elements + where + elements = + catMaybes + [ elementValue "showLegendKey" <$> _dlblShowLegendKey + , elementValue "showVal" <$> _dlblShowVal + , elementValue "showCatName" <$> _dlblShowCatName + , elementValue "showSerName" <$> _dlblShowSerName + , elementValue "showPercent" <$> _dlblShowPercent + ] + +instance ToElement AreaSeries where + toElement nm AreaSeries {..} = simpleSeries nm _arserShared _arserVal pr [] + where + pr = maybeToList $ fmap (toElement "dLbls") _arserDataLblProps + +instance ToElement BarSeries where + toElement nm BarSeries {..} = simpleSeries nm _brserShared _brserVal pr [] + where + pr = maybeToList $ fmap (toElement "dLbls") _brserDataLblProps + +instance ToElement PieSeries where + toElement nm PieSeries {..} = simpleSeries nm _piserShared _piserVal pr [] + where + pr = dPts ++ maybeToList (fmap (toElement "dLbls") _piserDataLblProps) + dPts = zipWith dPtEl [(0 :: Int) ..] _piserDataPoints + dPtEl i DataPoint {..} = + elementListSimple + "dPt" + (elementValue "idx" i : + catMaybes + [ toElement "marker" <$> _dpMarker + , toElement "spPr" <$> _dpShapeProperties + ]) + +instance ToElement ScatterSeries where + toElement nm ScatterSeries {..} = + serEl {elementNodes = elementNodes serEl ++ map NodeElement elements} + where + serEl = toElement nm _scserShared + elements = + catMaybes + [ toElement "marker" <$> _scserMarker + , toElement "dLbls" <$> _scserDataLblProps + ] ++ + [valEl "xVal" _scserXVal, valEl "yVal" _scserYVal] ++ + (maybeToList $ fmap (elementValue "smooth") _scserSmooth) + valEl vnm v = + elementListSimple + vnm + [elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)] + +-- should we respect idx and order? +instance ToElement Series where + toElement nm Series {..} = + elementListSimple nm $ + [ elementListSimple + "tx" + [elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)] + ] ++ + maybeToList (toElement "spPr" <$> _serShapeProperties) + +instance ToElement ChartTitle where + toElement nm (ChartTitle body) = + elementListSimple nm [txEl, elementValue "overlay" False] + where + txEl = elementListSimple "tx" $ catMaybes [toElement (c_ "rich") <$> body] + +instance ToElement Legend where + toElement nm Legend{..} = elementListSimple nm elements + where + elements = catMaybes [ elementValue "legendPos" <$> _legendPos + , elementValue "overlay" <$>_legendOverlay] + +instance ToAttrVal LegendPos where + toAttrVal LegendBottom = "b" + toAttrVal LegendLeft = "l" + toAttrVal LegendRight = "r" + toAttrVal LegendTop = "t" + toAttrVal LegendTopRight = "tr" + +instance ToAttrVal DispBlanksAs where + toAttrVal DispBlanksAsGap = "gap" + toAttrVal DispBlanksAsSpan = "span" + toAttrVal DispBlanksAsZero = "zero" + +instance ToAttrVal TickMark where + toAttrVal TickMarkCross = "cross" + toAttrVal TickMarkIn = "in" + toAttrVal TickMarkNone = "none" + toAttrVal TickMarkOut = "out" + +-- | Add chart namespace to name +c_ :: Text -> Name +c_ x = + Name {nameLocalName = x, nameNamespace = Just chartNs, namePrefix = Just "c"} + +chartNs :: Text +chartNs = "http://schemas.openxmlformats.org/drawingml/2006/chart" diff --git a/src/Codec/Xlsx/Types/Drawing/Common.hs b/src/Codec/Xlsx/Types/Drawing/Common.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Drawing/Common.hs @@ -0,0 +1,619 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Drawing.Common where + +import GHC.Generics (Generic) + +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 + +-- | 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, Generic) +instance NFData Angle + +-- | A string with rich text formatting +-- +-- TODO: horzOverflow, lIns, tIns, rIns, bIns, numCol, spcCol, rtlCol, +-- fromWordArt, forceAA, upright, compatLnSpc, prstTxWarp, +-- a_EG_TextAutofit, scene3d, a_EG_Text3D, extLst +-- +-- See @CT_TextBody@ (p. 4034) +data TextBody = TextBody + { _txbdRotation :: Angle + -- ^ Specifies the rotation that is being applied to the text within the bounding box. + , _txbdSpcFirstLastPara :: Bool + -- ^ Specifies whether the before and after paragraph spacing defined by the user is + -- to be respected. + , _txbdVertOverflow :: TextVertOverflow + -- ^ Determines whether the text can flow out of the bounding box vertically. + , _txbdVertical :: TextVertical + -- ^ Determines if the text within the given text body should be displayed vertically. + , _txbdWrap :: TextWrap + -- ^ Specifies the wrapping options to be used for this text body. + , _txbdAnchor :: TextAnchoring + -- ^ Specifies the anchoring position of the txBody within the shape. + , _txbdAnchorCenter :: Bool + -- ^ Specifies the centering of the text box. The way it works fundamentally is + -- to determine the smallest possible "bounds box" for the text and then to center + -- that "bounds box" accordingly. This is different than paragraph alignment, which + -- aligns the text within the "bounds box" for the text. + , _txbdParagraphs :: [TextParagraph] + -- ^ Paragraphs of text within the containing text body + } deriving (Eq, Show, Generic) +instance NFData TextBody + + +-- | Text vertical overflow +-- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083) +data TextVertOverflow + = TextVertOverflowClip + -- ^ Pay attention to top and bottom barriers. Provide no indication that there is + -- text which is not visible. + | TextVertOverflowEllipsis + -- ^ Pay attention to top and bottom barriers. Use an ellipsis to denote that + -- there is text which is not visible. + | TextVertOverflow + -- ^ Overflow the text and pay no attention to top and bottom barriers. + deriving (Eq, Show, Generic) +instance NFData TextVertOverflow + +-- | If there is vertical text, determines what kind of vertical text is going to be used. +-- +-- See 20.1.10.82 "ST_TextVerticalType (Vertical Text Types)" (p. 3083) +data TextVertical + = TextVerticalEA + -- ^ A special version of vertical text, where some fonts are displayed as if rotated + -- by 90 degrees while some fonts (mostly East Asian) are displayed vertical. + | TextVerticalHorz + -- ^ Horizontal text. This should be default. + | TextVerticalMongolian + -- ^ A special version of vertical text, where some fonts are displayed as if rotated + -- by 90 degrees while some fonts (mostly East Asian) are displayed vertical. The + -- difference between this and the 'TextVerticalEA' is the text flows top down then + -- LEFT RIGHT, instead of RIGHT LEFT + | TextVertical + -- ^ Determines if all of the text is vertical orientation (each line is 90 degrees + -- rotated clockwise, so it goes from top to bottom; each next line is to the left + -- from the previous one). + | TextVertical270 + -- ^ Determines if all of the text is vertical orientation (each line is 270 degrees + -- rotated clockwise, so it goes from bottom to top; each next line is to the right + -- from the previous one). + | TextVerticalWordArt + -- ^ Determines if all of the text is vertical ("one letter on top of another"). + | TextVerticalWordArtRtl + -- ^ Specifies that vertical WordArt should be shown from right to left rather than + -- left to right. + deriving (Eq, Show, Generic) +instance NFData TextVertical + +-- | Text wrapping types +-- +-- See 20.1.10.84 "ST_TextWrappingType (Text Wrapping Types)" (p. 3084) +data TextWrap + = TextWrapNone + -- ^ No wrapping occurs on this text body. Words spill out without + -- paying attention to the bounding rectangle boundaries. + | TextWrapSquare + -- ^ Determines whether we wrap words within the bounding rectangle. + deriving (Eq, Show, Generic) +instance NFData TextWrap + +-- | This type specifies a list of available anchoring types for text. +-- +-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058) +data TextAnchoring + = TextAnchoringBottom + -- ^ Anchor the text at the bottom of the bounding rectangle. + | TextAnchoringCenter + -- ^ Anchor the text at the middle of the bounding rectangle. + | TextAnchoringDistributed + -- ^ Anchor the text so that it is distributed vertically. When text is horizontal, + -- this spaces out the actual lines of text and is almost always identical in + -- behavior to 'TextAnchoringJustified' (special case: if only 1 line, then anchored + -- in middle). When text is vertical, then it distributes the letters vertically. + -- This is different than 'TextAnchoringJustified', because it always forces distribution + -- of the words, even if there are only one or two words in a line. + | TextAnchoringJustified + -- ^ Anchor the text so that it is justified vertically. When text is horizontal, + -- this spaces out the actual lines of text and is almost always identical in + -- behavior to 'TextAnchoringDistributed' (special case: if only 1 line, then anchored at + -- top). When text is vertical, then it justifies the letters vertically. This is + -- different than 'TextAnchoringDistributed' because in some cases such as very little + -- text in a line, it does not justify. + | TextAnchoringTop + -- ^ Anchor the text at the top of the bounding rectangle. + 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, Generic) +instance NFData TextParagraph + +-- | Text character properties +-- +-- TODO: kumimoji, lang, altLang, sz, strike, kern, cap, spc, +-- normalizeH, baseline, noProof, dirty, err, smtClean, smtId, +-- bmk, ln, a_EG_FillProperties, a_EG_EffectProperties, highlight, +-- a_EG_TextUnderlineLine, a_EG_TextUnderlineFill, latin, ea, cs, +-- sym, hlinkClick, hlinkMouseOver, rtl, extLst +-- +-- See @CT_TextCharacterProperties@ (p. 4039) +data TextCharacterProperties = TextCharacterProperties + { _txchBold :: Bool + , _txchItalic :: Bool + , _txchUnderline :: Bool + } deriving (Eq, Show, Generic) +instance NFData TextCharacterProperties + +-- | Text run +-- +-- TODO: br, fld +data TextRun = RegularRun + { _txrCharProps :: Maybe TextCharacterProperties + , _txrText :: Text + } deriving (Eq, Show, Generic) +instance NFData TextRun + +-- | This simple type represents a one dimensional position or length +-- +-- See 20.1.10.16 "ST_Coordinate (Coordinate)" (p. 2921) +data Coordinate + = UnqCoordinate Int + -- ^ see 20.1.10.19 "ST_CoordinateUnqualified (Coordinate)" (p. 2922) + | UniversalMeasure UnitIdentifier + Double + -- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) + deriving (Eq, Show, Generic) +instance NFData Coordinate + +-- | Units used in "Universal measure" coordinates +-- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) +data UnitIdentifier + = UnitCm -- "cm" As defined in ISO 31. + | UnitMm -- "mm" As defined in ISO 31. + | UnitIn -- "in" 1 in = 2.54 cm (informative) + | 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, Generic) +instance NFData UnitIdentifier + +-- See @CT_Point2D@ (p. 3989) +data Point2D = Point2D + { _pt2dX :: Coordinate + , _pt2dY :: Coordinate + } deriving (Eq, Show, Generic) +instance NFData Point2D + +unqPoint2D :: Int -> Int -> Point2D +unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y) + +-- | Positive position or length in EMUs, maximu allowed value is 27273042316900. +-- see 20.1.10.41 "ST_PositiveCoordinate (Positive Coordinate)" (p. 2942) +newtype PositiveCoordinate = + PositiveCoordinate Integer + deriving (Eq, Ord, Show, Generic) +instance NFData PositiveCoordinate + +data PositiveSize2D = PositiveSize2D + { _ps2dX :: PositiveCoordinate + , _ps2dY :: PositiveCoordinate + } 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 + -- ^ Specifies the rotation of the Graphic Frame. + , _trFlipH :: Bool + -- ^ Specifies a horizontal flip. When true, this attribute defines + -- that the shape is flipped horizontally about the center of its bounding box. + , _trFlipV :: Bool + -- ^ Specifies a vertical flip. When true, this attribute defines + -- that the shape is flipped vetically about the center of its bounding box. + , _trOffset :: Maybe Point2D + -- ^ See 20.1.7.4 "off (Offset)" (p. 2847) + , _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, Generic) +instance NFData Transform2D + +-- TODO: custGeom +data Geometry = + PresetGeometry + -- TODO: prst, avList + -- currently uses "rect" with empty avList + deriving (Eq, Show, Generic) +instance NFData Geometry + +-- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751) +data ShapeProperties = ShapeProperties + { _spXfrm :: Maybe Transform2D + , _spGeometry :: Maybe Geometry + , _spFill :: Maybe FillProperties + , _spOutline :: Maybe LineProperties + -- TODO: bwMode, a_EG_EffectProperties, scene3d, sp3d, extLst + } 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 + , _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 (Maybe ColorChoice) + -- ^ Solid fill + -- See 20.1.8.54 "solidFill (Solid Fill)" (p. 2879) + 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 +-------------------------------------------------------------------------------} + +instance Default ShapeProperties where + def = ShapeProperties Nothing Nothing Nothing Nothing + +instance Default LineProperties where + def = LineProperties Nothing 0 + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor TextBody where + fromCursor cur = do + cur' <- cur $/ element (a_ "bodyPr") + _txbdRotation <- fromAttributeDef "rot" (Angle 0) cur' + _txbdSpcFirstLastPara <- fromAttributeDef "spcFirstLastPara" False cur' + _txbdVertOverflow <- fromAttributeDef "vertOverflow" TextVertOverflow cur' + _txbdVertical <- fromAttributeDef "vert" TextVerticalHorz cur' + _txbdWrap <- fromAttributeDef "wrap" TextWrapSquare cur' + _txbdAnchor <- fromAttributeDef "anchor" TextAnchoringTop cur' + _txbdAnchorCenter <- fromAttributeDef "anchorCtr" False cur' + let _txbdParagraphs = cur $/ element (a_ "p") >=> fromCursor + return TextBody {..} + +instance FromCursor TextParagraph where + fromCursor cur = do + let _txpaDefCharProps = + join . listToMaybe $ + cur $/ element (a_ "pPr") >=> maybeFromElement (a_ "defRPr") + _txpaRuns = cur $/ element (a_ "r") >=> fromCursor + return TextParagraph {..} + +instance FromCursor TextCharacterProperties where + fromCursor cur = do + _txchBold <- fromAttributeDef "b" False cur + _txchItalic <- fromAttributeDef "i" False cur + _txchUnderline <- fromAttributeDef "u" False cur + return TextCharacterProperties {..} + +instance FromCursor TextRun where + fromCursor cur = do + _txrCharProps <- maybeFromElement (a_ "rPr") cur + _txrText <- cur $/ element (a_ "t") &/ content + return RegularRun {..} + +-- See 20.1.10.3 "ST_Angle (Angle)" (p. 2912) +instance FromAttrVal Angle where + fromAttrVal t = first Angle <$> fromAttrVal t + +-- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083) +instance FromAttrVal TextVertOverflow where + fromAttrVal "overflow" = readSuccess TextVertOverflow + fromAttrVal "ellipsis" = readSuccess TextVertOverflowEllipsis + fromAttrVal "clip" = readSuccess TextVertOverflowClip + fromAttrVal t = invalidText "TextVertOverflow" t + +instance FromAttrVal TextVertical where + fromAttrVal "horz" = readSuccess TextVerticalHorz + fromAttrVal "vert" = readSuccess TextVertical + fromAttrVal "vert270" = readSuccess TextVertical270 + fromAttrVal "wordArtVert" = readSuccess TextVerticalWordArt + fromAttrVal "eaVert" = readSuccess TextVerticalEA + fromAttrVal "mongolianVert" = readSuccess TextVerticalMongolian + fromAttrVal "wordArtVertRtl" = readSuccess TextVerticalWordArtRtl + fromAttrVal t = invalidText "TextVertical" t + +instance FromAttrVal TextWrap where + fromAttrVal "none" = readSuccess TextWrapNone + fromAttrVal "square" = readSuccess TextWrapSquare + fromAttrVal t = invalidText "TextWrap" t + +-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058) +instance FromAttrVal TextAnchoring where + fromAttrVal "t" = readSuccess TextAnchoringTop + fromAttrVal "ctr" = readSuccess TextAnchoringCenter + fromAttrVal "b" = readSuccess TextAnchoringBottom + fromAttrVal "just" = readSuccess TextAnchoringJustified + fromAttrVal "dist" = readSuccess TextAnchoringDistributed + fromAttrVal t = invalidText "TextAnchoring" t + +instance FromCursor ShapeProperties where + fromCursor cur = do + _spXfrm <- maybeFromElement (a_ "xfrm") cur + let _spGeometry = listToMaybe $ cur $/ anyElement >=> fromCursor + _spFill = listToMaybe $ cur $/ anyElement >=> fillPropsFromNode . node + _spOutline <- maybeFromElement (a_ "ln") cur + return ShapeProperties {..} + +instance FromCursor Transform2D where + fromCursor cur = do + _trRot <- fromAttributeDef "rot" (Angle 0) cur + _trFlipH <- fromAttributeDef "flipH" False cur + _trFlipV <- fromAttributeDef "flipV" False cur + _trOffset <- maybeFromElement (a_ "off") cur + _trExtents <- maybeFromElement (a_ "ext") cur + return Transform2D{..} + +instance FromCursor Geometry where + fromCursor = geometryFromNode . node + +geometryFromNode :: Node -> [Geometry] +geometryFromNode n | n `nodeElNameIs` a_ "prstGeom" = + return PresetGeometry + | otherwise = fail "no matching geometry node" + +instance FromCursor LineProperties where + fromCursor cur = do + let _lnFill = listToMaybe $ cur $/ anyElement >=> fromCursor + _lnWidth <- fromAttributeDef "w" 0 cur + return LineProperties{..} + +instance FromCursor Point2D where + fromCursor cur = do + x <- coordinate =<< fromAttribute "x" cur + y <- coordinate =<< fromAttribute "y" cur + return $ Point2D x y + +instance FromCursor PositiveSize2D where + fromCursor cur = do + cx <- PositiveCoordinate <$> fromAttribute "cx" cur + cy <- PositiveCoordinate <$> fromAttribute "cy" cur + return $ PositiveSize2D cx cy + +instance FromCursor FillProperties where + fromCursor = fillPropsFromNode . node + +fillPropsFromNode :: Node -> [FillProperties] +fillPropsFromNode n + | n `nodeElNameIs` a_ "noFill" = return NoFill + | n `nodeElNameIs` a_ "solidFill" = do + let color = + listToMaybe $ fromNode n $/ anyElement >=> colorChoiceFromNode . node + return $ SolidFill color + | otherwise = fail "no matching line fill node" + +colorChoiceFromNode :: Node -> [ColorChoice] +colorChoiceFromNode n + | n `nodeElNameIs` a_ "srgbClr" = do + val <- fromAttribute "val" $ fromNode n + return $ RgbColor val + | otherwise = fail "no matching color choice node" + +coordinate :: MonadFail m => Text -> m Coordinate +coordinate t = case T.decimal t of + Right (d, leftover) | leftover == T.empty -> + return $ UnqCoordinate d + _ -> + case T.rational t of + Right (r, "cm") -> return $ UniversalMeasure UnitCm r + Right (r, "mm") -> return $ UniversalMeasure UnitMm r + Right (r, "in") -> return $ UniversalMeasure UnitIn r + Right (r, "pt") -> return $ UniversalMeasure UnitPt r + Right (r, "pc") -> return $ UniversalMeasure UnitPc r + Right (r, "pi") -> return $ UniversalMeasure UnitPi r + _ -> fail $ "invalid coordinate: " ++ show t + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement TextBody where + toElement nm TextBody {..} = elementListSimple nm (bodyPr : paragraphs) + where + bodyPr = leafElement (a_ "bodyPr") bodyPrAttrs + bodyPrAttrs = + catMaybes + [ "rot" .=? justNonDef (Angle 0) _txbdRotation + , "spcFirstLastPara" .=? justTrue _txbdSpcFirstLastPara + , "vertOverflow" .=? justNonDef TextVertOverflow _txbdVertOverflow + , "vert" .=? justNonDef TextVerticalHorz _txbdVertical + , "wrap" .=? justNonDef TextWrapSquare _txbdWrap + , "anchor" .=? justNonDef TextAnchoringTop _txbdAnchor + , "anchorCtr" .=? justTrue _txbdAnchorCenter + ] + paragraphs = map (toElement (a_ "p")) _txbdParagraphs + +instance ToElement TextParagraph where + toElement nm TextParagraph {..} = elementListSimple nm elements + where + elements = + case _txpaDefCharProps of + Just props -> (defRPr props) : runs + Nothing -> runs + defRPr props = + elementListSimple (a_ "pPr") [toElement (a_ "defRPr") props] + runs = map (toElement (a_ "r")) _txpaRuns + +instance ToElement TextCharacterProperties where + toElement nm TextCharacterProperties {..} = leafElement nm attrs + where + attrs = ["b" .= _txchBold, "i" .= _txchItalic, "u" .= _txchUnderline] + +instance ToElement TextRun where + toElement nm RegularRun {..} = elementListSimple nm elements + where + elements = + catMaybes + [ toElement (a_ "rPr") <$> _txrCharProps + , Just $ elementContent (a_ "t") _txrText + ] + +instance ToAttrVal TextVertOverflow where + toAttrVal TextVertOverflow = "overflow" + toAttrVal TextVertOverflowEllipsis = "ellipsis" + toAttrVal TextVertOverflowClip = "clip" + +instance ToAttrVal TextVertical where + toAttrVal TextVerticalHorz = "horz" + toAttrVal TextVertical = "vert" + toAttrVal TextVertical270 = "vert270" + toAttrVal TextVerticalWordArt = "wordArtVert" + toAttrVal TextVerticalEA = "eaVert" + toAttrVal TextVerticalMongolian = "mongolianVert" + toAttrVal TextVerticalWordArtRtl = "wordArtVertRtl" + +instance ToAttrVal TextWrap where + toAttrVal TextWrapNone = "none" + toAttrVal TextWrapSquare = "square" + +-- See 20.1.10.59 "ST_TextAnchoringType (Text Anchoring Types)" (p. 3058) +instance ToAttrVal TextAnchoring where + toAttrVal TextAnchoringTop = "t" + toAttrVal TextAnchoringCenter = "ctr" + toAttrVal TextAnchoringBottom = "b" + toAttrVal TextAnchoringJustified = "just" + toAttrVal TextAnchoringDistributed = "dist" + +instance ToAttrVal Angle where + toAttrVal (Angle x) = toAttrVal x + +instance ToElement ShapeProperties where + toElement nm ShapeProperties{..} = elementListSimple nm elements + where + elements = catMaybes [ toElement (a_ "xfrm") <$> _spXfrm + , geometryToElement <$> _spGeometry + , fillPropsToElement <$> _spFill + , toElement (a_ "ln") <$> _spOutline ] + +instance ToElement Point2D where + toElement nm Point2D{..} = leafElement nm [ "x" .= _pt2dX + , "y" .= _pt2dY + ] + +instance ToElement PositiveSize2D where + toElement nm PositiveSize2D{..} = leafElement nm [ "cx" .= _ps2dX + , "cy" .= _ps2dY ] + +instance ToAttrVal Coordinate where + toAttrVal (UnqCoordinate x) = toAttrVal x + toAttrVal (UniversalMeasure unit x) = toAttrVal x <> unitToText unit + where + unitToText UnitCm = "cm" + unitToText UnitMm = "mm" + unitToText UnitIn = "in" + unitToText UnitPt = "pt" + unitToText UnitPc = "pc" + unitToText UnitPi = "pi" + +instance ToAttrVal PositiveCoordinate where + toAttrVal (PositiveCoordinate x) = toAttrVal x + +instance ToElement Transform2D where + toElement nm Transform2D{..} = elementList nm attrs elements + where + attrs = catMaybes [ "rot" .=? justNonDef (Angle 0) _trRot + , "flipH" .=? justTrue _trFlipH + , "flipV" .=? justTrue _trFlipV ] + elements = catMaybes [ toElement (a_ "off") <$> _trOffset + , toElement (a_ "ext") <$> _trExtents ] + +geometryToElement :: Geometry -> Element +geometryToElement PresetGeometry = + leafElement (a_ "prstGeom") ["prst" .= ("rect" :: Text)] + +instance ToElement LineProperties where + 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 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 +a_ x = + Name {nameLocalName = x, nameNamespace = Just drawingNs, namePrefix = Just "a"} + +drawingNs :: Text +drawingNs = "http://schemas.openxmlformats.org/drawingml/2006/main" diff --git a/src/Codec/Xlsx/Types/Internal.hs b/src/Codec/Xlsx/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal.hs @@ -0,0 +1,3 @@ +module Codec.Xlsx.Types.Internal (module Codec.Xlsx.Types.RefId) where + +import Codec.Xlsx.Types.RefId diff --git a/src/Codec/Xlsx/Types/Internal/CfPair.hs b/src/Codec/Xlsx/Types/Internal/CfPair.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/CfPair.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Internal.CfPair where + +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 +-- Implementing those will need this implementation to be changed +-- +-- See 18.3.1.18 "conditionalFormatting (Conditional Formatting)" (p. 1610) +newtype CfPair = CfPair + { unCfPair :: (SqRef, ConditionalFormatting) + } deriving (Eq, Show, Generic) + +instance FromCursor CfPair where + fromCursor cur = do + sqref <- fromAttribute "sqref" cur + 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)) = + elementList nm [ "sqref" .= toAttrVal sqRef ] + (map (toElement "cfRule") cfRules) diff --git a/src/Codec/Xlsx/Types/Internal/CommentTable.hs b/src/Codec/Xlsx/Types/Internal/CommentTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/CommentTable.hs @@ -0,0 +1,128 @@ +{-# 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 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 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 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 + +newtype CommentTable = CommentTable + { _commentsTable :: Map CellRef Comment } + 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 + +instance ToDocument CommentTable where + toDocument = documentFromElement "Sheet comments generated by xlsx" + . toElement "comments" + +instance ToElement CommentTable where + toElement nm (CommentTable m) = Element + { elementName = nm + , elementAttributes = M.empty + , elementNodes = [ NodeElement $ elementListSimple "authors" authorNodes + , NodeElement . elementListSimple "commentList" $ map commentToEl (M.toList m) ] + } + where + commentToEl (ref, Comment{..}) = Element + { elementName = "comment" + , elementAttributes = M.fromList [ ("ref" .= ref) + , ("authorId" .= lookupAuthor _commentAuthor) + , ("visible" .= tshow _commentVisible)] + , elementNodes = [NodeElement $ toElement "text" _commentText] + } + lookupAuthor a = fromJustNote "author lookup" $ M.lookup a authorIds + authorNames = nubOrd . map _commentAuthor $ M.elems m + decimalToText :: Integer -> Text + decimalToText = toStrict . B.toLazyText . B.decimal + authorIds = M.fromList $ zip authorNames (map decimalToText [0..]) + authorNodes = map (elementContent "author") authorNames + +instance FromCursor CommentTable where + fromCursor cur = do + let authorNames = cur $/ element (addSmlNamespace "authors") &/ element (addSmlNamespace "author") >=> contentOrEmpty + authors = M.fromList $ zip [0..] authorNames + 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 (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 visible) + +-- | helper to render comment baloons vml file, +-- currently uses fixed shape +renderShapes :: CommentTable -> ByteString +renderShapes (CommentTable m) = LB.concat + [ "" + , commentShapeType + , LB.concat commentShapes + , "" + ] + where + commentShapeType = LB.concat + [ "" + , "" + , "" + , "" + ] + 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 + [ "" + , "" + , "" + , "
" + , "" + , "" + , "4, 15, 0, 7, 6, 31, 5, 1False" + , "" + , LBC8.pack $ show (r - 1) + , "" + , "" + , LBC8.pack $ show (c - 1) + , "" + , "" + , "" + ] diff --git a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs @@ -0,0 +1,74 @@ +{-# 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 GHC.Generics (Generic) +import System.FilePath.Posix (takeExtension) +import Text.XML +import Text.XML.Cursor + +import Codec.Xlsx.Parser.Internal + +data CtDefault = CtDefault + { dfltExtension :: FilePath + , dfltContentType :: Text + } deriving (Eq, Show, Generic) + +data Override = Override + { ovrPartName :: FilePath + , ovrContentType :: Text + } deriving (Eq, Show, Generic) + +data ContentTypes = ContentTypes + { ctDefaults :: Map FilePath Text + , ctTypes :: Map FilePath Text + } deriving (Eq, Show, Generic) + +lookup :: FilePath -> ContentTypes -> Maybe Text +lookup path ContentTypes{..} = + asum [ flip M.lookup ctDefaults =<< ext, M.lookup path ctTypes ] + where + ext = case takeExtension path of + '.':e -> Just e + _ -> Nothing + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} +instance FromCursor ContentTypes where + fromCursor cur = do + let ds = M.fromList . map (dfltExtension &&& dfltContentType) $ + cur $/ element (ct"Default") >=> fromCursor + ts = M.fromList . map (ovrPartName &&& ovrContentType) $ + cur $/ element (ct"Override") >=> fromCursor + return (ContentTypes ds ts) + +instance FromCursor CtDefault where + fromCursor cur = do + dfltExtension <- T.unpack <$> attribute "Extension" cur + dfltContentType <- attribute "ContentType" cur + return CtDefault{..} + +instance FromCursor Override where + fromCursor cur = do + ovrPartName <- T.unpack <$> attribute "PartName" cur + ovrContentType <- attribute "ContentType" cur + return Override{..} + +-- | Add package relationship namespace to name +ct :: Text -> Name +ct x = Name + { nameLocalName = x + , nameNamespace = Just contentTypesNs + , namePrefix = Nothing + } + +contentTypesNs :: Text +contentTypesNs = "http://schemas.openxmlformats.org/package/2006/content-types" diff --git a/src/Codec/Xlsx/Types/Internal/CustomProperties.hs b/src/Codec/Xlsx/Types/Internal/CustomProperties.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/CustomProperties.hs @@ -0,0 +1,82 @@ +{-# 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 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 + +newtype CustomProperties = CustomProperties (Map Text Variant) + deriving (Eq, Show, Generic) + +fromList :: [(Text, Variant)] -> CustomProperties +fromList = CustomProperties . M.fromList + +empty :: CustomProperties +empty = CustomProperties M.empty + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor CustomProperties where + fromCursor cur = do + let items = cur $/ element (cpr"property") >=> parseCustomPropertyEntry + return (fromList items) + +parseCustomPropertyEntry :: Cursor -> [(Text, Variant)] +parseCustomPropertyEntry cur = do + name <- attribute "name" cur + value <- cur $/ anyElement >=> fromCursor + return (name, value) + +-- | Add custom properties namespace to name +cpr :: Text -> Name +cpr x = Name + { nameLocalName = x + , nameNamespace = Just custPropNs + , namePrefix = Nothing + } + +custPropNs :: Text +custPropNs = "http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToDocument CustomProperties where + toDocument = + documentFromNsElement "Custom properties generated by xlsx" + "http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" + . toElement "Properties" + +instance ToElement CustomProperties where + toElement nm (CustomProperties m) = Element + { elementName = nm + , elementAttributes = M.empty + , elementNodes = map (NodeElement . toElement "property" . CustomProperty) + . zip [2..] $ M.toList m + } + +newtype CustomProperty = CustomProperty (Int, (Text, Variant)) + +instance ToElement CustomProperty where + toElement nm (CustomProperty (i, (key, val))) = Element + { elementName = nm + , elementAttributes = M.fromList [ "name" .= key + , "fmtid" .= userDefinedFmtID + , "pid" .= txti i ] + , elementNodes = [ NodeElement $ variantToElement val ] + } + +-- | FMTID_UserDefinedProperties +userDefinedFmtID :: Text +userDefinedFmtID = "{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" diff --git a/src/Codec/Xlsx/Types/Internal/DvPair.hs b/src/Codec/Xlsx/Types/Internal/DvPair.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/DvPair.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Internal.DvPair where + +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, 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 + {elementAttributes = M.insert "sqref" (toAttrVal sqRef) $ elementAttributes e} + where + e = toElement nm dv 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/Relationships.hs b/src/Codec/Xlsx/Types/Internal/Relationships.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/Relationships.hs @@ -0,0 +1,146 @@ +{-# 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 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 + +data Relationship = Relationship + { relType :: Text + , relTarget :: FilePath + } deriving (Eq, Show, Generic) + +-- | Describes relationships according to Open Packaging Convention +-- +-- See ECMA-376, 4th Edition Office Open XML File Formats — Open Packaging +-- Conventions +newtype Relationships = Relationships + { relMap :: Map RefId Relationship + } deriving (Eq, Show, Generic) + +fromList :: [(RefId, Relationship)] -> Relationships +fromList = Relationships . Map.fromList + +empty :: Relationships +empty = fromList [] + +size :: Relationships -> Int +size = Map.size . relMap + +relEntry :: RefId -> Text -> FilePath -> (RefId, Relationship) +relEntry rId typ trg = (rId, Relationship (stdRelType typ) trg) + +lookup :: RefId -> Relationships -> Maybe Relationship +lookup ref = Map.lookup ref . relMap + +setTargetsFrom :: FilePath -> Relationships -> Relationships +setTargetsFrom fp (Relationships m) = Relationships (Map.map fixPath m) + where + fixPath rel = rel{ relTarget = fp `joinRel` relTarget rel} + +-- | joins relative URI (actually a file path as an internal relation target) +joinRel :: FilePath -> FilePath -> FilePath +joinRel abs rel = uriToString id (relPath `nonStrictRelativeTo` base) "" + where + base = fromJustNote "joinRel base path" $ parseURIReference abs + relPath = fromJustNote "joinRel relative path" $ parseURIReference rel + +relFrom :: FilePath -> FilePath -> FilePath +relFrom path base = uriToString id (pathURI `relativeFrom` baseURI) "" + where + baseURI = fromJustNote "joinRel base path" $ parseURIReference base + pathURI = fromJustNote "joinRel relative path" $ parseURIReference path + +findRelByType :: Text -> Relationships -> Maybe Relationship +findRelByType t (Relationships m) = find ((==t) . relType) (Map.elems m) + +allByType :: Text -> Relationships -> [Relationship] +allByType t (Relationships m) = filter ((==t) . relType) (Map.elems m) + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToDocument Relationships where + toDocument = documentFromNsElement "Relationships generated by xlsx" pkgRelNs + . toElement "Relationships" + +instance ToElement Relationships where + toElement nm Relationships{..} = Element + { elementName = nm + , elementAttributes = Map.empty + , elementNodes = map (NodeElement . relToEl "Relationship") $ + Map.toList relMap + } + where + relToEl nm' (relId, rel) = setAttr "Id" relId (toElement nm' rel) + +instance ToElement Relationship where + toElement nm Relationship{..} = Element + { elementName = nm + , elementAttributes = Map.fromList [ "Target" .= relTarget + , "Type" .= relType ] + , elementNodes = [] + } + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} +instance FromCursor Relationships where + fromCursor cur = do + let items = cur $/ element (pr"Relationship") >=> parseRelEntry + return . Relationships $ Map.fromList items + +parseRelEntry :: Cursor -> [(RefId, Relationship)] +parseRelEntry cur = do + rel <- fromCursor cur + rId <- attribute "Id" cur + return (RefId rId, rel) + +instance FromCursor Relationship where + fromCursor cur = do + ty <- attribute "Type" cur + trg <- T.unpack <$> attribute "Target" cur + return $ Relationship ty trg + +-- | Add package relationship namespace to name +pr :: Text -> Name +pr x = Name + { nameLocalName = x + , nameNamespace = Just pkgRelNs + , namePrefix = Nothing + } + +-- | Add office document relationship namespace to name +odr :: Text -> Name +odr x = Name + { nameLocalName = x + , nameNamespace = Just odRelNs + , namePrefix = Nothing + } + +odRelNs :: Text +odRelNs = "http://schemas.openxmlformats.org/officeDocument/2006/relationships" + +pkgRelNs :: Text +pkgRelNs = "http://schemas.openxmlformats.org/package/2006/relationships" + +stdRelType :: Text -> Text +stdRelType t = stdPart <> t + where + stdPart = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/" diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Internal.SharedStringTable ( + -- * Main types + SharedStringTable(..) + , sstConstruct + , sstLookupText + , sstLookupRich + , sstItem + , 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 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 + +-- | Shared string table +-- +-- A workbook can contain thousands of cells containing string (non-numeric) +-- data. Furthermore this data is very likely to be repeated across many rows or +-- columns. The goal of implementing a single string table that is shared across +-- the workbook is to improve performance in opening and saving the file by only +-- 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): +-- +-- * Section 18.4, "Shared String Table" (p. 1712) +-- in particular subsection 18.4.9, "sst (Shared String Table)" (p. 1726) +-- +-- TODO: The @extLst@ child element is currently unsupported. +newtype SharedStringTable = SharedStringTable { + sstTable :: Vector XlsxText + } + deriving (Eq, Ord, Show, Generic) + +sstEmpty :: SharedStringTable +sstEmpty = SharedStringTable V.empty + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToDocument SharedStringTable where + toDocument = documentFromElement "Shared string table generated by xlsx" + . toElement "sst" + +-- | See @CT_Sst@, p. 3902. +-- +-- TODO: The @count@ and @uniqCount@ attributes are currently unsupported. +instance ToElement SharedStringTable where + toElement nm SharedStringTable{..} = Element { + elementName = nm + , elementAttributes = Map.empty + , elementNodes = map (NodeElement . toElement "si") + $ V.toList sstTable + } + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +-- | See @CT_Sst@, p. 3902 +-- +-- The optional attributes @count@ and @uniqCount@ are being ignored at least currently +instance FromCursor SharedStringTable where + fromCursor cur = do + let + items = cur $/ element (addSmlNamespace "si") >=> fromCursor + return (SharedStringTable (V.fromList items)) + +{------------------------------------------------------------------------------- + Extract shared strings +-------------------------------------------------------------------------------} + +-- | Construct the 'SharedStringsTable' from an existing document +sstConstruct :: [Worksheet] -> SharedStringTable +sstConstruct = + SharedStringTable . V.fromList . uniq . concatMap goSheet + where + goSheet :: Worksheet -> [XlsxText] + goSheet = mapMaybe (_cellValue >=> sstEntry) . Map.elems . _wsCells + + sstEntry :: CellValue -> Maybe XlsxText + sstEntry (CellText text) = Just $ XlsxText text + sstEntry (CellRich rich) = Just $ XlsxRichText rich + sstEntry _ = Nothing + + uniq :: Ord a => [a] -> [a] + uniq = Set.elems . Set.fromList + +sstLookupText :: SharedStringTable -> Text -> Int +sstLookupText sst = sstLookup sst . XlsxText + +sstLookupRich :: SharedStringTable -> [RichTextRun] -> Int +sstLookupRich sst = sstLookup sst . XlsxRichText + +-- | Internal generalization used by 'sstLookupText' and 'sstLookupRich' +sstLookup :: SharedStringTable -> XlsxText -> Int +sstLookup SharedStringTable{sstTable = shared} si = + fromJustNote ("SST entry for " ++ show si ++ " not found") $ + searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1) + +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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/PageSetup.hs @@ -0,0 +1,670 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.PageSetup ( + -- * Main types + PageSetup(..) + -- * Enumerations + , CellComments(..) + , PrintErrors(..) + , Orientation(..) + , PageOrder(..) + , PaperSize(..) + -- * Lenses + -- ** PageSetup + , pageSetupBlackAndWhite + , pageSetupCellComments + , pageSetupCopies + , pageSetupDraft + , pageSetupErrors + , pageSetupFirstPageNumber + , pageSetupFitToHeight + , pageSetupFitToWidth + , pageSetupHorizontalDpi + , pageSetupId + , pageSetupOrientation + , pageSetupPageOrder + , pageSetupPaperHeight + , pageSetupPaperSize + , pageSetupPaperWidth + , pageSetupScale + , pageSetupUseFirstPageNumber + , pageSetupUsePrinterDefaults + , pageSetupVerticalDpi + ) where + +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 Codec.Xlsx.Writer.Internal +import Codec.Xlsx.Parser.Internal + +{------------------------------------------------------------------------------- + Main types +-------------------------------------------------------------------------------} + +data PageSetup = PageSetup { + -- | Print black and white. + _pageSetupBlackAndWhite :: Maybe Bool + + -- | This attribute specifies how to print cell comments. + , _pageSetupCellComments :: Maybe CellComments + + -- | Number of copies to print. + , _pageSetupCopies :: Maybe Int + + -- | Print without graphics. + , _pageSetupDraft :: Maybe Bool + + -- | Specifies how to print cell values for cells with errors. + , _pageSetupErrors :: Maybe PrintErrors + + -- | Page number for first printed page. If no value is specified, then + -- 'automatic' is assumed. + , _pageSetupFirstPageNumber :: Maybe Int + + -- | Number of vertical pages to fit on. + , _pageSetupFitToHeight :: Maybe Int + + -- | Number of horizontal pages to fit on. + , _pageSetupFitToWidth :: Maybe Int + + -- | Horizontal print resolution of the device. + , _pageSetupHorizontalDpi :: Maybe Int + + -- | Relationship Id of the devMode printer settings part. + -- + -- (Explicit reference to a parent XML element.) + -- + -- See 22.8.2.1 "ST_RelationshipId (Explicit Relationship ID)" (p. 3784) + , _pageSetupId :: Maybe Text + + -- | Orientation of the page. + , _pageSetupOrientation :: Maybe Orientation + + -- | Order of printed pages + , _pageSetupPageOrder :: Maybe PageOrder + + -- | Height of custom paper as a number followed by a unit identifier. + -- + -- When paperHeight and paperWidth are specified, paperSize shall be ignored. + -- Examples: @"297mm"@, @"11in"@. + -- + -- See 22.9.2.12 "ST_PositiveUniversalMeasure (Positive Universal Measurement)" (p. 3792) + , _pageSetupPaperHeight :: Maybe Text + + -- | Pager size + -- + -- When paperHeight, paperWidth, and paperUnits are specified, paperSize + -- should be ignored. + , _pageSetupPaperSize :: Maybe PaperSize + + -- | Width of custom paper as a number followed by a unit identifier + -- + -- Examples: @21cm@, @8.5in@ + -- + -- When paperHeight and paperWidth are specified, paperSize shall be + -- ignored. + , _pageSetupPaperWidth :: Maybe Text + + -- | Print scaling. + -- + -- This attribute is restricted to values ranging from 10 to 400. + -- This setting is overridden when fitToWidth and/or fitToHeight are in + -- use. + , _pageSetupScale :: Maybe Int + + -- | Use '_pageSetupFirstPageNumber' value for first page number, and do + -- not auto number the pages. + , _pageSetupUseFirstPageNumber :: Maybe Bool + + -- | Use the printer’s defaults settings for page setup values and don't + -- use the default values specified in the schema. + -- + -- Example: If dpi is not present or specified in the XML, the application + -- must not assume 600dpi as specified in the schema as a default and + -- instead must let the printer specify the default dpi. + , _pageSetupUsePrinterDefaults :: Maybe Bool + + -- | Vertical print resolution of the device. + , _pageSetupVerticalDpi :: Maybe Int + } + deriving (Eq, Ord, Show, Generic) +instance NFData PageSetup + +{------------------------------------------------------------------------------- + Enumerations +-------------------------------------------------------------------------------} + +-- | Cell comments +-- +-- These enumerations specify how cell comments shall be displayed for paper +-- printing purposes. +-- +-- See 18.18.5 "ST_CellComments (Cell Comments)" (p. 2441). +data CellComments = + -- | Print cell comments as displayed + CellCommentsAsDisplayed + + -- | Print cell comments at end of document + | CellCommentsAtEnd + + -- | Do not print cell comments + | CellCommentsNone + deriving (Eq, Ord, Show, Generic) +instance NFData CellComments + +-- | Print errors +-- +-- This enumeration specifies how to display cells with errors when printing the +-- worksheet. +data PrintErrors = + -- | Display cell errors as blank + PrintErrorsBlank + + -- | Display cell errors as dashes + | PrintErrorsDash + + -- | Display cell errors as displayed on screen + | PrintErrorsDisplayed + + -- | Display cell errors as @#N/A@ + | PrintErrorsNA + deriving (Eq, Ord, Show, Generic) +instance NFData PrintErrors + +-- | Print orientation for this sheet +data Orientation = + OrientationDefault + | OrientationLandscape + | OrientationPortrait + deriving (Eq, Ord, Show, Generic) +instance NFData Orientation + +-- | Specifies printed page order +data PageOrder = + -- | Order pages vertically first, then move horizontally + PageOrderDownThenOver + + -- | Order pages horizontally first, then move vertically + | PageOrderOverThenDown + deriving (Eq, Ord, Show, Generic) +instance NFData PageOrder + +-- | Paper size +data PaperSize = + PaperA2 -- ^ A2 paper (420 mm by 594 mm) + | PaperA3 -- ^ A3 paper (297 mm by 420 mm) + | PaperA3Extra -- ^ A3 extra paper (322 mm by 445 mm) + | PaperA3ExtraTransverse -- ^ A3 extra transverse paper (322 mm by 445 mm) + | PaperA3Transverse -- ^ A3 transverse paper (297 mm by 420 mm) + | PaperA4 -- ^ A4 paper (210 mm by 297 mm) + | PaperA4Extra -- ^ A4 extra paper (236 mm by 322 mm) + | PaperA4Plus -- ^ A4 plus paper (210 mm by 330 mm) + | PaperA4Small -- ^ A4 small paper (210 mm by 297 mm) + | PaperA4Transverse -- ^ A4 transverse paper (210 mm by 297 mm) + | PaperA5 -- ^ A5 paper (148 mm by 210 mm) + | PaperA5Extra -- ^ A5 extra paper (174 mm by 235 mm) + | PaperA5Transverse -- ^ A5 transverse paper (148 mm by 210 mm) + | PaperB4 -- ^ B4 paper (250 mm by 353 mm) + | PaperB5 -- ^ B5 paper (176 mm by 250 mm) + | PaperC -- ^ C paper (17 in. by 22 in.) + | PaperD -- ^ D paper (22 in. by 34 in.) + | PaperE -- ^ E paper (34 in. by 44 in.) + | PaperExecutive -- ^ Executive paper (7.25 in. by 10.5 in.) + | PaperFanfoldGermanLegal -- ^ German legal fanfold (8.5 in. by 13 in.) + | PaperFanfoldGermanStandard -- ^ German standard fanfold (8.5 in. by 12 in.) + | PaperFanfoldUsStandard -- ^ US standard fanfold (14.875 in. by 11 in.) + | PaperFolio -- ^ Folio paper (8.5 in. by 13 in.) + | PaperIsoB4 -- ^ ISO B4 (250 mm by 353 mm) + | PaperIsoB5Extra -- ^ ISO B5 extra paper (201 mm by 276 mm) + | PaperJapaneseDoublePostcard -- ^ Japanese double postcard (200 mm by 148 mm) + | PaperJisB5Transverse -- ^ JIS B5 transverse paper (182 mm by 257 mm) + | PaperLedger -- ^ Ledger paper (17 in. by 11 in.) + | PaperLegal -- ^ Legal paper (8.5 in. by 14 in.) + | PaperLegalExtra -- ^ Legal extra paper (9.275 in. by 15 in.) + | PaperLetter -- ^ Letter paper (8.5 in. by 11 in.) + | PaperLetterExtra -- ^ Letter extra paper (9.275 in. by 12 in.) + | PaperLetterExtraTransverse -- ^ Letter extra transverse paper (9.275 in. by 12 in.) + | PaperLetterPlus -- ^ Letter plus paper (8.5 in. by 12.69 in.) + | PaperLetterSmall -- ^ Letter small paper (8.5 in. by 11 in.) + | PaperLetterTransverse -- ^ Letter transverse paper (8.275 in. by 11 in.) + | PaperNote -- ^ Note paper (8.5 in. by 11 in.) + | PaperQuarto -- ^ Quarto paper (215 mm by 275 mm) + | PaperStandard9_11 -- ^ Standard paper (9 in. by 11 in.) + | PaperStandard10_11 -- ^ Standard paper (10 in. by 11 in.) + | PaperStandard10_14 -- ^ Standard paper (10 in. by 14 in.) + | PaperStandard11_17 -- ^ Standard paper (11 in. by 17 in.) + | PaperStandard15_11 -- ^ Standard paper (15 in. by 11 in.) + | PaperStatement -- ^ Statement paper (5.5 in. by 8.5 in.) + | PaperSuperA -- ^ SuperA/SuperA/A4 paper (227 mm by 356 mm) + | PaperSuperB -- ^ SuperB/SuperB/A3 paper (305 mm by 487 mm) + | PaperTabloid -- ^ Tabloid paper (11 in. by 17 in.) + | PaperTabloidExtra -- ^ Tabloid extra paper (11.69 in. by 18 in.) + | Envelope6_3_4 -- ^ 6 3/4 envelope (3.625 in. by 6.5 in.) + | Envelope9 -- ^ #9 envelope (3.875 in. by 8.875 in.) + | Envelope10 -- ^ #10 envelope (4.125 in. by 9.5 in.) + | Envelope11 -- ^ #11 envelope (4.5 in. by 10.375 in.) + | Envelope12 -- ^ #12 envelope (4.75 in. by 11 in.) + | Envelope14 -- ^ #14 envelope (5 in. by 11.5 in.) + | EnvelopeB4 -- ^ B4 envelope (250 mm by 353 mm) + | EnvelopeB5 -- ^ B5 envelope (176 mm by 250 mm) + | EnvelopeB6 -- ^ B6 envelope (176 mm by 125 mm) + | EnvelopeC3 -- ^ C3 envelope (324 mm by 458 mm) + | EnvelopeC4 -- ^ C4 envelope (229 mm by 324 mm) + | EnvelopeC5 -- ^ C5 envelope (162 mm by 229 mm) + | EnvelopeC6 -- ^ C6 envelope (114 mm by 162 mm) + | EnvelopeC65 -- ^ C65 envelope (114 mm by 229 mm) + | EnvelopeDL -- ^ DL envelope (110 mm by 220 mm) + | 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 (Eq, Ord, Show, Generic) +instance NFData PaperSize + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default PageSetup where + def = PageSetup { + _pageSetupBlackAndWhite = Nothing + , _pageSetupCellComments = Nothing + , _pageSetupCopies = Nothing + , _pageSetupDraft = Nothing + , _pageSetupErrors = Nothing + , _pageSetupFirstPageNumber = Nothing + , _pageSetupFitToHeight = Nothing + , _pageSetupFitToWidth = Nothing + , _pageSetupHorizontalDpi = Nothing + , _pageSetupId = Nothing + , _pageSetupOrientation = Nothing + , _pageSetupPageOrder = Nothing + , _pageSetupPaperHeight = Nothing + , _pageSetupPaperSize = Nothing + , _pageSetupPaperWidth = Nothing + , _pageSetupScale = Nothing + , _pageSetupUseFirstPageNumber = Nothing + , _pageSetupUsePrinterDefaults = Nothing + , _pageSetupVerticalDpi = Nothing + } + +{------------------------------------------------------------------------------- + Lenses +-------------------------------------------------------------------------------} + +makeLenses ''PageSetup + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +-- | See @CT_PageSetup@, p. 3922 +instance ToElement PageSetup where + toElement nm PageSetup{..} = Element { + elementName = nm + , elementNodes = [] + , elementAttributes = Map.fromList . catMaybes $ [ + "paperSize" .=? _pageSetupPaperSize + , "paperHeight" .=? _pageSetupPaperHeight + , "paperWidth" .=? _pageSetupPaperWidth + , "scale" .=? _pageSetupScale + , "firstPageNumber" .=? _pageSetupFirstPageNumber + , "fitToWidth" .=? _pageSetupFitToWidth + , "fitToHeight" .=? _pageSetupFitToHeight + , "pageOrder" .=? _pageSetupPageOrder + , "orientation" .=? _pageSetupOrientation + , "usePrinterDefaults" .=? _pageSetupUsePrinterDefaults + , "blackAndWhite" .=? _pageSetupBlackAndWhite + , "draft" .=? _pageSetupDraft + , "cellComments" .=? _pageSetupCellComments + , "useFirstPageNumber" .=? _pageSetupUseFirstPageNumber + , "errors" .=? _pageSetupErrors + , "horizontalDpi" .=? _pageSetupHorizontalDpi + , "verticalDpi" .=? _pageSetupVerticalDpi + , "copies" .=? _pageSetupCopies + , "id" .=? _pageSetupId + ] + } + +-- | See @ST_CellComments@, p. 3923 +instance ToAttrVal CellComments where + toAttrVal CellCommentsNone = "none" + toAttrVal CellCommentsAsDisplayed = "asDisplayed" + toAttrVal CellCommentsAtEnd = "atEnd" + +-- | See @ST_PrintError@, p. 3923 +instance ToAttrVal PrintErrors where + toAttrVal PrintErrorsDisplayed = "displayed" + toAttrVal PrintErrorsBlank = "blank" + toAttrVal PrintErrorsDash = "dash" + toAttrVal PrintErrorsNA = "NA" + +-- | See @ST_Orientation@, p. 3923 +instance ToAttrVal Orientation where + toAttrVal OrientationDefault = "default" + toAttrVal OrientationPortrait = "portrait" + toAttrVal OrientationLandscape = "landscape" + +-- | See @ST_PageOrder@, p. 3923 +instance ToAttrVal PageOrder where + toAttrVal PageOrderDownThenOver = "downThenOver" + toAttrVal PageOrderOverThenDown = "overThenDown" + +-- | See @paperSize@ (attribute of @pageSetup@), p. 1659 +instance ToAttrVal PaperSize where + toAttrVal PaperLetter = "1" + toAttrVal PaperLetterSmall = "2" + toAttrVal PaperTabloid = "3" + toAttrVal PaperLedger = "4" + toAttrVal PaperLegal = "5" + toAttrVal PaperStatement = "6" + toAttrVal PaperExecutive = "7" + toAttrVal PaperA3 = "8" + toAttrVal PaperA4 = "9" + toAttrVal PaperA4Small = "10" + toAttrVal PaperA5 = "11" + toAttrVal PaperB4 = "12" + toAttrVal PaperB5 = "13" + toAttrVal PaperFolio = "14" + toAttrVal PaperQuarto = "15" + toAttrVal PaperStandard10_14 = "16" + toAttrVal PaperStandard11_17 = "17" + toAttrVal PaperNote = "18" + toAttrVal Envelope9 = "19" + toAttrVal Envelope10 = "20" + toAttrVal Envelope11 = "21" + toAttrVal Envelope12 = "22" + toAttrVal Envelope14 = "23" + toAttrVal PaperC = "24" + toAttrVal PaperD = "25" + toAttrVal PaperE = "26" + toAttrVal EnvelopeDL = "27" + toAttrVal EnvelopeC5 = "28" + toAttrVal EnvelopeC3 = "29" + toAttrVal EnvelopeC4 = "30" + toAttrVal EnvelopeC6 = "31" + toAttrVal EnvelopeC65 = "32" + toAttrVal EnvelopeB4 = "33" + toAttrVal EnvelopeB5 = "34" + toAttrVal EnvelopeB6 = "35" + toAttrVal EnvelopeItaly = "36" + toAttrVal EnvelopeMonarch = "37" + toAttrVal Envelope6_3_4 = "38" + toAttrVal PaperFanfoldUsStandard = "39" + toAttrVal PaperFanfoldGermanStandard = "40" + toAttrVal PaperFanfoldGermanLegal = "41" + toAttrVal PaperIsoB4 = "42" + toAttrVal PaperJapaneseDoublePostcard = "43" + toAttrVal PaperStandard9_11 = "44" + toAttrVal PaperStandard10_11 = "45" + toAttrVal PaperStandard15_11 = "46" + toAttrVal EnvelopeInvite = "47" + toAttrVal PaperLetterExtra = "50" + toAttrVal PaperLegalExtra = "51" + toAttrVal PaperTabloidExtra = "52" + toAttrVal PaperA4Extra = "53" + toAttrVal PaperLetterTransverse = "54" + toAttrVal PaperA4Transverse = "55" + toAttrVal PaperLetterExtraTransverse = "56" + toAttrVal PaperSuperA = "57" + toAttrVal PaperSuperB = "58" + toAttrVal PaperLetterPlus = "59" + toAttrVal PaperA4Plus = "60" + toAttrVal PaperA5Transverse = "61" + toAttrVal PaperJisB5Transverse = "62" + toAttrVal PaperA3Extra = "63" + toAttrVal PaperA5Extra = "64" + toAttrVal PaperIsoB5Extra = "65" + toAttrVal PaperA2 = "66" + toAttrVal PaperA3Transverse = "67" + toAttrVal PaperA3ExtraTransverse = "68" + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} +-- | See @CT_PageSetup@, p. 3922 +instance FromCursor PageSetup where + fromCursor cur = do + _pageSetupPaperSize <- maybeAttribute "paperSize" cur + _pageSetupPaperHeight <- maybeAttribute "paperHeight" cur + _pageSetupPaperWidth <- maybeAttribute "paperWidth" cur + _pageSetupScale <- maybeAttribute "scale" cur + _pageSetupFirstPageNumber <- maybeAttribute "firstPageNumber" cur + _pageSetupFitToWidth <- maybeAttribute "fitToWidth" cur + _pageSetupFitToHeight <- maybeAttribute "fitToHeight" cur + _pageSetupPageOrder <- maybeAttribute "pageOrder" cur + _pageSetupOrientation <- maybeAttribute "orientation" cur + _pageSetupUsePrinterDefaults <- maybeAttribute "usePrinterDefaults" cur + _pageSetupBlackAndWhite <- maybeAttribute "blackAndWhite" cur + _pageSetupDraft <- maybeAttribute "draft" cur + _pageSetupCellComments <- maybeAttribute "cellComments" cur + _pageSetupUseFirstPageNumber <- maybeAttribute "useFirstPageNumber" cur + _pageSetupErrors <- maybeAttribute "errors" cur + _pageSetupHorizontalDpi <- maybeAttribute "horizontalDpi" cur + _pageSetupVerticalDpi <- maybeAttribute "verticalDpi" cur + _pageSetupCopies <- maybeAttribute "copies" cur + _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 + fromAttrVal "2" = readSuccess PaperLetterSmall + fromAttrVal "3" = readSuccess PaperTabloid + fromAttrVal "4" = readSuccess PaperLedger + fromAttrVal "5" = readSuccess PaperLegal + fromAttrVal "6" = readSuccess PaperStatement + fromAttrVal "7" = readSuccess PaperExecutive + fromAttrVal "8" = readSuccess PaperA3 + fromAttrVal "9" = readSuccess PaperA4 + fromAttrVal "10" = readSuccess PaperA4Small + fromAttrVal "11" = readSuccess PaperA5 + fromAttrVal "12" = readSuccess PaperB4 + fromAttrVal "13" = readSuccess PaperB5 + fromAttrVal "14" = readSuccess PaperFolio + fromAttrVal "15" = readSuccess PaperQuarto + fromAttrVal "16" = readSuccess PaperStandard10_14 + fromAttrVal "17" = readSuccess PaperStandard11_17 + fromAttrVal "18" = readSuccess PaperNote + fromAttrVal "19" = readSuccess Envelope9 + fromAttrVal "20" = readSuccess Envelope10 + fromAttrVal "21" = readSuccess Envelope11 + fromAttrVal "22" = readSuccess Envelope12 + fromAttrVal "23" = readSuccess Envelope14 + fromAttrVal "24" = readSuccess PaperC + fromAttrVal "25" = readSuccess PaperD + fromAttrVal "26" = readSuccess PaperE + fromAttrVal "27" = readSuccess EnvelopeDL + fromAttrVal "28" = readSuccess EnvelopeC5 + fromAttrVal "29" = readSuccess EnvelopeC3 + fromAttrVal "30" = readSuccess EnvelopeC4 + fromAttrVal "31" = readSuccess EnvelopeC6 + fromAttrVal "32" = readSuccess EnvelopeC65 + fromAttrVal "33" = readSuccess EnvelopeB4 + fromAttrVal "34" = readSuccess EnvelopeB5 + fromAttrVal "35" = readSuccess EnvelopeB6 + fromAttrVal "36" = readSuccess EnvelopeItaly + fromAttrVal "37" = readSuccess EnvelopeMonarch + fromAttrVal "38" = readSuccess Envelope6_3_4 + fromAttrVal "39" = readSuccess PaperFanfoldUsStandard + fromAttrVal "40" = readSuccess PaperFanfoldGermanStandard + fromAttrVal "41" = readSuccess PaperFanfoldGermanLegal + fromAttrVal "42" = readSuccess PaperIsoB4 + fromAttrVal "43" = readSuccess PaperJapaneseDoublePostcard + fromAttrVal "44" = readSuccess PaperStandard9_11 + fromAttrVal "45" = readSuccess PaperStandard10_11 + fromAttrVal "46" = readSuccess PaperStandard15_11 + fromAttrVal "47" = readSuccess EnvelopeInvite + fromAttrVal "50" = readSuccess PaperLetterExtra + fromAttrVal "51" = readSuccess PaperLegalExtra + fromAttrVal "52" = readSuccess PaperTabloidExtra + fromAttrVal "53" = readSuccess PaperA4Extra + fromAttrVal "54" = readSuccess PaperLetterTransverse + fromAttrVal "55" = readSuccess PaperA4Transverse + fromAttrVal "56" = readSuccess PaperLetterExtraTransverse + fromAttrVal "57" = readSuccess PaperSuperA + fromAttrVal "58" = readSuccess PaperSuperB + fromAttrVal "59" = readSuccess PaperLetterPlus + fromAttrVal "60" = readSuccess PaperA4Plus + fromAttrVal "61" = readSuccess PaperA5Transverse + fromAttrVal "62" = readSuccess PaperJisB5Transverse + fromAttrVal "63" = readSuccess PaperA3Extra + fromAttrVal "64" = readSuccess PaperA5Extra + fromAttrVal "65" = readSuccess PaperIsoB5Extra + fromAttrVal "66" = readSuccess PaperA2 + fromAttrVal "67" = readSuccess PaperA3Transverse + 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 + fromAttrVal "asDisplayed" = readSuccess CellCommentsAsDisplayed + 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 + fromAttrVal "blank" = readSuccess PrintErrorsBlank + fromAttrVal "dash" = readSuccess PrintErrorsDash + 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/PivotTable.hs @@ -0,0 +1,164 @@ +{-# 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 +import Codec.Xlsx.Writer.Internal + +data PivotTable = PivotTable + { _pvtName :: Text + , _pvtDataCaption :: Text + , _pvtRowFields :: [PositionedField] + , _pvtColumnFields :: [PositionedField] + , _pvtDataFields :: [DataField] + , _pvtFields :: [PivotFieldInfo] + , _pvtRowGrandTotals :: Bool + , _pvtColumnGrandTotals :: Bool + , _pvtOutline :: Bool + , _pvtOutlineData :: Bool + , _pvtLocation :: CellRef + , _pvtSrcSheet :: Text + , _pvtSrcRef :: Range + } deriving (Eq, Show, Generic) +instance NFData PivotTable + +data PivotFieldInfo = PivotFieldInfo + { _pfiName :: Maybe PivotFieldName + , _pfiOutline :: Bool + , _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, Generic) +instance NFData PivotFieldName + +data PositionedField + = DataPosition + | FieldPosition PivotFieldName + deriving (Eq, Ord, Show, Generic) +instance NFData PositionedField + +data DataField = DataField + { _dfField :: PivotFieldName + , _dfName :: Text + , _dfFunction :: ConsolidateFunction + } deriving (Eq, Show, Generic) +instance NFData DataField + +-- | Data consolidation functions specified by the user and used to +-- consolidate ranges of data +-- +-- See 18.18.17 "ST_DataConsolidateFunction (Data Consolidation +-- Functions)" (p. 2447) +data ConsolidateFunction + = ConsolidateAverage + -- ^ The average of the values. + | ConsolidateCount + -- ^ The number of data values. The Count consolidation function + -- works the same as the COUNTA worksheet function. + | ConsolidateCountNums + -- ^ The number of data values that are numbers. The Count Nums + -- consolidation function works the same as the COUNT worksheet + -- function. + | ConsolidateMaximum + -- ^ The largest value. + | ConsolidateMinimum + -- ^ The smallest value. + | ConsolidateProduct + -- ^ The product of the values. + | ConsolidateStdDev + -- ^ An estimate of the standard deviation of a population, where + -- the sample is a subset of the entire population. + | ConsolidateStdDevP + -- ^ The standard deviation of a population, where the population + -- is all of the data to be summarized. + | ConsolidateSum + -- ^ The sum of the values. + | ConsolidateVariance + -- ^ An estimate of the variance of a population, where the sample + -- is a subset of the entire population. + | ConsolidateVarP + -- ^ The variance of a population, where the population is all of + -- the data to be summarized. + deriving (Eq, Show, Generic) +instance NFData ConsolidateFunction + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToAttrVal ConsolidateFunction where + toAttrVal ConsolidateAverage = "average" + toAttrVal ConsolidateCount = "count" + toAttrVal ConsolidateCountNums = "countNums" + toAttrVal ConsolidateMaximum = "max" + toAttrVal ConsolidateMinimum = "min" + toAttrVal ConsolidateProduct = "product" + toAttrVal ConsolidateStdDev = "stdDev" + toAttrVal ConsolidateStdDevP = "stdDevp" + toAttrVal ConsolidateSum = "sum" + toAttrVal ConsolidateVariance = "var" + toAttrVal ConsolidateVarP = "varp" + +instance ToAttrVal PivotFieldName where + toAttrVal (PivotFieldName n) = toAttrVal n + +instance ToAttrVal FieldSortType where + toAttrVal FieldSortManual = "manual" + toAttrVal FieldSortAscending = "ascending" + toAttrVal FieldSortDescending = "descending" + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromAttrVal ConsolidateFunction where + fromAttrVal "average" = readSuccess ConsolidateAverage + fromAttrVal "count" = readSuccess ConsolidateCount + fromAttrVal "countNums" = readSuccess ConsolidateCountNums + fromAttrVal "max" = readSuccess ConsolidateMaximum + fromAttrVal "min" = readSuccess ConsolidateMinimum + fromAttrVal "product" = readSuccess ConsolidateProduct + fromAttrVal "stdDev" = readSuccess ConsolidateStdDev + fromAttrVal "stdDevp" = readSuccess ConsolidateStdDevP + fromAttrVal "sum" = readSuccess ConsolidateSum + fromAttrVal "var" = readSuccess ConsolidateVariance + fromAttrVal "varp" = readSuccess ConsolidateVarP + fromAttrVal t = invalidText "ConsolidateFunction" t + +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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/PivotTable/Internal.hs @@ -0,0 +1,102 @@ +{-# 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, 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/RichText.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.RichText ( + -- * Main types + RichTextRun(..) + , RunProperties(..) + , applyRunProperties + -- * Lenses + -- ** RichTextRun + , richTextRunProperties + , richTextRunText + -- ** RunProperties + , runPropertiesBold + , runPropertiesCharset + , runPropertiesColor + , runPropertiesCondense + , runPropertiesExtend + , runPropertiesFontFamily + , runPropertiesItalic + , runPropertiesOutline + , runPropertiesFont + , runPropertiesScheme + , runPropertiesShadow + , runPropertiesStrikeThrough + , runPropertiesSize + , runPropertiesUnderline + , runPropertiesVertAlign + ) where + +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) +import Text.XML +import Text.XML.Cursor +import qualified Data.Map as Map + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.StyleSheet +import Codec.Xlsx.Writer.Internal + +-- | Rich Text Run +-- +-- This element represents a run of rich text. A rich text run is a region of +-- text that share a common set of properties, such as formatting properties. +-- +-- Section 18.4.4, "r (Rich Text Run)" (p. 1724) +data RichTextRun = RichTextRun { + -- | This element represents a set of properties to apply to the contents of + -- this rich text run. + _richTextRunProperties :: Maybe RunProperties + + -- | This element represents the text content shown as part of a string. + -- + -- NOTE: 'RichTextRun' elements with an empty text field will result in + -- an error when opening the file in Excel. + -- + -- Section 18.4.12, "t (Text)" (p. 1727) + , _richTextRunText :: Text + } + deriving (Eq, Ord, Show, Generic) + +instance NFData RichTextRun + +-- | Run properties +-- +-- Section 18.4.7, "rPr (Run Properties)" (p. 1725) +data RunProperties = RunProperties { + -- | Displays characters in bold face font style. + -- + -- Section 18.8.2, "b (Bold)" (p. 1757) + _runPropertiesBold :: Maybe Bool + + -- | This element defines the font character set of this font. + -- + -- Section 18.4.1, "charset (Character Set)" (p. 1721) + , _runPropertiesCharset :: Maybe Int + + -- | One of the colors associated with the data bar or color scale. + -- + -- Section 18.3.1.15, "color (Data Bar Color)" (p. 1608) + , _runPropertiesColor :: Maybe Color + + -- | Macintosh compatibility setting. Represents special word/character + -- rendering on Macintosh, when this flag is set. The effect is to condense + -- the text (squeeze it together). + -- + -- Section 18.8.12, "condense (Condense)" (p. 1764) + , _runPropertiesCondense :: Maybe Bool + + -- | This element specifies a compatibility setting used for previous + -- spreadsheet applications, resulting in special word/character rendering + -- on those legacy applications, when this flag is set. The effect extends + -- or stretches out the text. + -- + -- Section 18.8.17, "extend (Extend)" (p. 1766) + , _runPropertiesExtend :: Maybe Bool + + -- | The font family this font belongs to. A font family is a set of fonts + -- having common stroke width and serif characteristics. This is system + -- level font information. The font name overrides when there are + -- conflicting values. + -- + -- Section 18.8.18, "family (Font Family)" (p. 1766) + , _runPropertiesFontFamily :: Maybe FontFamily + + -- | Displays characters in italic font style. The italic style is defined + -- by the font at a system level and is not specified by ECMA-376. + -- + -- Section 18.8.26, "i (Italic)" (p. 1773) + , _runPropertiesItalic :: Maybe Bool + + -- | This element displays only the inner and outer borders of each + -- character. This is very similar to Bold in behavior. + -- + -- Section 18.4.2, "outline (Outline)" (p. 1722) + , _runPropertiesOutline :: Maybe Bool + + -- | This element is a string representing the name of the font assigned to + -- display this run. + -- + -- Section 18.4.5, "rFont (Font)" (p. 1724) + , _runPropertiesFont :: Maybe Text + + -- | Defines the font scheme, if any, to which this font belongs. When a + -- font definition is part of a theme definition, then the font is + -- categorized as either a major or minor font scheme component. When a new + -- theme is chosen, every font that is part of a theme definition is updated + -- to use the new major or minor font definition for that theme. Usually + -- major fonts are used for styles like headings, and minor fonts are used + -- for body and paragraph text. + -- + -- Section 18.8.35, "scheme (Scheme)" (p. 1794) + , _runPropertiesScheme :: Maybe FontScheme + + -- | Macintosh compatibility setting. Represents special word/character + -- rendering on Macintosh, when this flag is set. The effect is to render a + -- shadow behind, beneath and to the right of the text. + -- + -- Section 18.8.36, "shadow (Shadow)" (p. 1795) + , _runPropertiesShadow :: Maybe Bool + + -- | This element draws a strikethrough line through the horizontal middle + -- of the text. + -- + -- Section 18.4.10, "strike (Strike Through)" (p. 1726) + , _runPropertiesStrikeThrough :: Maybe Bool + + -- | This element represents the point size (1/72 of an inch) of the Latin + -- and East Asian text. + -- + -- Section 18.4.11, "sz (Font Size)" (p. 1727) + , _runPropertiesSize :: Maybe Double + + -- | This element represents the underline formatting style. + -- + -- Section 18.4.13, "u (Underline)" (p. 1728) + , _runPropertiesUnderline :: Maybe FontUnderline + + -- | This element adjusts the vertical position of the text relative to the + -- text's default appearance for this run. It is used to get 'superscript' + -- or 'subscript' texts, and shall reduce the font size (if a smaller size + -- is available) accordingly. + -- + -- Section 18.4.14, "vertAlign (Vertical Alignment)" (p. 1728) + , _runPropertiesVertAlign :: Maybe FontVerticalAlignment + } + deriving (Eq, Ord, Show, Generic) + +instance NFData RunProperties + +{------------------------------------------------------------------------------- + Lenses +-------------------------------------------------------------------------------} + +makeLenses ''RichTextRun +makeLenses ''RunProperties + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default RichTextRun where + def = RichTextRun { + _richTextRunProperties = Nothing + , _richTextRunText = "" + } + +instance Default RunProperties where + def = RunProperties { + _runPropertiesBold = Nothing + , _runPropertiesCharset = Nothing + , _runPropertiesColor = Nothing + , _runPropertiesCondense = Nothing + , _runPropertiesExtend = Nothing + , _runPropertiesFontFamily = Nothing + , _runPropertiesItalic = Nothing + , _runPropertiesOutline = Nothing + , _runPropertiesFont = Nothing + , _runPropertiesScheme = Nothing + , _runPropertiesShadow = Nothing + , _runPropertiesStrikeThrough = Nothing + , _runPropertiesSize = Nothing + , _runPropertiesUnderline = Nothing + , _runPropertiesVertAlign = Nothing + } + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +-- | See @CT_RElt@, p. 3903 +instance ToElement RichTextRun where + toElement nm RichTextRun{..} = Element { + elementName = nm + , elementAttributes = Map.empty + , elementNodes = map NodeElement . catMaybes $ [ + toElement "rPr" <$> _richTextRunProperties + , Just $ elementContentPreserved "t" _richTextRunText + ] + } + +-- | See @CT_RPrElt@, p. 3903 +instance ToElement RunProperties where + toElement nm RunProperties{..} = Element { + elementName = nm + , elementAttributes = Map.empty + , elementNodes = map NodeElement . catMaybes $ [ + elementValue "rFont" <$> _runPropertiesFont + , elementValue "charset" <$> _runPropertiesCharset + , elementValue "family" <$> _runPropertiesFontFamily + , elementValue "b" <$> _runPropertiesBold + , elementValue "i" <$> _runPropertiesItalic + , elementValue "strike" <$> _runPropertiesStrikeThrough + , elementValue "outline" <$> _runPropertiesOutline + , elementValue "shadow" <$> _runPropertiesShadow + , elementValue "condense" <$> _runPropertiesCondense + , elementValue "extend" <$> _runPropertiesExtend + , toElement "color" <$> _runPropertiesColor + , elementValue "sz" <$> _runPropertiesSize + , elementValueDef "u" FontUnderlineSingle + <$> _runPropertiesUnderline + , elementValue "vertAlign" <$> _runPropertiesVertAlign + , elementValue "scheme" <$> _runPropertiesScheme + ] + } + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +-- | See @CT_RElt@, p. 3903 +instance FromCursor RichTextRun where + fromCursor cur = do + _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 (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. +instance Monoid RunProperties where + mempty = def + a `mappend` 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 + +-- | Apply properties to a 'RichTextRun' +-- +-- If the 'RichTextRun' specifies its own properties, then these overrule the +-- properties specified here. For example, adding @bold@ to a 'RichTextRun' +-- which is already @italic@ will make the 'RichTextRun' both @bold and @italic@ +-- but adding it to one that that is explicitly _not_ bold will leave the +-- 'RichTextRun' unchanged. +applyRunProperties :: RunProperties -> RichTextRun -> RichTextRun +applyRunProperties p (RichTextRun Nothing t) = RichTextRun (Just p) t +applyRunProperties p (RichTextRun (Just p') t) = RichTextRun (Just (p `mappend` p')) t diff --git a/src/Codec/Xlsx/Types/SheetViews.hs b/src/Codec/Xlsx/Types/SheetViews.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/SheetViews.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.SheetViews ( + -- * Structured type to construct 'SheetViews' + SheetView(..) + , Selection(..) + , Pane(..) + , SheetViewType(..) + , PaneType(..) + , PaneState(..) + -- * Lenses + -- ** SheetView + , sheetViewColorId + , sheetViewDefaultGridColor + , sheetViewRightToLeft + , sheetViewShowFormulas + , sheetViewShowGridLines + , sheetViewShowOutlineSymbols + , sheetViewShowRowColHeaders + , sheetViewShowRuler + , sheetViewShowWhiteSpace + , sheetViewShowZeros + , sheetViewTabSelected + , sheetViewTopLeftCell + , sheetViewType + , sheetViewWindowProtection + , sheetViewWorkbookViewId + , sheetViewZoomScale + , sheetViewZoomScaleNormal + , sheetViewZoomScalePageLayoutView + , sheetViewZoomScaleSheetLayoutView + , sheetViewPane + , sheetViewSelection + -- ** Selection + , selectionActiveCell + , selectionActiveCellId + , selectionPane + , selectionSqref + -- ** Pane + , paneActivePane + , paneState + , paneTopLeftCell + , paneXSplit + , paneYSplit + ) where + +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 + +import Codec.Xlsx.Types.Common +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +{------------------------------------------------------------------------------- + Main types +-------------------------------------------------------------------------------} + +-- | Worksheet view +-- +-- A single sheet view definition. When more than one sheet view is defined in +-- the file, it means that when opening the workbook, each sheet view +-- corresponds to a separate window within the spreadsheet application, where +-- each window is showing the particular sheet containing the same +-- workbookViewId value, the last sheetView definition is loaded, and the others +-- are discarded. When multiple windows are viewing the same sheet, multiple +-- sheetView elements (with corresponding workbookView entries) are saved. +-- +-- TODO: The @pivotSelection@ and @extLst@ child elements are unsupported. +-- +-- See Section 18.3.1.87 "sheetView (Worksheet View)" (p. 1880) +data SheetView = SheetView { + -- | Index to the color value for row/column text headings and gridlines. + -- This is an 'index color value' (ICV) rather than rgb value. + _sheetViewColorId :: Maybe Int + + -- | Flag indicating that the consuming application should use the default + -- grid lines color (system dependent). Overrides any color specified in + -- colorId. + , _sheetViewDefaultGridColor :: Maybe Bool + + -- | Flag indicating whether the sheet is in 'right to left' display mode. + -- When in this mode, Column A is on the far right, Column B ;is one column + -- left of Column A, and so on. Also, information in cells is displayed in + -- the Right to Left format. + , _sheetViewRightToLeft :: Maybe Bool + + -- | Flag indicating whether this sheet should display formulas. + , _sheetViewShowFormulas :: Maybe Bool + + -- | Flag indicating whether this sheet should display gridlines. + , _sheetViewShowGridLines :: Maybe Bool + + -- | Flag indicating whether the sheet has outline symbols visible. This + -- flag shall always override SheetPr element's outlinePr child element + -- whose attribute is named showOutlineSymbols when there is a conflict. + , _sheetViewShowOutlineSymbols :: Maybe Bool + + -- | Flag indicating whether the sheet should display row and column headings. + , _sheetViewShowRowColHeaders :: Maybe Bool + + -- | Show the ruler in Page Layout View. + , _sheetViewShowRuler :: Maybe Bool + + -- | Flag indicating whether page layout view shall display margins. False + -- means do not display left, right, top (header), and bottom (footer) + -- margins (even when there is data in the header or footer). + , _sheetViewShowWhiteSpace :: Maybe Bool + + -- | Flag indicating whether the window should show 0 (zero) in cells + -- containing zero value. When false, cells with zero value appear blank + -- instead of showing the number zero. + , _sheetViewShowZeros :: Maybe Bool + + -- | Flag indicating whether this sheet is selected. When only 1 sheet is + -- selected and active, this value should be in synch with the activeTab + -- value. In case of a conflict, the Start Part setting wins and sets the + -- active sheet tab. + -- + -- Multiple sheets can be selected, but only one sheet shall be active at + -- one time. + , _sheetViewTabSelected :: Maybe Bool + + -- | Location of the top left visible cell Location of the top left visible + -- cell in the bottom right pane (when in Left-to-Right mode). + , _sheetViewTopLeftCell :: Maybe CellRef + + -- | Indicates the view type. + , _sheetViewType :: Maybe SheetViewType + + -- | Flag indicating whether the panes in the window are locked due to + -- workbook protection. This is an option when the workbook structure is + -- protected. + , _sheetViewWindowProtection :: Maybe Bool + + -- | Zero-based index of this workbook view, pointing to a workbookView + -- element in the bookViews collection. + -- + -- NOTE: This attribute is required. + , _sheetViewWorkbookViewId :: Int + + -- | Window zoom magnification for current view representing percent values. + -- This attribute is restricted to values ranging from 10 to 400. Horizontal & + -- Vertical scale together. + , _sheetViewZoomScale :: Maybe Int + + -- | Zoom magnification to use when in normal view, representing percent + -- values. This attribute is restricted to values ranging from 10 to 400. + -- Horizontal & Vertical scale together. + , _sheetViewZoomScaleNormal :: Maybe Int + + -- | Zoom magnification to use when in page layout view, representing + -- percent values. This attribute is restricted to values ranging from 10 to + -- 400. Horizontal & Vertical scale together. + , _sheetViewZoomScalePageLayoutView :: Maybe Int + + -- | Zoom magnification to use when in page break preview, representing + -- percent values. This attribute is restricted to values ranging from 10 to + -- 400. Horizontal & Vertical scale together. + , _sheetViewZoomScaleSheetLayoutView :: Maybe Int + + -- | Worksheet view pane + , _sheetViewPane :: Maybe Pane + + -- | Worksheet view selection + -- + -- Minimum of 0, maximum of 4 elements + , _sheetViewSelection :: [Selection] + } + deriving (Eq, Ord, Show, Generic) +instance NFData SheetView + +-- | Worksheet view selection. +-- +-- Section 18.3.1.78 "selection (Selection)" (p. 1864) +data Selection = Selection { + -- | Location of the active cell + _selectionActiveCell :: Maybe CellRef + + -- | 0-based index of the range reference (in the array of references listed + -- in sqref) containing the active cell. Only used when the selection in + -- sqref is not contiguous. Therefore, this value needs to be aware of the + -- order in which the range references are written in sqref. + -- + -- When this value is out of range then activeCell can be used. + , _selectionActiveCellId :: Maybe Int + + -- | The pane to which this selection belongs. + , _selectionPane :: Maybe PaneType + + -- | Range of the selection. Can be non-contiguous set of ranges. + , _selectionSqref :: Maybe SqRef + } + deriving (Eq, Ord, Show, Generic) +instance NFData Selection + +-- | Worksheet view pane +-- +-- Section 18.3.1.66 "pane (View Pane)" (p. 1843) +data Pane = Pane { + -- | The pane that is active. + _paneActivePane :: Maybe PaneType + + -- | Indicates whether the pane has horizontal / vertical splits, and + -- whether those splits are frozen. + , _paneState :: Maybe PaneState + + -- | Location of the top left visible cell in the bottom right pane (when in + -- Left-To-Right mode). + , _paneTopLeftCell :: Maybe CellRef + + -- | Horizontal position of the split, in 1/20th of a point; 0 (zero) if + -- none. If the pane is frozen, this value indicates the number of columns + -- visible in the top pane. + , _paneXSplit :: Maybe Double + + -- | Vertical position of the split, in 1/20th of a point; 0 (zero) if none. + -- If the pane is frozen, this value indicates the number of rows visible in + -- the left pane. + , _paneYSplit :: Maybe Double + } + deriving (Eq, Ord, Show, Generic) +instance NFData Pane + +{------------------------------------------------------------------------------- + Enumerations +-------------------------------------------------------------------------------} + +-- | View setting of the sheet +-- +-- Section 18.18.69 "ST_SheetViewType (Sheet View Type)" (p. 2726) +data SheetViewType = + -- | Normal view + SheetViewTypeNormal + + -- | Page break preview + | SheetViewTypePageBreakPreview + + -- | Page layout view + | SheetViewTypePageLayout + deriving (Eq, Ord, Show, Generic) +instance NFData SheetViewType + +-- | Pane type +-- +-- Section 18.18.52 "ST_Pane (Pane Types)" (p. 2710) +data PaneType = + -- | Bottom left pane, when both vertical and horizontal splits are applied. + -- + -- This value is also used when only a horizontal split has been applied, + -- dividing the pane into upper and lower regions. In that case, this value + -- specifies the bottom pane. + PaneTypeBottomLeft + + -- Bottom right pane, when both vertical and horizontal splits are applied. + | PaneTypeBottomRight + + -- | Top left pane, when both vertical and horizontal splits are applied. + -- + -- This value is also used when only a horizontal split has been applied, + -- dividing the pane into upper and lower regions. In that case, this value + -- specifies the top pane. + -- + -- This value is also used when only a vertical split has been applied, + -- dividing the pane into right and left regions. In that case, this value + -- specifies the left pane + | PaneTypeTopLeft + + -- | Top right pane, when both vertical and horizontal splits are applied. + -- + -- This value is also used when only a vertical split has been applied, + -- dividing the pane into right and left regions. In that case, this value + -- specifies the right pane. + | PaneTypeTopRight + deriving (Eq, Ord, Show, Generic) +instance NFData PaneType + +-- | State of the sheet's pane. +-- +-- Section 18.18.53 "ST_PaneState (Pane State)" (p. 2711) +data PaneState = + -- | Panes are frozen, but were not split being frozen. In this state, when + -- the panes are unfrozen again, a single pane results, with no split. In + -- this state, the split bars are not adjustable. + PaneStateFrozen + + -- | Panes are frozen and were split before being frozen. In this state, + -- when the panes are unfrozen again, the split remains, but is adjustable. + | PaneStateFrozenSplit + + -- | Panes are split, but not frozen. In this state, the split bars are + -- adjustable by the user. + | PaneStateSplit + deriving (Eq, Ord, Show, Generic) +instance NFData PaneState + +{------------------------------------------------------------------------------- + Lenses +-------------------------------------------------------------------------------} + +makeLenses ''SheetView +makeLenses ''Selection +makeLenses ''Pane + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +-- | NOTE: The 'Default' instance for 'SheetView' sets the required attribute +-- '_sheetViewWorkbookViewId' to @0@. +instance Default SheetView where + def = SheetView { + _sheetViewColorId = Nothing + , _sheetViewDefaultGridColor = Nothing + , _sheetViewRightToLeft = Nothing + , _sheetViewShowFormulas = Nothing + , _sheetViewShowGridLines = Nothing + , _sheetViewShowOutlineSymbols = Nothing + , _sheetViewShowRowColHeaders = Nothing + , _sheetViewShowRuler = Nothing + , _sheetViewShowWhiteSpace = Nothing + , _sheetViewShowZeros = Nothing + , _sheetViewTabSelected = Nothing + , _sheetViewTopLeftCell = Nothing + , _sheetViewType = Nothing + , _sheetViewWindowProtection = Nothing + , _sheetViewWorkbookViewId = 0 + , _sheetViewZoomScale = Nothing + , _sheetViewZoomScaleNormal = Nothing + , _sheetViewZoomScalePageLayoutView = Nothing + , _sheetViewZoomScaleSheetLayoutView = Nothing + , _sheetViewPane = Nothing + , _sheetViewSelection = [] + } + +instance Default Selection where + def = Selection { + _selectionActiveCell = Nothing + , _selectionActiveCellId = Nothing + , _selectionPane = Nothing + , _selectionSqref = Nothing + } + +instance Default Pane where + def = Pane { + _paneActivePane = Nothing + , _paneState = Nothing + , _paneTopLeftCell = Nothing + , _paneXSplit = Nothing + , _paneYSplit = Nothing + } + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +-- | See @CT_SheetView@, p. 3913 +instance ToElement SheetView where + toElement nm SheetView{..} = Element { + elementName = nm + , elementNodes = map NodeElement . concat $ [ + map (toElement "pane") (maybeToList _sheetViewPane) + , map (toElement "selection") _sheetViewSelection + -- TODO: pivotSelection + -- TODO: extLst + ] + , elementAttributes = Map.fromList . catMaybes $ [ + "windowProtection" .=? _sheetViewWindowProtection + , "showFormulas" .=? _sheetViewShowFormulas + , "showGridLines" .=? _sheetViewShowGridLines + , "showRowColHeaders" .=? _sheetViewShowRowColHeaders + , "showZeros" .=? _sheetViewShowZeros + , "rightToLeft" .=? _sheetViewRightToLeft + , "tabSelected" .=? _sheetViewTabSelected + , "showRuler" .=? _sheetViewShowRuler + , "showOutlineSymbols" .=? _sheetViewShowOutlineSymbols + , "defaultGridColor" .=? _sheetViewDefaultGridColor + , "showWhiteSpace" .=? _sheetViewShowWhiteSpace + , "view" .=? _sheetViewType + , "topLeftCell" .=? _sheetViewTopLeftCell + , "colorId" .=? _sheetViewColorId + , "zoomScale" .=? _sheetViewZoomScale + , "zoomScaleNormal" .=? _sheetViewZoomScaleNormal + , "zoomScaleSheetLayoutView" .=? _sheetViewZoomScaleSheetLayoutView + , "zoomScalePageLayoutView" .=? _sheetViewZoomScalePageLayoutView + , Just $ "workbookViewId" .= _sheetViewWorkbookViewId + ] + } + +-- | See @CT_Selection@, p. 3914 +instance ToElement Selection where + toElement nm Selection{..} = Element { + elementName = nm + , elementNodes = [] + , elementAttributes = Map.fromList . catMaybes $ [ + "pane" .=? _selectionPane + , "activeCell" .=? _selectionActiveCell + , "activeCellId" .=? _selectionActiveCellId + , "sqref" .=? _selectionSqref + ] + } + +-- | See @CT_Pane@, p. 3913 +instance ToElement Pane where + toElement nm Pane{..} = Element { + elementName = nm + , elementNodes = [] + , elementAttributes = Map.fromList . catMaybes $ [ + "xSplit" .=? _paneXSplit + , "ySplit" .=? _paneYSplit + , "topLeftCell" .=? _paneTopLeftCell + , "activePane" .=? _paneActivePane + , "state" .=? _paneState + ] + } + +-- | See @ST_SheetViewType@, p. 3913 +instance ToAttrVal SheetViewType where + toAttrVal SheetViewTypeNormal = "normal" + toAttrVal SheetViewTypePageBreakPreview = "pageBreakPreview" + toAttrVal SheetViewTypePageLayout = "pageLayout" + +-- | See @ST_Pane@, p. 3914 +instance ToAttrVal PaneType where + toAttrVal PaneTypeBottomRight = "bottomRight" + toAttrVal PaneTypeTopRight = "topRight" + toAttrVal PaneTypeBottomLeft = "bottomLeft" + toAttrVal PaneTypeTopLeft = "topLeft" + +-- | See @ST_PaneState@, p. 3929 +instance ToAttrVal PaneState where + toAttrVal PaneStateSplit = "split" + toAttrVal PaneStateFrozen = "frozen" + toAttrVal PaneStateFrozenSplit = "frozenSplit" + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} +-- | See @CT_SheetView@, p. 3913 +instance FromCursor SheetView where + fromCursor cur = do + _sheetViewWindowProtection <- maybeAttribute "windowProtection" cur + _sheetViewShowFormulas <- maybeAttribute "showFormulas" cur + _sheetViewShowGridLines <- maybeAttribute "showGridLines" cur + _sheetViewShowRowColHeaders <- maybeAttribute "showRowColHeaders"cur + _sheetViewShowZeros <- maybeAttribute "showZeros" cur + _sheetViewRightToLeft <- maybeAttribute "rightToLeft" cur + _sheetViewTabSelected <- maybeAttribute "tabSelected" cur + _sheetViewShowRuler <- maybeAttribute "showRuler" cur + _sheetViewShowOutlineSymbols <- maybeAttribute "showOutlineSymbols" cur + _sheetViewDefaultGridColor <- maybeAttribute "defaultGridColor" cur + _sheetViewShowWhiteSpace <- maybeAttribute "showWhiteSpace" cur + _sheetViewType <- maybeAttribute "view" cur + _sheetViewTopLeftCell <- maybeAttribute "topLeftCell" cur + _sheetViewColorId <- maybeAttribute "colorId" cur + _sheetViewZoomScale <- maybeAttribute "zoomScale" cur + _sheetViewZoomScaleNormal <- maybeAttribute "zoomScaleNormal" cur + _sheetViewZoomScaleSheetLayoutView <- maybeAttribute "zoomScaleSheetLayoutView" cur + _sheetViewZoomScalePageLayoutView <- maybeAttribute "zoomScalePageLayoutView" cur + _sheetViewWorkbookViewId <- fromAttribute "workbookViewId" cur + 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 + _paneXSplit <- maybeAttribute "xSplit" cur + _paneYSplit <- maybeAttribute "ySplit" cur + _paneTopLeftCell <- maybeAttribute "topLeftCell" cur + _paneActivePane <- maybeAttribute "activePane" cur + _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 + _selectionPane <- maybeAttribute "pane" cur + _selectionActiveCell <- maybeAttribute "activeCell" cur + _selectionActiveCellId <- maybeAttribute "activeCellId" cur + _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 + fromAttrVal "pageBreakPreview" = readSuccess SheetViewTypePageBreakPreview + 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 + fromAttrVal "topRight" = readSuccess PaneTypeTopRight + fromAttrVal "bottomLeft" = readSuccess PaneTypeBottomLeft + 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/StyleSheet.hs @@ -0,0 +1,1697 @@ +{-# 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 + StyleSheet(..) + , CellXf(..) + , minimalStyleSheet + -- * Supporting record types + , Alignment(..) + , Border(..) + , BorderStyle(..) + , Color(..) + , Dxf(..) + , Fill(..) + , FillPattern(..) + , Font(..) + , NumberFormat(..) + , NumFmt(..) + , ImpliedNumberFormat (..) + , FormatCode + , Protection(..) + -- * Supporting enumerations + , CellHorizontalAlignment(..) + , CellVerticalAlignment(..) + , FontFamily(..) + , FontScheme(..) + , FontUnderline(..) + , FontVerticalAlignment(..) + , LineStyle(..) + , PatternType(..) + , ReadingOrder(..) + -- * Lenses + -- ** StyleSheet + , styleSheetBorders + , styleSheetFonts + , styleSheetFills + , styleSheetCellXfs + , styleSheetDxfs + , styleSheetNumFmts + -- ** CellXf + , cellXfApplyAlignment + , cellXfApplyBorder + , cellXfApplyFill + , cellXfApplyFont + , cellXfApplyNumberFormat + , cellXfApplyProtection + , cellXfBorderId + , cellXfFillId + , cellXfFontId + , cellXfNumFmtId + , cellXfPivotButton + , cellXfQuotePrefix + , cellXfId + , cellXfAlignment + , cellXfProtection + -- ** Dxf + , dxfAlignment + , dxfBorder + , dxfFill + , dxfFont + , dxfNumFmt + , dxfProtection + -- ** Alignment + , alignmentHorizontal + , alignmentIndent + , alignmentJustifyLastLine + , alignmentReadingOrder + , alignmentRelativeIndent + , alignmentShrinkToFit + , alignmentTextRotation + , alignmentVertical + , alignmentWrapText + -- ** Border + , borderDiagonalDown + , borderDiagonalUp + , borderOutline + , borderBottom + , borderDiagonal + , borderEnd + , borderHorizontal + , borderStart + , borderTop + , borderVertical + , borderLeft + , borderRight + -- ** BorderStyle + , borderStyleColor + , borderStyleLine + -- ** Color + , colorAutomatic + , colorARGB + , colorTheme + , colorTint + -- ** Fill + , fillPattern + -- ** FillPattern + , fillPatternBgColor + , fillPatternFgColor + , fillPatternType + -- ** Font + , fontBold + , fontCharset + , fontColor + , fontCondense + , fontExtend + , fontFamily + , fontItalic + , fontName + , fontOutline + , fontScheme + , fontShadow + , fontStrikeThrough + , fontSize + , fontUnderline + , fontVertAlign + -- ** Protection + , protectionHidden + , protectionLocked + -- * Helpers + -- ** Number formats + , fmtDecimals + , fmtDecimalsZeroes + , stdNumberFormatId + , idToStdNumberFormat + , firstUserNumFmtId + ) where + +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.Writer.Internal + +{------------------------------------------------------------------------------- + The main types +-------------------------------------------------------------------------------} + +-- | 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) +-- 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 +-- specifies the top-level style sheet format. +-- +-- TODO: the following child elements: +-- +-- * cellStyles +-- * cellStyleXfs +-- * colors +-- * extLst +-- * tableStyles +-- +-- 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' +-- * 'Codec.Xlsx.Formatted.formatted' for a higher level interface. +-- * 'Codec.Xlsx.Types.parseStyleSheet' to translate a raw 'StyleSheet' into 'Styles' +data StyleSheet = StyleSheet + { _styleSheetBorders :: [Border] + -- ^ This element contains borders formatting information, specifying all + -- border definitions for all cells in the workbook. + -- + -- Section 18.8.5, "borders (Borders)" (p. 1760) + + , _styleSheetCellXfs :: [CellXf] + -- ^ Cell formats + -- + -- This element contains the master formatting records (xf) which define the + -- formatting applied to cells in this workbook. These records are the + -- starting point for determining the formatting for a cell. Cells in the + -- Sheet Part reference the xf records by zero-based index. + -- + -- Section 18.8.10, "cellXfs (Cell Formats)" (p. 1764) + + , _styleSheetFills :: [Fill] + -- ^ This element defines the cell fills portion of the Styles part, + -- consisting of a sequence of fill records. A cell fill consists of a + -- background color, foreground color, and pattern to be applied across the + -- cell. + -- + -- Section 18.8.21, "fills (Fills)" (p. 1768) + + , _styleSheetFonts :: [Font] + -- ^ This element contains all font definitions for this workbook. + -- + -- Section 18.8.23 "fonts (Fonts)" (p. 1769) + + , _styleSheetDxfs :: [Dxf] + -- ^ Differential formatting + -- + -- This element contains the master differential formatting records (dxf's) + -- which define formatting for all non-cell formatting in this workbook. + -- Whereas xf records fully specify a particular aspect of formatting (e.g., + -- cell borders) by referencing those formatting definitions elsewhere in + -- the Styles part, dxf records specify incremental (or differential) aspects + -- of formatting directly inline within the dxf element. The dxf formatting + -- is to be applied on top of or in addition to any formatting already + -- present on the object using the dxf record. + -- + -- Section 18.8.15, "dxfs (Formats)" (p. 1765) + + , _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, Generic) + +instance NFData StyleSheet + +-- | Cell formatting +-- +-- TODO: The @extLst@ field is currently unsupported. +-- +-- Section 18.8.45 "xf (Format)" (p. 1800) +data CellXf = CellXf { + -- | A boolean value indicating whether the alignment formatting specified + -- for this xf should be applied. + _cellXfApplyAlignment :: Maybe Bool + + -- | A boolean value indicating whether the border formatting specified for + -- this xf should be applied. + , _cellXfApplyBorder :: Maybe Bool + + -- | A boolean value indicating whether the fill formatting specified for + -- this xf should be applied. + , _cellXfApplyFill :: Maybe Bool + + -- | A boolean value indicating whether the font formatting specified for + -- this xf should be applied. + , _cellXfApplyFont :: Maybe Bool + + -- | A boolean value indicating whether the number formatting specified for + -- this xf should be applied. + , _cellXfApplyNumberFormat :: Maybe Bool + + -- | A boolean value indicating whether the protection formatting specified + -- for this xf should be applied. + , _cellXfApplyProtection :: Maybe Bool + + -- | Zero-based index of the border record used by this cell format. + -- + -- (18.18.2, p. 2437). + , _cellXfBorderId :: Maybe Int + + -- | Zero-based index of the fill record used by this cell format. + -- + -- (18.18.30, p. 2455) + , _cellXfFillId :: Maybe Int + + -- | Zero-based index of the font record used by this cell format. + -- + -- An integer that represents a zero based index into the `styleSheetFonts` + -- collection in the style sheet (18.18.32, p. 2456). + , _cellXfFontId :: Maybe Int + + -- | Id of the number format (numFmt) record used by this cell format. + -- + -- This simple type defines the identifier to a style sheet number format + -- entry in CT_NumFmts. Number formats are written to the styles part + -- (18.18.47, p. 2468). See also 18.8.31 (p. 1784) for more information on + -- number formats. + -- + , _cellXfNumFmtId :: Maybe Int + + -- | A boolean value indicating whether the cell rendering includes a pivot + -- table dropdown button. + , _cellXfPivotButton :: Maybe Bool + + -- | A boolean value indicating whether the text string in a cell should be + -- prefixed by a single quote mark (e.g., 'text). In these cases, the quote + -- is not stored in the Shared Strings Part. + , _cellXfQuotePrefix :: Maybe Bool + + -- | For xf records contained in cellXfs this is the zero-based index of an + -- xf record contained in cellStyleXfs corresponding to the cell style + -- applied to the cell. + -- + -- Not present for xf records contained in cellStyleXfs. + -- + -- Used by xf records and cellStyle records to reference xf records defined + -- in the cellStyleXfs collection. (18.18.10, p. 2442) + -- TODO: the cellStyleXfs field of a style sheet not currently implemented. + , _cellXfId :: Maybe Int + + -- | Formatting information pertaining to text alignment in cells. There are + -- a variety of choices for how text is aligned both horizontally and + -- vertically, as well as indentation settings, and so on. + , _cellXfAlignment :: Maybe Alignment + + -- | Contains protection properties associated with the cell. Each cell has + -- protection properties that can be set. The cell protection properties do + -- not take effect unless the sheet has been protected. + , _cellXfProtection :: Maybe Protection + } + deriving (Eq, Ord, Show, Generic) + +instance NFData CellXf + +{------------------------------------------------------------------------------- + Supporting record types +-------------------------------------------------------------------------------} + +-- | Alignment +-- +-- See 18.8.1 "alignment (Alignment)" (p. 1754) +data Alignment = Alignment { + -- | Specifies the type of horizontal alignment in cells. + _alignmentHorizontal :: Maybe CellHorizontalAlignment + + -- | An integer value, where an increment of 1 represents 3 spaces. + -- Indicates the number of spaces (of the normal style font) of indentation + -- for text in a cell. + , _alignmentIndent :: Maybe Int + + -- | A boolean value indicating if the cells justified or distributed + -- alignment should be used on the last line of text. (This is typical for + -- East Asian alignments but not typical in other contexts.) + , _alignmentJustifyLastLine :: Maybe Bool + + -- | An integer value indicating whether the reading order + -- (bidirectionality) of the cell is leftto- right, right-to-left, or + -- context dependent. + , _alignmentReadingOrder :: Maybe ReadingOrder + + -- | An integer value (used only in a dxf element) to indicate the + -- additional number of spaces of indentation to adjust for text in a cell. + , _alignmentRelativeIndent :: Maybe Int + + -- | A boolean value indicating if the displayed text in the cell should be + -- shrunk to fit the cell width. Not applicable when a cell contains + -- multiple lines of text. + , _alignmentShrinkToFit :: Maybe Bool + + -- | Text rotation in cells. Expressed in degrees. Values range from 0 to + -- 180. The first letter of the text is considered the center-point of the + -- arc. + , _alignmentTextRotation :: Maybe Int + + -- | Vertical alignment in cells. + , _alignmentVertical :: Maybe CellVerticalAlignment + + -- | A boolean value indicating if the text in a cell should be line-wrapped + -- within the cell. + , _alignmentWrapText :: Maybe Bool + } + 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. +-- +-- See 18.8.4 "border (Border)" (p. 1759) +data Border = Border { + -- | A boolean value indicating if the cell's diagonal border includes a + -- diagonal line, starting at the top left corner of the cell and moving + -- down to the bottom right corner of the cell. + _borderDiagonalDown :: Maybe Bool + + -- | A boolean value indicating if the cell's diagonal border includes a + -- diagonal line, starting at the bottom left corner of the cell and moving + -- up to the top right corner of the cell. + , _borderDiagonalUp :: Maybe Bool + + -- | A boolean value indicating if left, right, top, and bottom borders + -- should be applied only to outside borders of a cell range. + , _borderOutline :: Maybe Bool + + -- | Bottom border + , _borderBottom :: Maybe BorderStyle + + -- | Diagonal + , _borderDiagonal :: Maybe BorderStyle + + -- | Trailing edge border + -- + -- See also 'borderRight' + , _borderEnd :: Maybe BorderStyle + + -- | Horizontal inner borders + , _borderHorizontal :: Maybe BorderStyle + + -- | Left border + -- + -- NOTE: The spec does not formally list a 'left' border element, but the + -- examples do mention 'left' and the scheme contains it too. See also 'borderStart'. + , _borderLeft :: Maybe BorderStyle + + -- | Right border + -- + -- NOTE: The spec does not formally list a 'right' border element, but the + -- examples do mention 'right' and the scheme contains it too. See also 'borderEnd'. + , _borderRight :: Maybe BorderStyle + + -- | Leading edge border + -- + -- See also 'borderLeft' + , _borderStart :: Maybe BorderStyle + + -- | Top border + , _borderTop :: Maybe BorderStyle + + -- | Vertical inner border + , _borderVertical :: Maybe BorderStyle + } + 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 (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 +-- modelled here. +-- +-- See 18.3.1.15 "color (Data Bar Color)" (p. 1608) +data Color = Color { + -- | A boolean value indicating the color is automatic and system color + -- dependent. + _colorAutomatic :: Maybe Bool + + -- | Standard Alpha Red Green Blue color value (ARGB). + -- + -- This simple type's contents have a length of exactly 8 hexadecimal + -- digit(s); see "18.18.86 ST_UnsignedIntHex (Hex Unsigned Integer)" (p. + -- 2511). + , _colorARGB :: Maybe Text + + -- | A zero-based index into the collection (20.1.6.2), + -- referencing a particular or value expressed in the + -- Theme part. + , _colorTheme :: Maybe Int + + -- | Specifies the tint value applied to the color. + -- + -- If tint is supplied, then it is applied to the RGB value of the color to + -- determine the final color applied. + -- + -- The tint value is stored as a double from -1.0 .. 1.0, where -1.0 means + -- 100% darken and 1.0 means 100% lighten. Also, 0.0 means no change. + , _colorTint :: Maybe Double + } + 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, +-- then the spec says (@CT_Fill@, p. 3935), _either_ a gradient _or_ a solid +-- fill pattern should be specified. +-- +-- Section 18.8.20, "fill (Fill)" (p. 1768) +data Fill = Fill { + _fillPattern :: Maybe FillPattern + } + 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 +-- the bgColor element. +-- +-- Section 18.8.32 "patternFill (Pattern)" (p. 1793) +data FillPattern = FillPattern { + _fillPatternBgColor :: Maybe Color + , _fillPatternFgColor :: Maybe Color + , _fillPatternType :: Maybe PatternType + } + deriving (Eq, Ord, Show, Generic) + +instance NFData FillPattern + +-- | This element defines the properties for one of the fonts used in this +-- workbook. +-- +-- Section 18.2.22 "font (Font)" (p. 1769) +data Font = Font { + -- | Displays characters in bold face font style. + _fontBold :: Maybe Bool + + -- | This element defines the font character set of this font. + -- + -- This field is used in font creation and selection if a font of the given + -- facename is not available on the system. Although it is not required to + -- have around when resolving font facename, the information can be stored + -- for when needed to help resolve which font face to use of all available + -- fonts on a system. + -- + -- Charset represents the basic set of characters associated with a font + -- (that it can display), and roughly corresponds to the ANSI codepage + -- (8-bit or DBCS) of that character set used by a given language. Given + -- more common use of Unicode where many fonts support more than one of the + -- traditional charset categories, and the use of font linking, using + -- charset to resolve font name is less and less common, but still can be + -- useful. + -- + -- These are operating-system-dependent values. + -- + -- Section 18.4.1 "charset (Character Set)" provides some example values. + , _fontCharset :: Maybe Int + + -- | Color + , _fontColor :: Maybe Color + + -- | Macintosh compatibility setting. Represents special word/character + -- rendering on Macintosh, when this flag is set. The effect is to condense + -- the text (squeeze it together). SpreadsheetML applications are not + -- required to render according to this flag. + , _fontCondense :: Maybe Bool + + -- | This element specifies a compatibility setting used for previous + -- spreadsheet applications, resulting in special word/character rendering + -- on those legacy applications, when this flag is set. The effect extends + -- or stretches out the text. SpreadsheetML applications are not required to + -- render according to this flag. + , _fontExtend :: Maybe Bool + + -- | The font family this font belongs to. A font family is a set of fonts + -- having common stroke width and serif characteristics. This is system + -- level font information. The font name overrides when there are + -- conflicting values. + , _fontFamily :: Maybe FontFamily + + -- | Displays characters in italic font style. The italic style is defined + -- by the font at a system level and is not specified by ECMA-376. + , _fontItalic :: Maybe Bool + + -- | This element specifies the face name of this font. + -- + -- A string representing the name of the font. If the font doesn't exist + -- (because it isn't installed on the system), or the charset not supported + -- by that font, then another font should be substituted. + -- + -- The string length for this attribute shall be 0 to 31 characters. + , _fontName :: Maybe Text + + -- | This element displays only the inner and outer borders of each + -- character. This is very similar to Bold in behavior. + , _fontOutline :: Maybe Bool + + -- | Defines the font scheme, if any, to which this font belongs. When a + -- font definition is part of a theme definition, then the font is + -- categorized as either a major or minor font scheme component. When a new + -- theme is chosen, every font that is part of a theme definition is updated + -- to use the new major or minor font definition for that theme. Usually + -- major fonts are used for styles like headings, and minor fonts are used + -- for body and paragraph text. + , _fontScheme :: Maybe FontScheme + + -- | Macintosh compatibility setting. Represents special word/character + -- rendering on Macintosh, when this flag is set. The effect is to render a + -- shadow behind, beneath and to the right of the text. SpreadsheetML + -- applications are not required to render according to this flag. + , _fontShadow :: Maybe Bool + + -- | This element draws a strikethrough line through the horizontal middle + -- of the text. + , _fontStrikeThrough :: Maybe Bool + + -- | This element represents the point size (1/72 of an inch) of the Latin + -- and East Asian text. + , _fontSize :: Maybe Double + + -- | This element represents the underline formatting style. + , _fontUnderline :: Maybe FontUnderline + + -- | This element adjusts the vertical position of the text relative to the + -- text's default appearance for this run. It is used to get 'superscript' + -- or 'subscript' texts, and shall reduce the font size (if a smaller size + -- is available) accordingly. + , _fontVertAlign :: Maybe FontVerticalAlignment + } + 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 + -- | 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, Generic) + +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.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 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 +fmtDecimals :: Int -> NumberFormat +fmtDecimals k = UserNumberFormat $ "0." <> T.replicate k "#" + +-- | Basic number format with predefined number of decimals. +-- Works like 'fmtDecimals' with the only difference that extra zeroes are +-- displayed when number of digits after the point is less than the number +-- of digits specified in the format +fmtDecimalsZeroes :: Int -> NumberFormat +fmtDecimalsZeroes k = UserNumberFormat $ "0." <> T.replicate k "0" + +-- | Implied number formats +-- +-- /Note:/ This only implements the predefined values for 18.2.30 "All Languages", +-- other built-in format ids (with id < 'firstUserNumFmtId') are stored in 'NfOtherBuiltin' +data ImpliedNumberFormat = + NfGeneral -- ^> 0 General + | NfZero -- ^> 1 0 + | Nf2Decimal -- ^> 2 0.00 + | NfMax3Decimal -- ^> 3 #,##0 + | NfThousandSeparator2Decimal -- ^> 4 #,##0.00 + | NfPercent -- ^> 9 0% + | NfPercent2Decimal -- ^> 10 0.00% + | NfExponent2Decimal -- ^> 11 0.00E+00 + | NfSingleSpacedFraction -- ^> 12 # ?/? + | NfDoubleSpacedFraction -- ^> 13 # ??/?? + | NfMmDdYy -- ^> 14 mm-dd-yy + | NfDMmmYy -- ^> 15 d-mmm-yy + | NfDMmm -- ^> 16 d-mmm + | NfMmmYy -- ^> 17 mmm-yy + | NfHMm12Hr -- ^> 18 h:mm AM/PM + | NfHMmSs12Hr -- ^> 19 h:mm:ss AM/PM + | NfHMm -- ^> 20 h:mm + | NfHMmSs -- ^> 21 h:mm:ss + | NfMdyHMm -- ^> 22 m/d/yy h:mm + | NfThousandsNegativeParens -- ^> 37 #,##0 ;(#,##0) + | NfThousandsNegativeRed -- ^> 38 #,##0 ;[Red](#,##0) + | NfThousands2DecimalNegativeParens -- ^> 39 #,##0.00;(#,##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 (Eq, Ord, Show, Generic) + +instance NFData ImpliedNumberFormat + +stdNumberFormatId :: ImpliedNumberFormat -> Int +stdNumberFormatId NfGeneral = 0 -- General +stdNumberFormatId NfZero = 1 -- 0 +stdNumberFormatId Nf2Decimal = 2 -- 0.00 +stdNumberFormatId NfMax3Decimal = 3 -- #,##0 +stdNumberFormatId NfThousandSeparator2Decimal = 4 -- #,##0.00 +stdNumberFormatId NfPercent = 9 -- 0% +stdNumberFormatId NfPercent2Decimal = 10 -- 0.00% +stdNumberFormatId NfExponent2Decimal = 11 -- 0.00E+00 +stdNumberFormatId NfSingleSpacedFraction = 12 -- # ?/? +stdNumberFormatId NfDoubleSpacedFraction = 13 -- # ??/?? +stdNumberFormatId NfMmDdYy = 14 -- mm-dd-yy +stdNumberFormatId NfDMmmYy = 15 -- d-mmm-yy +stdNumberFormatId NfDMmm = 16 -- d-mmm +stdNumberFormatId NfMmmYy = 17 -- mmm-yy +stdNumberFormatId NfHMm12Hr = 18 -- h:mm AM/PM +stdNumberFormatId NfHMmSs12Hr = 19 -- h:mm:ss AM/PM +stdNumberFormatId NfHMm = 20 -- h:mm +stdNumberFormatId NfHMmSs = 21 -- h:mm:ss +stdNumberFormatId NfMdyHMm = 22 -- m/d/yy h:mm +stdNumberFormatId NfThousandsNegativeParens = 37 -- #,##0 ;(#,##0) +stdNumberFormatId NfThousandsNegativeRed = 38 -- #,##0 ;[Red](#,##0) +stdNumberFormatId NfThousands2DecimalNegativeParens = 39 -- #,##0.00;(#,##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 +stdNumberFormatId NfExponent1Decimal = 48 -- ##0.0E+0 +stdNumberFormatId NfTextPlaceHolder = 49 -- @ +stdNumberFormatId (NfOtherImplied i) = i + +idToStdNumberFormat :: Int -> Maybe ImpliedNumberFormat +idToStdNumberFormat 0 = Just NfGeneral -- General +idToStdNumberFormat 1 = Just NfZero -- 0 +idToStdNumberFormat 2 = Just Nf2Decimal -- 0.00 +idToStdNumberFormat 3 = Just NfMax3Decimal -- #,##0 +idToStdNumberFormat 4 = Just NfThousandSeparator2Decimal -- #,##0.00 +idToStdNumberFormat 9 = Just NfPercent -- 0% +idToStdNumberFormat 10 = Just NfPercent2Decimal -- 0.00% +idToStdNumberFormat 11 = Just NfExponent2Decimal -- 0.00E+00 +idToStdNumberFormat 12 = Just NfSingleSpacedFraction -- # ?/? +idToStdNumberFormat 13 = Just NfDoubleSpacedFraction -- # ??/?? +idToStdNumberFormat 14 = Just NfMmDdYy -- mm-dd-yy +idToStdNumberFormat 15 = Just NfDMmmYy -- d-mmm-yy +idToStdNumberFormat 16 = Just NfDMmm -- d-mmm +idToStdNumberFormat 17 = Just NfMmmYy -- mmm-yy +idToStdNumberFormat 18 = Just NfHMm12Hr -- h:mm AM/PM +idToStdNumberFormat 19 = Just NfHMmSs12Hr -- h:mm:ss AM/PM +idToStdNumberFormat 20 = Just NfHMm -- h:mm +idToStdNumberFormat 21 = Just NfHMmSs -- h:mm:ss +idToStdNumberFormat 22 = Just NfMdyHMm -- m/d/yy h:mm +idToStdNumberFormat 37 = Just NfThousandsNegativeParens -- #,##0 ;(#,##0) +idToStdNumberFormat 38 = Just NfThousandsNegativeRed -- #,##0 ;[Red](#,##0) +idToStdNumberFormat 39 = Just NfThousands2DecimalNegativeParens -- #,##0.00;(#,##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 +idToStdNumberFormat 48 = Just NfExponent1Decimal -- ##0.0E+0 +idToStdNumberFormat 49 = Just NfTextPlaceHolder -- @ +idToStdNumberFormat i = if i < firstUserNumFmtId then Just (NfOtherImplied i) else Nothing + +firstUserNumFmtId :: Int +firstUserNumFmtId = 164 + +-- | Protection properties +-- +-- Contains protection properties associated with the cell. Each cell has +-- protection properties that can be set. The cell protection properties do not +-- take effect unless the sheet has been protected. +-- +-- Section 18.8.33, "protection (Protection Properties)", p. 1793 +data Protection = Protection { + _protectionHidden :: Maybe Bool + , _protectionLocked :: Maybe Bool + } + deriving (Eq, Ord, Show, Generic) +instance NFData Protection + +{------------------------------------------------------------------------------- + Enumerations +-------------------------------------------------------------------------------} + +-- | Horizontal alignment in cells +-- +-- See 18.18.40 "ST_HorizontalAlignment (Horizontal Alignment Type)" (p. 2459) +data CellHorizontalAlignment = + CellHorizontalAlignmentCenter + | CellHorizontalAlignmentCenterContinuous + | CellHorizontalAlignmentDistributed + | CellHorizontalAlignmentFill + | CellHorizontalAlignmentGeneral + | CellHorizontalAlignmentJustify + | CellHorizontalAlignmentLeft + | CellHorizontalAlignmentRight + deriving (Eq, Ord, Show, Generic) +instance NFData CellHorizontalAlignment + +-- | Vertical alignment in cells +-- +-- See 18.18.88 "ST_VerticalAlignment (Vertical Alignment Types)" (p. 2512) +data CellVerticalAlignment = + CellVerticalAlignmentBottom + | CellVerticalAlignmentCenter + | CellVerticalAlignmentDistributed + | CellVerticalAlignmentJustify + | CellVerticalAlignmentTop + deriving (Eq, Ord, Show, Generic) +instance NFData CellVerticalAlignment + +-- | Font family +-- +-- See 18.8.18 "family (Font Family)" (p. 1766) +-- and 17.18.30 "ST_FontFamily (Font Family Value)" (p. 1388) +data FontFamily = + -- | Family is not applicable + FontFamilyNotApplicable + + -- | Proportional font with serifs + | FontFamilyRoman + + -- | Proportional font without serifs + | FontFamilySwiss + + -- | Monospace font with or without serifs + | FontFamilyModern + + -- | Script font designed to mimic the appearance of handwriting + | FontFamilyScript + + -- | Novelty font + | FontFamilyDecorative + deriving (Eq, Ord, Show, Generic) +instance NFData FontFamily + +-- | Font scheme +-- +-- See 18.18.33 "ST_FontScheme (Font scheme Styles)" (p. 2456) +data FontScheme = + -- | This font is the major font for this theme. + FontSchemeMajor + + -- | This font is the minor font for this theme. + | FontSchemeMinor + + -- | This font is not a theme font. + | FontSchemeNone + deriving (Eq, Ord, Show, Generic) +instance NFData FontScheme + +-- | Font underline property +-- +-- See 18.4.13 "u (Underline)", p 1728 +data FontUnderline = + FontUnderlineSingle + | FontUnderlineDouble + | FontUnderlineSingleAccounting + | FontUnderlineDoubleAccounting + | FontUnderlineNone + deriving (Eq, Ord, Show, Generic) +instance NFData FontUnderline + +-- | Vertical alignment +-- +-- See 22.9.2.17 "ST_VerticalAlignRun (Vertical Positioning Location)" (p. 3794) +data FontVerticalAlignment = + FontVerticalAlignmentBaseline + | FontVerticalAlignmentSubscript + | FontVerticalAlignmentSuperscript + deriving (Eq, Ord, Show, Generic) +instance NFData FontVerticalAlignment + +data LineStyle = + LineStyleDashDot + | LineStyleDashDotDot + | LineStyleDashed + | LineStyleDotted + | LineStyleDouble + | LineStyleHair + | LineStyleMedium + | LineStyleMediumDashDot + | LineStyleMediumDashDotDot + | LineStyleMediumDashed + | LineStyleNone + | LineStyleSlantDashDot + | LineStyleThick + | LineStyleThin + deriving (Eq, Ord, Show, Generic) +instance NFData LineStyle + +-- | Indicates the style of fill pattern being used for a cell format. +-- +-- Section 18.18.55 "ST_PatternType (Pattern Type)" (p. 2472) +data PatternType = + PatternTypeDarkDown + | PatternTypeDarkGray + | PatternTypeDarkGrid + | PatternTypeDarkHorizontal + | PatternTypeDarkTrellis + | PatternTypeDarkUp + | PatternTypeDarkVertical + | PatternTypeGray0625 + | PatternTypeGray125 + | PatternTypeLightDown + | PatternTypeLightGray + | PatternTypeLightGrid + | PatternTypeLightHorizontal + | PatternTypeLightTrellis + | PatternTypeLightUp + | PatternTypeLightVertical + | PatternTypeMediumGray + | PatternTypeNone + | PatternTypeSolid + deriving (Eq, Ord, Show, Generic) +instance NFData PatternType + +-- | Reading order +-- +-- See 18.8.1 "alignment (Alignment)" (p. 1754, esp. p. 1755) +data ReadingOrder = + ReadingOrderContextDependent + | ReadingOrderLeftToRight + | ReadingOrderRightToLeft + deriving (Eq, Ord, Show, Generic) +instance NFData ReadingOrder + +{------------------------------------------------------------------------------- + Lenses +-------------------------------------------------------------------------------} + +makeLenses ''StyleSheet +makeLenses ''CellXf +makeLenses ''Dxf + +makeLenses ''Alignment +makeLenses ''Border +makeLenses ''BorderStyle +makeLenses ''Color +makeLenses ''Fill +makeLenses ''FillPattern +makeLenses ''Font +makeLenses ''Protection + +{------------------------------------------------------------------------------- + Minimal stylesheet +-------------------------------------------------------------------------------} + +-- | Minimal style sheet +-- +-- Excel expects some minimal definitions in the stylesheet; you probably want +-- to define your own stylesheets based on this one. +-- +-- This more-or-less follows the recommendations at +-- , +-- but with some additions based on experimental evidence. +minimalStyleSheet :: StyleSheet +minimalStyleSheet = def + & styleSheetBorders .~ [defaultBorder] + & styleSheetFonts .~ [defaultFont] + & styleSheetFills .~ [fillNone, fillGray125] + & styleSheetCellXfs .~ [defaultCellXf] + where + -- The 'Default' instance for 'Border' uses 'left' and 'right' rather than + -- 'start' and 'end', because this is what Excel does (even though the spec + -- says different) + defaultBorder :: Border + defaultBorder = def + & borderBottom .~ Just def + & borderTop .~ Just def + & borderLeft .~ Just def + & borderRight .~ Just def + + defaultFont :: Font + defaultFont = def + & fontFamily .~ Just FontFamilySwiss + & fontSize .~ Just 11 + + fillNone, fillGray125 :: Fill + fillNone = def + & fillPattern .~ Just (def & fillPatternType .~ Just PatternTypeNone) + fillGray125 = def + & fillPattern .~ Just (def & fillPatternType .~ Just PatternTypeGray125) + + defaultCellXf :: CellXf + defaultCellXf = def + & cellXfBorderId .~ Just 0 + & cellXfFillId .~ Just 0 + & cellXfFontId .~ Just 0 + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default StyleSheet where + def = StyleSheet { + _styleSheetBorders = [] + , _styleSheetFonts = [] + , _styleSheetFills = [] + , _styleSheetCellXfs = [] + , _styleSheetDxfs = [] + , _styleSheetNumFmts = M.empty + } + +instance Default CellXf where + def = CellXf { + _cellXfApplyAlignment = Nothing + , _cellXfApplyBorder = Nothing + , _cellXfApplyFill = Nothing + , _cellXfApplyFont = Nothing + , _cellXfApplyNumberFormat = Nothing + , _cellXfApplyProtection = Nothing + , _cellXfBorderId = Nothing + , _cellXfFillId = Nothing + , _cellXfFontId = Nothing + , _cellXfNumFmtId = Nothing + , _cellXfPivotButton = Nothing + , _cellXfQuotePrefix = Nothing + , _cellXfId = Nothing + , _cellXfAlignment = Nothing + , _cellXfProtection = Nothing + } + +instance Default Dxf where + def = Dxf + { _dxfFont = Nothing + , _dxfNumFmt = Nothing + , _dxfFill = Nothing + , _dxfAlignment = Nothing + , _dxfBorder = Nothing + , _dxfProtection = Nothing + } + +instance Default Alignment where + def = Alignment { + _alignmentHorizontal = Nothing + , _alignmentIndent = Nothing + , _alignmentJustifyLastLine = Nothing + , _alignmentReadingOrder = Nothing + , _alignmentRelativeIndent = Nothing + , _alignmentShrinkToFit = Nothing + , _alignmentTextRotation = Nothing + , _alignmentVertical = Nothing + , _alignmentWrapText = Nothing + } + +instance Default Border where + def = Border { + _borderDiagonalDown = Nothing + , _borderDiagonalUp = Nothing + , _borderOutline = Nothing + , _borderBottom = Nothing + , _borderDiagonal = Nothing + , _borderEnd = Nothing + , _borderHorizontal = Nothing + , _borderStart = Nothing + , _borderTop = Nothing + , _borderVertical = Nothing + , _borderLeft = Nothing + , _borderRight = Nothing + } + +instance Default BorderStyle where + def = BorderStyle { + _borderStyleColor = Nothing + , _borderStyleLine = Nothing + } + +instance Default Color where + def = Color { + _colorAutomatic = Nothing + , _colorARGB = Nothing + , _colorTheme = Nothing + , _colorTint = Nothing + } + +instance Default Fill where + def = Fill { + _fillPattern = Nothing + } + +instance Default FillPattern where + def = FillPattern { + _fillPatternBgColor = Nothing + , _fillPatternFgColor = Nothing + , _fillPatternType = Nothing + } + +instance Default Font where + def = Font { + _fontBold = Nothing + , _fontCharset = Nothing + , _fontColor = Nothing + , _fontCondense = Nothing + , _fontExtend = Nothing + , _fontFamily = Nothing + , _fontItalic = Nothing + , _fontName = Nothing + , _fontOutline = Nothing + , _fontScheme = Nothing + , _fontShadow = Nothing + , _fontStrikeThrough = Nothing + , _fontSize = Nothing + , _fontUnderline = Nothing + , _fontVertAlign = Nothing + } + +instance Default Protection where + def = Protection { + _protectionHidden = Nothing + , _protectionLocked = Nothing + } + +{------------------------------------------------------------------------------- + Rendering record types + + NOTE: Excel is sensitive to the order of the child nodes, so we are careful + to follow the XML schema here. We are also careful to follow the ordering + for attributes, although this is actually pointless, as xml-conduit stores + these as a Map, so we lose the ordering. But if we change representation, + at least they are in the right order (hopefully) in the source code. +-------------------------------------------------------------------------------} + +instance ToDocument StyleSheet where + toDocument = documentFromElement "Stylesheet generated by xlsx" + . toElement "styleSheet" + +-- | See @CT_Stylesheet@, p. 4482 +instance ToElement StyleSheet where + toElement nm StyleSheet{..} = elementListSimple nm elements + where + 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) ++ + -- TODO: cellStyles + countedElementList' "dxfs" (map (toElement "dxf") _styleSheetDxfs) + -- TODO: tableStyles + -- TODO: colors + -- TODO: extLst + numFmts = map (uncurry NumFmt) $ M.toList _styleSheetNumFmts + +-- | See @CT_Xf@, p. 4486 +instance ToElement CellXf where + toElement nm CellXf{..} = Element { + elementName = nm + , elementNodes = map NodeElement . catMaybes $ [ + toElement "alignment" <$> _cellXfAlignment + , toElement "protection" <$> _cellXfProtection + -- TODO: extLst + ] + , elementAttributes = M.fromList . catMaybes $ [ + "numFmtId" .=? _cellXfNumFmtId + , "fontId" .=? _cellXfFontId + , "fillId" .=? _cellXfFillId + , "borderId" .=? _cellXfBorderId + , "xfId" .=? _cellXfId + , "quotePrefix" .=? _cellXfQuotePrefix + , "pivotButton" .=? _cellXfPivotButton + , "applyNumberFormat" .=? _cellXfApplyNumberFormat + , "applyFont" .=? _cellXfApplyFont + , "applyFill" .=? _cellXfApplyFill + , "applyBorder" .=? _cellXfApplyBorder + , "applyAlignment" .=? _cellXfApplyAlignment + , "applyProtection" .=? _cellXfApplyProtection + ] + } + +-- | See @CT_Dxf@, p. 3937 +instance ToElement Dxf where + toElement nm Dxf{..} = Element + { elementName = nm + , elementNodes = map NodeElement $ + catMaybes [ toElement "font" <$> _dxfFont + , toElement "numFmt" <$> _dxfNumFmt + , toElement "fill" <$> _dxfFill + , toElement "alignment" <$> _dxfAlignment + , toElement "border" <$> _dxfBorder + , toElement "protection" <$> _dxfProtection + ] + , elementAttributes = M.empty + } + +-- | See @CT_CellAlignment@, p. 4482 +instance ToElement Alignment where + toElement nm Alignment{..} = Element { + elementName = nm + , elementNodes = [] + , elementAttributes = M.fromList . catMaybes $ [ + "horizontal" .=? _alignmentHorizontal + , "vertical" .=? _alignmentVertical + , "textRotation" .=? _alignmentTextRotation + , "wrapText" .=? _alignmentWrapText + , "relativeIndent" .=? _alignmentRelativeIndent + , "indent" .=? _alignmentIndent + , "justifyLastLine" .=? _alignmentJustifyLastLine + , "shrinkToFit" .=? _alignmentShrinkToFit + , "readingOrder" .=? _alignmentReadingOrder + ] + } + +-- | See @CT_Border@, p. 4483 +instance ToElement Border where + toElement nm Border{..} = Element { + elementName = nm + , elementAttributes = M.fromList . catMaybes $ [ + "diagonalUp" .=? _borderDiagonalUp + , "diagonalDown" .=? _borderDiagonalDown + , "outline" .=? _borderOutline + ] + , elementNodes = map NodeElement . catMaybes $ [ + toElement "start" <$> _borderStart + , toElement "end" <$> _borderEnd + , toElement "left" <$> _borderLeft + , toElement "right" <$> _borderRight + , toElement "top" <$> _borderTop + , toElement "bottom" <$> _borderBottom + , toElement "diagonal" <$> _borderDiagonal + , toElement "vertical" <$> _borderVertical + , toElement "horizontal" <$> _borderHorizontal + ] + } + +-- | See @CT_BorderPr@, p. 4483 +instance ToElement BorderStyle where + toElement nm BorderStyle{..} = Element { + elementName = nm + , elementAttributes = M.fromList . catMaybes $ [ + "style" .=? _borderStyleLine + ] + , elementNodes = map NodeElement . catMaybes $ [ + toElement "color" <$> _borderStyleColor + ] + } + +-- | See @CT_Color@, p. 4484 +instance ToElement Color where + toElement nm Color{..} = Element { + elementName = nm + , elementNodes = [] + , elementAttributes = M.fromList . catMaybes $ [ + "auto" .=? _colorAutomatic + , "rgb" .=? _colorARGB + , "theme" .=? _colorTheme + , "tint" .=? _colorTint + ] + } + +-- | See @CT_Fill@, p. 4484 +instance ToElement Fill where + toElement nm Fill{..} = Element { + elementName = nm + , elementAttributes = M.empty + , elementNodes = map NodeElement . catMaybes $ [ + toElement "patternFill" <$> _fillPattern + ] + } + +-- | See @CT_PatternFill@, p. 4484 +instance ToElement FillPattern where + toElement nm FillPattern{..} = Element { + elementName = nm + , elementAttributes = M.fromList . catMaybes $ [ + "patternType" .=? _fillPatternType + ] + , elementNodes = map NodeElement . catMaybes $ [ + toElement "fgColor" <$> _fillPatternFgColor + , toElement "bgColor" <$> _fillPatternBgColor + ] + } + +-- | See @CT_Font@, p. 4489 +instance ToElement Font where + toElement nm Font{..} = Element { + elementName = nm + , elementAttributes = M.empty -- all properties specified as child nodes + , elementNodes = map NodeElement . catMaybes $ [ + elementValue "name" <$> _fontName + , elementValue "charset" <$> _fontCharset + , elementValue "family" <$> _fontFamily + , elementValue "b" <$> _fontBold + , elementValue "i" <$> _fontItalic + , elementValue "strike" <$> _fontStrikeThrough + , elementValue "outline" <$> _fontOutline + , elementValue "shadow" <$> _fontShadow + , elementValue "condense" <$> _fontCondense + , elementValue "extend" <$> _fontExtend + , toElement "color" <$> _fontColor + , elementValue "sz" <$> _fontSize + , elementValue "u" <$> _fontUnderline + , elementValue "vertAlign" <$> _fontVertAlign + , elementValue "scheme" <$> _fontScheme + ] + } + +-- | 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 { + elementName = nm + , elementNodes = [] + , elementAttributes = M.fromList . catMaybes $ [ + "locked" .=? _protectionLocked + , "hidden" .=? _protectionHidden + ] + } + +{------------------------------------------------------------------------------- + Rendering attribute values +-------------------------------------------------------------------------------} + +instance ToAttrVal CellHorizontalAlignment where + toAttrVal CellHorizontalAlignmentCenter = "center" + toAttrVal CellHorizontalAlignmentCenterContinuous = "centerContinuous" + toAttrVal CellHorizontalAlignmentDistributed = "distributed" + toAttrVal CellHorizontalAlignmentFill = "fill" + toAttrVal CellHorizontalAlignmentGeneral = "general" + toAttrVal CellHorizontalAlignmentJustify = "justify" + toAttrVal CellHorizontalAlignmentLeft = "left" + toAttrVal CellHorizontalAlignmentRight = "right" + +instance ToAttrVal CellVerticalAlignment where + toAttrVal CellVerticalAlignmentBottom = "bottom" + toAttrVal CellVerticalAlignmentCenter = "center" + toAttrVal CellVerticalAlignmentDistributed = "distributed" + toAttrVal CellVerticalAlignmentJustify = "justify" + toAttrVal CellVerticalAlignmentTop = "top" + +instance ToAttrVal FontFamily where + toAttrVal FontFamilyNotApplicable = "0" + toAttrVal FontFamilyRoman = "1" + toAttrVal FontFamilySwiss = "2" + toAttrVal FontFamilyModern = "3" + toAttrVal FontFamilyScript = "4" + toAttrVal FontFamilyDecorative = "5" + +instance ToAttrVal FontScheme where + toAttrVal FontSchemeMajor = "major" + toAttrVal FontSchemeMinor = "minor" + toAttrVal FontSchemeNone = "none" + +-- See @ST_UnderlineValues@, p. 3940 +instance ToAttrVal FontUnderline where + toAttrVal FontUnderlineSingle = "single" + toAttrVal FontUnderlineDouble = "double" + toAttrVal FontUnderlineSingleAccounting = "singleAccounting" + toAttrVal FontUnderlineDoubleAccounting = "doubleAccounting" + toAttrVal FontUnderlineNone = "none" + +instance ToAttrVal FontVerticalAlignment where + toAttrVal FontVerticalAlignmentBaseline = "baseline" + toAttrVal FontVerticalAlignmentSubscript = "subscript" + toAttrVal FontVerticalAlignmentSuperscript = "superscript" + +instance ToAttrVal LineStyle where + toAttrVal LineStyleDashDot = "dashDot" + toAttrVal LineStyleDashDotDot = "dashDotDot" + toAttrVal LineStyleDashed = "dashed" + toAttrVal LineStyleDotted = "dotted" + toAttrVal LineStyleDouble = "double" + toAttrVal LineStyleHair = "hair" + toAttrVal LineStyleMedium = "medium" + toAttrVal LineStyleMediumDashDot = "mediumDashDot" + toAttrVal LineStyleMediumDashDotDot = "mediumDashDotDot" + toAttrVal LineStyleMediumDashed = "mediumDashed" + toAttrVal LineStyleNone = "none" + toAttrVal LineStyleSlantDashDot = "slantDashDot" + toAttrVal LineStyleThick = "thick" + toAttrVal LineStyleThin = "thin" + +instance ToAttrVal PatternType where + toAttrVal PatternTypeDarkDown = "darkDown" + toAttrVal PatternTypeDarkGray = "darkGray" + toAttrVal PatternTypeDarkGrid = "darkGrid" + toAttrVal PatternTypeDarkHorizontal = "darkHorizontal" + toAttrVal PatternTypeDarkTrellis = "darkTrellis" + toAttrVal PatternTypeDarkUp = "darkUp" + toAttrVal PatternTypeDarkVertical = "darkVertical" + toAttrVal PatternTypeGray0625 = "gray0625" + toAttrVal PatternTypeGray125 = "gray125" + toAttrVal PatternTypeLightDown = "lightDown" + toAttrVal PatternTypeLightGray = "lightGray" + toAttrVal PatternTypeLightGrid = "lightGrid" + toAttrVal PatternTypeLightHorizontal = "lightHorizontal" + toAttrVal PatternTypeLightTrellis = "lightTrellis" + toAttrVal PatternTypeLightUp = "lightUp" + toAttrVal PatternTypeLightVertical = "lightVertical" + toAttrVal PatternTypeMediumGray = "mediumGray" + toAttrVal PatternTypeNone = "none" + toAttrVal PatternTypeSolid = "solid" + +instance ToAttrVal ReadingOrder where + toAttrVal ReadingOrderContextDependent = "0" + toAttrVal ReadingOrderLeftToRight = "1" + toAttrVal ReadingOrderRightToLeft = "2" + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} +-- | See @CT_Stylesheet@, p. 4482 +instance FromCursor StyleSheet where + fromCursor cur = do + let + _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 (addSmlNamespace "cellXfs") &/ element (addSmlNamespace "xf") >=> fromCursor + -- TODO: cellStyles + _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 + return StyleSheet{..} + +-- | See @CT_Font@, p. 4489 +instance FromCursor Font where + fromCursor cur = do + _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) +instance FromAttrVal FontFamily where + fromAttrVal "0" = readSuccess FontFamilyNotApplicable + fromAttrVal "1" = readSuccess FontFamilyRoman + fromAttrVal "2" = readSuccess FontFamilySwiss + fromAttrVal "3" = readSuccess FontFamilyModern + fromAttrVal "4" = readSuccess FontFamilyScript + 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 + _colorAutomatic <- maybeAttribute "auto" cur + _colorARGB <- maybeAttribute "rgb" cur + _colorTheme <- maybeAttribute "theme" cur + _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 + fromAttrVal "double" = readSuccess FontUnderlineDouble + fromAttrVal "singleAccounting" = readSuccess FontUnderlineSingleAccounting + fromAttrVal "doubleAccounting" = readSuccess FontUnderlineDoubleAccounting + 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 (addSmlNamespace "patternFill") cur + return Fill{..} + +-- | See @CT_PatternFill@, p. 4484 +instance FromCursor FillPattern where + fromCursor cur = do + _fillPatternType <- maybeAttribute "patternType" cur + _fillPatternFgColor <- maybeFromElement (addSmlNamespace "fgColor") cur + _fillPatternBgColor <- maybeFromElement (addSmlNamespace "bgColor") cur + return FillPattern{..} + +instance FromAttrVal PatternType where + fromAttrVal "darkDown" = readSuccess PatternTypeDarkDown + fromAttrVal "darkGray" = readSuccess PatternTypeDarkGray + fromAttrVal "darkGrid" = readSuccess PatternTypeDarkGrid + fromAttrVal "darkHorizontal" = readSuccess PatternTypeDarkHorizontal + fromAttrVal "darkTrellis" = readSuccess PatternTypeDarkTrellis + fromAttrVal "darkUp" = readSuccess PatternTypeDarkUp + fromAttrVal "darkVertical" = readSuccess PatternTypeDarkVertical + fromAttrVal "gray0625" = readSuccess PatternTypeGray0625 + fromAttrVal "gray125" = readSuccess PatternTypeGray125 + fromAttrVal "lightDown" = readSuccess PatternTypeLightDown + fromAttrVal "lightGray" = readSuccess PatternTypeLightGray + fromAttrVal "lightGrid" = readSuccess PatternTypeLightGrid + fromAttrVal "lightHorizontal" = readSuccess PatternTypeLightHorizontal + fromAttrVal "lightTrellis" = readSuccess PatternTypeLightTrellis + fromAttrVal "lightUp" = readSuccess PatternTypeLightUp + fromAttrVal "lightVertical" = readSuccess PatternTypeLightVertical + fromAttrVal "mediumGray" = readSuccess PatternTypeMediumGray + fromAttrVal "none" = readSuccess PatternTypeNone + fromAttrVal "solid" = readSuccess PatternTypeSolid + fromAttrVal t = invalidText "PatternType" t + +-- | See @CT_Border@, p. 4483 +instance FromCursor Border where + fromCursor cur = do + _borderDiagonalUp <- maybeAttribute "diagonalUp" cur + _borderDiagonalDown <- maybeAttribute "diagonalDown" cur + _borderOutline <- maybeAttribute "outline" 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 (addSmlNamespace "color") cur + return BorderStyle{..} + +instance FromAttrVal LineStyle where + fromAttrVal "dashDot" = readSuccess LineStyleDashDot + fromAttrVal "dashDotDot" = readSuccess LineStyleDashDotDot + fromAttrVal "dashed" = readSuccess LineStyleDashed + fromAttrVal "dotted" = readSuccess LineStyleDotted + fromAttrVal "double" = readSuccess LineStyleDouble + fromAttrVal "hair" = readSuccess LineStyleHair + fromAttrVal "medium" = readSuccess LineStyleMedium + fromAttrVal "mediumDashDot" = readSuccess LineStyleMediumDashDot + fromAttrVal "mediumDashDotDot" = readSuccess LineStyleMediumDashDotDot + fromAttrVal "mediumDashed" = readSuccess LineStyleMediumDashed + fromAttrVal "none" = readSuccess LineStyleNone + fromAttrVal "slantDashDot" = readSuccess LineStyleSlantDashDot + fromAttrVal "thick" = readSuccess LineStyleThick + fromAttrVal "thin" = readSuccess LineStyleThin + fromAttrVal t = invalidText "LineStyle" t + +-- | See @CT_Xf@, p. 4486 +instance FromCursor CellXf where + fromCursor cur = do + _cellXfAlignment <- maybeFromElement (addSmlNamespace "alignment") cur + _cellXfProtection <- maybeFromElement (addSmlNamespace "protection") cur + _cellXfNumFmtId <- maybeAttribute "numFmtId" cur + _cellXfFontId <- maybeAttribute "fontId" cur + _cellXfFillId <- maybeAttribute "fillId" cur + _cellXfBorderId <- maybeAttribute "borderId" cur + _cellXfId <- maybeAttribute "xfId" cur + _cellXfQuotePrefix <- maybeAttribute "quotePrefix" cur + _cellXfPivotButton <- maybeAttribute "pivotButton" cur + _cellXfApplyNumberFormat <- maybeAttribute "applyNumberFormat" cur + _cellXfApplyFont <- maybeAttribute "applyFont" cur + _cellXfApplyFill <- maybeAttribute "applyFill" cur + _cellXfApplyBorder <- maybeAttribute "applyBorder" cur + _cellXfApplyAlignment <- maybeAttribute "applyAlignment" cur + _cellXfApplyProtection <- maybeAttribute "applyProtection" cur + return CellXf{..} + +-- | See @CT_Dxf@, p. 3937 +instance FromCursor Dxf where + fromCursor cur = do + _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 + fromCursor cur = do + _alignmentHorizontal <- maybeAttribute "horizontal" cur + _alignmentVertical <- maybeAttribute "vertical" cur + _alignmentTextRotation <- maybeAttribute "textRotation" cur + _alignmentWrapText <- maybeAttribute "wrapText" cur + _alignmentRelativeIndent <- maybeAttribute "relativeIndent" cur + _alignmentIndent <- maybeAttribute "indent" cur + _alignmentJustifyLastLine <- maybeAttribute "justifyLastLine" cur + _alignmentShrinkToFit <- maybeAttribute "shrinkToFit" cur + _alignmentReadingOrder <- maybeAttribute "readingOrder" cur + return Alignment{..} + +instance FromAttrVal CellHorizontalAlignment where + fromAttrVal "center" = readSuccess CellHorizontalAlignmentCenter + fromAttrVal "centerContinuous" = readSuccess CellHorizontalAlignmentCenterContinuous + fromAttrVal "distributed" = readSuccess CellHorizontalAlignmentDistributed + fromAttrVal "fill" = readSuccess CellHorizontalAlignmentFill + fromAttrVal "general" = readSuccess CellHorizontalAlignmentGeneral + fromAttrVal "justify" = readSuccess CellHorizontalAlignmentJustify + fromAttrVal "left" = readSuccess CellHorizontalAlignmentLeft + fromAttrVal "right" = readSuccess CellHorizontalAlignmentRight + fromAttrVal t = invalidText "CellHorizontalAlignment" t + +instance FromAttrVal CellVerticalAlignment where + fromAttrVal "bottom" = readSuccess CellVerticalAlignmentBottom + fromAttrVal "center" = readSuccess CellVerticalAlignmentCenter + fromAttrVal "distributed" = readSuccess CellVerticalAlignmentDistributed + fromAttrVal "justify" = readSuccess CellVerticalAlignmentJustify + fromAttrVal "top" = readSuccess CellVerticalAlignmentTop + fromAttrVal t = invalidText "CellVerticalAlignment" t + +instance FromAttrVal ReadingOrder where + fromAttrVal "0" = readSuccess ReadingOrderContextDependent + fromAttrVal "1" = readSuccess ReadingOrderLeftToRight + fromAttrVal "2" = readSuccess ReadingOrderRightToLeft + fromAttrVal t = invalidText "ReadingOrder" t + +-- | See @CT_CellProtection@, p. 4484 +instance FromCursor Protection where + fromCursor cur = do + _protectionLocked <- maybeAttribute "locked" cur + _protectionHidden <- maybeAttribute "hidden" cur + return Protection{..} 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 new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Variant.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +module Codec.Xlsx.Types.Variant where + +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 + +data Variant + = VtBlob ByteString + | VtBool Bool + | VtDecimal Double + | VtLpwstr Text + | VtInt Int + -- TODO: vt_vector, vt_array, vt_oblob, vt_empty, vt_null, vt_i1, vt_i2, + -- 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, Generic) + +instance NFData Variant + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor Variant where + fromCursor = variantFromNode . node + +variantFromNode :: Node -> [Variant] +variantFromNode n@(NodeElement el) | elementName el == vt "lpwstr" = + fromNode n $/ content &| VtLpwstr + | elementName el == vt "bool" = + fromNode n $/ content >=> fmap VtBool . boolean + | elementName el == vt "int" = + fromNode n $/ content >=> fmap VtInt . decimal + | elementName el == vt "decimal" = + fromNode n $/ content >=> fmap VtDecimal . rational + | elementName el == vt "blob" = + fromNode n $/ content >=> fmap VtBlob . decodeBase64 . killWhitespace +variantFromNode _ = fail "no matching nodes" + +killWhitespace :: Text -> Text +killWhitespace = T.filter (/=' ') + +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 + +-- | Add doc props variant types namespace to name +vt :: Text -> Name +vt x = Name + { nameLocalName = x + , nameNamespace = Just docPropsVtNs + , namePrefix = Nothing + } + +docPropsVtNs :: Text +docPropsVtNs = "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +variantToElement :: Variant -> Element +variantToElement (VtLpwstr t) = elementContent (vt"lpwstr") t +variantToElement (VtBlob bs) = elementContent (vt"blob") (T.decodeLatin1 $ B64.encode bs) +variantToElement (VtBool b) = elementContent (vt"bool") (txtb b) +variantToElement (VtDecimal d) = elementContent (vt"decimal") (txtd d) +variantToElement (VtInt i) = elementContent (vt"int") (txti i) 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,76 +1,401 @@ +{-# 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 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.Map (Map) +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.Text (Text, ) +import Data.Maybe +import Data.Monoid ((<>)) +import Data.STRef +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.Set as S -import Data.Vector (Vector) -import qualified Data.Vector as V -import Numeric.Search.Range (searchFromTo) -import System.Locale -import System.Time -import Text.XML - -import Codec.Xlsx.Types +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 GHC.Generics (Generic) +import Safe +import Text.XML +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 :: ClockTime -> Xlsx -> L.ByteString -fromXlsx ct xlsx = +fromXlsx :: POSIXTime -> Xlsx -> L.ByteString +fromXlsx pt xlsx = Zip.fromArchive $ foldr Zip.addEntryToArchive Zip.emptyArchive entries where - TOD t _ = ct + t = round pt + utcTime = posixSecondsToUTCTime pt entries = Zip.toEntry "[Content_Types].xml" t (contentTypesXml files) : - map (\fd -> Zip.toEntry (T.unpack $ fdName fd) t (fdContents fd)) files - files = sheetFiles ++ + map (\fd -> Zip.toEntry (fdPath fd) t (fdContents fd)) files + files = workbookFiles ++ customPropFiles ++ [ FileData "docProps/core.xml" - "application/vnd.openxmlformats-package.core-properties+xml" $ coreXml (toUTCTime ct) "xlsxwriter" + "application/vnd.openxmlformats-package.core-properties+xml" + "metadata/core-properties" $ coreXml utcTime "xlsxwriter" , FileData "docProps/app.xml" - "application/vnd.openxmlformats-officedocument.extended-properties+xml" $ appXml (xlsx ^. xlSheets) - , FileData "xl/workbook.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" $ bookXml (xlsx ^. xlSheets) - , FileData "xl/styles.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" $ unStyles (xlsx ^. xlStyles) - , FileData "xl/sharedStrings.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" $ ssXml $ V.toList shared - , FileData "xl/_rels/workbook.xml.rels" - "application/vnd.openxmlformats-package.relationships+xml" $ bookRelXml sheetCount - , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" rootRelXml + "application/vnd.openxmlformats-officedocument.extended-properties+xml" + "xtended-properties" $ appXml sheetNames + , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" + "relationships" rootRelXml ] - sheetFiles = - [ FileData ("xl/worksheets/sheet" <> txti n <> ".xml") - "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" $ - sheetXml (w ^. wsColumns) (w ^. wsRowPropertiesMap) cells (w ^. wsMerges) | - (n, cells, w) <- zip3 [1..] sheetCells sheets] - sheets = xlsx ^. xlSheets . to M.elems - sheetCount = length sheets - shared = V.fromList $ S.elems $ S.fromList $ concatMap (concatMap celltext . M.elems . _wsCells) sheets - sheetCells = map (transformSheetData shared) sheets - celltext (Cell{_cellValue=v}) = case v of - Just(CellText a) -> [a] - _ -> [] + rootRelXml = renderLBS def . toDocument $ Relationships.fromList rootRels + rootFiles = customPropFileRels ++ + [ ("officeDocument", "xl/workbook.xml") + , ("metadata/core-properties", "docProps/core.xml") + , ("extended-properties", "docProps/app.xml") ] + rootRels = [ relEntry (unsafeRefId i) typ trg + | (i, (typ, trg)) <- zip [1..] rootFiles ] + customProps = xlsx ^. xlCustomProperties + (customPropFiles, customPropFileRels) = case M.null customProps of + True -> ([], []) + False -> ([ FileData "docProps/custom.xml" + "application/vnd.openxmlformats-officedocument.custom-properties+xml" + "custom-properties" + (customPropsXml (CustomProperties customProps)) ], + [ ("custom-properties", "docProps/custom.xml") ]) + workbookFiles = bookFiles xlsx + sheetNames = xlsx ^. xlSheets & mapped %~ fst -data FileData = FileData { fdName :: Text +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" + "worksheet" $ + sheetXml + nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] + sheetXml= renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root [] + root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ + elementListSimple "worksheet" rootEls + rootEls = catMaybes $ + [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews + , 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 + mergeE1 r = leafElement "mergeCell" [("ref" .= r)] + + sheetRels = if null referencedFiles + then [] + else [ FileData ("xl/worksheets/_rels/sheet" <> show n <> ".xml.rels") + "application/vnd.openxmlformats-package.relationships+xml" + "relationships" sheetRelsXml ] + sheetRelsXml = renderLBS def . toDocument . Relationships.fromList $ + [ relEntry i fdRelType (fdPath `relFrom` sheetFilePath) + | (i, FileData{..}) <- referenced ] + referenced = fromMaybe [] (snd <$> mCmntData) ++ + catMaybes [ snd3 <$> mDrawingData ] ++ + pivRefs ++ + refTables + referencedFiles = map snd referenced + extraFiles = maybe [] thd3 mDrawingData + otherFiles = sheetRels ++ referencedFiles ++ extraFiles + + return (sheetFile, otherFiles) + +nextRefId :: STRef s Int -> ST s RefId +nextRefId r = do + num <- readSTRef r + modifySTRef' r (+1) + return (unsafeRefId num) + +sheetDataXml :: + Cells + -> Map RowIndex RowProperties + -> Map SharedFormulaIndex SharedFormulaOptions + -> [Element] +sheetDataXml rows rh sharedFormulas = + evalState (mapM rowEl rows) sharedFormulas + where + 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 = + if null comments + then do + return Nothing + else do + rId1 <- nextRefId ref + rId2 <- nextRefId ref + let el = refElement "legacyDrawing" rId2 + return $ Just (el, [(rId1, commentsFile), (rId2, vmlDrawingFile)]) + where + comments = concatMap (\(row, rowCells) -> mapMaybe (maybeCellComment row) rowCells) cells + maybeCellComment row (col, cell) = do + comment <- xlsxComment cell + return (singleCellRef (row, col), comment) + commentTable = CommentTable.fromList comments + commentsFile = FileData commentsPath + "application/vnd.openxmlformats-officedocument.spreadsheetml.comments+xml" + "comments" + commentsBS + commentsPath = "xl/comments" <> show n <> ".xml" + commentsBS = renderLBS def $ toDocument commentTable + vmlDrawingFile = FileData vmlPath + "application/vnd.openxmlformats-officedocument.vmlDrawing" + "vmlDrawing" + vmlDrawingBS + vmlPath = "xl/drawings/vmlDrawing" <> show n <> ".vml" + vmlDrawingBS = CommentTable.renderShapes commentTable + +genDrawing :: Int -> STRef s Int -> Drawing -> ST s (Element, ReferencedFileData, [FileData]) +genDrawing n ref dr = do + rId <- nextRefId ref + let el = refElement "drawing" rId + return (el, (rId, drawingFile), referenced) + where + drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml" + 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") + , ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] + dr' = Drawing{ _xdrAnchors = reverse anchors' } + (anchors', images, charts, _) = foldl' collectFile ([], [], [], 1) (dr ^. xdrAnchors) + collectFile :: ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int) + -> Anchor FileInfo ChartSpace + -> ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int) + collectFile (as, fis, chs, i) anch0 = + case anch0 ^. anchObject of + Picture {..} -> + let fi = (i,) <$> _picBlipFill ^. bfpImageInfo + pic' = + Picture + { _picMacro = _picMacro + , _picPublished = _picPublished + , _picNonVisual = _picNonVisual + , _picBlipFill = + (_picBlipFill & bfpImageInfo ?~ RefId ("rId" <> txti i)) + , _picShapeProperties = _picShapeProperties + } + anch = anch0 {_anchObject = pic'} + in (anch : as, fi : fis, chs, i + 1) + Graphic nv ch tr -> + let gr' = Graphic nv (RefId ("rId" <> txti i)) tr + anch = anch0 {_anchObject = gr'} + in (anch : as, fis, (i, ch) : chs, i + 1) + imageFiles = + [ ( unsafeRefId i + , FileData ("xl/media/" <> _fiFilename) _fiContentType "image" _fiContents) + | (i, FileInfo {..}) <- reverse (catMaybes images) + ] + + chartFiles = + [ (unsafeRefId i, genChart n k chart) + | (k, (i, chart)) <- zip [1 ..] (reverse charts) + ] + + innerFiles = imageFiles ++ chartFiles + + drawingRels = + FileData + ("xl/drawings/_rels/drawing" <> show n <> ".xml.rels") + relsCT + "relationships" + drawingRelsXml + + drawingRelsXml = + renderLBS def . toDocument . Relationships.fromList $ + map (refFileDataToRel drawingFilePath) innerFiles + + referenced = + case innerFiles of + [] -> [] + _ -> drawingRels : (map snd innerFiles) + +genChart :: Int -> Int -> ChartSpace -> FileData +genChart n i ch = FileData path contentType relType contents + where + path = "xl/charts/chart" <> show n <> "_" <> show i <> ".xml" + contentType = + "application/vnd.openxmlformats-officedocument.drawingml.chart+xml" + relType = "chart" + contents = renderLBS def {rsNamespaces = nss} $ toDocument ch + nss = + [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart") + , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") + ] + +data PvGenerated = PvGenerated + { pvgCacheFiles :: [(CacheId, FileData)] + , pvgSheetTableFiles :: [[FileData]] + , pvgOthers :: [FileData] + } + +generatePivotFiles :: [(CellMap, [PivotTable])] -> PvGenerated +generatePivotFiles cmTables = PvGenerated cacheFiles shTableFiles others + where + cacheFiles = [cacheFile | (cacheFile, _, _) <- flatRendered] + shTableFiles = map (map (\(_, tableFile, _) -> tableFile)) rendered + others = concat [other | (_, _, other) <- flatRendered] + firstCacheId = 1 + flatRendered = concat rendered + (_, rendered) = + mapAccumL + (\c (cm, ts) -> mapAccumL (\c' t -> (c' + 1, render cm c' t)) c ts) + firstCacheId + cmTables + render cm cacheIdRaw tbl = + let PivotTableFiles {..} = renderPivotTableFiles cm cacheIdRaw tbl + cacheId = CacheId cacheIdRaw + cacheIdStr = show cacheIdRaw + cachePath = + "xl/pivotCache/pivotCacheDefinition" <> cacheIdStr <> ".xml" + cacheFile = + FileData + cachePath + (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 = + FileData tablePath (smlCT "pivotTable") "pivotTable" pvtfTable + tableRels = + FileData + ("xl/pivotTables/_rels/pivotTable" <> cacheIdStr <> ".xml.rels") + relsCT + "relationships" $ + renderRels [refFileDataToRel tablePath (unsafeRefId 1, cacheFile)] + 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 - , fdContents :: L.ByteString} + , fdRelType :: Text + , fdContents :: L.ByteString } -coreXml :: CalendarTime -> Text -> L.ByteString +type ReferencedFileData = (RefId, FileData) + +refFileDataToRel :: FilePath -> ReferencedFileData -> (RefId, Relationship) +refFileDataToRel basePath (i, FileData {..}) = + relEntry i fdRelType (fdPath `relFrom` basePath) + +type Cells = [(RowIndex, [(ColumnIndex, XlsxCell)])] + +coreXml :: UTCTime -> Text -> L.ByteString coreXml created creator = renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root [] where @@ -80,7 +405,7 @@ , ("xsi","http://www.w3.org/2001/XMLSchema-instance") ] namespaced = nsName nss - date = T.pack $ formatCalendarTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" created + date = T.pack $ formatTime defaultTimeLocale "%FT%T%QZ" created root = Element (namespaced "cp" "coreProperties") M.empty [ nEl (namespaced "dcterms" "created") (M.fromList [(namespaced "xsi" "type", "dcterms:W3CDTF")]) [NodeContent date] @@ -88,134 +413,180 @@ , nEl (namespaced "cp" "lastModifiedBy") M.empty [NodeContent creator] ] -appXml :: Map Text Worksheet -> L.ByteString -appXml s = renderLBS def $ Document (Prologue [] Nothing []) root [] +appXml :: [Text] -> L.ByteString +appXml sheetNames = + renderLBS def $ Document (Prologue [] Nothing []) root [] where - nsAttrs = M.fromList [("xmlns:vt", "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")] + sheetCount = length sheetNames root = Element (extPropNm "Properties") nsAttrs [ extPropEl "TotalTime" [NodeContent "0"] , extPropEl "HeadingPairs" [ - vTypeEl "vector" (M.fromList [("size", "2"), ("baseType", "variant")]) - [ vTypeEl0 "variant" - [vTypeEl0 "lpstr" [NodeContent "Worksheets"]] - , vTypeEl0 "variant" - [vTypeEl0 "i4" [NodeContent $ txti $ M.size s]] - ] - ] + vTypeEl "vector" (M.fromList [ ("size", "2") + , ("baseType", "variant")]) + [ vTypeEl0 "variant" + [vTypeEl0 "lpstr" [NodeContent "Worksheets"]] + , vTypeEl0 "variant" + [vTypeEl0 "i4" [NodeContent $ txti sheetCount]] + ] + ] , extPropEl "TitlesOfParts" [ - vTypeEl "vector" (M.fromList [("size", txti $ M.size s),("baseType","lpstr")]) $ - map (vTypeEl0 "lpstr" . return . NodeContent) $ M.keys s - ] + vTypeEl "vector" (M.fromList [ ("size", txti sheetCount) + , ("baseType", "lpstr")]) $ + map (vTypeEl0 "lpstr" . return . NodeContent) sheetNames + ] ] + nsAttrs = M.fromList [("xmlns:vt", "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")] extPropNm n = nm "http://schemas.openxmlformats.org/officeDocument/2006/extended-properties" n extPropEl n = nEl (extPropNm n) M.empty 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 - } deriving (Show, Eq) + { xlsxCellStyle :: Maybe Int + , xlsxCellValue :: Maybe XlsxCellData + , xlsxComment :: Maybe Comment + , xlsxCellFormula :: Maybe CellFormula + } 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 :: XlsxCell -> Text -value XlsxCell{xlsxCellValue=Just(XlsxSS i)} = txti i -value XlsxCell{xlsxCellValue=Just(XlsxDouble d)} = txtd d -value XlsxCell{xlsxCellValue=Just(XlsxBool True)} = "1" -value XlsxCell{xlsxCellValue=Just(XlsxBool False)} = "0" -value _ = error "value undefined" +value :: XlsxCellData -> Text +value (XlsxSS i) = txti i +value (XlsxDouble d) = txtd d +value (XlsxBool True) = "1" +value (XlsxBool False) = "0" +value (XlsxError eType) = toAttrVal eType -transformSheetData :: Vector Text -> Worksheet -> [(Int, [(Int, XlsxCell)])] +transformSheetData :: SharedStringTable -> Worksheet -> Cells transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells) where transformRow = second (map transformCell) - transformCell (c, Cell{_cellValue=v, _cellStyle=s}) = - (c, XlsxCell s (fmap transformValue v)) - transformValue (CellText t) = - let Just i = searchFromTo (\p -> shared V.! p >= t) 0 (V.length shared - 1) - in XlsxSS i + transformCell (c, Cell{..}) = + (c, XlsxCell _cellStyle (fmap transformValue _cellValue) _cellComment _cellFormula) + transformValue (CellText t) = XlsxSS (sstLookupText shared t) transformValue (CellDouble dbl) = XlsxDouble dbl transformValue (CellBool b) = XlsxBool b + transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) + transformValue (CellError e) = XlsxError e -sheetXml :: [ColumnsWidth] -> Map Int RowProperties -> [(Int, [(Int, XlsxCell)])] -> [Text]-> L.ByteString -sheetXml cws rh rows merges = renderLBS def $ Document (Prologue [] Nothing []) root [] - where - cType = xlsxCellType - root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ - Element "worksheet" M.empty $ catMaybes - [nonEmptyNmEl "cols" M.empty $ map cwEl cws, - justNmEl "sheetData" M.empty $ map rowEl rows, - nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges] - cwEl cw = NodeElement $! Element "col" (M.fromList - [("min", txti $ cwMin cw), ("max", txti $ cwMax cw), ("width", txtd $ cwWidth cw), ("style", txti $ cwStyle cw)]) [] - rowEl (r, cells) = nEl "row" - (M.fromList (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,[]) - mergeE1 t = NodeElement $! Element "mergeCell" (M.fromList [("ref",t)]) [] - cellEl r (icol, cell) = - nEl "c" (M.fromList (cellAttrs r (int2col icol) cell)) - [nEl "v" M.empty [NodeContent $ value cell] | isJust $ xlsxCellValue cell] - cellAttrs r col cell = cellStyleAttr cell ++ [("r", T.concat [col, txti r]), ("t", cType cell)] - cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] - cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] +bookFiles :: Xlsx -> [FileData] +bookFiles xlsx = runST $ do + ref <- newSTRef 1 + ssRId <- nextRefId ref + let sheets = xlsx ^. xlSheets & mapped %~ snd + shared = sstConstruct sheets + sharedStrings = + (ssRId, FileData "xl/sharedStrings.xml" (smlCT "sharedStrings") "sharedStrings" $ + ssXml shared) + stRId <- nextRefId ref + let style = + (stRId, FileData "xl/styles.xml" (smlCT "styles") "styles" $ + unStyles (xlsx ^. xlStyles)) + 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 + (sheetFile, others) <- singleSheetFiles i cells pvTables sheet tblIdRef + return ((rId, sheetFile), others) + let sheetFiles = map fst allSheetFiles + 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 + return (cacheId, (refId, fd)) + let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ] + cacheRefs = map snd cacheRefFDsById + bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $ + bookXml sheetAttrsByRId (xlsx ^. xlDefinedNames) cacheRefsById (xlsx ^. xlDateBase) + rels = FileData "xl/_rels/workbook.xml.rels" + "application/vnd.openxmlformats-package.relationships+xml" + "relationships" relsXml + relsXml = renderLBS def . toDocument . Relationships.fromList $ + [ relEntry i fdRelType (fdPath `relFrom` "xl/workbook.xml") + | (i, FileData{..}) <- referenced ] + referenced = sharedStrings:style:sheetFiles ++ cacheRefs + otherFiles = concat [rels:(map snd referenced), pivotOtherFiles, sheetOthers] + return $ bookFile:otherFiles -bookXml :: Map Text Worksheet -> L.ByteString -bookXml wss = renderLBS def $ Document (Prologue [] Nothing []) root [] +bookXml :: [(RefId, Text, SheetState)] + -> DefinedNames + -> [(CacheId, RefId)] + -> DateBase + -> L.ByteString +bookXml rIdAttrs (DefinedNames names) cacheIdRefs dateBase = + renderLBS def {rsNamespaces = nss} $ Document (Prologue [] Nothing []) root [] where - numNames = [(txti i, name) | (i, name) <- zip [1..] (M.keys wss)] - root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ Element "workbook" M.empty - [nEl "sheets" M.empty $ - map (\(n, name) -> nEl "sheet" - (M.fromList [("name", name), ("sheetId", n), ("state", "visible"), - (rId, T.concat ["rId", n])]) []) numNames] - rId = nm "http://schemas.openxmlformats.org/officeDocument/2006/relationships" "id" + 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 + -- to define a bookViews with a single empty @workbookView@ element + -- (the @bookViews@ must contain at least one @wookbookView@). + root = + addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ + elementListSimple + "workbook" + ( [ 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) + ) -ssXml :: [Text] -> L.ByteString -ssXml ss = - renderLBS def $ Document (Prologue [] Nothing []) root [] - where - root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ Element "sst" M.empty $ - map (\s -> nEl "si" M.empty [nEl "t" M.empty [NodeContent s]]) ss + pivotCacheEl (CacheId cId, refId) = + leafElement "pivotCache" ["cacheId" .= cId, (odr "id") .= refId] -bookRelXml :: Int -> L.ByteString -bookRelXml n = renderLBS def $ Document (Prologue [] Nothing []) root [] - where - root = addNS "http://schemas.openxmlformats.org/package/2006/relationships" $ - Element "Relationships" M.empty $ - map (\sn -> relEl sn (T.concat ["worksheets/sheet", txti sn, ".xml"]) "worksheet") [1..n] - ++ - [relEl (n + 1) "styles.xml" "styles", relEl (n + 2) "sharedStrings.xml" "sharedStrings"] - relEl i target typ = - nEl "Relationship" - (M.fromList [("Id", T.concat ["rId", txti i]), ("Target", target), - ("Type", T.concat ["http://schemas.openxmlformats.org/officeDocument/2006/relationships/", typ])]) [] + definedName :: Text -> Maybe Text -> [(Name, Text)] + definedName name Nothing = ["name" .= name] + definedName name (Just lsId) = ["name" .= name, "localSheetId" .= lsId] -rootRelXml :: L.ByteString -rootRelXml = "\ -\" +ssXml :: SharedStringTable -> L.ByteString +ssXml = renderLBS def . toDocument +customPropsXml :: CustomProperties -> L.ByteString +customPropsXml = renderLBS def . toDocument + contentTypesXml :: [FileData] -> L.ByteString contentTypesXml fds = renderLBS def $ Document (Prologue [] Nothing []) root [] where - root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" $ + root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" Nothing $ Element "Types" M.empty $ - map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", fdName fd]), + map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", T.pack $ fdPath fd]), ("ContentType", fdContentType fd)]) []) fds -- | fully qualified XML name @@ -231,7 +602,7 @@ nsName :: [(Text, Text)] -> Text -> Text -> Name nsName nss p n = qName n ns p where - ns = fromJust $ lookup p nss + ns = fromJustNote "ns name lookup" $ lookup p nss nm :: Text -> Text -> Name nm ns n = Name @@ -239,31 +610,16 @@ , nameNamespace = Just ns , namePrefix = Nothing} -addNS :: Text -> Element -> Element -addNS namespace (Element (Name ln _ _) as ns) = Element (Name ln (Just namespace) Nothing) as (map addNS' ns) - where - addNS' (NodeElement e) = NodeElement $ addNS namespace e - addNS' n = n - --- | Creates an element with the given name, attributes and children, --- if there is at least one child. Otherwise returns `Nothing`. -nonEmptyNmEl :: Name -> Map Name Text -> [Node] -> Maybe Node -nonEmptyNmEl _ _ [] = Nothing -nonEmptyNmEl name attrs nodes = justNmEl name attrs nodes - --- | Creates an element with the given name, attributes and children. --- Always returns a node/`Just`. -justNmEl :: Name -> Map Name Text -> [Node] -> Maybe Node -justNmEl name attrs nodes = Just $ nEl name attrs nodes - nEl :: Name -> Map Name Text -> [Node] -> Node nEl name attrs nodes = NodeElement $ Element name attrs nodes -txti :: Int -> Text -txti = toStrict . toLazyText . decimal +-- | Creates element holding reference to some linked file +refElement :: Name -> RefId -> Element +refElement name rId = leafElement name [ odr "id" .= rId ] -txtd :: Double -> Text -txtd = toStrict . toLazyText . realFloat +smlCT :: Text -> Text +smlCT t = + "application/vnd.openxmlformats-officedocument.spreadsheetml." <> t <> "+xml" -txtb :: Bool -> Text -txtb = T.toLower . T.pack . show +relsCT :: Text +relsCT = "application/vnd.openxmlformats-package.relationships+xml" diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} + +module Codec.Xlsx.Writer.Internal ( + -- * Rendering documents + ToDocument(..) + , documentFromElement + , documentFromNsElement + , documentFromNsPrefElement + -- * Rendering elements + , ToElement(..) + , countedElementList + , nonEmptyCountedElementList + , elementList + , elementListSimple + , nonEmptyElListSimple + , leafElement + , emptyElement + , elementContent0 + , elementContent + , elementContentPreserved + , elementValue + , elementValueDef + -- * Rendering attributes + , ToAttrVal(..) + , (.=) + , (.=?) + , setAttr + -- * Dealing with namespaces + , addNS + , mainNamespace + -- * Misc + , txti + , txtb + , txtd + , justNonDef + , justTrue + , justFalse + ) where + +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 +-------------------------------------------------------------------------------} + +class ToDocument a where + toDocument :: a -> Document + +documentFromElement :: Text -> Element -> Document +documentFromElement comment e = + documentFromNsElement comment mainNamespace e + +documentFromNsElement :: Text -> Text -> Element -> Document +documentFromNsElement comment ns e = + documentFromNsPrefElement comment ns Nothing e + +documentFromNsPrefElement :: Text -> Text -> Maybe Text -> Element -> Document +documentFromNsPrefElement comment ns prefix e = Document { + documentRoot = addNS ns prefix e + , documentEpilogue = [] + , documentPrologue = Prologue { + prologueBefore = [MiscComment comment] + , prologueDoctype = Nothing + , prologueAfter = [] + } + } + +{------------------------------------------------------------------------------- + Rendering elements +-------------------------------------------------------------------------------} + +class ToElement a where + toElement :: Name -> a -> Element + +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 + , elementNodes = map NodeElement els + , elementAttributes = Map.fromList attrs + } + +elementListSimple :: Name -> [Element] -> Element +elementListSimple nm els = elementList nm [] els + +nonEmptyElListSimple :: Name -> [Element] -> Maybe Element +nonEmptyElListSimple _ [] = Nothing +nonEmptyElListSimple nm els = Just $ elementListSimple nm els + +leafElement :: Name -> [(Name, Text)] -> Element +leafElement nm attrs = elementList nm attrs [] + +emptyElement :: Name -> Element +emptyElement nm = elementList nm [] [] + +elementContent0 :: Name -> [(Name, Text)] -> Text -> Element +elementContent0 nm attrs txt = Element { + elementName = nm + , elementAttributes = Map.fromList attrs + , elementNodes = [NodeContent txt] + } + +elementContent :: Name -> Text -> Element +elementContent nm txt = elementContent0 nm [] txt + +elementContentPreserved :: Name -> Text -> Element +elementContentPreserved nm txt = elementContent0 nm [ preserveSpace ] txt + where + preserveSpace = ( + Name { nameLocalName = "space" + , nameNamespace = Just "http://www.w3.org/XML/1998/namespace" + , namePrefix = Nothing + } + , "preserve" + ) + +{------------------------------------------------------------------------------- + Rendering attributes +-------------------------------------------------------------------------------} + +class ToAttrVal a where + toAttrVal :: a -> Text + +instance ToAttrVal Text where toAttrVal = id +instance ToAttrVal String where toAttrVal = fromString +instance ToAttrVal Int where toAttrVal = txti +instance ToAttrVal Integer where toAttrVal = txti +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 = 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) + +(.=?) :: ToAttrVal a => Name -> Maybe a -> Maybe (Name, Text) +_ .=? Nothing = Nothing +nm .=? (Just a) = Just (nm .= a) + +setAttr :: ToAttrVal a => Name -> a -> Element -> Element +setAttr nm a el@Element{..} = el{ elementAttributes = attrs' } + where + attrs' = Map.insert nm (toAttrVal a) elementAttributes + +{------------------------------------------------------------------------------- + Dealing with namespaces +-------------------------------------------------------------------------------} + +-- | Set the namespace for the entire document +-- +-- This follows the same policy that the rest of the xlsx package uses. +addNS :: Text -> Maybe Text -> Element -> Element +addNS ns prefix Element{..} = Element{ + elementName = goName elementName + , elementAttributes = elementAttributes + , elementNodes = map goNode elementNodes + } + where + goName :: Name -> Name + goName n@Name{..} = + case nameNamespace of + Just _ -> n -- If a namespace was explicitly set, leave it + Nothing -> Name{ + nameLocalName = nameLocalName + , nameNamespace = Just ns + , namePrefix = prefix + } + + goNode :: Node -> Node + goNode (NodeElement e) = NodeElement $ addNS ns prefix e + goNode n = n + +-- | The main namespace for Excel +mainNamespace :: Text +mainNamespace = "http://schemas.openxmlformats.org/spreadsheetml/2006/main" + + +txtd :: Double -> Text +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 + +txti :: (Integral a) => a -> Text +txti = toStrict . toLazyText . decimal + +justNonDef :: (Eq a) => a -> a -> Maybe a +justNonDef defVal a | a == defVal = Nothing + | otherwise = Just a + +justFalse :: Bool -> Maybe Bool +justFalse = justNonDef True + +justTrue :: Bool -> Maybe Bool +justTrue = justNonDef False diff --git a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs @@ -0,0 +1,204 @@ +{-# 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, 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 + , pvtfCacheRecords :: ByteString + } deriving (Eq, Show, Generic) + +data CacheDefinition = CacheDefinition + { cdSourceRef :: CellRef + , cdSourceSheet :: Text + , cdFields :: [CacheField] + } deriving (Eq, Show, Generic) + +renderPivotTableFiles :: CellMap -> Int -> PivotTable -> PivotTableFiles +renderPivotTableFiles cm cacheId t = PivotTableFiles {..} + where + 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 -> CacheDefinition -> PivotTable -> Document +ptDefinitionDocument cacheId cache t = + documentFromElement "Pivot table generated by xlsx" $ + ptDefinitionElement "pivotTableDefinition" cacheId cache t + +ptDefinitionElement :: Name -> Int -> CacheDefinition -> PivotTable -> Element +ptDefinitionElement nm cacheId cache PivotTable {..} = + elementList nm attrs elements + where + attrs = + catMaybes + [ "colGrandTotals" .=? justFalse _pvtColumnGrandTotals + , "rowGrandTotals" .=? justFalse _pvtRowGrandTotals + , "outline" .=? justTrue _pvtOutline + , "outlineData" .=? justTrue _pvtOutlineData + ] ++ + [ "name" .= _pvtName + , "dataCaption" .= _pvtDataCaption + , "cacheId" .= cacheId + , "dataOnRows" .= (DataPosition `elem` _pvtRowFields) + ] + elements = [location, pivotFields, rowFields, colFields, dataFields] + location = + leafElement + "location" + [ "ref" .= _pvtLocation + -- TODO : set proper + , "firstHeaderRow" .= (1 :: Int) + , "firstDataRow" .= (2 :: Int) + , "firstDataCol" .= (1 :: Int) + ] + name2x = M.fromList $ zip (mapMaybe _pfiName _pvtFields) [0 ..] + mapFieldToX f = fromJustNote "no field" $ M.lookup f name2x + 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" $ + [ "dataField" .= True + , "showAll" .= False + , "outline" .= outline] ++ + catMaybes ["name" .=? fName] + pFieldEl' fName outline axis hidden sortType = + elementList + "pivotField" + ([ "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 + then _pvtRowFields + else filter (/= DataPosition) _pvtRowFields + colFields = elementListSimple "colFields" $ map fieldEl _pvtColumnFields + fieldEl p = leafElement "field" ["x" .= fieldPos p] + fieldPos DataPosition = (-2) :: Int + fieldPos (FieldPosition f) = mapFieldToX f + dataFields = elementListSimple "dataFields" $ map dFieldEl _pvtDataFields + dFieldEl DataField {..} = + leafElement "dataField" $ + catMaybes + [ "name" .=? Just _dfName + , "fld" .=? Just (mapFieldToX _dfField) + , "subtotal" .=? justNonDef ConsolidateSum _dfFunction + ] + +generateCache :: CellMap -> PivotTable -> CacheDefinition +generateCache cm PivotTable {..} = + CacheDefinition + { cdSourceRef = _pvtSrcRef + , cdSourceSheet = _pvtSrcSheet + , cdFields = cachedFields + } + where + 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) + +writeCache :: CacheDefinition -> (Document, Document) +writeCache CacheDefinition {..} = (cacheDefDoc, cacheRecordsDoc) + where + 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 + "cacheSource" + ["type" .= ("worksheet" :: Text)] + [ leafElement + "worksheetSource" + ["ref" .= cdSourceRef, "sheet" .= cdSourceSheet] + ] + cacheFields = + elementListSimple "cacheFields" $ map (toElement "cacheField") cdFields + 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/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Codec.Xlsx - -import Control.Applicative ((<$>)) -import Control.Lens -import qualified Data.ByteString.Lazy as L -import qualified Data.Map as M -import Data.Text (Text,pack) -import System.Time - - -xEmpty :: Cell -xEmpty = Cell{_cellValue=Nothing, _cellStyle=Just 0} - -xText :: Text -> Cell -xText t = Cell{_cellValue=Just $ CellText t, _cellStyle=Just 0} - -xDouble :: Double -> Cell -xDouble d = Cell{_cellValue=Just $ CellDouble d, _cellStyle=Just 0} - -styles :: Styles -styles = Styles "\ -\\ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\ \ -\" - -main :: IO () -main = do - ct <- getClockTime - L.writeFile "test.xlsx" $ fromXlsx ct $ Xlsx sheets styles - x <- toXlsx <$> L.readFile "test.xlsx" - putStrLn $ "And cell (3,2) value in list 'List' is " ++ - show (x ^? xlSheets . ix "List" . wsCells . ix (3,2) . cellValue . _Just) - where - cols = [ColumnsWidth 1 10 15 1] - rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] - cells = M.fromList [((r, c), v) | r <- [1..10000], (c, v) <- zip [1..] (row r) ] - row r = [ xText $ pack $ "column1-r" ++ show r - , xText $ pack $ "column2-r" ++ show r - , xEmpty - , xText $ pack $ "column4-r" ++ show r - , xDouble 42.12345 - , xText "False"] - sheets = M.fromList [("List", Worksheet cols rowProps cells [])] -- wtf merges? 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,68 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import qualified Data.IntMap as IM -import Data.Map (Map) -import qualified Data.Map as M -import Data.Time.Calendar -import Data.Time.LocalTime -import System.Time -import Text.XML -import Text.XML.Cursor - -import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.SmallCheck (testProperty) -import Test.Tasty.HUnit (testCase) - -import Test.HUnit ((@=?)) -import Test.SmallCheck.Series (Positive(..)) - -import Codec.Xlsx -import Codec.Xlsx.Parser.Internal - - -main = defaultMain $ - testGroup "Tests" - [ testProperty "col2int . int2col == id" $ - \(Positive i) -> i == col2int (int2col i) - , testCase "write . read == id" $ - testXlsx @=? toXlsx (fromXlsx testTime testXlsx) - , testCase "fromRows . toRows == id" $ - testCellMap @=? fromRows (toRows testCellMap) - , testCase "correct shared strings parsing" $ - testSharedStrings @=? testParseSharedStrings - ] - -testXlsx :: Xlsx -testXlsx = Xlsx sheets emptyStyles - where - sheets = M.fromList [( "List1", sheet )] - sheet = Worksheet cols rowProps testCellMap [] - rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] - cols = [ColumnsWidth 1 10 15 1] - -testCellMap :: CellMap -testCellMap = M.fromList [ ((1, 2), cd1), ((1, 5), cd2) - , ((3, 1), cd3), ((3, 2), cd4), ((3, 7), cd5) - ] - where - cd v = Cell{_cellValue=Just v, _cellStyle=Nothing} - cd1 = cd (CellText "just a text") - cd2 = cd (CellDouble 42.4567) - cd3 = cd (CellText "another text") - cd4 = Cell{_cellValue=Nothing, _cellStyle=Nothing} -- shouldn't it be skipped? - cd5 = cd $(CellBool True) - -testTime :: ClockTime -testTime = TOD 123 567 - -testSharedStrings = IM.fromAscList $ zip [0..] ["plain text", "Just example"] - -testParseSharedStrings = parseSharedStrings $ fromDocument $ parseLBS_ def strings - where - strings = "\ - \\ - \plain text\ - \Just \ - \example\ - \" diff --git a/test/Diff.hs b/test/Diff.hs new file mode 100644 --- /dev/null +++ b/test/Diff.hs @@ -0,0 +1,14 @@ +module Diff where + +import Data.Algorithm.Diff (Diff (..), getGroupedDiff) +import Data.Algorithm.DiffOutput (ppDiff) +import Data.Monoid ((<>)) +import Test.Tasty.HUnit (Assertion, HasCallStack, assertBool) +import Text.Groom (groom) + +-- | Like '@=?' but producing a diff on failure. +(@==?) :: HasCallStack => (Eq a, Show a) => a -> a -> Assertion +x @==? y = + assertBool ("Expected:\n" <> groom x <> "\nDifference:\n" <> msg) (x == y) + where + msg = ppDiff $ getGroupedDiff (lines . groom $ x) (lines . groom $ y) 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.1.2 +Version: 1.2.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -10,10 +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 - + 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 @@ -24,84 +28,186 @@ Category: Codec Build-type: Simple - +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.Parser - , Codec.Xlsx.Types - , Codec.Xlsx.Writer - , Codec.Xlsx.Lens - , Codec.Xlsx.Parser.Internal - - Build-depends: base == 4.* - , containers >= 0.5.0.0 - , transformers >= 0.3.0.0 - , bytestring >= 0.10.0.2 - , text >= 0.11.3.1 - , lens >= 3.8 && < 5 - , conduit >= 1.0.0 - , xml-types == 0.3.* - , xml-conduit >= 1.1.0 - , zip-archive == 0.2.* - , digest == 0.0.* - , zlib >= 0.5.4.0 - , utf8-string >= 0.3.7 - , time >= 1.4.0.1 - , old-time >= 1.1.0.1 - , old-locale >= 1.0.0.5 - , data-default == 0.5.* - , vector >= 0.10 - , binary-search - Default-Language: Haskell2010 - + , 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 + , Codec.Xlsx.Types.DataValidation + , Codec.Xlsx.Types.Drawing + , Codec.Xlsx.Types.Drawing.Chart + , Codec.Xlsx.Types.Drawing.Common + , Codec.Xlsx.Types.Internal + , Codec.Xlsx.Types.Internal.CfPair + , Codec.Xlsx.Types.Internal.CommentTable + , Codec.Xlsx.Types.Internal.ContentTypes + , Codec.Xlsx.Types.Internal.CustomProperties + , Codec.Xlsx.Types.Internal.DvPair + , 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.StyleSheet + , Codec.Xlsx.Types.Table + , Codec.Xlsx.Types.Variant + , 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 -Executable test - Hs-source-dirs: src - Other-modules: Codec.Xlsx - , Codec.Xlsx.Parser - , Codec.Xlsx.Writer - ghc-options: -Wall -threaded + -- 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 - main-is: Test.hs + Build-depends: base >= 4.9.0.0 && < 5.0 + , attoparsec + , base64-bytestring + , binary-search + , bytestring >= 0.10.8.0 + , conduit >= 1.0.0 + , containers >= 0.5.0.0 + , data-default + , deepseq >= 1.4 + , dlist + , errors + , extra + , filepath + , hexpat + , mtl >= 2.1 + , network-uri + , old-locale >= 1.0.0.5 + , safe >= 0.3 + , text >= 0.11.3.1 + , 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 + , 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 - Build-depends: base, containers, transformers, bytestring, text - , conduit >= 1.0.0 - , xml-types == 0.3.* - , xml-conduit >= 1.1.0 - , zip-archive == 0.2.* - , lens >= 3.8 && < 5 - , digest > 0.0.0.1 - , zlib - , utf8-string - , time - , old-time - , old-locale - , data-default == 0.5.* - , vector >= 0.10 - , binary-search Default-Language: Haskell2010 + Other-Extensions: DeriveDataTypeable + FlexibleInstances + NoMonomorphismRestriction + OverloadedStrings + RankNTypes + RecordWildCards + TemplateHaskell + TupleSections test-suite data-test type: exitcode-stdio-1.0 - main-is: DataTest.hs + main-is: Main.hs hs-source-dirs: test/ - Build-Depends: base, - containers, - time, - old-time, - xlsx, - xml-conduit >= 1.1.0, - smallcheck, - HUnit, - tasty, - tasty-smallcheck, - tasty-hunit + 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 + , mtl + , raw-strings-qq + , smallcheck + , tasty + , tasty-hunit + , tasty-smallcheck + , text + , time + , 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