packages feed

xlsx 0.1.2 → 1.2.0

raw patch · 72 files changed

Files

+ CHANGELOG.markdown view
@@ -0,0 +1,245 @@+1.2.0+------------+* expose sheet state in stream parser+  (thanks to Benjamin McRae <benjamin@supercede.com>)+* drop unnecessary `n`  namespace from stream writer+  (thanks to Michael Schneider <michael@m1-s.com>)+* add support support for writing multiple sheets with stream writer+  (thanks to Michael Schneider <michael@m1-s.com>)++1.1.4+------------+* fix the problem with leading slashes for comments, drawings and pivot tables+  (thanks to  mindston <mindston@eml.cc>)++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 <lukec@themk.net>)++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 <nikita@supercede.com>)+* 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 <luke@supercede.com>)+* Added newtypes for column and row indices+  (thanks to Luke <luke@supercede.com>)++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 <david.hewson@tracsis.com>)++0.8.2+------+* added a flag allowing to use `microlens` instead of `lens`+ (thanks to Samuel Balco <goodlyrottenapple@gmail.com>)++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 <david.hewson@tracsis.com>)++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+  <dixiecko@gmail.com>)+* 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 <emax@chalmers.se>)+* 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 <malaquias@gmail.com>)++0.6.0+-----+* fixed reading files with optional table name (thanks Aleksey Khudyakov+  <alexey.skladnoy@gmail.com> for reporting)+* removed unnecessary 10cm offset from `simpleAnchorXY`+* `customRowHeight` added to row properties (thanks Aleksey Khudyakov+  <alexey.skladnoy@gmail.com>)+* added `Generic` instances for library types (thanks Remy Goldschmidt+  <taktoa@gmail.com>)+* `hidden` property added for rows (thanks Aleksey Khudyakov+  <alexey.skladnoy@gmail.com>)++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 <laurent_step@yahoo.fr> for+  reporting)+* fixed parsing cells with comments but with no content (thanks+  Stéphane Laurent <laurent_step@yahoo.fr> 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 <laurent_step@yahoo.fr> for reporting)+* fixed problem of `cwStyle` not being optional (thanks laurent+  stephane <laurent_step@yahoo.fr> for reporting)+* added basic autofilter support++0.4.1+-----+* fixed serialization problem of empty validations and pivot caches+  (thanks laurent stephane <laurent_step@yahoo.fr> for reporting)++0.4.0+-----+* implemented basic charts support with only line charts currently+* added data validation support (thanks Emil Axelsson <emax@chalmers.se>)+* fixed reading comments with empty author names (thanks Aleksey+  Khudyakov <alexey.skladnoy@gmail.com> 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 <steve.bigham@gmail.com> for reporting)+* fixed parsing workbooks with no shared strings (thanks Steve Bigham <steve.bigham@gmail.com> 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 <brad.ediger@madriska.com>)++0.2.3+-----+* added conditional formatting support+* fixed reading empty <font> subelements with defaults (thanks Steve Bigham <steve.bigham@gmail.com>)++0.2.2.2+-----+* fixed missing from parsing code font family value 0 (Not applicable) (thanks Steve Bigham <steve.bigham@gmail.com>)+* fixed time type used in haddock example (thanks Manoj <manoj.p.gudi@gmail.com>)++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 <whosekiteneverfly@gmail.com>)++0.2.1+-------+* added number formats (thanks to Alan Zimmerman <alan.zimm@gmail.com>)+* loosened dependency on zip-archive package++0.2.0+-----+* added style sheet support (thanks to Edsko de Vries <edsko@well-typed.com>)+* added high level interface for styling (thanks to Edsko de Vries <edsko@well-typed.com>)+* added sheet views support (thanks to Edsko de Vries <edsko@well-typed.com>)+* added page setup support (thanks to Edsko de Vries <edsko@well-typed.com>)+* switched from `System.Time` to `Data.Time`+* added rich text support (thanks to Edsko de Vries <edsko@well-typed.com>) including shared strings+* added a bit better internals for rendering (thanks to Edsko de Vries <edsko@well-typed.com>) 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 <steve.bigham@gmail.com>)++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 <nikitinskiy@gmail.com>)+* improved shared strings collection by using Vector (thanks Dmitriy Nikitinskiy <nikitinskiy@gmail.com>)+* empty xml elements don't get emmitted anymore (thanks Philipp Hausmann <nikitinskiy@gmail.com>)+* imporoved and cleaned up core.xml generation++0.1.0.3+-------+* added "str" cells content extraction as text+* added a notice that formulas in <f> 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
+ benchmarks/Main.hs view
@@ -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+        ]+    ]
− changelog 
@@ -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 <steve.bigham@gmail.com>)-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 <nick@linux-i294.site>)-	* improved shared strings collection by using Vector (thanks Dmitriy Nikitinskiy <nick@linux-i294.site>)-	* empty xml elements don't get emmitted anymore (thanks Philipp Hausmann <ph_git@314.ch>)-	* imporoved and cleaned up core.xml generation-0.1.0.3-	* added "str" cells content extraction as text-	* added a notice that formulas in <f> 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
+ data/absolute_relationships.xlsx view

binary file changed (absent → 6869 bytes)

+ data/floats.xlsx view

binary file changed (absent → 8455 bytes)

+ data/inline-strings.xlsx view

binary file changed (absent → 8695 bytes)

src/Codec/Xlsx.hs view
@@ -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"
+ src/Codec/Xlsx/Formatted.hs view
@@ -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+        }
src/Codec/Xlsx/Lens.hs view
@@ -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
+ src/Codec/Xlsx/LensCompat.hs view
@@ -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
src/Codec/Xlsx/Parser.hs view
@@ -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 <https://www.w3.org/TR/REC-xml/#sec-predefined-ent predefined entities>+--   and <https://www.w3.org/TR/REC-xml/#NT-CharRef Unicode character references>+--   (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):+    -- <xsd:complexType name="CT_Cell">+    --  ..+    --  <xsd:attribute name="t" type="ST_CellType" use="optional" default="n"/>+    -- </xsd:complexType>+    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.+            --+            -- <xsd:complexType name="CT_Cell" from spec (see the `CellValue` spec reference)>+            --  ..+            --  <xsd:attribute name="t" type="ST_CellType" use="optional" default="n"/>+            -- </xsd:complexType>+            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)
src/Codec/Xlsx/Parser/Internal.hs view
@@ -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 <t> or <r>s with <t> inside-      parseT c' = [T.concat $ c' $| orSelf (child >=> (element (n"r"))) &/ element (n"t") &/ content]
+ src/Codec/Xlsx/Parser/Internal/Fast.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Internal/Memoize.hs view
@@ -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 _ = "<<Memoized>>"++-- | 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
+ src/Codec/Xlsx/Parser/Internal/PivotTable.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Internal/Util.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Stream.hs view
@@ -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 <row> <row> (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 <f>+  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.+    --+    -- <xsd:complexType name="CT_Cell" from spec (see the `CellValue` spec reference)>+    --  ..+    --  <xsd:attribute name="t" type="ST_CellType" use="optional" default="n"/>+    -- </xsd:complexType>+    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
+ src/Codec/Xlsx/Parser/Stream/HexpatInternal.hs view
@@ -0,0 +1,95 @@+{-+Under BSD 3-Clause license, (c) 2009 Doug Beardsley <mightybyte@gmail.com>, (c) 2009-2012 Stephen Blackheath <http://blacksapphire.com/antispam/>, (c) 2009 Gregory Collins, (c) 2008 Evan Martin <martine@danga.com>, (c) 2009 Matthew Pocock <matthew.pocock@ncl.ac.uk>, (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"
+ src/Codec/Xlsx/Parser/Stream/Row.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Stream/SheetIndex.hs view
@@ -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" #-}
+ src/Codec/Xlsx/Parser/Stream/SheetInfo.hs view
@@ -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.+-- <sheet name="Data" sheetId="1" state="hidden" r:id="rId2" /+data SheetInfo = MkSheetInfo+  { sheetInfoName    :: Text,+    -- | The r:id attribute value+    sheetInfoRelId   :: RefId,+    -- | The sheetId attribute value+    sheetInfoSheetId :: Int,+    -- | The index into the sheets in the workbook+    sheetInfoSheetIndex :: Int,+    -- | The sheet visibility state+    sheetInfoState    :: SheetState+  } deriving (Show, Eq)++{-# DEPRECATED sheetInfoRelId, sheetInfoSheetId "this field will be removed in future, see issue #193" #-} ++getSheetIdentifier :: SheetInfo -> SheetIdentifier+getSheetIdentifier sheetInfo = unsafeGetSheetIdentifier (sheetInfoRelId sheetInfo) (sheetInfoSheetId sheetInfo)
+ src/Codec/Xlsx/Parser/Stream/SheetItem.hs view
@@ -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" #-}
src/Codec/Xlsx/Types.hs view
@@ -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 @\<f\>@ and inline strings from @\<is\>@--- 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 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\-\<styleSheet xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\"></styleSheet>"+emptyStyles = Styles "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?><styleSheet xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\"></styleSheet>" --- | 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+          ]
+ src/Codec/Xlsx/Types/AutoFilter.hs view
@@ -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"
+ src/Codec/Xlsx/Types/Cell.hs view
@@ -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 @\<is\>@ 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+  }
+ src/Codec/Xlsx/Types/Comment.hs view
@@ -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
+ src/Codec/Xlsx/Types/Common.hs view
@@ -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 #-}
+ src/Codec/Xlsx/Types/ConditionalFormatting.hs view
@@ -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
+ src/Codec/Xlsx/Types/DataValidation.hs view
@@ -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: <dataValidation type="list" ...> 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)
+ src/Codec/Xlsx/Types/Drawing.hs view
@@ -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"
+ src/Codec/Xlsx/Types/Drawing/Chart.hs view
@@ -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"
+ src/Codec/Xlsx/Types/Drawing/Common.hs view
@@ -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"
+ src/Codec/Xlsx/Types/Internal.hs view
@@ -0,0 +1,3 @@+module Codec.Xlsx.Types.Internal (module Codec.Xlsx.Types.RefId) where++import Codec.Xlsx.Types.RefId
+ src/Codec/Xlsx/Types/Internal/CfPair.hs view
@@ -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)
+ src/Codec/Xlsx/Types/Internal/CommentTable.hs view
@@ -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+    [ "<xml xmlns:v=\"urn:schemas-microsoft-com:vml\" "+    , "xmlns:o=\"urn:schemas-microsoft-com:office:office\" "+    , "xmlns:x=\"urn:schemas-microsoft-com:office:excel\">"+    , commentShapeType+    , LB.concat commentShapes+    , "</xml>"+    ]+  where+    commentShapeType = LB.concat+        [ "<v:shapetype id=\"baloon\" coordsize=\"21600,21600\" o:spt=\"202\" "+        , "path=\"m,l,21600r21600,l21600,xe\">"+        , "<v:stroke joinstyle=\"miter\"></v:stroke>"+        , "<v:path gradientshapeok=\"t\" o:connecttype=\"rect\"></v:path>"+        , "</v:shapetype>"+        ]+    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+        [ "<v:shape type=\"#baloon\" "+        , "style=\"position:absolute;width:auto" -- ;width:108pt;height:59.25pt"+        , if v then "" else ";visibility:hidden"+        , "\" fillcolor=\"#ffffe1\" o:insetmode=\"auto\">"+        , "<v:fill color2=\"#ffffe1\"></v:fill><v:shadow color=\"black\" obscured=\"t\"></v:shadow>"+        , "<v:path o:connecttype=\"none\"></v:path><v:textbox style=\"mso-direction-alt:auto\">"+        , "<div style=\"text-align:left\"></div></v:textbox>"+        , "<x:ClientData ObjectType=\"Note\">"+        , "<x:MoveWithCells></x:MoveWithCells><x:SizeWithCells></x:SizeWithCells>"+        , "<x:Anchor>4, 15, 0, 7, 6, 31, 5, 1</x:Anchor><x:AutoFill>False</x:AutoFill>"+        , "<x:Row>"+        , LBC8.pack $ show (r - 1)+        , "</x:Row>"+        , "<x:Column>"+        , LBC8.pack $ show (c - 1)+        , "</x:Column>"+        , "</x:ClientData>"+        , "</v:shape>"+        ]
+ src/Codec/Xlsx/Types/Internal/ContentTypes.hs view
@@ -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"
+ src/Codec/Xlsx/Types/Internal/CustomProperties.hs view
@@ -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}"
+ src/Codec/Xlsx/Types/Internal/DvPair.hs view
@@ -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
+ src/Codec/Xlsx/Types/Internal/FormulaData.hs view
@@ -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
+ src/Codec/Xlsx/Types/Internal/Relationships.hs view
@@ -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/"
+ src/Codec/Xlsx/Types/Internal/SharedStringTable.hs view
@@ -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,+-- <https://ecma-international.org/publications-and-standards/standards/ecma-376/>),+-- 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
+ src/Codec/Xlsx/Types/PageSetup.hs view
@@ -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
+ src/Codec/Xlsx/Types/PivotTable.hs view
@@ -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
+ src/Codec/Xlsx/Types/PivotTable/Internal.hs view
@@ -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
+ src/Codec/Xlsx/Types/Protection.hs view
@@ -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
+ src/Codec/Xlsx/Types/RefId.hs view
@@ -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
+ src/Codec/Xlsx/Types/RichText.hs view
@@ -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
+ src/Codec/Xlsx/Types/SheetViews.hs view
@@ -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
+ src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -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,+-- <https://ecma-international.org/publications-and-standards/standards/ecma-376/>),+-- 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+-- <https://stackoverflow.com/questions/26050708/minimal-style-sheet-for-excel-open-xml-with-dates SO post>).+-- '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 <clrScheme> collection (20.1.6.2),+    -- referencing a particular <sysClr> or <srgbClr> 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+-- <http://stackoverflow.com/questions/26050708/minimal-style-sheet-for-excel-open-xml-with-dates>,+-- 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{..}
+ src/Codec/Xlsx/Types/Table.hs view
@@ -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+                    ]+                  )
+ src/Codec/Xlsx/Types/Variant.hs view
@@ -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)
src/Codec/Xlsx/Writer.hs view
@@ -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 <https://phpexcel.codeplex.com/workitem/2935>). 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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\-\<Relationships xmlns=\"http://schemas.openxmlformats.org/package/2006/relationships\"><Relationship Id=\"rId1\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument\" Target=\"xl/workbook.xml\"/><Relationship Id=\"rId2\" Type=\"http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties\" Target=\"docProps/core.xml\"/><Relationship Id=\"rId3\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties\" Target=\"docProps/app.xml\"/></Relationships>"+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"
+ src/Codec/Xlsx/Writer/Internal.hs view
@@ -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
+ src/Codec/Xlsx/Writer/Internal/PivotTable.hs view
@@ -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
+ src/Codec/Xlsx/Writer/Internal/Stream.hs view
@@ -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)+
+ src/Codec/Xlsx/Writer/Stream.hs view
@@ -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:+--   <https://hackage.haskell.org/package/xml-types-0.3.8/docs/Data-XML-Types.html#t:Name>+--   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"
− src/Test.hs 
@@ -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 "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\-\<styleSheet xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" xmlns:mc=\"http://schemas.openxmlformats.org/markup-compatibility/2006\" xmlns:x14ac=\"http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac\" mc:Ignorable=\"x14ac\">\-\  <numFmts count=\"1\">\-\    <numFmt numFmtId=\"164\" formatCode=\"yyyy/mm/dd\"/>\-\  </numFmts>\-\  <fonts count=\"2\" x14ac:knownFonts=\"1\">\-\    <font>\-\      <sz val=\"11\"/>\-\      <color theme=\"1\"/>\-\      <name val=\"Calibri\"/>\-\      <family val=\"2\"/>\-\      <scheme val=\"minor\"/>\-\    </font>\-\    <font>\-\      <b/>\-\      <sz val=\"11\"/>\-\      <color theme=\"1\"/>\-\      <name val=\"Calibri\"/>\-\      <family val=\"2\"/>\-\      <scheme val=\"minor\"/>\-\    </font>\-\  </fonts>\-\  <fills count=\"2\">\-\    <fill>\-\      <patternFill patternType=\"none\"/>\-\    </fill>\-\    <fill>\-\      <patternFill patternType=\"gray125\"/>\-\    </fill>\-\  </fills>\-\  <borders count=\"1\">\-\    <border>\-\      <left/>\-\      <right/>\-\      <top/>\-\      <bottom/>\-\      <diagonal/>\-\    </border>\-\  </borders>\-\  <cellStyleXfs count=\"1\">\-\    <xf numFmtId=\"0\" fontId=\"0\" fillId=\"0\" borderId=\"0\"/>\-\  </cellStyleXfs>\-\  <cellXfs count=\"5\">\-\    <xf numFmtId=\"0\" fontId=\"0\" fillId=\"0\" borderId=\"0\" xfId=\"0\"/>\-\    <xf numFmtId=\"0\" fontId=\"1\" fillId=\"0\" borderId=\"0\" xfId=\"0\" applyFont=\"1\"/>\-\    <xf numFmtId=\"164\" fontId=\"1\" fillId=\"0\" borderId=\"0\" xfId=\"0\" applyNumberFormat=\"1\" applyFont=\"1\"/>\-\    <xf numFmtId=\"0\" fontId=\"0\" fillId=\"0\" borderId=\"0\" xfId=\"0\" applyFont=\"1\"/>\-\    <xf numFmtId=\"2\" fontId=\"0\" fillId=\"0\" borderId=\"0\" xfId=\"0\" applyNumberFormat=\"1\" applyFont=\"1\"/>\-\  </cellXfs>\-\  <cellStyles count=\"1\">\-\    <cellStyle name=\"Normal\" xfId=\"0\" builtinId=\"0\"/>\-\  </cellStyles>\-\  <dxfs count=\"0\"/>\-\  <tableStyles count=\"0\" defaultTableStyle=\"TableStyleMedium2\" defaultPivotStyle=\"PivotStyleLight16\"/>\-\  <extLst>\-\    <ext xmlns:x14=\"http://schemas.microsoft.com/office/spreadsheetml/2009/9/main\" uri=\"{EB79DEF2-80B8-43e5-95BD-54CBDDF9020C}\">\-\      <x14:slicerStyles defaultSlicerStyle=\"SlicerStyleLight1\"/>\-\    </ext>\-\    <ext xmlns:x15=\"http://schemas.microsoft.com/office/spreadsheetml/2010/11/main\" uri=\"{9260A510-F301-46a8-8635-F512D64BE5F5}\">\-\      <x15:timelineStyles defaultTimelineStyle=\"TimeSlicerStyleLight1\"/>\-\    </ext>\-\  </extLst>\-\</styleSheet>"--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?
+ test/AutoFilterTests.hs view
@@ -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)+    ]
+ test/Common.hs view
@@ -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
+ test/CommonTests.hs view
@@ -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
+ test/CommonTests/CellRefTests.hs view
@@ -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 '\''
+ test/CondFmtTests.hs view
@@ -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)+    ]
− test/DataTest.hs 
@@ -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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\-                \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\-                \<si><t>plain text</t></si>\-                \<si><r><t>Just </t></r><r><rPr><b val=\"true\"/><u val=\"single\"/>\-                \<sz val=\"10\"/><rFont val=\"Arial\"/><family val=\"2\"/></rPr><t>example</t></r></si>\-                \</sst>"
+ test/Diff.hs view
@@ -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)
+ test/DrawingTests.hs view
@@ -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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<xdr:wsDr xmlns:xdr="http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+  <xdr:twoCellAnchor editAs="absolute">+    <xdr:from>+      <xdr:col>0</xdr:col><xdr:colOff>0</xdr:colOff>+      <xdr:row>0</xdr:row><xdr:rowOff>0</xdr:rowOff>+    </xdr:from>+    <xdr:to>+      <xdr:col>12</xdr:col><xdr:colOff>320760</xdr:colOff>+      <xdr:row>33</xdr:row><xdr:rowOff>38160</xdr:rowOff>+    </xdr:to>+    <xdr:pic>+      <xdr:nvPicPr><xdr:cNvPr id="0" name="Picture 1" descr=""/><xdr:cNvPicPr/></xdr:nvPicPr>+      <xdr:blipFill><a:blip r:embed="rId1"></a:blip><a:stretch/></xdr:blipFill>+      <xdr:spPr>+        <a:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></a:xfrm>+        <a:prstGeom prst="rect"><a:avLst/></a:prstGeom><a:ln><a:noFill/></a:ln>+      </xdr:spPr>+    </xdr:pic>+    <xdr:clientData/>+  </xdr:twoCellAnchor>+  <xdr:twoCellAnchor editAs="oneCell">+    <xdr:from>+      <xdr:col>0</xdr:col><xdr:colOff>87840</xdr:colOff>+      <xdr:row>21</xdr:row><xdr:rowOff>131040</xdr:rowOff>+    </xdr:from>+    <xdr:to>+      <xdr:col>7</xdr:col><xdr:colOff>580320</xdr:colOff>+      <xdr:row>38</xdr:row><xdr:rowOff>132480</xdr:rowOff>+    </xdr:to>+    <xdr:graphicFrame>+      <xdr:nvGraphicFramePr><xdr:cNvPr id="1" name=""/><xdr:cNvGraphicFramePr/></xdr:nvGraphicFramePr>+      <xdr:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></xdr:xfrm>+      <a:graphic>+        <a:graphicData uri="http://schemas.openxmlformats.org/drawingml/2006/chart">+          <c:chart xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" r:id="rId2"/>+        </a:graphicData>+      </a:graphic>+    </xdr:graphicFrame>+    <xdr:clientData/>+  </xdr:twoCellAnchor>+</xdr:wsDr>+|]++testWrittenDrawing :: ByteString+testWrittenDrawing = renderLBS def $ toDocument testDrawing++testLineChartFile :: ByteString+testLineChartFile = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<c:chartSpace xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+<c:chart>+<c:title>+ <c:tx><c:rich><a:bodyPr rot="0" anchor="b"/><a:p><a:r><a:t>Line chart title</a:t></a:r></a:p></c:rich></c:tx>+</c:title>+<c:plotArea>+<c:lineChart>+<c:grouping val="standard"/>+<c:ser>+  <c:idx val="0"/><c:order val="0"/>+  <c:tx><c:strRef><c:f>Sheet1!$A$1</c:f></c:strRef></c:tx>+  <c:spPr>+    <a:solidFill><a:srgbClr val="0000FF"/></a:solidFill>+    <a:ln w="28800"><a:solidFill><a:srgbClr val="0000FF"/></a:solidFill></a:ln>+  </c:spPr>+  <c:marker><c:symbol val="none"/></c:marker>+  <c:val><c:numRef><c:f>Sheet1!$B$1:$D$1</c:f></c:numRef></c:val>+  <c:smooth val="0"/>+</c:ser>+<c:ser>+  <c:idx val="1"/><c:order val="1"/>+  <c:tx><c:strRef><c:f>Sheet1!$A$2</c:f></c:strRef></c:tx>+  <c:spPr>+    <a:solidFill><a:srgbClr val="FF0000"/></a:solidFill>+    <a:ln w="28800"><a:solidFill><a:srgbClr val="FF0000"/></a:solidFill></a:ln>+  </c:spPr>+  <c:marker><c:symbol val="none"/></c:marker>+  <c:val><c:numRef><c:f>Sheet1!$B$2:$D$2</c:f></c:numRef></c:val>+  <c:smooth val="0"/>+</c:ser>+<c:marker val="0"/>+<c:smooth val="0"/>+</c:lineChart>+</c:plotArea>+<c:plotVisOnly val="1"/>+<c:dispBlanksAs val="gap"/>+</c:chart>+</c:chartSpace>+|]++oneChartChartSpace :: Chart -> ChartSpace+oneChartChartSpace chart =+  ChartSpace+  { _chspTitle = Just $ ChartTitle (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+          }+        ]+    }
+ test/Main.hs view
@@ -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 <t/>" $+        [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty+    , testCase "correct comments parsing" $+        [testCommentTable] @=? parseBS testComments+    , testCase "correct custom properties parsing" $+        [testCustomProperties] @==? parseBS testCustomPropertiesXml+    , testCase "proper results from `formatted`" $+        testFormattedResult @==? testRunFormatted+    , testCase "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
+ test/PivotTableTests.hs view
@@ -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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot table generated by xlsx-->+<pivotTableDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" name="PivotTable1" cacheId="3" dataOnRows="1" colGrandTotals="0" dataCaption="Values">+  <location ref="A3:D12" firstHeaderRow="1" firstDataRow="2" firstDataCol="1"/>+  <pivotFields>+    <pivotField name="Color" axis="axisRow" showAll="0" outline="0" sortType="ascending">+      <items>+        <item h="1" x="0"/><item x="1"/><item x="2"/><item t="default"/>+      </items>+    </pivotField>+    <pivotField name="Year" axis="axisCol" showAll="0" outline="1">+      <items>+        <item x="0"/><item x="1"/><item t="default"/>+      </items>+    </pivotField>+    <pivotField name="Price" dataField="1" showAll="0" outline="0"/>+    <pivotField name="Count" dataField="1" showAll="0" outline="0"/>+ </pivotFields>+  <rowFields><field x="0"/><field x="-2"/></rowFields>+  <colFields><field x="1"/></colFields>+  <dataFields>+    <dataField name="Sum of field Price" fld="2"/>+    <dataField name="Sum of field Count" fld="3"/>+  </dataFields>+</pivotTableDefinition>+|]++testPivotCacheDefinition :: ByteString+testPivotCacheDefinition = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot cache definition generated by xlsx-->+<pivotCacheDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"+    xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships" r:id="rId1"+    invalid="1" refreshOnLoad="1"+    xmlns:ns="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+  <cacheSource type="worksheet">+    <worksheetSource ref="A1:D5" sheet="Sheet1"/>+  </cacheSource>+  <cacheFields>+    <cacheField name="Color">+     <sharedItems>+       <s v="green"/><s v="white"/><s v="red"/>+     </sharedItems>+    </cacheField>+    <cacheField name="Year">+     <sharedItems containsNumber="1" containsString="0" containsSemiMixedTypes="0"/>+    </cacheField>+    <cacheField name="Price">+     <sharedItems containsNumber="1" containsString="0" containsSemiMixedTypes="0"/>+    </cacheField>+    <cacheField name="Count">+     <sharedItems containsNumber="1" containsString="0" containsSemiMixedTypes="0"/>+    </cacheField>+</cacheFields>+</pivotCacheDefinition>+|]++stripContentSpaces :: Document -> Document+stripContentSpaces doc@Document {documentRoot = root} =+  doc {documentRoot = go root}+  where+    go e@Element {elementNodes = nodes} =+      e {elementNodes = mapMaybe goNode nodes}+    goNode (NodeElement el) = Just $ NodeElement (go el)+    goNode t@(NodeContent txt) =+      if T.strip txt == T.empty+        then Nothing+        else Just t+    goNode other = Just $ other
+ test/StreamTests.hs view
@@ -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
+ test/Test/SmallCheck/Series/Instances.hs view
@@ -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
+ test/TestXlsx.hs view
@@ -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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+  <sst xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" count="2" uniqueCount="2">+  <si><t>plain text</t></si>+  <si><r><t>Just </t></r><r><rPr><b /><i />+  <sz val="10"/><rFont val="Arial"/><family val="2"/></rPr><t>example</t></r></si>+  </sst>+|]++testStringsWithSingleUnderline :: ByteString+testStringsWithSingleUnderline = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+  <sst xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" count="2" uniqueCount="2">+  <si><t>plain text</t></si>+  <si><r><t>Just </t></r><r><rPr><b /><i /><u />+  <sz val="10"/><rFont val="Arial"/><family val="2"/></rPr><t>example</t></r></si>+  </sst>+|]++testStringsWithDoubleUnderline :: ByteString+testStringsWithDoubleUnderline = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+  <sst xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" count="2" uniqueCount="2">+  <si><t>plain text</t></si>+  <si><r><t>Just </t></r><r><rPr><b /><i /><u val="double"/>+  <sz val="10"/><rFont val="Arial"/><family val="2"/></rPr><t>example</t></r></si>+  </sst>+|]++testStringsWithEmpty :: ByteString+testStringsWithEmpty = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+  <sst xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" count="2" uniqueCount="2">+  <si><t/></si>+  </sst>+|]++testComments :: ByteString+testComments = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<comments xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">+  <authors>+    <author>Bob</author>+    <author>CBR</author>+  </authors>+  <commentList>+    <comment ref="D4" authorId="0" visible="False">+      <text>+        <r>+          <rPr>+            <b/><sz val="8"/><color indexed="81"/><rFont val="Calibri"/>+            <charset val="1"/><scheme val="minor"/>+          </rPr>+          <t>Bob:</t>+        </r>+        <r>+          <rPr>+            <sz val="8"/><color indexed="81"/><rFont val="Calibri"/>+            <charset val="1"/> <scheme val="minor"/>+          </rPr>+          <t xml:space="preserve">Why such high expense?</t>+        </r>+      </text>+    </comment>+    <comment ref="A2" authorId="1" visible="True">+      <text><t>Some comment here</t></text>+    </comment>+  </commentList>+</comments>+|]++testCustomProperties :: CustomProperties+testCustomProperties = CustomProperties.fromList+    [ ("testTextProp", VtLpwstr "test text property value")+    , ("prop2", VtLpwstr "222")+    , ("bool", VtBool False)+    , ("prop333", VtInt 1)+    , ("decimal", VtDecimal 1.234) ]++testCustomPropertiesXml :: ByteString+testCustomPropertiesXml = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<Properties xmlns="http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">+  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="2" name="prop2">+    <vt:lpwstr>222</vt:lpwstr>+  </property>+  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="3" name="prop333">+    <vt:int>1</vt:int>+  </property>+  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="4" name="testTextProp">+    <vt:lpwstr>test text property value</vt:lpwstr>+  </property>+  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="5" name="decimal">+    <vt:decimal>1.234</vt:decimal>+  </property>+  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="6" name="bool">+    <vt:bool>false</vt:bool>+  </property>+  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="7" name="blob">+    <vt:blob>+    ZXhhbXBs+    ZSBibG9i+    IGNvbnRl+    bnRz+    </vt:blob>+  </property>+</Properties>+|]++testFormattedResult :: Formatted+testFormattedResult = Formatted cm styleSheet merges+  where+    cm = M.fromList [ ((1, 1), cell11)+                    , ((1, 2), cell12)+                    , ((2, 5), cell25) ]+    cell11 = Cell+        { _cellStyle   = Just 1+        , _cellValue   = Just (CellText "text at A1")+        , _cellComment = Nothing+        , _cellFormula = Nothing }+    cell12 = Cell+        { _cellStyle   = Just 2+        , _cellValue   = Just (CellDouble 1.23)+        , _cellComment = Nothing+        , _cellFormula = Nothing }+    cell25 = Cell+        { _cellStyle   = Just 3+        , _cellValue   = Just (CellDouble 1.23456)+        , _cellComment = Nothing+        , _cellFormula = Nothing }+    merges = []+    styleSheet =+        minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3])+                          & styleSheetFonts   %~ (++ [font1, font2])+                          & styleSheetNumFmts .~ numFmts+    nextFontId = length (minimalStyleSheet ^. styleSheetFonts)+    cellXf1 = def+        { _cellXfApplyFont = Just True+        , _cellXfFontId    = Just nextFontId }+    font1 = def+        { _fontName = Just "Calibri"+        , _fontBold = Just True }+    cellXf2 = def+        { _cellXfApplyFont         = Just True+        , _cellXfFontId            = Just (nextFontId + 1)+        , _cellXfApplyNumberFormat = Just True+        , _cellXfNumFmtId          = Just 164 }+    font2 = def+        { _fontItalic = Just True }+    cellXf3 = def+        { _cellXfApplyNumberFormat = Just True+        , _cellXfNumFmtId          = Just 2 }+    numFmts = M.fromList [(164, "0.0000")]++testRunFormatted :: Formatted+testRunFormatted = formatted formattedCellMap minimalStyleSheet+  where+    formattedCellMap = flip execState def $ do+        let font1 = def & fontBold ?~ True+                        & fontName ?~ "Calibri"+        at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1"+                          & formattedFormat . formatFont  ?~ font1)+        at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23+                          & formattedFormat . formatFont . non def . fontItalic ?~ True+                          & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4)+        at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456+                          & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal)++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"+        }+      )+  ]
xlsx.cabal view
@@ -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:-    <http://www.ecma-international.org/publications/standards/Ecma-376.htm>+    <https://ecma-international.org/publications-and-standards/standards/ecma-376/>+    .+    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