packages feed

xlsx 0.4.1 → 1.2.0

raw patch · 70 files changed

Files

CHANGELOG.markdown view
@@ -1,3 +1,139 @@+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
+ 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+        ]+    ]
+ 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/Formatted.hs view
@@ -1,12 +1,14 @@ -- | Higher level interface for creating styled worksheets-{-# LANGUAGE CPP             #-} {-# LANGUAGE RankNTypes      #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}-module Codec.Xlsx.Formatted (-    FormattedCell(..)+{-# LANGUAGE DeriveGeneric #-}+module Codec.Xlsx.Formatted+  ( FormattedCell(..)   , Formatted(..)+  , Format(..)   , formatted+  , formatWorkbook   , toFormattedCells   , CondFormatted(..)   , conditionallyFormatted@@ -32,26 +34,24 @@   , condfmtStopIfTrue   ) where -import           Control.Lens-import           Control.Monad.State hiding (forM_, mapM)-import           Data.Default-import           Data.Foldable       (asum, forM_)-import           Data.Function       (on)-import           Data.List           (foldl', groupBy, sortBy, sortBy)-import           Data.Map            (Map)-import qualified Data.Map            as M-import           Data.Ord            (comparing)-import           Data.Text           (Text)-import           Data.Traversable    (mapM)-import           Data.Tuple          (swap)-import           Prelude             hiding (mapM)-import           Safe                (headNote, fromJustNote)--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Codec.Xlsx.LensCompat+import Control.Monad (forM, guard)+import Control.Monad.State hiding (forM_, mapM)+import Data.Default+import Data.Foldable (asum, forM_)+import Data.Function (on)+import Data.List (foldl', groupBy, sortBy, sortBy)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Ord (comparing)+import Data.Text (Text)+import Data.Traversable (mapM)+import Data.Tuple (swap)+import GHC.Generics (Generic)+import Prelude hiding (mapM)+import Safe (headNote, fromJustNote) -import           Codec.Xlsx.Types+import Codec.Xlsx.Types  {-------------------------------------------------------------------------------   Internal: formatting state@@ -74,7 +74,7 @@     , _formattingCellXfs = fromValueList _styleSheetCellXfs     , _formattingFills   = fromValueList _styleSheetFills     , _formattingFonts   = fromValueList _styleSheetFonts-    , _formattingNumFmts = M.empty+    , _formattingNumFmts = M.fromList . map swap $ M.toList _styleSheetNumFmts     , _formattingMerges  = []     } @@ -118,7 +118,7 @@     , _condfmtDxf        :: Dxf     , _condfmtPriority   :: Int     , _condfmtStopIfTrue :: Maybe Bool-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  makeLenses ''FormattedCondFmt @@ -141,7 +141,7 @@     , _formatProtection   :: Maybe Protection     , _formatPivotButton  :: Maybe Bool     , _formatQuotePrefix  :: Maybe Bool-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  makeLenses ''Format @@ -153,7 +153,7 @@     , _formattedFormat  :: Format     , _formattedColSpan :: Int     , _formattedRowSpan :: Int-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  makeLenses ''FormattedCell @@ -200,7 +200,7 @@      -- | The final list of cell merges; see '_wsMerges'   , formattedMerges     :: [Range]-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)  -- | Higher level API for creating formatted documents --@@ -227,7 +227,7 @@ -- -- If you don't already have a 'StyleSheet' you want to use as starting point -- then 'minimalStyleSheet' is a good choice.-formatted :: Map (Int, Int) FormattedCell -> StyleSheet -> Formatted+formatted :: Map (RowIndex, ColumnIndex) FormattedCell -> StyleSheet -> Formatted formatted cs styleSheet =    let initSt         = stateFromStyleSheet styleSheet        (cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt@@ -238,9 +238,26 @@         , formattedMerges     = reverse (finalSt ^. formattingMerges)         } +-- | Build an 'Xlsx', render provided cells as per the 'StyleSheet'.+formatWorkbook ::+  [(Text, Map (RowIndex, ColumnIndex) FormattedCell)] -> StyleSheet -> Xlsx+formatWorkbook nfcss initStyle = extract go+  where+    initSt = stateFromStyleSheet initStyle+    go = flip runState initSt $+      forM nfcss $ \(name, fcs) -> do+        cs' <- forM (M.toList fcs) $ \(rc, fc) -> formatCell rc fc+        merges <- reverse . _formattingMerges <$> get+        return ( name+               , def & wsCells  .~ M.fromList (concat cs')+                     & wsMerges .~ merges)+    extract (sheets, st) =+      def & xlSheets .~ sheets+          & xlStyles .~ renderStyleSheet (updateStyleSheetFromState initStyle st)+ -- | reverse to 'formatted' which allows to get a map of formatted cells -- from an existing worksheet and its workbook's style sheet-toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (Int, Int) FormattedCell+toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (RowIndex, ColumnIndex) FormattedCell toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m   where     toFormattedCell cell@Cell{..} =@@ -278,18 +295,21 @@         if apply then prop cXf else fail "not applied"     applyMerges cells = foldl' onlyTopLeft cells merges     onlyTopLeft cells range = flip execState cells $ do-        let ((r1, c1), (r2, c2)) = fromJustNote "fromRange" $ fromRange range+        let ((r1, c1), (r2, c2)) =+              fromJustNote "fromRange" $ fromRange range             nonTopLeft = tail [(r, c) | r<-[r1..r2], c<-[c1..c2]]         forM_ nonTopLeft (modify . M.delete)-        at (r1, c1) . non def . formattedRowSpan .= (r2 - r1 +1)-        at (r1, c1) . non def . formattedColSpan .= (c2 - c1 +1)+        at (r1, c1) . non def . formattedRowSpan .=+          (unRowIndex r2 - unRowIndex r1 + 1)+        at (r1, c1) . non def . formattedColSpan .=+          (unColumnIndex c2 - unColumnIndex c1 + 1)  data CondFormatted = CondFormatted {     -- | The resulting stylesheet     condformattedStyleSheet    :: StyleSheet     -- | The final map of conditional formatting rules applied to ranges     , condformattedFormattings :: Map SqRef ConditionalFormatting-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  conditionallyFormatted :: Map CellRef [FormattedCondFmt] -> StyleSheet -> CondFormatted conditionallyFormatted cfs styleSheet = CondFormatted@@ -311,14 +331,16 @@ -------------------------------------------------------------------------------}  -- | Format a cell with (potentially) rowspan or colspan-formatCell :: (Int, Int) -> FormattedCell -> State FormattingState [((Int, Int), Cell)]+formatCell :: (RowIndex, ColumnIndex) -> FormattedCell+  -> State FormattingState [((RowIndex, ColumnIndex), Cell)] formatCell (row, col) cell = do     let (block, mMerge) = cellBlock (row, col) cell     forM_ mMerge $ \merge -> formattingMerges %= (:) merge     mapM go block   where-    go :: ((Int, Int), FormattedCell) -> State FormattingState ((Int, Int), Cell)-    go (pos, c@ FormattedCell{..}) = do+    go :: ((RowIndex, ColumnIndex), FormattedCell)+      -> State FormattingState ((RowIndex, ColumnIndex), Cell)+    go (pos, c@FormattedCell{..}) = do       styleId <- cellStyleId c       return (pos, _formattedCell{_cellStyle = styleId}) @@ -331,11 +353,11 @@ -- remaining cells are the cells covered by the rowspan/colspan. -- -- Also returns the cell merge instruction, if any.-cellBlock :: (Int, Int) -> FormattedCell-          -> ([((Int, Int), FormattedCell)], Maybe Range)+cellBlock :: (RowIndex, ColumnIndex) -> FormattedCell+          -> ([((RowIndex, ColumnIndex), FormattedCell)], Maybe Range) cellBlock (row, col) cell@FormattedCell{..} = (block, merge)   where-    block :: [((Int, Int), FormattedCell)]+    block :: [((RowIndex, ColumnIndex), FormattedCell)]     block = [ ((row', col'), cellAt (row', col'))             | row' <- [topRow  .. bottomRow]             , col' <- [leftCol .. rightCol]@@ -345,7 +367,7 @@     merge = do guard (topRow /= bottomRow || leftCol /= rightCol)                return $ mkRange (topRow, leftCol) (bottomRow, rightCol) -    cellAt :: (Int, Int) -> FormattedCell+    cellAt :: (RowIndex, ColumnIndex) -> FormattedCell     cellAt (row', col') =       if row' == row && col == col'         then cell@@ -353,18 +375,19 @@      border = _formatBorder _formattedFormat -    borderAt :: (Int, Int) -> Border+    borderAt :: (RowIndex, ColumnIndex) -> Border     borderAt (row', col') = def       & borderTop    .~ do guard (row' == topRow)    ; _borderTop    =<< border       & borderBottom .~ do guard (row' == bottomRow) ; _borderBottom =<< border       & borderLeft   .~ do guard (col' == leftCol)   ; _borderLeft   =<< border       & borderRight  .~ do guard (col' == rightCol)  ; _borderRight  =<< border -    topRow, bottomRow, leftCol, rightCol :: Int+    topRow, bottomRow :: RowIndex+    leftCol, rightCol :: ColumnIndex     topRow    = row-    bottomRow = row + _formattedRowSpan - 1+    bottomRow = RowIndex $ unRowIndex row + _formattedRowSpan - 1     leftCol   = col-    rightCol  = col + _formattedColSpan - 1+    rightCol  = ColumnIndex $ unColumnIndex col + _formattedColSpan - 1  cellStyleId :: FormattedCell -> State FormattingState (Maybe Int) cellStyleId c = mapM (getId formattingCellXfs) =<< constructCellXf c
src/Codec/Xlsx/Lens.hs view
@@ -1,36 +1,32 @@-{-# LANGUAGE CPP          #-} {-# LANGUAGE RankNTypes   #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveGeneric #-}  -- | lenses to access sheets, cells and values of 'Xlsx'- module Codec.Xlsx.Lens-    ( ixSheet-    , atSheet-    , ixCell-    , ixCellRC-    , ixCellXY-    , atCell-    , atCellRC-    , atCellXY-    , cellValueAt-    , cellValueAtRC-    , cellValueAtXY- ) where--import           Codec.Xlsx.Types-import           Control.Lens-import           Data.Function       (on)-import           Data.List           (deleteBy)-import           Data.Text-import           Data.Tuple          (swap)+  ( ixSheet+  , atSheet+  , ixCell+  , ixCellRC+  , ixCellXY+  , atCell+  , atCellRC+  , atCellXY+  , cellValueAt+  , cellValueAtRC+  , cellValueAtXY+  ) where -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Codec.Xlsx.Types+import Codec.Xlsx.LensCompat+import Data.Function (on)+import Data.List (deleteBy)+import Data.Text+import Data.Tuple (swap)+import GHC.Generics (Generic)  newtype SheetList = SheetList{ unSheetList :: [(Text, Worksheet)] }-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)  type instance IxValue (SheetList) = Worksheet type instance Index (SheetList) = Text@@ -56,61 +52,58 @@     then (k,v):r     else (k1,v1):upsert k v r -sheetList :: Iso' [(Text, Worksheet)] SheetList-sheetList = iso SheetList unSheetList- -- | lens giving access to a worksheet from 'Xlsx' object -- by its name ixSheet :: Text -> Traversal' Xlsx Worksheet-ixSheet s = xlSheets . sheetList . ix s+ixSheet s = xlSheets . \f -> fmap unSheetList . ix s f . SheetList  -- | 'Control.Lens.At' variant of 'ixSheet' lens -- -- /Note:/ if there is no such sheet in this workbook then new sheet will be -- added as the last one to the sheet list atSheet :: Text -> Lens' Xlsx (Maybe Worksheet)-atSheet s = xlSheets . sheetList . at s+atSheet s = xlSheets . \f -> fmap unSheetList . at s f . SheetList  -- | lens giving access to a cell in some worksheet -- by its position, by default row+column index is used -- so this lens is a synonym of 'ixCellRC'-ixCell :: (Int, Int) -> Traversal' Worksheet Cell+ixCell :: (RowIndex, ColumnIndex) -> Traversal' Worksheet Cell ixCell = ixCellRC  -- | lens to access cell in a worksheet-ixCellRC :: (Int, Int) -> Traversal' Worksheet Cell+ixCellRC :: (RowIndex, ColumnIndex) -> Traversal' Worksheet Cell ixCellRC i = wsCells . ix i  -- | lens to access cell in a worksheet using more traditional -- x+y coordinates-ixCellXY :: (Int, Int) -> Traversal' Worksheet Cell-ixCellXY = ixCellRC . swap+ixCellXY :: (ColumnIndex, RowIndex) -> Traversal' Worksheet Cell+ixCellXY i = ixCellRC $ swap i  -- | accessor that can read, write or delete cell in a worksheet -- synonym of 'atCellRC' so uses row+column index-atCell :: (Int, Int) -> Lens' Worksheet (Maybe Cell)+atCell :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe Cell) atCell = atCellRC  -- | lens to read, write or delete cell in a worksheet-atCellRC :: (Int, Int) -> Lens' Worksheet (Maybe Cell)+atCellRC :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe Cell) atCellRC i = wsCells . at i  -- | lens to read, write or delete cell in a worksheet -- using more traditional x+y or row+column index-atCellXY :: (Int, Int) -> Lens' Worksheet (Maybe Cell)-atCellXY = atCellRC . swap+atCellXY :: (ColumnIndex, RowIndex) -> Lens' Worksheet (Maybe Cell)+atCellXY i = atCellRC $ swap i  -- | lens to read, write or delete cell value in a worksheet -- with row+column coordinates, synonym for 'cellValueRC'-cellValueAt :: (Int, Int) -> Lens' Worksheet (Maybe CellValue)+cellValueAt :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe CellValue) cellValueAt = cellValueAtRC  -- | lens to read, write or delete cell value in a worksheet -- using row+column coordinates of that cell-cellValueAtRC :: (Int, Int) -> Lens' Worksheet (Maybe CellValue)+cellValueAtRC :: (RowIndex, ColumnIndex) -> Lens' Worksheet (Maybe CellValue) cellValueAtRC i = atCell i . non def . cellValue  -- | lens to read, write or delete cell value in a worksheet -- using traditional x+y coordinates-cellValueAtXY :: (Int, Int) -> Lens' Worksheet (Maybe CellValue)-cellValueAtXY = cellValueAtRC . swap+cellValueAtXY :: (ColumnIndex, RowIndex) -> Lens' Worksheet (Maybe CellValue)+cellValueAtXY i = cellValueAtRC $ swap i
+ 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,196 +1,527 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards           #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TupleSections             #-}  -- | This module provides a function for reading .xlsx files module Codec.Xlsx.Parser-    ( toXlsx-    , toXlsxEither-    , ParseError (..)-    , Parser-    ) where+  ( toXlsx+  , toXlsxEither+  , toXlsxFast+  , toXlsxEitherFast+  , ParseError(..)+  , Parser+  ) where -import qualified Codec.Archive.Zip                           as Zip-import           Control.Applicative-import           Control.Arrow                               (left)-import           Control.Error.Safe                          (headErr)-import           Control.Error.Util                          (note)-import           Control.Lens                                hiding (element,-                                                              views, (<.>))-import           Control.Monad.Except                        (catchError,-                                                              throwError)-import qualified Data.ByteString.Lazy                        as L-import           Data.ByteString.Lazy.Char8                  ()-import           Data.List-import qualified Data.Map                                    as M-import           Data.Maybe-import           Data.Monoid-import           Data.Ord-import           Data.Text                                   (Text)-import qualified Data.Text                                   as T-import qualified Data.Text.Read                              as T-import           Data.Traversable-import           Prelude                                     hiding (sequence)-import           System.FilePath.Posix-import           Text.XML                                    as X-import           Text.XML.Cursor+import qualified "zip-archive" Codec.Archive.Zip as Zip+import Control.Applicative+import Control.Arrow (left)+import Control.Error.Safe (headErr)+import Control.Error.Util (note)+import Control.Exception (Exception)+import Codec.Xlsx.LensCompat hiding ((<.>), element, views)+import Control.Monad (join, void, liftM4)+import Control.Monad.Except (catchError, throwError)+import Data.Bool (bool)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy as LB+import Data.ByteString.Lazy.Char8 ()+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Data.Traversable+import GHC.Generics (Generic)+import Prelude hiding (sequence)+import Safe (headNote)+import System.FilePath.Posix+import Text.XML as X+import Text.XML.Cursor hiding (bool)+import qualified Xeno.DOM as Xeno -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Parser.Internal.PivotTable-import           Codec.Xlsx.Types-import           Codec.Xlsx.Types.Internal-import           Codec.Xlsx.Types.Internal.CfPair-import           Codec.Xlsx.Types.Internal.CommentTable-import           Codec.Xlsx.Types.Internal.ContentTypes      as ContentTypes-import           Codec.Xlsx.Types.Internal.CustomProperties  as CustomProperties-import           Codec.Xlsx.Types.Internal.DvPair-import           Codec.Xlsx.Types.Internal.Relationships     as Relationships-import           Codec.Xlsx.Types.Internal.SharedStringTable-import           Codec.Xlsx.Types.PivotTable.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Parser.Internal.PivotTable+import Codec.Xlsx.Types+import Codec.Xlsx.Types.Cell (formulaDataFromCursor)+import Codec.Xlsx.Types.Internal+import Codec.Xlsx.Types.Internal.CfPair+import Codec.Xlsx.Types.Internal.CommentTable as CommentTable+import Codec.Xlsx.Types.Internal.ContentTypes as ContentTypes+import Codec.Xlsx.Types.Internal.CustomProperties+       as CustomProperties+import Codec.Xlsx.Types.Internal.DvPair+import Codec.Xlsx.Types.Internal.FormulaData+import Codec.Xlsx.Types.Internal.Relationships as Relationships+import Codec.Xlsx.Types.Internal.SharedStringTable+import Codec.Xlsx.Types.PivotTable.Internal  -- | Reads `Xlsx' from raw data (lazy bytestring) toXlsx :: L.ByteString -> Xlsx toXlsx = either (error . show) id . toXlsxEither -data ParseError = InvalidZipArchive+data ParseError = InvalidZipArchive String                 | MissingFile FilePath-                | InvalidFile FilePath+                | InvalidFile FilePath Text                 | InvalidRef FilePath RefId                 | InconsistentXlsx Text-                deriving (Show, Eq)+                deriving (Eq, Show, Generic) +instance Exception ParseError+ type Parser = Either ParseError --- | Reads `Xlsx' from raw data (lazy bytestring), failing with Left on parse error+-- | Reads `Xlsx' from raw data (lazy bytestring) using @xeno@ library+-- using some "cheating":+--+-- * not doing 100% xml validation+-- * replacing only <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 bs = do-  ar <- left (const InvalidZipArchive) $ Zip.toArchiveOrFail bs+toXlsxEither = toXlsxEitherBase extractSheet++-- | Fast parsing with 'Left' on parse error, see 'toXlsxFast'+toXlsxEitherFast :: L.ByteString -> Parser Xlsx+toXlsxEitherFast = toXlsxEitherBase extractSheetFast++toXlsxEitherBase ::+     (Zip.Archive -> SharedStringTable -> ContentTypes -> Caches -> WorksheetFile -> Parser Worksheet)+  -> L.ByteString+  -> Parser Xlsx+toXlsxEitherBase parseSheet bs = do+  ar <- left InvalidZipArchive $ Zip.toArchiveOrFail bs   sst <- getSharedStrings ar   contentTypes <- getContentTypes ar-  (wfs, names, cacheSources) <- readWorkbook ar+  (wfs, names, cacheSources, dateBase) <- readWorkbook ar   sheets <- forM wfs $ \wf -> do-      sheet <- extractSheet ar sst contentTypes cacheSources wf-      return (wfName wf, sheet)+      sheet <- parseSheet ar sst contentTypes cacheSources wf+      return . (wfName wf,) . (wsState .~ wfState wf) $ sheet   CustomProperties customPropMap <- getCustomProperties ar-  return $ Xlsx sheets (getStyles ar) names customPropMap+  return $ Xlsx sheets (getStyles ar) names customPropMap dateBase  data WorksheetFile = WorksheetFile { wfName :: Text+                                   , wfSheetId :: Int+                                   , wfState :: SheetState                                    , wfPath :: FilePath                                    }-                   deriving Show+                   deriving (Show, Generic) -type Caches = [(CacheId, (Text, CellRef, [PivotFieldName]))]+type Caches = [(CacheId, (Text, CellRef, [CacheField]))] -extractSheet :: Zip.Archive-             -> SharedStringTable-             -> ContentTypes-             -> Caches-             -> WorksheetFile-             -> Parser Worksheet+extractSheetFast :: Zip.Archive+                 -> SharedStringTable+                 -> ContentTypes+                 -> Caches+                 -> WorksheetFile+                 -> Parser Worksheet+extractSheetFast ar sst contentTypes caches wf = do+  file <-+    note (MissingFile filePath) $+    Zip.fromEntry <$> Zip.findEntryByPath filePath ar+  sheetRels <- getRels ar filePath+  root <-+    left (\ex -> InvalidFile filePath $ T.pack (show ex)) $+    Xeno.parse (LB.toStrict file)+  parseWorksheet root sheetRels+  where+    filePath = wfPath wf+    parseWorksheet :: Xeno.Node -> Relationships -> Parser Worksheet+    parseWorksheet root sheetRels = do+      let prefixes = nsPrefixes root+          odrNs =+            "http://schemas.openxmlformats.org/officeDocument/2006/relationships"+          odrX = addPrefix prefixes odrNs+          skip = void . maybeChild+      (ws, tableIds, drawingRId, legacyDrRId) <-+        liftEither . collectChildren root $ do+          skip "sheetPr"+          skip "dimension"+          _wsSheetViews <- fmap justNonEmpty . maybeParse "sheetViews" $ \n ->+            collectChildren n $ fromChildList "sheetView"+          skip "sheetFormatPr"+          _wsColumnsProperties <-+            fmap (fromMaybe []) . maybeParse "cols" $ \n ->+              collectChildren n (fromChildList "col")+          (_wsRowPropertiesMap, _wsCells, _wsSharedFormulas) <-+            requireAndParse "sheetData" $ \n -> do+              rows <- collectChildren n $ childList "row"+              collectRows <$> forM rows parseRow+          skip "sheetCalcPr"+          _wsProtection <- maybeFromChild "sheetProtection"+          skip "protectedRanges"+          skip "scenarios"+          _wsAutoFilter <- maybeFromChild "autoFilter"+          skip "sortState"+          skip "dataConsolidate"+          skip "customSheetViews"+          _wsMerges <- fmap (fromMaybe []) . maybeParse "mergeCells" $ \n -> do+            mCells <- collectChildren n $ childList "mergeCell"+            forM mCells $ \mCell -> parseAttributes mCell $ fromAttr "ref"+          _wsConditionalFormattings <-+            M.fromList . map unCfPair <$> fromChildList "conditionalFormatting"+          _wsDataValidations <-+            fmap (fromMaybe mempty) . maybeParse "dataValidations" $ \n -> do+              M.fromList . map unDvPair <$>+                collectChildren n (fromChildList "dataValidation")+          skip "hyperlinks"+          skip "printOptions"+          skip "pageMargins"+          _wsPageSetup <- maybeFromChild "pageSetup"+          skip "headerFooter"+          skip "rowBreaks"+          skip "colBreaks"+          skip "customProperties"+          skip "cellWatches"+          skip "ignoredErrors"+          skip "smartTags"+          drawingRId <- maybeParse "drawing" $ \n ->+            parseAttributes n $ fromAttr (odrX "id")+          legacyDrRId <- maybeParse "legacyDrawing" $ \n ->+            parseAttributes n $ fromAttr (odrX "id")+          tableIds <- fmap (fromMaybe []) . maybeParse "tableParts" $ \n -> do+            tParts <- collectChildren n $ childList "tablePart"+            forM tParts $ \part ->+              parseAttributes part $ fromAttr (odrX "id")++          -- all explicitly assigned fields filled below+          return (+            Worksheet+            { _wsDrawing = Nothing+            , _wsPivotTables = []+            , _wsTables = []+            , _wsState = wfState wf+            , ..+            }+            , tableIds+            , drawingRId+            , legacyDrRId)++      let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments"+          commentTarget :: Maybe FilePath+          commentTarget = logicalNameToZipItemName . relTarget <$> findRelByType commentsType sheetRels+          legacyDrPath = fmap (logicalNameToZipItemName . relTarget) . flip Relationships.lookup sheetRels =<< legacyDrRId+      commentsMap <-+        fmap join . forM commentTarget $ getComments ar legacyDrPath+      let commentCells =+            M.fromList+            [ (fromSingleCellRefNoting r, def { _cellComment = Just cmnt})+            | (r, cmnt) <- maybe [] CommentTable.toList commentsMap+            ]+          assignComment withCmnt noCmnt =+            noCmnt & cellComment .~ (withCmnt ^. cellComment)+          mergeComments = M.unionWith assignComment commentCells+      tables <- forM tableIds $ \rId -> do+        fp <- lookupRelPath filePath sheetRels rId+        getTable ar fp+      drawing <- forM drawingRId $ \dId -> do+        fp <- lookupRelPath filePath sheetRels dId+        getDrawing ar contentTypes fp+      let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable"+      pivotTables <- forM (allByType ptType sheetRels) $ \rel -> do+        let ptPath = logicalNameToZipItemName $ relTarget rel+        bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar+        note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $+          parsePivotTable (flip Prelude.lookup caches) bs++      return $ ws & wsTables .~ tables+                  & wsCells %~ mergeComments+                  & wsDrawing .~ drawing+                  & wsPivotTables .~ pivotTables+    liftEither :: Either Text a -> Parser a+    liftEither = left (\t -> InvalidFile filePath t)+    justNonEmpty v@(Just (_:_)) = v+    justNonEmpty _ = Nothing+    collectRows = foldr collectRow (M.empty, M.empty, M.empty)+    collectRow ::+         ( RowIndex+         , Maybe RowProperties+         , [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])+      -> ( Map RowIndex RowProperties+         , CellMap+         , Map SharedFormulaIndex SharedFormulaOptions)+      -> ( Map RowIndex RowProperties+         , CellMap+         , Map SharedFormulaIndex SharedFormulaOptions)+    collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) =+      let (newCells0, newSharedF0) =+            unzip [(((rInd, cInd), cd), shared) | (rInd, cInd, cd, shared) <- rowCells]+          newCells = M.fromAscList newCells0+          newSharedF = M.fromAscList $ catMaybes newSharedF0+          newRowMap =+            case mRP of+              Just rp -> M.insert r rp rowMap+              Nothing -> rowMap+      in (newRowMap, cellMap <> newCells, sharedF <> newSharedF)+    parseRow ::+         Xeno.Node+      -> Either Text ( RowIndex+                     , Maybe RowProperties+                     , [( RowIndex+                        , ColumnIndex+                        , Cell+                        , Maybe (SharedFormulaIndex, SharedFormulaOptions))])+    parseRow row = do+      (r, s, ht, cstHt, hidden) <-+        parseAttributes row $+        ((,,,,) <$> fromAttr "r" <*> maybeAttr "s" <*> maybeAttr "ht" <*>+         fromAttrDef "customHeight" False <*>+         fromAttrDef "hidden" False)+      let props =+            RowProps+            { rowHeight =+                if cstHt+                  then CustomHeight <$> ht+                  else AutomaticHeight <$> ht+            , rowStyle = s+            , rowHidden = hidden+            }+      cellNodes <- collectChildren row $ childList "c"+      cells <- forM cellNodes parseCell+      return+        ( RowIndex r+        , if props == def+            then Nothing+            else Just props+        , cells)++    -- NB: According to format specification default value for cells without+    -- `t` attribute is a `n` - number.+    --+    -- Schema part from spec (see the `CellValue` spec reference):+    -- <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+      (ref, s, t) <-+        parseAttributes cell $+        (,,) <$> fromAttr "r" <*> maybeAttr "s" <*> fromAttrDef "t" "n"+      (fNode, vNode, isNode) <-+        collectChildren cell $+        (,,) <$> maybeChild "f" <*> maybeChild "v" <*> maybeChild "is"+      let vConverted :: (FromAttrBs a) => Either Text (Maybe a)+          vConverted =+            case contentBs <$> vNode of+              Nothing -> return Nothing+              Just c -> Just <$> fromAttrBs c+      mFormulaData <- mapM fromXenoNode fNode+      d <-+        case t of+          ("s" :: ByteString) -> do+            si <- vConverted+            case sstItem sst =<< si of+              Just xlTxt -> return $ Just (xlsxTextToCellValue xlTxt)+              Nothing -> throwError "bad shared string index"+          "inlineStr" -> mapM (fmap xlsxTextToCellValue . fromXenoNode) isNode+          "str" -> fmap CellText <$> vConverted+          "n" -> fmap CellDouble <$> vConverted+          "b" -> fmap CellBool <$> vConverted+          "e" -> fmap CellError <$> vConverted+          unexpected ->+            throwError $ "unexpected cell type " <> T.pack (show unexpected)+      let (r, c) = fromSingleCellRefNoting ref+          f = frmdFormula <$> mFormulaData+          shared = frmdShared =<< mFormulaData+      return (r, c, Cell s d Nothing f, shared)++extractSheet ::+     Zip.Archive+  -> SharedStringTable+  -> ContentTypes+  -> Caches+  -> WorksheetFile+  -> Parser Worksheet extractSheet ar sst contentTypes caches wf = do   let filePath = wfPath wf   file <- note (MissingFile filePath) $ Zip.fromEntry <$> Zip.findEntryByPath filePath ar-  cur <- fmap fromDocument . left (\_ -> InvalidFile filePath) $+  cur <- fmap fromDocument . left (\ex -> InvalidFile filePath (T.pack $ show ex)) $          parseLBS def file   sheetRels <- getRels ar filePath    -- The specification says the file should contain either 0 or 1 @sheetViews@   -- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910)-  let  sheetViewList = cur $/ element (n_ "sheetViews") &/ element (n_ "sheetView") >=> fromCursor+  let  sheetViewList = cur $/ element (addSmlNamespace "sheetViews") &/ element (addSmlNamespace "sheetView") >=> fromCursor        sheetViews = case sheetViewList of          []    -> Nothing          views -> Just views    let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments"       commentTarget :: Maybe FilePath-      commentTarget = relTarget <$> findRelByType commentsType sheetRels-      legacyDrRId = cur $/ element (n_ "legacyDrawing") >=> fromAttribute (odr"id")-      legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels  =<< listToMaybe legacyDrRId+      commentTarget = logicalNameToZipItemName . relTarget <$> findRelByType commentsType sheetRels+      legacyDrRId = cur $/ element (addSmlNamespace "legacyDrawing") >=> fromAttribute (odr"id")+      legacyDrPath = fmap (logicalNameToZipItemName . relTarget) . flip Relationships.lookup sheetRels  =<< listToMaybe legacyDrRId    commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget    -- Likewise, @pageSetup@ also occurs either 0 or 1 times-  let pageSetup = listToMaybe $ cur $/ element (n_ "pageSetup") >=> fromCursor+  let pageSetup = listToMaybe $ cur $/ element (addSmlNamespace "pageSetup") >=> fromCursor -      cws = cur $/ element (n_ "cols") &/ element (n_ "col") >=> fromCursor+      cws = cur $/ element (addSmlNamespace "cols") &/ element (addSmlNamespace "col") >=> fromCursor -      (rowProps, cells) = collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow-      parseRow :: Cursor -> [(Int, Maybe RowProperties, [(Int, Int, Cell)])]+      (rowProps, cells0, sharedFormulas) =+        collect $ cur $/ element (addSmlNamespace "sheetData") &/ element (addSmlNamespace "row") >=> parseRow+      parseRow ::+           Cursor+        -> [( RowIndex+            , Maybe RowProperties+            , [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])]       parseRow c = do-        r <- c $| attribute "r" >=> decimal-        let ht = if attribute "customHeight" c == ["true"]-                 then listToMaybe $ c $| attribute "ht" >=> rational-                 else Nothing-        let s = listToMaybe $ decimal =<< attribute "s" c :: Maybe Int-        let rp = if isNothing s && isNothing ht-                 then  Nothing-                 else  Just (RowProps ht s)-        return (r, rp, c $/ element (n_ "c") >=> parseCell)-      parseCell :: Cursor -> [(Int, Int, Cell)]+        r <- RowIndex <$> fromAttribute "r" c+        let prop = RowProps+              { rowHeight = do h <- listToMaybe $ fromAttribute "ht" c+                               case fromAttribute "customHeight" c of+                                 [True] -> return $ CustomHeight    h+                                 _      -> return $ AutomaticHeight h+              , rowStyle  = listToMaybe $ fromAttribute "s" c+              , rowHidden =+                  case fromAttribute "hidden" c of+                    []  -> False+                    f:_ -> f+              }+        return ( r+               , if prop == def then Nothing else Just prop+               , c $/ element (addSmlNamespace "c") >=> parseCell+               )+      parseCell ::+           Cursor+        -> [(RowIndex, ColumnIndex, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))]       parseCell cell = do         ref <- fromAttribute "r" cell-        let-          s = listToMaybe $ cell $| attribute "s" >=> decimal-          t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t"-          d = listToMaybe $ cell $/ element (n_ "v") &/ content >=> extractCellValue sst t-          f = listToMaybe $ cell $/ element (n_ "f") >=> fromCursor-          (c, r) = T.span (>'9') $ unCellRef ref-          comment = commentsMap >>= lookupComment ref-        return (int r, col2int c, Cell s d comment f)-      collect = foldr collectRow (M.empty, M.empty)-      collectRow (_, Nothing, rowCells) (rowMap, cellMap) =-        (rowMap, foldr collectCell cellMap rowCells)-      collectRow (r, Just h, rowCells) (rowMap, cellMap) =-        (M.insert r h rowMap, foldr collectCell cellMap rowCells)-      collectCell (x, y, cd) = M.insert (x,y) cd+        let s = listToMaybe $ cell $| attribute "s" >=> decimal+            -- NB: According to format specification default value for cells without+            -- `t` attribute is a `n` - number.+            --+            -- <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) -      mDrawingId = listToMaybe $ cur $/ element (n_ "drawing") >=> fromAttribute (odr"id")+      commentCells =+        M.fromList+          [ (fromSingleCellRefNoting r, def {_cellComment = Just cmnt})+          | (r, cmnt) <- maybe [] CommentTable.toList commentsMap+          ]+      cells = cells0 `M.union` commentCells +      mProtection = listToMaybe $ cur $/ element (addSmlNamespace "sheetProtection") >=> fromCursor++      mDrawingId = listToMaybe $ cur $/ element (addSmlNamespace "drawing") >=> fromAttribute (odr"id")+       merges = cur $/ parseMerges       parseMerges :: Cursor -> [Range]-      parseMerges = element (n_ "mergeCells") &/ element (n_ "mergeCell") >=> fromAttribute "ref"+      parseMerges = element (addSmlNamespace "mergeCells") &/ element (addSmlNamespace "mergeCell") >=> fromAttribute "ref" -      condFormtattings = M.fromList . map unCfPair  $ cur $/ element (n_ "conditionalFormatting") >=> fromCursor+      condFormtattings = M.fromList . map unCfPair  $ cur $/ element (addSmlNamespace "conditionalFormatting") >=> fromCursor        validations = M.fromList . map unDvPair $-          cur $/ element (n_ "dataValidations") &/ element (n_ "dataValidation") >=> fromCursor+          cur $/ element (addSmlNamespace "dataValidations") &/ element (addSmlNamespace "dataValidation") >=> fromCursor +      tableIds =+        cur $/ element (addSmlNamespace "tableParts") &/ element (addSmlNamespace "tablePart") >=>+        fromAttribute (odr "id")++  let mAutoFilter = listToMaybe $ cur $/ element (addSmlNamespace "autoFilter") >=> fromCursor+   mDrawing <- case mDrawingId of       Just dId -> do-          rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels-          Just <$> getDrawing ar contentTypes (relTarget rel)+          fp <- lookupRelPath filePath sheetRels dId+          Just <$> getDrawing ar contentTypes fp       Nothing  ->           return Nothing    let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable"   pTables <- forM (allByType ptType sheetRels) $ \rel -> do-    let ptPath = relTarget rel+    let ptPath = logicalNameToZipItemName $ relTarget rel     bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar     note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $       parsePivotTable (flip Prelude.lookup caches) bs -  return $ Worksheet cws rowProps cells mDrawing merges sheetViews pageSetup condFormtattings validations pTables+  tables <- forM tableIds $ \rId -> do+    fp <- lookupRelPath filePath sheetRels rId+    getTable ar fp -extractCellValue :: SharedStringTable -> Text -> Text -> [CellValue]-extractCellValue sst "s" v =-    case T.decimal v of-      Right (d, _) ->-        case sstItem sst d of-          XlsxText     txt  -> [CellText txt]-          XlsxRichText rich -> [CellRich rich]-      _ ->-        []-extractCellValue _ "str" str = [CellText str]-extractCellValue _ "n" v =-    case T.rational v of-      Right (d, _) -> [CellDouble d]-      _            -> []-extractCellValue _ "b" "1" = [CellBool True]-extractCellValue _ "b" "0" = [CellBool False]-extractCellValue _ _ _ = []+  return $+    Worksheet+      cws+      rowProps+      cells+      mDrawing+      merges+      sheetViews+      pageSetup+      condFormtattings+      validations+      pTables+      mAutoFilter+      tables+      mProtection+      sharedFormulas+      (wfState wf) +extractCellValue :: SharedStringTable -> Text -> Cursor -> [CellValue]+extractCellValue sst t cur+  | t == "s" = do+    si <- vConverted "shared string"+    case sstItem sst si of+      Just xlTxt -> return $ xlsxTextToCellValue xlTxt+      Nothing -> fail "bad shared string index"+  | t == "inlineStr" =+    cur $/ element (addSmlNamespace "is") >=> fmap xlsxTextToCellValue . fromCursor+  | t == "str" = CellText <$> vConverted "string"+  | t == "n" = CellDouble <$> vConverted "double"+  | t == "b" = CellBool <$> vConverted "boolean"+  | t == "e" = CellError <$> vConverted "error"+  | otherwise = fail "bad cell value"+  where+    vConverted typeStr = do+      vContent <- cur $/ element (addSmlNamespace "v") >=> \c ->+        return (T.concat $ c $/ content)+      case fromAttrVal vContent of+        Right (val, _) -> return $ val+        _ -> fail $ "bad " ++ typeStr ++ " cell value"+ -- | Get xml cursor from the specified file inside the zip archive. xmlCursorOptional :: Zip.Archive -> FilePath -> Parser (Maybe Cursor) xmlCursorOptional ar fname =@@ -204,16 +535,30 @@ xmlCursorRequired :: Zip.Archive -> FilePath -> Parser Cursor xmlCursorRequired ar fname = do     entry <- note (MissingFile fname) $ Zip.findEntryByPath fname ar-    cur <- left (\_ -> InvalidFile fname) $ parseLBS def (Zip.fromEntry entry)+    cur <- left (\ex -> InvalidFile fname (T.pack $ show ex)) $ parseLBS def (Zip.fromEntry entry)     return $ fromDocument cur +fromFileCursorDef ::+     FromCursor a => Zip.Archive -> FilePath -> Text -> a -> Parser a+fromFileCursorDef x fp contentsDescr defVal = do+  mCur <- xmlCursorOptional x fp+  case mCur of+    Just cur ->+      headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur+    Nothing -> return defVal++fromFileCursor :: FromCursor a => Zip.Archive -> FilePath -> Text -> Parser a+fromFileCursor x fp contentsDescr = do+  cur <- xmlCursorRequired x fp+  headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur+ -- | Get shared string table getSharedStrings  :: Zip.Archive -> Parser SharedStringTable-getSharedStrings x = maybe sstEmpty (head . fromCursor) <$>-                     xmlCursorOptional x "xl/sharedStrings.xml"+getSharedStrings x =+  fromFileCursorDef x "xl/sharedStrings.xml" "shared strings" sstEmpty  getContentTypes :: Zip.Archive -> Parser ContentTypes-getContentTypes x = head . fromCursor <$> xmlCursorRequired x "[Content_Types].xml"+getContentTypes x = fromFileCursor x "[Content_Types].xml" "content types"  getStyles :: Zip.Archive -> Styles getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of@@ -242,13 +587,14 @@         return $ singleCellRef (r0 + 1, c0 + 1)  getCustomProperties :: Zip.Archive -> Parser CustomProperties-getCustomProperties ar = maybe CustomProperties.empty (head . fromCursor) <$> xmlCursorOptional ar "docProps/custom.xml"+getCustomProperties ar =+  fromFileCursorDef ar "docProps/custom.xml" "custom properties" CustomProperties.empty  getDrawing :: Zip.Archive -> ContentTypes ->  FilePath -> Parser Drawing getDrawing ar contentTypes fp = do     cur <- xmlCursorRequired ar fp     drawingRels <- getRels ar fp-    unresolved <- headErr (InvalidFile fp) (fromCursor cur)+    unresolved <- headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur)     anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels     return $ Drawing anchors   where@@ -273,19 +619,22 @@           return uAnch {_anchObject = Graphic nv chart tr}     lookupFI _ Nothing = return Nothing     lookupFI rels (Just rId) = do-        path <- lookupRelPath fp rels rId+      path <- lookupRelPath fp rels rId         -- content types use paths starting with /-        contentType <- note (InvalidFile path) $ ContentTypes.lookup ("/" <> path) contentTypes-        contents <- Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar)-        return . Just $ FileInfo (stripMediaPrefix path) contentType contents+      contentType <-+        note (InvalidFile path "Missing content type") $+        ContentTypes.lookup ("/" <> path) contentTypes+      contents <-+        Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar)+      return . Just $ FileInfo (stripMediaPrefix path) contentType contents     stripMediaPrefix :: FilePath -> FilePath     stripMediaPrefix p = fromMaybe p $ stripPrefix "xl/media/" p  readChart :: Zip.Archive -> FilePath -> Parser ChartSpace-readChart ar path = head . fromCursor <$> xmlCursorRequired ar path+readChart ar path = fromFileCursor ar path "chart"  -- | readWorkbook pulls the names of the sheets and the defined names-readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches)+readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches, DateBase) readWorkbook ar = do   let wbPath = "xl/workbook.xml"   cur <- xmlCursorRequired ar wbPath@@ -294,49 +643,73 @@   let mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)]       mkDefinedName c =         return-          ( head $ attribute "name" c+          ( headNote "Missing name attribute" $ attribute "name" c           , listToMaybe $ attribute "localSheetId" c           , T.concat $ c $/ content)       names =-        cur $/ element (n_ "definedNames") &/ element (n_ "definedName") >=>+        cur $/ element (addSmlNamespace "definedNames") &/ element (addSmlNamespace "definedName") >=>         mkDefinedName   sheets <-     sequence $-    cur $/ element (n_ "sheets") &/ element (n_ "sheet") >=>-    liftA2 (worksheetFile wbPath wbRels) <$> attribute "name" <*>+    cur $/ element (addSmlNamespace "sheets") &/ element (addSmlNamespace "sheet") >=>+    liftM4 (worksheetFile wbPath wbRels) <$> attribute "name" <*> fromAttribute "sheetId" <*> fromAttributeDef "state" def <*>     fromAttribute (odr "id")   let cacheRefs =-        cur $/ element (n_ "pivotCaches") &/ element (n_ "pivotCache") >=>+        cur $/ element (addSmlNamespace "pivotCaches") &/ element (addSmlNamespace "pivotCache") >=>         liftA2 (,) <$> fromAttribute "cacheId" <*> fromAttribute (odr "id")   caches <-     forM cacheRefs $ \(cacheId, rId) -> do       path <- lookupRelPath wbPath wbRels rId       bs <-         note (MissingFile path) $ Zip.fromEntry <$> Zip.findEntryByPath path ar-      sources <-+      (sheet, ref, fields0, mRecRId) <-         note (InconsistentXlsx $ "Bad pivot table cache in " <> T.pack path) $         parseCache bs-      return (cacheId, sources)-  return (sheets, DefinedNames names, caches)+      fields <- case mRecRId of+        Just recId -> do+          cacheRels <- getRels ar path+          recsPath <- lookupRelPath path cacheRels recId+          rCur <- xmlCursorRequired ar recsPath+          let recs = rCur $/ element (addSmlNamespace "r") >=> \cur' ->+                return $ cur' $/ anyElement >=> recordValueFromNode . node+          return $ fillCacheFieldsFromRecords fields0 recs+        Nothing ->+          return fields0+      return $ (cacheId, (sheet, ref, fields))+  let dateBase = bool DateBase1900 DateBase1904 . fromMaybe False . listToMaybe $+                 cur $/ element (addSmlNamespace "workbookPr") >=> fromAttribute "date1904"+  return (sheets, DefinedNames names, caches, dateBase) +getTable :: Zip.Archive -> FilePath -> Parser Table+getTable ar fp = do+  cur <- xmlCursorRequired ar fp+  headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) -worksheetFile :: FilePath -> Relationships -> Text -> RefId -> Parser WorksheetFile-worksheetFile parentPath wbRels name rId =-  WorksheetFile name <$> lookupRelPath parentPath wbRels rId+worksheetFile :: FilePath -> Relationships -> Text -> Int -> SheetState -> RefId -> Parser WorksheetFile+worksheetFile parentPath wbRels name sheetId visibility rId =+  WorksheetFile name sheetId visibility <$> lookupRelPath parentPath wbRels rId  getRels :: Zip.Archive -> FilePath -> Parser Relationships getRels ar fp = do     let (dir, file) = splitFileName fp         relsPath = dir </> "_rels" </> file <.> "rels"     c <- xmlCursorOptional ar relsPath-    return $ maybe Relationships.empty (setTargetsFrom fp . head . fromCursor) c+    return $ maybe Relationships.empty (setTargetsFrom fp . headNote "Missing rels" . fromCursor) c +-- According to part 2, section 7.3.4 of ECMA-376, when mapping logical item+-- names to ZIP item names we need to remove the leading slash.+--+-- Non-ASCII characters should be percent-encoded as well, but this is not+-- currently implemented.+--+-- https://ecma-international.org/publications-and-standards/standards/ecma-376/+logicalNameToZipItemName :: FilePath -> FilePath+logicalNameToZipItemName ('/' : name) = name+logicalNameToZipItemName name = name+ lookupRelPath :: FilePath               -> Relationships               -> RefId               -> Either ParseError FilePath lookupRelPath fp rels rId =-  relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels)--int :: Text -> Int-int = either error fst . T.decimal+  logicalNameToZipItemName . relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels)
src/Codec/Xlsx/Parser/Internal.hs view
@@ -1,45 +1,50 @@-{-# LANGUAGE CPP                #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Codec.Xlsx.Parser.Internal-    ( ParseException(..)-    , n_-    , nodeElNameIs-    , FromCursor(..)-    , FromAttrVal(..)-    , fromAttribute-    , fromAttributeDef-    , maybeAttribute-    , fromElementValue-    , maybeElementValue-    , maybeElementValueDef-    , maybeBoolElementValue-    , maybeFromElement-    , contentOrEmpty-    , readSuccess-    , readFailure-    , invalidText-    , defaultReadFailure-    , boolean-    , decimal-    , rational-    ) where+  ( ParseException(..)+  , n_+  , addSmlNamespace+  , nodeElNameIs+  , FromCursor(..)+  , FromAttrVal(..)+  , fromAttribute+  , fromAttributeDef+  , maybeAttribute+  , fromElementValue+  , maybeElementValue+  , maybeElementValueDef+  , maybeBoolElementValue+  , maybeFromElement+  , attrValIs+  , contentOrEmpty+  , readSuccess+  , readFailure+  , invalidText+  , defaultReadFailure+  , module Codec.Xlsx.Parser.Internal.Util+  , module Codec.Xlsx.Parser.Internal.Fast+  ) where -import           Control.Exception       (Exception)-import           Data.Maybe-import           Data.Text               (Text)-import qualified Data.Text               as T-import qualified Data.Text.Read          as T-import           Data.Typeable           (Typeable)-import           Text.XML-import           Text.XML.Cursor+import Control.Exception (Exception)+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as T+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Text.XML+import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal.Fast+import Codec.Xlsx.Parser.Internal.Util  data ParseException = ParseException String-                    deriving (Show, Typeable)+                    deriving (Show, Typeable, Generic)  instance Exception ParseException @@ -113,6 +118,12 @@   [cursor'] -> Just <$> fromCursor cursor'   _ -> [Nothing] +attrValIs :: (Eq a, FromAttrVal a) => Name -> a -> Axis+attrValIs n v c =+  case fromAttribute n c of+    [x] | x == v -> [c]+    _ -> []+ contentOrEmpty :: Cursor -> [Text] contentOrEmpty c =   case c $/ content of@@ -137,26 +148,15 @@   Right (r, leftover) | T.null leftover -> [r]   _ -> [] --- | Add sml namespace to name++{-# DEPRECATED n_ "Renamed to addSmlNamespace" #-} n_ :: Text -> Name-n_ x = Name+n_ = addSmlNamespace++-- | Add sml namespace to name+addSmlNamespace :: Text -> Name+addSmlNamespace x = Name   { nameLocalName = x-  , nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main"-  , namePrefix = Just "n"+  , nameNamespace = Just mainNamespace+  , namePrefix = Nothing   }--decimal :: (Monad m, Integral a) => Text -> m a-decimal t = case T.signed T.decimal $ t of-  Right (d, leftover) | T.null leftover -> return d-  _ -> fail $ "invalid decimal" ++ show t--rational :: Monad m => Text -> m Double-rational t = case T.rational t of-  Right (r, leftover) | T.null leftover -> return r-  _ -> fail $ "invalid rational: " ++ show t--boolean :: Monad m => Text -> m Bool-boolean t = case T.strip t of-    "true"  -> return True-    "false" -> return False-    _       -> fail $ "invalid boolean: " ++ show t
+ 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
@@ -1,24 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-module Codec.Xlsx.Parser.Internal.PivotTable (-   parsePivotTable+{-# LANGUAGE DeriveGeneric #-}+module Codec.Xlsx.Parser.Internal.PivotTable+  ( parsePivotTable   , parseCache-) where+  , fillCacheFieldsFromRecords+  ) where  import Control.Applicative import Data.ByteString.Lazy (ByteString)-import Data.Maybe (listToMaybe, maybeToList)+import Data.List (transpose)+import Data.Maybe (listToMaybe, mapMaybe, maybeToList) import Data.Text (Text)+import Safe (atMay) import Text.XML import Text.XML.Cursor  import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.Internal+import Codec.Xlsx.Types.Internal.Relationships (odr) import Codec.Xlsx.Types.PivotTable import Codec.Xlsx.Types.PivotTable.Internal  parsePivotTable-  :: (CacheId -> Maybe (Text, Range, [PivotFieldName]))+  :: (CacheId -> Maybe (Text, Range, [CacheField]))   -> ByteString   -> Maybe PivotTable parsePivotTable srcByCacheId bs =@@ -28,32 +34,45 @@       cacheId <- fromAttribute "cacheId" cur       case srcByCacheId cacheId of         Nothing -> fail "no such cache"-        Just (_pvtSrcSheet, _pvtSrcRef, fieldNames) -> do+        Just (_pvtSrcSheet, _pvtSrcRef, cacheFields) -> do           _pvtDataCaption <- attribute "dataCaption" cur           _pvtName <- attribute "name" cur-          _pvtLocation <- cur $/ element (n_ "location") >=> fromAttribute "ref"+          _pvtLocation <- cur $/ element (addSmlNamespace "location") >=> fromAttribute "ref"           _pvtRowGrandTotals <- fromAttributeDef "rowGrandTotals" True cur           _pvtColumnGrandTotals <- fromAttributeDef "colGrandTotals" True cur           _pvtOutline <- fromAttributeDef "outline" False cur           _pvtOutlineData <- fromAttributeDef "outlineData" False cur-          let nToField = zip [0 ..] fieldNames-              outlines =-                cur $/ element (n_ "pivotFields") &/ element (n_ "pivotField") >=>-                fromAttributeDef "outline" True-              _pvtFields =-                [ PivotFieldInfo {_pfiName = name, _pfiOutline = outline}-                | (name, outline) <- zip fieldNames outlines-                ]+          let pvtFieldsWithHidden =+                cur $/ element (addSmlNamespace "pivotFields") &/ element (addSmlNamespace "pivotField") >=> \c -> do+                  -- actually gets overwritten from cache to have consistent field names+                  _pfiName <- maybeAttribute "name" c+                  _pfiSortType <- fromAttributeDef "sortType" FieldSortManual c+                  _pfiOutline <- fromAttributeDef "outline" True c+                  let hidden =+                        c $/ element (addSmlNamespace "items") &/ element (addSmlNamespace "item") >=>+                        attrValIs "h" True >=> fromAttribute "x"+                      _pfiHiddenItems = []+                  return (PivotFieldInfo {..}, hidden)+              _pvtFields = flip map (zip [0.. ] pvtFieldsWithHidden) $+                           \(i, (PivotFieldInfo {..}, hidden)) ->+                             let  _pfiHiddenItems =+                                    [item | (n, item) <- zip [(0 :: Int) ..] items, n `elem` hidden]+                                  (_pfiName, items) = case atMay cacheFields i of+                                    Just CacheField{..} -> (Just cfName, cfItems)+                                    Nothing -> (Nothing, [])+                             in PivotFieldInfo {..}+              nToFieldName = zip [0 ..] $ map cfName cacheFields+              fieldNameList fld = maybeToList $ lookup fld nToFieldName               _pvtRowFields =-                cur $/ element (n_ "rowFields") &/ element (n_ "field") >=>+                cur $/ element (addSmlNamespace "rowFields") &/ element (addSmlNamespace "field") >=>                 fromAttribute "x" >=> fieldPosition               _pvtColumnFields =-                cur $/ element (n_ "colFields") &/ element (n_ "field") >=>+                cur $/ element (addSmlNamespace "colFields") &/ element (addSmlNamespace "field") >=>                 fromAttribute "x" >=> fieldPosition               _pvtDataFields =-                cur $/ element (n_ "dataFields") &/ element (n_ "dataField") >=> \c -> do+                cur $/ element (addSmlNamespace "dataFields") &/ element (addSmlNamespace "dataField") >=> \c -> do                   fld <- fromAttribute "fld" c-                  _dfField <- maybeToList $ lookup fld nToField+                  _dfField <- fieldNameList fld                   -- TOFIX                   _dfName <- fromAttributeDef "name" "" c                   _dfFunction <- fromAttributeDef "subtotal" ConsolidateSum c@@ -61,17 +80,30 @@               fieldPosition :: Int -> [PositionedField]               fieldPosition (-2) = return DataPosition               fieldPosition n =-                FieldPosition <$> maybeToList (lookup n nToField)+                FieldPosition <$> fieldNameList n           return PivotTable {..} -parseCache :: ByteString -> Maybe (Text, CellRef, [PivotFieldName])+parseCache :: ByteString -> Maybe (Text, CellRef, [CacheField], Maybe RefId) parseCache bs = listToMaybe . parse . fromDocument $ parseLBS_ def bs   where     parse cur = do+      refId <- maybeAttribute (odr "id") cur       (sheet, ref) <--        cur $/ element (n_ "cacheSource") &/ element (n_ "worksheetSource") >=>+        cur $/ element (addSmlNamespace "cacheSource") &/ element (addSmlNamespace "worksheetSource") >=>         liftA2 (,) <$> attribute "sheet" <*> fromAttribute "ref"-      let fieldNames =-            cur $/ element (n_ "cacheFields") &/ element (n_ "cacheField") >=>-            fromAttribute "name"-      return (sheet, ref, fieldNames)+      let fields =+            cur $/ element (addSmlNamespace "cacheFields") &/ element (addSmlNamespace "cacheField") >=>+            fromCursor+      return (sheet, ref, fields, refId)++fillCacheFieldsFromRecords :: [CacheField] -> [CacheRecord] -> [CacheField]+fillCacheFieldsFromRecords fields recs =+  zipWith addValues fields (transpose recs)+  where+    addValues field recVals =+      if null (cfItems field)+        then field {cfItems = mapMaybe recToCellValue recVals}+        else field+    recToCellValue (CacheText t) = Just $ CellText t+    recToCellValue (CacheNumber n) = Just $ CellDouble n+    recToCellValue (CacheIndex _) = Nothing
+ 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
@@ -2,18 +2,26 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes          #-}+ module Codec.Xlsx.Types (     -- * The main types     Xlsx(..)     , Styles(..)     , DefinedNames(..)-    , ColumnsWidth(..)+    , ColumnsProperties(..)     , PageSetup(..)     , Worksheet(..)+    , SheetState(..)     , CellMap     , CellValue(..)     , CellFormula(..)+    , FormulaExpression(..)+    , Cell.SharedFormulaIndex(..)+    , Cell.SharedFormulaOptions(..)     , Cell(..)+    , RowHeight(..)     , RowProperties (..)     -- * Lenses     -- ** Workbook@@ -21,8 +29,9 @@     , xlStyles     , xlDefinedNames     , xlCustomProperties+    , xlDateBase     -- ** Worksheet-    , wsColumns+    , wsColumnsProperties     , wsRowPropertiesMap     , wsCells     , wsDrawing@@ -32,121 +41,208 @@     , wsConditionalFormattings     , wsDataValidations     , wsPivotTables+    , wsAutoFilter+    , wsTables+    , wsProtection+    , wsSharedFormulas+    , wsState     -- ** Cells-    , cellValue-    , cellStyle-    , cellComment-    , cellFormula+    , Cell.cellValue+    , Cell.cellStyle+    , Cell.cellComment+    , Cell.cellFormula+    -- ** Row properties+    , rowHeightLens+    , _CustomHeight+    , _AutomaticHeight     -- * Style helpers     , emptyStyles     , renderStyleSheet     , parseStyleSheet     -- * Misc     , simpleCellFormula+    , sharedFormulaByIndex     , def     , toRows     , fromRows     , module X     ) where -import           Control.Exception                      (SomeException,-                                                         toException)-import           Control.Lens.TH-import qualified Data.ByteString.Lazy                   as L-import           Data.Default-import           Data.Function                          (on)-import           Data.List                              (groupBy)-import           Data.Map                               (Map)-import qualified Data.Map                               as M-import           Data.Maybe                             (catMaybes)-import           Data.Text                              (Text)-import           Text.XML                               (Element (..), parseLBS,-                                                         renderLBS)-import           Text.XML.Cursor+import Control.Exception (SomeException, toException)+import Codec.Xlsx.LensCompat (lens, Lens', makeLenses, Prism', prism)+import Control.DeepSeq (NFData)+import qualified Data.ByteString.Lazy as L+import Data.Default+import Data.Function (on)+import Data.List (groupBy)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe (catMaybes, isJust)+import Data.Text (Text)+import GHC.Generics (Generic)+import Text.XML (parseLBS, renderLBS)+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Comment               as X-import           Codec.Xlsx.Types.Common                as X-import           Codec.Xlsx.Types.ConditionalFormatting as X-import           Codec.Xlsx.Types.DataValidation        as X-import           Codec.Xlsx.Types.Drawing               as X-import           Codec.Xlsx.Types.Drawing.Chart         as X-import           Codec.Xlsx.Types.Drawing.Common        as X-import           Codec.Xlsx.Types.PageSetup             as X-import           Codec.Xlsx.Types.PivotTable            as X-import           Codec.Xlsx.Types.RichText              as X-import           Codec.Xlsx.Types.SheetViews            as X-import           Codec.Xlsx.Types.StyleSheet            as X-import           Codec.Xlsx.Types.Variant               as X-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.AutoFilter as X+import Codec.Xlsx.Types.Cell as Cell+import Codec.Xlsx.Types.Comment as X+import Codec.Xlsx.Types.Common as X+import Codec.Xlsx.Types.ConditionalFormatting as X+import Codec.Xlsx.Types.DataValidation as X+import Codec.Xlsx.Types.Drawing as X+import Codec.Xlsx.Types.Drawing.Chart as X+import Codec.Xlsx.Types.Drawing.Common as X+import Codec.Xlsx.Types.PageSetup as X+import Codec.Xlsx.Types.PivotTable as X+import Codec.Xlsx.Types.Protection as X+import Codec.Xlsx.Types.RichText as X+import Codec.Xlsx.Types.SheetViews as X+import Codec.Xlsx.Types.StyleSheet as X+import Codec.Xlsx.Types.Table as X+import Codec.Xlsx.Types.Variant as X+import Codec.Xlsx.Writer.Internal --- | Formula for the cell.------ TODO: array. dataTable and shared formula types support------ See 18.3.1.40 "f (Formula)" (p. 1636)-data CellFormula-    = NormalCellFormula-      { _cellfExpression    :: Formula-      , _cellfAssignsToName :: Bool-      -- ^ Specifies that this formula assigns a value to a name.-      , _cellfCalculate     :: Bool-      -- ^ Indicates that this formula needs to be recalculated-      -- the next time calculation is performed.-      -- [/Example/: This is always set on volatile functions,-      -- like =RAND(), and circular references. /end example/]-      } deriving (Eq, Show)+-- | Height of a row in points (1/72in)+data RowHeight+  = CustomHeight    !Double+    -- ^ Row height is set by the user+  | AutomaticHeight !Double+    -- ^ Row height is set automatically by the program+  deriving (Eq, Ord, Show, Read, Generic)+instance NFData RowHeight -simpleCellFormula :: Text -> CellFormula-simpleCellFormula expr = NormalCellFormula-    { _cellfExpression    = Formula expr-    , _cellfAssignsToName = False-    , _cellfCalculate     = False-    }+_CustomHeight :: Prism' RowHeight Double+_CustomHeight+  = (prism (\ x1_a4xgd -> CustomHeight x1_a4xgd))+      (\ x_a4xge+         -> case x_a4xge of+              CustomHeight y1_a4xgf -> Right y1_a4xgf+              _ -> Left x_a4xge)+{-# INLINE _CustomHeight #-} --- | Currently cell details include only cell values and style ids--- (e.g. formulas from @\<f\>@ and inline strings from @\<is\>@--- subelements are ignored)-data Cell = Cell-    { _cellStyle   :: Maybe Int-    , _cellValue   :: Maybe CellValue-    , _cellComment :: Maybe Comment-    , _cellFormula :: Maybe CellFormula-    } deriving (Eq, Show)+_AutomaticHeight :: Prism' RowHeight Double+_AutomaticHeight+  = (prism (\ x1_a4xgg -> AutomaticHeight x1_a4xgg))+      (\ x_a4xgh+         -> case x_a4xgh of+              AutomaticHeight y1_a4xgi -> Right y1_a4xgi+              _ -> Left x_a4xgh)+{-# INLINE _AutomaticHeight #-} -makeLenses ''Cell+-- | Properties of a row. See §18.3.1.73 "row (Row)" for more details+data RowProperties = RowProps+  { rowHeight       :: Maybe RowHeight+    -- ^ Row height in points+  , rowStyle        :: Maybe Int+    -- ^ Style to be applied to row+  , rowHidden       :: Bool+    -- ^ Whether row is visible or not+  } deriving (Eq, Ord, Show, Read, Generic)+instance NFData RowProperties -instance Default Cell where-    def = Cell Nothing Nothing Nothing Nothing+rowHeightLens :: Lens' RowProperties (Maybe RowHeight)+rowHeightLens = lens rowHeight $ \x y -> x{rowHeight=y} --- | Map containing cell values which are indexed by row and column--- if you need to use more traditional (x,y) indexing please you could--- use corresponding accessors from ''Codec.Xlsx.Lens''-type CellMap = Map (Int, Int) Cell+instance Default RowProperties where+  def = RowProps { rowHeight       = Nothing+                 , rowStyle        = Nothing+                 , rowHidden       = False+                 } -data RowProperties = RowProps { rowHeight :: Maybe Double, rowStyle::Maybe Int}-                   deriving (Read,Eq,Show,Ord)+-- | Column range (from cwMin to cwMax) properties+data ColumnsProperties = ColumnsProperties+  { cpMin :: Int+  -- ^ First column affected by this 'ColumnWidth' record.+  , cpMax :: Int+  -- ^ Last column affected by this 'ColumnWidth' record.+  , cpWidth :: Maybe Double+  -- ^ Column width measured as the number of characters of the+  -- maximum digit width of the numbers 0, 1, 2, ..., 9 as rendered in+  -- the normal style's font.+  --+  -- See longer description in Section 18.3.1.13 "col (Column Width &+  -- Formatting)" (p. 1605)+  , cpStyle :: Maybe Int+  -- ^ Default style for the affected column(s). Affects cells not yet+  -- allocated in the column(s).  In other words, this style applies+  -- to new columns.+  , cpHidden :: Bool+  -- ^ Flag indicating if the affected column(s) are hidden on this+  -- worksheet.+  , cpCollapsed :: Bool+  -- ^ Flag indicating if the outlining of the affected column(s) is+  -- in the collapsed state.+  , cpBestFit :: Bool+  -- ^ Flag indicating if the specified column(s) is set to 'best+  -- fit'.+  } deriving (Eq, Show, Generic)+instance NFData ColumnsProperties --- | Column range (from cwMin to cwMax) width-data ColumnsWidth = ColumnsWidth-    { cwMin   :: Int-    , cwMax   :: Int-    , cwWidth :: Double-    , cwStyle :: Int-    } deriving (Eq, Show)+instance FromCursor ColumnsProperties where+  fromCursor c = do+    cpMin <- fromAttribute "min" c+    cpMax <- fromAttribute "max" c+    cpWidth <- maybeAttribute "width" c+    cpStyle <- maybeAttribute "style" c+    cpHidden <- fromAttributeDef "hidden" False c+    cpCollapsed <- fromAttributeDef "collapsed" False c+    cpBestFit <- fromAttributeDef "bestFit" False c+    return ColumnsProperties {..} -instance FromCursor ColumnsWidth where-    fromCursor c = do-      cwMin <- decimal =<< attribute "min" c-      cwMax <- decimal =<< attribute "max" c-      cwWidth <- rational =<< attribute "width" c-      cwStyle <- decimal =<< attribute "style" c-      return ColumnsWidth{..}+instance FromXenoNode ColumnsProperties where+  fromXenoNode root = parseAttributes root $ do+    cpMin <- fromAttr "min"+    cpMax <- fromAttr "max"+    cpWidth <- maybeAttr "width"+    cpStyle <- maybeAttr "style"+    cpHidden <- fromAttrDef "hidden" False+    cpCollapsed <- fromAttrDef "collapsed" False+    cpBestFit <- fromAttrDef "bestFit" False+    return ColumnsProperties {..} +-- | Sheet visibility state+-- cf. Ecma Office Open XML Part 1:+-- 18.18.68 ST_SheetState (Sheet Visibility Types)+-- * "visible"+--     Indicates the sheet is visible (default)+-- * "hidden"+--     Indicates the workbook window is hidden, but can be shown by the user via the user interface.+-- * "veryHidden"+--     Indicates the sheet is hidden and cannot be shown in the user interface (UI). This state is only available programmatically.+data SheetState =+  Visible -- ^ state="visible"+  | Hidden -- ^ state="hidden"+  | VeryHidden -- ^ state="veryHidden"+  deriving (Eq, Show, Generic)++instance NFData SheetState++instance Default SheetState where+  def = Visible++instance FromAttrVal SheetState where+    fromAttrVal "visible"    = readSuccess Visible+    fromAttrVal "hidden"     = readSuccess Hidden+    fromAttrVal "veryHidden" = readSuccess VeryHidden+    fromAttrVal t            = invalidText "SheetState" t++instance FromAttrBs SheetState where+    fromAttrBs "visible"    = return Visible+    fromAttrBs "hidden"     = return Hidden+    fromAttrBs "veryHidden" = return VeryHidden+    fromAttrBs t            = unexpectedAttrBs "SheetState" t++instance ToAttrVal SheetState where+    toAttrVal Visible    = "visible"+    toAttrVal Hidden     = "hidden"+    toAttrVal VeryHidden = "veryHidden"+ -- | Xlsx worksheet data Worksheet = Worksheet-  { _wsColumns :: [ColumnsWidth] -- ^ column widths-  , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map+  { _wsColumnsProperties :: [ColumnsProperties] -- ^ column widths+  , _wsRowPropertiesMap :: Map RowIndex RowProperties+    -- ^ custom row properties (height, style) map   , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs   , _wsDrawing :: Maybe Drawing -- ^ SpreadsheetML Drawing   , _wsMerges :: [Range] -- ^ list of cell merges@@ -155,24 +251,57 @@   , _wsConditionalFormattings :: Map SqRef ConditionalFormatting   , _wsDataValidations :: Map SqRef DataValidation   , _wsPivotTables :: [PivotTable]-  } deriving (Eq, Show)+  , _wsAutoFilter :: Maybe AutoFilter+  , _wsTables :: [Table]+  , _wsProtection :: Maybe SheetProtection+  , _wsSharedFormulas :: Map SharedFormulaIndex SharedFormulaOptions+  , _wsState :: SheetState+  } deriving (Eq, Show, Generic)+instance NFData Worksheet  makeLenses ''Worksheet  instance Default Worksheet where-    def = Worksheet [] M.empty M.empty Nothing [] Nothing Nothing M.empty M.empty []+  def =+    Worksheet+    { _wsColumnsProperties = []+    , _wsRowPropertiesMap = M.empty+    , _wsCells = M.empty+    , _wsDrawing = Nothing+    , _wsMerges = []+    , _wsSheetViews = Nothing+    , _wsPageSetup = Nothing+    , _wsConditionalFormattings = M.empty+    , _wsDataValidations = M.empty+    , _wsPivotTables = []+    , _wsAutoFilter = Nothing+    , _wsTables = []+    , _wsProtection = Nothing+    , _wsSharedFormulas = M.empty+    , _wsState = def+    } +-- | Raw worksheet styles, for structured implementation see 'StyleSheet'+-- and functions in "Codec.Xlsx.Types.StyleSheet" newtype Styles = Styles {unStyles :: L.ByteString}-            deriving (Eq, Show)+            deriving (Eq, Show, Generic)+instance NFData Styles  -- | Structured representation of Xlsx file (currently a subset of its contents) data Xlsx = Xlsx-    { _xlSheets           :: [(Text, Worksheet)]-    , _xlStyles           :: Styles-    , _xlDefinedNames     :: DefinedNames-    , _xlCustomProperties :: Map Text Variant-    } deriving (Eq, Show)+  { _xlSheets :: [(Text, Worksheet)]+  , _xlStyles :: Styles+  , _xlDefinedNames :: DefinedNames+  , _xlCustomProperties :: Map Text Variant+  , _xlDateBase :: DateBase+  -- ^ date base to use when converting serial value (i.e. 'CellDouble d')+  -- into date-time. Default value is 'DateBase1900'+  --+  -- See also 18.17.4.1 "Date Conversion for Serial Date-Times" (p. 2067)+  } deriving (Eq, Show, Generic)+instance NFData Xlsx + -- | Defined names -- -- Each defined name consists of a name, an optional local sheet ID, and a value.@@ -195,19 +324,19 @@ -- -- NOTE: Right now this is only a minimal implementation of defined names. newtype DefinedNames = DefinedNames [(Text, Maybe Text, Text)]-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData DefinedNames  makeLenses ''Xlsx  instance Default Xlsx where-    def = Xlsx [] emptyStyles def M.empty+    def = Xlsx [] emptyStyles def M.empty DateBase1900  instance Default DefinedNames where     def = DefinedNames []  emptyStyles :: Styles-emptyStyles = Styles "<?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>"  -- | Render 'StyleSheet' --@@ -233,7 +362,7 @@  -- | converts cells mapped by (row, column) into rows which contain -- row index and cells as pairs of column indices and cell values-toRows :: CellMap -> [(Int, [(Int, Cell)])]+toRows :: CellMap -> [(RowIndex, [(ColumnIndex, Cell)])] toRows cells =     map extractRow $ groupBy ((==) `on` (fst . fst)) $ M.toList cells   where@@ -242,37 +371,22 @@     extractRow _ = error "invalid CellMap row"  -- | reverse to 'toRows'-fromRows :: [(Int, [(Int, Cell)])] -> CellMap+fromRows :: [(RowIndex, [(ColumnIndex, Cell)])] -> CellMap fromRows rows = M.fromList $ concatMap mapRow rows   where     mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells -{--------------------------------------------------------------------------------  Parsing--------------------------------------------------------------------------------} -instance FromCursor CellFormula where-    fromCursor cur = do-        t <- fromAttributeDef "t" "normal" cur-        typedCellFormula t cur--typedCellFormula :: Text -> Cursor -> [CellFormula]-typedCellFormula "normal" cur = do-    _cellfExpression <- fromCursor cur-    _cellfAssignsToName <- fromAttributeDef "bx" False cur-    _cellfCalculate <- fromAttributeDef "ca" False cur-    return NormalCellFormula{..}-typedCellFormula _ _ = fail "parseable cell formula type was not found"--{--------------------------------------------------------------------------------  Rendering--------------------------------------------------------------------------------}--instance ToElement CellFormula where-    toElement nm NormalCellFormula{..} =-        let formulaEl = toElement nm _cellfExpression-        in formulaEl-           { elementAttributes =-                   M.fromList $ catMaybes [ "bx" .=? justTrue _cellfAssignsToName-                                          , "ca" .=? justTrue _cellfCalculate ]-           }+instance ToElement ColumnsProperties where+  toElement nm ColumnsProperties {..} = leafElement nm attrs+    where+      attrs =+        ["min" .= cpMin, "max" .= cpMax] +++        catMaybes+          [ "style" .=? (justNonDef 0 =<< cpStyle)+          , "width" .=? cpWidth+          , "customWidth" .=? justTrue (isJust cpWidth)+          , "hidden" .=? justTrue cpHidden+          , "collapsed" .=? justTrue cpCollapsed+          , "bestFit" .=? justTrue cpBestFit+          ]
+ 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
@@ -1,8 +1,11 @@+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Comment where -import           Data.Text               (Text)+import Control.DeepSeq (NFData)+import Data.Text (Text)+import GHC.Generics (Generic) -import           Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.Common  -- | User comment for a cell --@@ -17,4 +20,5 @@     , _commentAuthor  :: Text     -- ^ comment author     , _commentVisible :: Bool-    } deriving (Show, Eq)+    } deriving (Eq, Show, Generic)+instance NFData Comment
src/Codec/Xlsx/Types/Common.hs view
@@ -1,41 +1,113 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ module Codec.Xlsx.Types.Common   ( CellRef(..)+  , RowCoord(..)+  , ColumnCoord(..)+  , CellCoord+  , RangeCoord+  , mapBoth+  , col2coord+  , coord2col+  , row2coord+  , coord2row   , singleCellRef+  , singleCellRef'   , fromSingleCellRef+  , fromSingleCellRef'+  , fromSingleCellRefNoting+  , escapeRefSheetName+  , unEscapeRefSheetName+  , mkForeignSingleCellRef+  , fromForeignSingleCellRef   , Range   , mkRange+  , mkRange'+  , mkForeignRange   , fromRange+  , fromRange'+  , fromForeignRange   , SqRef(..)   , XlsxText(..)+  , xlsxTextToCellValue   , Formula(..)   , CellValue(..)+  , ErrorType(..)+  , DateBase(..)+  , dateFromNumber+  , dateToNumber   , int2col   , col2int+  , columnIndexToText+  , textToColumnIndex+  -- ** prisms+  , _XlsxText+  , _XlsxRichText+  , _CellText+  , _CellDouble+  , _CellBool+  , _CellRich+  , _CellError+  , RowIndex(..)+  , ColumnIndex(..)   ) where +import GHC.Generics (Generic)++import Control.Applicative (liftA2) import Control.Arrow-import Control.Monad (guard)+import Control.DeepSeq (NFData)+import Control.Monad (forM, guard)+import Data.Bifunctor (bimap)+import qualified Data.ByteString as BS import Data.Char+import Data.Maybe (isJust, fromMaybe)+import Data.Function ((&)) import Data.Ix (inRange) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time.Calendar (Day, addDays, diffDays, fromGregorian)+import Data.Time.Clock (UTCTime(UTCTime), picosecondsToDiffTime)+import Safe import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif- import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.RichText import Codec.Xlsx.Writer.Internal+import Codec.Xlsx.LensCompat (Prism', prism) +newtype RowIndex = RowIndex {unRowIndex :: Int}+  deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral)+newtype ColumnIndex = ColumnIndex {unColumnIndex :: Int}+  deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral)+instance NFData RowIndex+instance NFData ColumnIndex++instance ToAttrVal RowIndex where+  toAttrVal = toAttrVal . unRowIndex++{-# DEPRECATED int2col+    "this function will be removed in an upcoming release, use columnIndexToText instead." #-}+int2col :: ColumnIndex -> Text+int2col = columnIndexToText++{-# DEPRECATED col2int+    "this function will be removed in an upcoming release, use textToColumnIndex instead." #-}+col2int :: Text -> ColumnIndex+col2int = textToColumnIndex+ -- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\")-int2col :: Int -> Text-int2col = T.pack . reverse . map int2let . base26+columnIndexToText :: ColumnIndex -> Text+columnIndexToText = T.pack . reverse . map int2let . base26 . unColumnIndex     where         int2let 0 = 'Z'         int2let x = chr $ (x - 1) + ord 'A'@@ -44,61 +116,247 @@                         i'' = if i' == 0 then 26 else i'                     in seq i' (i' : base26 ((i - i'') `div` 26)) --- | reverse to 'int2col'-col2int :: Text -> Int-col2int = T.foldl' (\i c -> i * 26 + let2int c) 0+rowIndexToText :: RowIndex -> Text+rowIndexToText = T.pack . show . unRowIndex++-- | reverse of 'columnIndexToText'+textToColumnIndex :: Text -> ColumnIndex+textToColumnIndex = ColumnIndex . T.foldl' (\i c -> i * 26 + let2int c) 0     where         let2int c = 1 + ord c - ord 'A' --- | Excel cell or cell range reference (e.g. @E3@)+textToRowIndex :: Text -> RowIndex+textToRowIndex = RowIndex . read . T.unpack++-- | Excel cell or cell range reference (e.g. @E3@), possibly absolute. -- See 18.18.62 @ST_Ref@ (p. 2482)+--+-- Note: The @ST_Ref@ type can point to another sheet (supported)+-- or a sheet in another workbook (separate .xlsx file, not implemented). newtype CellRef = CellRef   { unCellRef :: Text-  } deriving (Eq, Ord, Show)+  } deriving (Eq, Ord, Show, Generic)+instance NFData CellRef +-- | A helper type for coordinates to carry the intent of them being relative or absolute (preceded by '$'):+--+-- > singleCellRefRaw' (RowRel 5, ColumnAbs 1) == "$A5"+data RowCoord+  = RowAbs !RowIndex+  | RowRel !RowIndex+  deriving (Eq, Ord, Show, Read, Generic)+instance NFData RowCoord++data ColumnCoord+  = ColumnAbs !ColumnIndex+  | ColumnRel !ColumnIndex+  deriving (Eq, Ord, Show, Read, Generic)+instance NFData ColumnCoord++type CellCoord = (RowCoord, ColumnCoord)++type RangeCoord = (CellCoord, CellCoord)++mkColumnCoord :: Bool -> ColumnIndex -> ColumnCoord+mkColumnCoord isAbs = if isAbs then ColumnAbs else ColumnRel++mkRowCoord :: Bool -> RowIndex -> RowCoord+mkRowCoord isAbs = if isAbs then RowAbs else RowRel++coord2col :: ColumnCoord -> Text+coord2col (ColumnAbs c) = "$" <> coord2col (ColumnRel c)+coord2col (ColumnRel c) = columnIndexToText c++col2coord :: Text -> ColumnCoord+col2coord t =+  let t' = T.stripPrefix "$" t+    in mkColumnCoord (isJust t') (textToColumnIndex (fromMaybe t t'))++coord2row :: RowCoord -> Text+coord2row (RowAbs c) = "$" <> coord2row (RowRel c)+coord2row (RowRel c) = rowIndexToText c++row2coord :: Text -> RowCoord+row2coord t =+  let t' = T.stripPrefix "$" t+    in mkRowCoord (isJust t') (textToRowIndex (fromMaybe t t'))++-- | Unwrap a Coord into an abstract Int coordinate+unRowCoord :: RowCoord -> RowIndex+unRowCoord (RowAbs i) = i+unRowCoord (RowRel i) = i++-- | Unwrap a Coord into an abstract Int coordinate+unColumnCoord :: ColumnCoord -> ColumnIndex+unColumnCoord (ColumnAbs i) = i+unColumnCoord (ColumnRel i) = i++-- | Helper function to apply the same transformation to both members of a tuple+--+-- > mapBoth Abs (1, 2) == (Abs 1, Abs 2s)+mapBoth :: (a -> b) -> (a, a) -> (b, b)+mapBoth f = bimap f f+ -- | Render position in @(row, col)@ format to an Excel reference. ----- > mkCellRef (2, 4) == "D2"-singleCellRef :: (Int, Int) -> CellRef+-- > singleCellRef (RowIndex 2, ColumnIndex 4) == CellRef "D2"+singleCellRef :: (RowIndex, ColumnIndex) -> CellRef singleCellRef = CellRef . singleCellRefRaw -singleCellRefRaw :: (Int, Int) -> Text-singleCellRefRaw (row, col) = T.concat [int2col col, T.pack (show row)]+-- | Allow specifying whether a coordinate parameter is relative or absolute.+--+-- > singleCellRef' (Rel 5, Abs 1) == CellRef "$A5"+singleCellRef' :: CellCoord -> CellRef+singleCellRef' = CellRef . singleCellRefRaw' --- | reverse to 'mkCellRef'-fromSingleCellRef :: CellRef -> Maybe (Int, Int)+singleCellRefRaw :: (RowIndex, ColumnIndex) -> Text+singleCellRefRaw (row, col) = T.concat [columnIndexToText col, rowIndexToText row]++singleCellRefRaw' :: CellCoord -> Text+singleCellRefRaw' (row, col) =+    coord2col col <> coord2row row++-- | Converse function to 'singleCellRef'+-- Ignores a potential foreign sheet prefix.+fromSingleCellRef :: CellRef -> Maybe (RowIndex, ColumnIndex) fromSingleCellRef = fromSingleCellRefRaw . unCellRef -fromSingleCellRefRaw :: Text -> Maybe (Int, Int)-fromSingleCellRefRaw t = do-  let (colT, rowT) = T.span (inRange ('A', 'Z')) t-  guard $ not (T.null colT) && not (T.null rowT) && T.all isDigit rowT-  row <- decimal rowT-  return (row, col2int colT)+-- | Converse function to 'singleCellRef\''+-- Ignores a potential foreign sheet prefix.+fromSingleCellRef' :: CellRef -> Maybe CellCoord+fromSingleCellRef' = fromSingleCellRefRaw' . unCellRef +fromSingleCellRefRaw :: Text -> Maybe (RowIndex, ColumnIndex)+fromSingleCellRefRaw =+  fmap (first unRowCoord . second unColumnCoord) . fromSingleCellRefRaw'++fromSingleCellRefRaw' :: Text -> Maybe CellCoord+fromSingleCellRefRaw' t' = ignoreRefSheetName t' >>= \t -> do+    let (isColAbsolute, remT) =+          T.stripPrefix "$" t+          & \remT' -> (isJust remT', fromMaybe t remT')+    let (colT, rowExpr) = T.span (inRange ('A', 'Z')) remT+    let (isRowAbsolute, rowT) =+          T.stripPrefix "$" rowExpr+          & \rowT' -> (isJust rowT', fromMaybe rowExpr rowT')+    guard $ not (T.null colT) && not (T.null rowT) && T.all isDigit rowT+    row <- decimal rowT+    return $+      bimap+      (mkRowCoord isRowAbsolute)+      (mkColumnCoord isColAbsolute)+      (row, textToColumnIndex colT)++-- | Converse function to 'singleCellRef' expecting valid reference and failig with+-- a standard error message like /"Bad cell reference 'XXX'"/+fromSingleCellRefNoting :: CellRef -> (RowIndex, ColumnIndex)+fromSingleCellRefNoting ref = fromJustNote errMsg $ fromSingleCellRefRaw txt+  where+    txt = unCellRef ref+    errMsg = "Bad cell reference '" ++ T.unpack txt ++ "'"++-- | Frame and escape the referenced sheet name in single quotes (apostrophe).+--+-- Sheet name in ST_Ref can be single-quoted when it contains non-alphanum class, non-ASCII range characters.+-- Intermediate squote characters are escaped in a doubled fashion:+-- "My ' Sheet" -> 'My '' Sheet'+escapeRefSheetName :: Text -> Text+escapeRefSheetName sheetName =+   T.concat ["'", escape sheetName, "'"]+  where+    escape sn = T.splitOn "'" sn & T.intercalate "''"++-- | Unframe and unescape the referenced sheet name.+unEscapeRefSheetName :: Text -> Text+unEscapeRefSheetName = unescape . unFrame+      where+        unescape  = T.intercalate "'" . T.splitOn "''"+        unFrame sn = fromMaybe sn $ T.stripPrefix "'" sn >>= T.stripSuffix "'"++ignoreRefSheetName :: Text -> Maybe Text+ignoreRefSheetName t =+  case T.split (== '!') t of+    [_, r] -> Just r+    [r] -> Just r+    _ -> Nothing++-- | Render a single cell existing in another worksheet.+-- This function always renders the sheet name single-quoted regardless the presence of spaces.+-- A sheet name shouldn't contain @"[]*:?/\"@ chars and apostrophe @"'"@ should not happen at extremities.+--+-- > mkForeignRange "MyOtherSheet" (Rel 2, Rel 4) (Abs 6, Abs 8) == "'MyOtherSheet'!D2:$H$6"+mkForeignSingleCellRef :: Text -> CellCoord -> CellRef+mkForeignSingleCellRef sheetName coord =+    let cr = singleCellRefRaw' coord+      in CellRef $ T.concat [escapeRefSheetName sheetName, "!", cr]++-- | Converse function to 'mkForeignSingleCellRef'.+-- The provided CellRef must be a foreign range.+fromForeignSingleCellRef :: CellRef -> Maybe (Text, CellCoord)+fromForeignSingleCellRef r =+    case T.split (== '!') (unCellRef r) of+      [sheetName, ref] -> (unEscapeRefSheetName sheetName,) <$> fromSingleCellRefRaw' ref+      _ -> Nothing+ -- | Excel range (e.g. @D13:H14@), actually store as as 'CellRef' in -- xlsx type Range = CellRef  -- | Render range ----- > mkRange (2, 4) (6, 8) == "D2:H6"-mkRange :: (Int, Int) -> (Int, Int) -> Range-mkRange fr to = CellRef $ T.concat [singleCellRefRaw fr, T.pack ":", singleCellRefRaw to]+-- > mkRange (RowIndex 2, ColumnIndex 4) (RowIndex 6, ColumnIndex 8) == CellRef "D2:H6"+mkRange :: (RowIndex, ColumnIndex) -> (RowIndex, ColumnIndex) -> Range+mkRange fr to = CellRef $ T.concat [singleCellRefRaw fr, ":", singleCellRefRaw to] --- | reverse to 'mkRange'-fromRange :: Range -> Maybe ((Int, Int), (Int, Int))+-- | Render range with possibly absolute coordinates+--+-- > mkRange' (Abs 2, Abs 4) (6, 8) == CellRef "$D$2:H6"+mkRange' :: (RowCoord,ColumnCoord) -> (RowCoord,ColumnCoord) -> Range+mkRange' fr to =+  CellRef $ T.concat [singleCellRefRaw' fr, ":", singleCellRefRaw' to]++-- | Render a cell range existing in another worksheet.+-- This function always renders the sheet name single-quoted regardless the presence of spaces.+-- A sheet name shouldn't contain @"[]*:?/\"@ chars and apostrophe @"'"@ should not happen at extremities.+--+-- > mkForeignRange "MyOtherSheet" (Rel 2, Rel 4) (Abs 6, Abs 8) == "'MyOtherSheet'!D2:$H$6"+mkForeignRange :: Text -> CellCoord -> CellCoord -> Range+mkForeignRange sheetName fr to =+    case mkRange' fr to of+      CellRef cr -> CellRef $ T.concat [escapeRefSheetName sheetName, "!", cr]++-- | Converse function to 'mkRange' ignoring absolute coordinates.+-- Ignores a potential foreign sheet prefix.+fromRange :: Range -> Maybe ((RowIndex, ColumnIndex), (RowIndex, ColumnIndex)) fromRange r =-  case T.split (== ':') (unCellRef r) of-    [from, to] -> (,) <$> fromSingleCellRefRaw from <*> fromSingleCellRefRaw to-    _ -> Nothing+  mapBoth (first unRowCoord . second unColumnCoord) <$> fromRange' r +-- | Converse function to 'mkRange\'' to handle possibly absolute coordinates.+-- Ignores a potential foreign sheet prefix.+fromRange' :: Range -> Maybe RangeCoord+fromRange' t' = parseRange =<< ignoreRefSheetName (unCellRef t')+  where+    parseRange t =+      case T.split (== ':') t of+        [from, to] -> liftA2 (,) (fromSingleCellRefRaw' from) (fromSingleCellRefRaw' to)+        _ -> Nothing++-- | Converse function to 'mkForeignRange'.+-- The provided Range must be a foreign range.+fromForeignRange :: Range -> Maybe (Text, RangeCoord)+fromForeignRange r =+    case T.split (== '!') (unCellRef r) of+      [sheetName, ref] -> (unEscapeRefSheetName sheetName,) <$> fromRange' (CellRef ref)+      _ -> Nothing+ -- | A sequence of cell references -- -- See 18.18.76 "ST_Sqref (Reference Sequence)" (p.2488) newtype SqRef = SqRef [CellRef]-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Generic) +instance NFData SqRef+ -- | Common type containing either simple string or rich formatted text. -- Used in @si@, @comment@ and @is@ elements --@@ -119,26 +377,160 @@ -- See @CT_Rst@, p. 3903 data XlsxText = XlsxText Text               | XlsxRichText [RichTextRun]-              deriving (Show, Eq, Ord)+              deriving (Eq, Ord, Show, Generic) +instance NFData XlsxText++xlsxTextToCellValue :: XlsxText -> CellValue+xlsxTextToCellValue (XlsxText txt) = CellText txt+xlsxTextToCellValue (XlsxRichText rich) = CellRich rich+ -- | A formula -- -- See 18.18.35 "ST_Formula (Formula)" (p. 2457) newtype Formula = Formula {unFormula :: Text}-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Generic) +instance NFData Formula  -- | Cell values include text, numbers and booleans, -- standard includes date format also but actually dates -- are represented by numbers with a date format assigned -- to a cell containing it+-- Specification (ECMA-376):+-- - 18.3.1.4 c (Cell)+-- - 18.18.11 ST_CellType (Cell Type) data CellValue   = CellText Text   | CellDouble Double   | CellBool Bool   | CellRich [RichTextRun]-  deriving (Eq, Ord, Show)+  | CellError ErrorType+  deriving (Eq, Ord, Show, Generic) ++instance NFData CellValue++-- | The evaluation of an expression can result in an error having one+-- of a number of error values.+--+-- See Annex L, L.2.16.8 "Error values" (p. 4764)+data ErrorType+  = ErrorDiv0+  -- ^ @#DIV/0!@ - Intended to indicate when any number, including+  -- zero, is divided by zero.+  | ErrorNA+  -- ^ @#N/A@ - Intended to indicate when a designated value is not+  -- available. For example, some functions, such as @SUMX2MY2@,+  -- perform a series of operations on corresponding elements in two+  -- arrays. If those arrays do not have the same number of elements,+  -- then for some elements in the longer array, there are no+  -- corresponding elements in the shorter one; that is, one or more+  -- values in the shorter array are not available. This error value+  -- can be produced by calling the function @NA@.+  | ErrorName+  -- ^ @#NAME?@ - Intended to indicate when what looks like a name is+  -- used, but no such name has been defined. For example, @XYZ/3@,+  -- where @XYZ@ is not a defined name. @Total is & A10@, where+  -- neither @Total@ nor @is@ is a defined name. Presumably, @"Total+  -- is " & A10@ was intended. @SUM(A1C10)@, where the range @A1:C10@+  -- was intended.+  | ErrorNull+  -- ^ @#NULL!@ - Intended to indicate when two areas are required to+  -- intersect, but do not. For example, In the case of @SUM(B1 C1)@,+  -- the space between @B1@ and @C1@ is treated as the binary+  -- intersection operator, when a comma was intended.+  | ErrorNum+  -- ^ @#NUM!@ - Intended to indicate when an argument to a function+  -- has a compatible type, but has a value that is outside the domain+  -- over which that function is defined. (This is known as a domain+  -- error.) For example, Certain calls to @ASIN@, @ATANH@, @FACT@,+  -- and @SQRT@ might result in domain errors. Intended to indicate+  -- that the result of a function cannot be represented in a value of+  -- the specified type, typically due to extreme magnitude. (This is+  -- known as a range error.) For example, @FACT(1000)@ might result+  -- in a range error.+  | ErrorRef+  -- ^ @#REF!@ - Intended to indicate when a cell reference is+  -- invalid. For example, If a formula contains a reference to a+  -- cell, and then the row or column containing that cell is deleted,+  -- a @#REF!@ error results. If a worksheet does not support 20,001+  -- columns, @OFFSET(A1,0,20000)@ results in a @#REF!@ error.+  | ErrorValue+  -- ^ @#VALUE!@ - Intended to indicate when an incompatible type+  -- argument is passed to a function, or an incompatible type operand+  -- is used with an operator. For example, In the case of a function+  -- argument, a number was expected, but text was provided. In the+  -- case of @1+"ABC"@, the binary addition operator is not defined for+  -- text.+  deriving (Eq, Ord, Show, Generic)++instance NFData ErrorType++-- | Specifies date base used for conversion of serial values to and+-- from datetime values+--+-- See Annex L, L.2.16.9.1 "Date Conversion for Serial Values" (p. 4765)+data DateBase+  = DateBase1900+  -- ^ 1900 date base system, the lower limit is January 1, -9999+  -- 00:00:00, which has serial value -4346018. The upper-limit is+  -- December 31, 9999, 23:59:59, which has serial value+  -- 2,958,465.9999884. The base date for this date base system is+  -- December 30, 1899, which has a serial value of 0.+  | DateBase1904+  -- ^ 1904 backward compatibility date-base system, the lower limit+  -- is January 1, 1904, 00:00:00, which has serial value 0. The upper+  -- limit is December 31, 9999, 23:59:59, which has serial value+  -- 2,957,003.9999884. The base date for this date base system is+  -- January 1, 1904, which has a serial value of 0.+  deriving (Eq, Show, Generic)+instance NFData DateBase++baseDate :: DateBase -> Day+baseDate DateBase1900 = fromGregorian 1899 12 30+baseDate DateBase1904 = fromGregorian 1904 1 1++-- | Converts serial value into datetime according to the specified+-- date base. Because Excel treats 1900 as a leap year even though it isn't,+-- this function converts any numbers that represent some time in /1900-02-29/+-- in Excel to `UTCTime` /1900-03-01 00:00/.+-- See https://docs.microsoft.com/en-gb/office/troubleshoot/excel/wrongly-assumes-1900-is-leap-year for details.+--+-- > show (dateFromNumber DateBase1900 42929.75) == "2017-07-13 18:00:00 UTC"+-- > show (dateFromNumber DateBase1900 60) == "1900-03-01 00:00:00 UTC"+-- > show (dateFromNumber DateBase1900 61) == "1900-03-01 00:00:00 UTC"+dateFromNumber :: forall t. RealFrac t => DateBase -> t -> UTCTime+dateFromNumber b d+  -- 60 is Excel's 2020-02-29 00:00 and 61 is Excel's 2020-03-01+  | b == DateBase1900 && d < 60            = getUTCTime (d + 1)+  | b == DateBase1900 && d >= 60 && d < 61 = getUTCTime (61 :: t)+  | otherwise                              = getUTCTime d+  where+    getUTCTime n =+      let+        (numberOfDays, fractionOfOneDay) = properFraction n+        day = addDays numberOfDays $ baseDate b+        diffTime = picosecondsToDiffTime (round (fractionOfOneDay * 24*60*60*1E12))+      in+        UTCTime day diffTime++-- | Converts datetime into serial value.+-- Because Excel treats 1900 as a leap year even though it isn't,+-- the numbers that represent times in /1900-02-29/ in Excel, in the range /[60, 61[/,+-- are never generated by this function for `DateBase1900`. This means that+-- under those conditions this is not an inverse of `dateFromNumber`.+-- See https://docs.microsoft.com/en-gb/office/troubleshoot/excel/wrongly-assumes-1900-is-leap-year for details.+dateToNumber :: Fractional a => DateBase -> UTCTime -> a+dateToNumber b (UTCTime day diffTime) = numberOfDays + fractionOfOneDay+  where+    numberOfDays = fromIntegral (diffDays excel1900CorrectedDay $ baseDate b)+    fractionOfOneDay = realToFrac diffTime / (24 * 60 * 60)+    marchFirst1900              = fromGregorian 1900 3 1+    excel1900CorrectedDay = if day < marchFirst1900+      then addDays (-1) day+      else day+ {-------------------------------------------------------------------------------   Parsing -------------------------------------------------------------------------------}@@ -147,8 +539,8 @@ instance FromCursor XlsxText where   fromCursor cur = do     let-      ts = cur $/ element (n_ "t") >=> contentOrEmpty-      rs = cur $/ element (n_ "r") >=> fromCursor+      ts = cur $/ element (addSmlNamespace "t") >=> contentOrEmpty+      rs = cur $/ element (addSmlNamespace "r") >=> fromCursor     case (ts,rs) of       ([t], []) ->         return $ XlsxText t@@ -157,18 +549,70 @@       _ ->         fail "invalid item" +instance FromXenoNode XlsxText where+  fromXenoNode root = do+    (mCh, rs) <-+      collectChildren root $ (,) <$> maybeChild "t" <*> fromChildList "r"+    mT <- mapM contentX mCh+    case mT of+      Just t -> return $ XlsxText t+      Nothing ->+        case rs of+          [] -> Left $ "missing rich text subelements"+          _ -> return $ XlsxRichText rs+ instance FromAttrVal CellRef where   fromAttrVal = fmap (first CellRef) . fromAttrVal +instance FromAttrBs CellRef where+  -- we presume that cell references contain only latin letters,+  -- numbers and colon+  fromAttrBs = pure . CellRef . T.decodeLatin1+ instance FromAttrVal SqRef where   fromAttrVal t = do     rs <- mapM (fmap fst . fromAttrVal) $ T.split (== ' ') t     readSuccess $ SqRef rs +instance FromAttrBs SqRef where+  fromAttrBs bs = do+    -- split on space+    rs <- forM  (BS.split 32 bs) fromAttrBs+    return $ SqRef rs+ -- | See @ST_Formula@, p. 3873 instance FromCursor Formula where     fromCursor cur = [Formula . T.concat $ cur $/ content] +instance FromXenoNode Formula where+  fromXenoNode = fmap Formula . contentX++instance FromAttrVal Formula where+  fromAttrVal t = readSuccess $ Formula t++instance FromAttrBs Formula where+  fromAttrBs = fmap Formula . fromAttrBs++instance FromAttrVal ErrorType where+  fromAttrVal "#DIV/0!" = readSuccess ErrorDiv0+  fromAttrVal "#N/A" = readSuccess ErrorNA+  fromAttrVal "#NAME?" = readSuccess ErrorName+  fromAttrVal "#NULL!" = readSuccess ErrorNull+  fromAttrVal "#NUM!" = readSuccess ErrorNum+  fromAttrVal "#REF!" = readSuccess ErrorRef+  fromAttrVal "#VALUE!" = readSuccess ErrorValue+  fromAttrVal t = invalidText "ErrorType" t++instance FromAttrBs ErrorType where+  fromAttrBs "#DIV/0!" = return ErrorDiv0+  fromAttrBs "#N/A" = return ErrorNA+  fromAttrBs "#NAME?" = return ErrorName+  fromAttrBs "#NULL!" = return ErrorNull+  fromAttrBs "#NUM!" = return ErrorNum+  fromAttrBs "#REF!" = return ErrorRef+  fromAttrBs "#VALUE!" = return ErrorValue+  fromAttrBs x = unexpectedAttrBs "ErrorType" x+ {-------------------------------------------------------------------------------   Rendering -------------------------------------------------------------------------------}@@ -194,3 +638,76 @@ -- | See @ST_Formula@, p. 3873 instance ToElement Formula where     toElement nm (Formula txt) = elementContent nm txt++instance ToAttrVal ErrorType where+  toAttrVal ErrorDiv0 = "#DIV/0!"+  toAttrVal ErrorNA = "#N/A"+  toAttrVal ErrorName = "#NAME?"+  toAttrVal ErrorNull = "#NULL!"+  toAttrVal ErrorNum = "#NUM!"+  toAttrVal ErrorRef = "#REF!"+  toAttrVal ErrorValue = "#VALUE!"++-- Since micro-lens denies the existence of prisms,+-- I pasted the splice that's generated from makePrisms,+-- then I copied over the definitions from Control.Lens for the prism+-- function as well.+-- Essentially this is doing the template haskell by hand.++_CellText :: Prism' CellValue Text+_CellText+  = (prism (\ x1_a1ZQv -> CellText x1_a1ZQv))+      (\ x_a1ZQw+         -> case x_a1ZQw of+              CellText y1_a1ZQx -> Right y1_a1ZQx+              _ -> Left x_a1ZQw)+{-# INLINE _CellText #-}+_CellDouble :: Prism' CellValue Double+_CellDouble+  = (prism (\ x1_a1ZQy -> CellDouble x1_a1ZQy))+      (\ x_a1ZQz+         -> case x_a1ZQz of+              CellDouble y1_a1ZQA -> Right y1_a1ZQA+              _ -> Left x_a1ZQz)+{-# INLINE _CellDouble #-}+_CellBool :: Prism' CellValue Bool+_CellBool+  = (prism (\ x1_a1ZQB -> CellBool x1_a1ZQB))+      (\ x_a1ZQC+         -> case x_a1ZQC of+              CellBool y1_a1ZQD -> Right y1_a1ZQD+              _ -> Left x_a1ZQC)+{-# INLINE _CellBool #-}+_CellRich :: Prism' CellValue [RichTextRun]+_CellRich+  = (prism (\ x1_a1ZQE -> CellRich x1_a1ZQE))+      (\ x_a1ZQF+         -> case x_a1ZQF of+              CellRich y1_a1ZQG -> Right y1_a1ZQG+              _ -> Left x_a1ZQF)+{-# INLINE _CellRich #-}+_CellError :: Prism' CellValue ErrorType+_CellError+  = (prism (\ x1_a1ZQH -> CellError x1_a1ZQH))+      (\ x_a1ZQI+         -> case x_a1ZQI of+              CellError y1_a1ZQJ -> Right y1_a1ZQJ+              _ -> Left x_a1ZQI)+{-# INLINE _CellError #-}++_XlsxText :: Prism' XlsxText Text+_XlsxText+  = (prism (\ x1_a1ZzU -> XlsxText x1_a1ZzU))+      (\ x_a1ZzV+         -> case x_a1ZzV of+              XlsxText y1_a1ZzW -> Right y1_a1ZzW+              _ -> Left x_a1ZzV)+{-# INLINE _XlsxText #-}+_XlsxRichText :: Prism' XlsxText [RichTextRun]+_XlsxRichText+  = (prism (\ x1_a1ZzX -> XlsxRichText x1_a1ZzX))+      (\ x_a1ZzY+         -> case x_a1ZzY of+              XlsxRichText y1_a1ZzZ -> Right y1_a1ZzZ+              _ -> Left x_a1ZzY)+{-# INLINE _XlsxRichText #-}
src/Codec/Xlsx/Types/ConditionalFormatting.hs view
@@ -1,33 +1,66 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types.ConditionalFormatting-    ( ConditionalFormatting-    , CfRule(..)-    , Condition(..)-    , OperatorExpression (..)-    , TimePeriod (..)+  ( ConditionalFormatting+  , CfRule(..)+  , NStdDev(..)+  , Inclusion(..)+  , CfValue(..)+  , MinCfValue(..)+  , MaxCfValue(..)+  , Condition(..)+  , OperatorExpression(..)+  , TimePeriod(..)+  , IconSetOptions(..)+  , IconSetType(..)+  , DataBarOptions(..)+  , dataBarWithColor     -- * Lenses     -- ** CfRule-    , cfrCondition-    , cfrDxfId-    , cfrPriority-    , cfrStopIfTrue+  , cfrCondition+  , cfrDxfId+  , cfrPriority+  , cfrStopIfTrue+    -- ** IconSetOptions+  , isoIconSet+  , isoValues+  , isoReverse+  , isoShowValue+    -- ** DataBarOptions+  , dboMaxLength+  , dboMinLength+  , dboShowValue+  , dboMinimum+  , dboMaximum+  , dboColor     -- * Misc-    , topCfPriority-    ) where+  , topCfPriority+  ) where -import           Control.Lens               (makeLenses)-import           Data.Map                   (Map)-import qualified Data.Map                   as M-import           Data.Maybe-import           Data.Text                  (Text)-import           Text.XML-import           Text.XML.Cursor+import Control.Arrow (first, right)+import Control.DeepSeq (NFData)+import Codec.Xlsx.LensCompat (makeLenses)+import Data.Bool (bool)+import Data.ByteString (ByteString)+import Data.Default+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Text.XML+import Text.XML.Cursor hiding (bool)+import qualified Xeno.DOM as Xeno -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Common-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.StyleSheet (Color)+import Codec.Xlsx.Writer.Internal  -- | Logical operation used in 'CellIs' condition --@@ -46,7 +79,8 @@     | OpNotBetween Formula Formula -- ^ 'Not between' operator     | OpNotContains Formula        -- ^ 'Does not contain' operator     | OpNotEqual Formula           -- ^ 'Not equal to' operator-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Generic)+instance NFData OperatorExpression  -- | Used in a "contains dates" conditional formatting rule. -- These are dynamic time periods, which change based on@@ -64,19 +98,56 @@     | PerToday      -- ^ Today's date.     | PerTomorrow   -- ^ Tomorrow's date.     | PerYesterday  -- ^ Yesterday's date.-    deriving (Eq, Ord, Show)+    deriving (Eq, Ord, Show, Generic)+instance NFData TimePeriod +-- | Flag indicating whether the 'aboveAverage' and 'belowAverage'+-- criteria is inclusive of the average itself, or exclusive of that+-- value.+data Inclusion+  = Inclusive+  | Exclusive+  deriving (Eq, Ord, Show, Generic)+instance NFData Inclusion++-- | The number of standard deviations to include above or below the+-- average in the conditional formatting rule.+newtype NStdDev =+  NStdDev Int+  deriving (Eq, Ord, Show, Generic)+instance NFData NStdDev+ -- | Conditions which could be used for conditional formatting -- -- See 18.18.12 "ST_CfType (Conditional Format Type)" (p. 2443) data Condition+    -- | This conditional formatting rule highlights cells that are+    -- above (or maybe equal to) the average for all values in the range.+    = AboveAverage Inclusion (Maybe NStdDev)     -- | This conditional formatting rule highlights cells in the     -- range that begin with the given text. Equivalent to     -- using the LEFT() sheet function and comparing values.-    = BeginsWith Text+    | BeginsWith Text+    -- | This conditional formatting rule highlights cells that are+    -- below the average for all values in the range.+    | BelowAverage Inclusion (Maybe NStdDev)+    -- | This conditional formatting rule highlights cells whose+    -- values fall in the bottom N percent bracket.+    | BottomNPercent Int+    -- | This conditional formatting rule highlights cells whose+    -- values fall in the bottom N bracket.+    | BottomNValues Int     -- | This conditional formatting rule compares a cell value     -- to a formula calculated result, using an operator.     | CellIs OperatorExpression+    -- | This conditional formatting rule creates a gradated color+    -- scale on the cells with specified colors for specified minimum+    -- and maximum.+    | ColorScale2 MinCfValue Color MaxCfValue Color+    -- | This conditional formatting rule creates a gradated color+    -- scale on the cells with specified colors for specified minimum,+    -- midpoint and maximum.+    | ColorScale3 MinCfValue Color CfValue Color MaxCfValue Color     -- | This conditional formatting rule highlights cells that     -- are completely blank. Equivalent of using LEN(TRIM()).     -- This means that if the cell contains only characters@@ -92,6 +163,9 @@     -- sheet function to determine whether the cell contains     -- the text.     | ContainsText Text+    -- | This conditional formatting rule displays a gradated data bar+    -- in the range of cells.+    | DataBar DataBarOptions     -- | This conditional formatting rule highlights cells     -- without formula errors. Equivalent to using ISERROR()     -- sheet function to determine if there is a formula error.@@ -106,6 +180,9 @@     -- not contain given text. Equivalent to using the     -- SEARCH() sheet function.     | DoesNotContainText Text+    -- | This conditional formatting rule highlights duplicated+    -- values.+    | DuplicateValues     -- | This conditional formatting rule highlights cells ending     -- with given text. Equivalent to using the RIGHT() sheet     -- function and comparing values.@@ -114,6 +191,9 @@     -- evaluate. When the formula result is true, the cell is     -- highlighted.     | Expression Formula+    -- | This conditional formatting rule applies icons to cells+    -- according to their values.+    | IconSet IconSetOptions     -- | This conditional formatting rule highlights cells     -- containing dates in the specified time period. The     -- underlying value of the cell is evaluated, therefore the@@ -122,15 +202,149 @@     -- value 38913 the conditional format shall be applied if     -- the rule requires a value of 7/14/2006.     | InTimePeriod TimePeriod-    -- TODO: aboveAverage-    -- TODO: colorScale-    -- TODO: dataBar-    -- TODO: iconSet-    -- TODO: timePeriod-    -- TODO: top10-    -- TODO: uniqueValues-    deriving (Eq, Ord, Show)+    -- | This conditional formatting rule highlights cells whose+    -- values fall in the top N percent bracket.+    | TopNPercent Int+    -- | This conditional formatting rule highlights cells whose+    -- values fall in the top N bracket.+    | TopNValues Int+    -- | This conditional formatting rule highlights unique values in the range.+    | UniqueValues+    deriving (Eq, Ord, Show, Generic)+instance NFData Condition +-- | Describes the values of the interpolation points in a color+-- scale, data bar or icon set conditional formatting rules.+--+-- See 18.3.1.11 "cfvo (Conditional Format Value Object)" (p. 1604)+data CfValue+  = CfValue Double+  | CfPercent Double+  | CfPercentile Double+  | CfFormula Formula+  deriving (Eq, Ord, Show, Generic)+instance NFData CfValue++data MinCfValue+  = CfvMin+  | MinCfValue CfValue+  deriving (Eq, Ord, Show, Generic)+instance NFData MinCfValue++data MaxCfValue+  = CfvMax+  | MaxCfValue CfValue+  deriving (Eq, Ord, Show, Generic)+instance NFData MaxCfValue++-- | internal type for (de)serialization+--+-- See 18.18.13 "ST_CfvoType (Conditional Format Value Object Type)" (p. 2445)+data CfvType =+  CfvtFormula+  -- ^ The minimum\/ midpoint \/ maximum value for the gradient is+  -- determined by a formula.+  | CfvtMax+  -- ^ Indicates that the maximum value in the range shall be used as+  -- the maximum value for the gradient.+  | CfvtMin+  -- ^ Indicates that the minimum value in the range shall be used as+  -- the minimum value for the gradient.+  | CfvtNum+  -- ^ Indicates that the minimum \/ midpoint \/ maximum value for the+  -- gradient is specified by a constant numeric value.+  | CfvtPercent+  -- ^ Value indicates a percentage between the minimum and maximum+  -- values in the range shall be used as the minimum \/ midpoint \/+  -- maximum value for the gradient.+  | CfvtPercentile+  -- ^ Value indicates a percentile ranking in the range shall be used+  -- as the minimum \/ midpoint \/ maximum value for the gradient.+  deriving (Eq, Ord, Show, Generic)+instance NFData CfvType++-- | Describes an icon set conditional formatting rule.+--+-- See 18.3.1.49 "iconSet (Icon Set)" (p. 1645)+data IconSetOptions = IconSetOptions+  { _isoIconSet :: IconSetType+  -- ^ icon set used, default value is 'IconSet3Trafficlights1'+  , _isoValues :: [CfValue]+  -- ^ values describing per icon ranges+  , _isoReverse :: Bool+  -- ^ reverses the default order of the icons in the specified icon set+  , _isoShowValue :: Bool+  -- ^ indicates whether to show the values of the cells on which this+  -- icon set is applied.+  } deriving (Eq, Ord, Show, Generic)+instance NFData IconSetOptions++-- | Icon set type for conditional formatting. 'CfValue' fields+-- determine lower range bounds. I.e. @IconSet3Signs (CfPercent 0)+-- (CfPercent 33) (CfPercent 67)@ say that 1st icon will be shown for+-- values ranging from 0 to 33 percents, 2nd for 33 to 67 percent and+-- the 3rd one for values from 67 to 100 percent.+--+-- 18.18.42 "ST_IconSetType (Icon Set Type)" (p. 2463)+data IconSetType =+  IconSet3Arrows -- CfValue CfValue CfValue+  | IconSet3ArrowsGray -- CfValue CfValue CfValue+  | IconSet3Flags -- CfValue CfValue CfValue+  | IconSet3Signs -- CfValue CfValue CfValue+  | IconSet3Symbols -- CfValue CfValue CfValue+  | IconSet3Symbols2 -- CfValue CfValue CfValue+  | IconSet3TrafficLights1 -- CfValue CfValue CfValue+  | IconSet3TrafficLights2 -- CfValue CfValue CfValue+  -- ^ 3 traffic lights icon set with thick black border.+  | IconSet4Arrows -- CfValue CfValue CfValue CfValue+  | IconSet4ArrowsGray -- CfValue CfValue CfValue CfValue+  | IconSet4Rating -- CfValue CfValue CfValue CfValue+  | IconSet4RedToBlack -- CfValue CfValue CfValue CfValue+  | IconSet4TrafficLights -- CfValue CfValue CfValue CfValue+  | IconSet5Arrows -- CfValue CfValue CfValue CfValue CfValue+  | IconSet5ArrowsGray -- CfValue CfValue CfValue CfValue CfValue+  | IconSet5Quarters -- CfValue CfValue CfValue CfValue CfValue+  | IconSet5Rating -- CfValue CfValue CfValue CfValue CfValue+  deriving  (Eq, Ord, Show, Generic)+instance NFData IconSetType++-- | Describes a data bar conditional formatting rule.+--+-- See 18.3.1.28 "dataBar (Data Bar)" (p. 1621)+data DataBarOptions = DataBarOptions+  { _dboMaxLength :: Int+  -- ^ The maximum length of the data bar, as a percentage of the cell+  -- width.+  , _dboMinLength :: Int+  -- ^ The minimum length of the data bar, as a percentage of the cell+  -- width.+  , _dboShowValue :: Bool+  -- ^ Indicates whether to show the values of the cells on which this+  -- data bar is applied.+  , _dboMinimum :: MinCfValue+  , _dboMaximum :: MaxCfValue+  , _dboColor :: Color+  } deriving (Eq, Ord, Show, Generic)+instance NFData DataBarOptions++defaultDboMaxLength :: Int+defaultDboMaxLength = 90++defaultDboMinLength :: Int+defaultDboMinLength = 10++dataBarWithColor :: Color -> Condition+dataBarWithColor c =+  DataBar+    DataBarOptions+    { _dboMaxLength = defaultDboMaxLength+    , _dboMinLength = defaultDboMinLength+    , _dboShowValue = True+    , _dboMinimum = CfvMin+    , _dboMaximum = CfvMax+    , _dboColor = c+    }+ -- | This collection represents a description of a conditional formatting rule. -- -- See 18.3.1.10 "cfRule (Conditional Formatting Rule)" (p. 1602)@@ -149,9 +363,22 @@     -- be applied over this rule, when this rule     -- evaluates to true.     , _cfrStopIfTrue :: Maybe Bool-    } deriving (Eq, Ord, Show)+    } deriving (Eq, Ord, Show, Generic)+instance NFData CfRule +instance Default IconSetOptions where+  def =+    IconSetOptions+    { _isoIconSet = IconSet3TrafficLights1+    , _isoValues = [CfPercent 0, CfPercent 33.33, CfPercent 66.67]+--        IconSet3TrafficLights1 (CfPercent 0) (CfPercent 33.33) (CfPercent 66.67)+    , _isoReverse = False+    , _isoShowValue = True+    }+ makeLenses ''CfRule+makeLenses ''IconSetOptions+makeLenses ''DataBarOptions  type ConditionalFormatting = [CfRule] @@ -174,12 +401,39 @@         return CfRule{..}  readCondition :: Text -> Cursor -> [Condition]-readCondition "beginsWith" cur       = do-    txt <- fromAttribute "text" cur-    return $ BeginsWith txt+readCondition "aboveAverage" cur       = do+  above <- fromAttributeDef "aboveAverage" True cur+  inclusion <- fromAttributeDef "equalAverage" Exclusive cur+  nStdDev <- maybeAttribute "stdDev" cur+  if above+    then return $ AboveAverage inclusion nStdDev+    else return $ BelowAverage inclusion nStdDev+readCondition "beginsWith" cur = do+  txt <- fromAttribute "text" cur+  return $ BeginsWith txt+readCondition "colorScale" cur = do+  let cfvos = cur $/ element (addSmlNamespace "colorScale") &/ element (addSmlNamespace "cfvo") &| node+      colors = cur $/ element (addSmlNamespace "colorScale") &/ element (addSmlNamespace "color") &| node+  case (cfvos, colors) of+    ([n1, n2], [cn1, cn2]) -> do+      mincfv <- fromCursor $ fromNode n1+      minc <- fromCursor $ fromNode cn1+      maxcfv <- fromCursor $ fromNode n2+      maxc <- fromCursor $ fromNode cn2+      return $ ColorScale2 mincfv minc maxcfv maxc+    ([n1, n2, n3], [cn1, cn2, cn3]) -> do+      mincfv <- fromCursor $ fromNode n1+      minc <- fromCursor $ fromNode cn1+      midcfv <- fromCursor $ fromNode n2+      midc <- fromCursor $ fromNode cn2+      maxcfv <- fromCursor $ fromNode n3+      maxc <- fromCursor $ fromNode cn3+      return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc+    _ ->+      error "Malformed colorScale condition" readCondition "cellIs" cur           = do     operator <- fromAttribute "operator" cur-    let formulas = cur $/ element (n_ "formula") >=> fromCursor+    let formulas = cur $/ element (addSmlNamespace "formula") >=> fromCursor     expr <- readOpExpression operator formulas     return $ CellIs expr readCondition "containsBlanks" _     = return ContainsBlanks@@ -187,24 +441,37 @@ readCondition "containsText" cur     = do     txt <- fromAttribute "text" cur     return $ ContainsText txt-readCondition "notContainsBlanks" _  = return DoesNotContainBlanks-readCondition "notContainsErrors" _  = return DoesNotContainErrors-readCondition "notContainsText" cur  = do-    txt <- fromAttribute "text" cur-    return $ DoesNotContainText txt+readCondition "dataBar" cur = fmap DataBar $ cur $/ element (addSmlNamespace "dataBar") >=> fromCursor+readCondition "duplicateValues" _    = return DuplicateValues readCondition "endsWith" cur         = do     txt <- fromAttribute "text" cur     return $ EndsWith txt readCondition "expression" cur       = do-    formula <- cur $/ element "formula" >=> fromCursor+    formula <- cur $/ element (addSmlNamespace "formula") >=> fromCursor     return $ Expression formula+readCondition "iconSet" cur = fmap IconSet $ cur $/ element (addSmlNamespace "iconSet") >=> fromCursor+readCondition "notContainsBlanks" _  = return DoesNotContainBlanks+readCondition "notContainsErrors" _  = return DoesNotContainErrors+readCondition "notContainsText" cur  = do+    txt <- fromAttribute "text" cur+    return $ DoesNotContainText txt readCondition "timePeriod" cur  = do     period <- fromAttribute "timePeriod" cur     return $ InTimePeriod period-readCondition _ _                    = error "Unexpected conditional formatting type"+readCondition "top10" cur = do+  bottom <- fromAttributeDef "bottom" False cur+  percent <- fromAttributeDef "percent" False cur+  rank <- fromAttribute "rank" cur+  case (bottom, percent) of+    (True, True) -> return $ BottomNPercent rank+    (True, False) -> return $ BottomNValues rank+    (False, True) -> return $ TopNPercent rank+    (False, False) -> return $ TopNValues rank+readCondition "uniqueValues" _       = return UniqueValues+readCondition t _                    = error $ "Unexpected conditional formatting type " ++ show t  readOpExpression :: Text -> [Formula] -> [OperatorExpression]-readOpExpression "beginsWith" [f ]        = [OpBeginsWith f ]+readOpExpression "beginsWith" [f]         = [OpBeginsWith f ] readOpExpression "between" [f1, f2]       = [OpBetween f1 f2] readOpExpression "containsText" [f]       = [OpContainsText f] readOpExpression "endsWith" [f]           = [OpEndsWith f]@@ -218,6 +485,92 @@ readOpExpression "notEqual" [f]           = [OpNotEqual f] readOpExpression _ _                      = [] +instance FromXenoNode CfRule where+  fromXenoNode root = parseAttributes root $ do+        _cfrDxfId <- maybeAttr "dxfId"+        _cfrPriority <- fromAttr "priority"+        _cfrStopIfTrue <- maybeAttr "stopIfTrue"+        -- spec shows this attribute as optional but it's not clear why could+        -- conditional formatting record be needed with no condition type set+        cfType <- fromAttr "type"+        _cfrCondition <- readConditionX cfType+        return CfRule {..}+    where+      readConditionX ("aboveAverage" :: ByteString) = do+        above <- fromAttrDef "aboveAverage" True+        inclusion <- fromAttrDef "equalAverage" Exclusive+        nStdDev <- maybeAttr "stdDev"+        if above+          then return $ AboveAverage inclusion nStdDev+          else return $ BelowAverage inclusion nStdDev+      readConditionX "beginsWith" = BeginsWith <$> fromAttr "text"+      readConditionX "colorScale" = toAttrParser $ do+        xs <- collectChildren root . maybeParse "colorScale" $ \node ->+          collectChildren node $ (,) <$> childList "cfvo"+                                     <*> childList "color"+        case xs of+          Just ([n1, n2], [cn1, cn2]) -> do+            mincfv <- fromXenoNode n1+            minc <- fromXenoNode cn1+            maxcfv <- fromXenoNode n2+            maxc <- fromXenoNode cn2+            return $ ColorScale2 mincfv minc maxcfv maxc+          Just ([n1, n2, n3], [cn1, cn2, cn3]) -> do+            mincfv <- fromXenoNode n1+            minc <- fromXenoNode cn1+            midcfv <- fromXenoNode n2+            midc <- fromXenoNode cn2+            maxcfv <- fromXenoNode n3+            maxc <- fromXenoNode cn3+            return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc+          _ ->+            Left "Malformed colorScale condition"+      readConditionX "cellIs" = do+        operator <- fromAttr "operator"+        formulas <- toAttrParser . collectChildren root $ fromChildList "formula"+        case (operator, formulas) of+          ("beginsWith" :: ByteString, [f]) -> return . CellIs $ OpBeginsWith f+          ("between", [f1, f2]) -> return . CellIs $ OpBetween f1 f2+          ("containsText", [f]) -> return . CellIs $ OpContainsText f+          ("endsWith", [f]) -> return . CellIs $ OpEndsWith f+          ("equal", [f]) -> return . CellIs $ OpEqual f+          ("greaterThan", [f]) -> return . CellIs $ OpGreaterThan f+          ("greaterThanOrEqual", [f]) -> return . CellIs $ OpGreaterThanOrEqual f+          ("lessThan", [f]) -> return . CellIs $ OpLessThan f+          ("lessThanOrEqual", [f]) -> return . CellIs $ OpLessThanOrEqual f+          ("notBetween", [f1, f2]) -> return . CellIs $ OpNotBetween f1 f2+          ("notContains", [f]) -> return . CellIs $ OpNotContains f+          ("notEqual", [f]) -> return . CellIs $ OpNotEqual f+          _ -> toAttrParser $ Left "Bad cellIs rule"+      readConditionX "containsBlanks" = return ContainsBlanks+      readConditionX "containsErrors" = return ContainsErrors+      readConditionX "containsText" = ContainsText <$> fromAttr "text"+      readConditionX "dataBar" =+        fmap DataBar . toAttrParser . collectChildren root $ fromChild "dataBar"+      readConditionX "duplicateValues" = return DuplicateValues+      readConditionX "endsWith" = EndsWith <$> fromAttr "text"+      readConditionX "expression" =+        fmap Expression . toAttrParser . collectChildren root $ fromChild "formula"+      readConditionX "iconSet" =+        fmap IconSet . toAttrParser . collectChildren root $ fromChild "iconSet"+      readConditionX "notContainsBlanks" = return DoesNotContainBlanks+      readConditionX "notContainsErrors" = return DoesNotContainErrors+      readConditionX "notContainsText" =+        DoesNotContainText <$> fromAttr "text"+      readConditionX "timePeriod" = InTimePeriod <$> fromAttr "timePeriod"+      readConditionX "top10" = do+        bottom <- fromAttrDef "bottom" False+        percent <- fromAttrDef "percent" False+        rank <- fromAttr "rank"+        case (bottom, percent) of+          (True, True) -> return $ BottomNPercent rank+          (True, False) -> return $ BottomNValues rank+          (False, True) -> return $ TopNPercent rank+          (False, False) -> return $ TopNValues rank+      readConditionX "uniqueValues" = return UniqueValues+      readConditionX x =+        toAttrParser . Left $ "Unexpected conditional formatting type " <> T.pack (show x)+ instance FromAttrVal TimePeriod where     fromAttrVal "last7Days" = readSuccess PerLast7Days     fromAttrVal "lastMonth" = readSuccess PerLastMonth@@ -231,7 +584,213 @@     fromAttrVal "yesterday" = readSuccess PerYesterday     fromAttrVal t           = invalidText "TimePeriod" t +instance FromAttrBs TimePeriod where+    fromAttrBs "last7Days" = return PerLast7Days+    fromAttrBs "lastMonth" = return PerLastMonth+    fromAttrBs "lastWeek"  = return PerLastWeek+    fromAttrBs "nextMonth" = return PerNextMonth+    fromAttrBs "nextWeek"  = return PerNextWeek+    fromAttrBs "thisMonth" = return PerThisMonth+    fromAttrBs "thisWeek"  = return PerThisWeek+    fromAttrBs "today"     = return PerToday+    fromAttrBs "tomorrow"  = return PerTomorrow+    fromAttrBs "yesterday" = return PerYesterday+    fromAttrBs x           = unexpectedAttrBs "TimePeriod" x +instance FromAttrVal CfvType where+  fromAttrVal "num"        = readSuccess CfvtNum+  fromAttrVal "percent"    = readSuccess CfvtPercent+  fromAttrVal "max"        = readSuccess CfvtMax+  fromAttrVal "min"        = readSuccess CfvtMin+  fromAttrVal "formula"    = readSuccess CfvtFormula+  fromAttrVal "percentile" = readSuccess CfvtPercentile+  fromAttrVal t            = invalidText "CfvType" t++instance FromAttrBs CfvType where+  fromAttrBs "num"        = return CfvtNum+  fromAttrBs "percent"    = return CfvtPercent+  fromAttrBs "max"        = return CfvtMax+  fromAttrBs "min"        = return CfvtMin+  fromAttrBs "formula"    = return CfvtFormula+  fromAttrBs "percentile" = return CfvtPercentile+  fromAttrBs x            = unexpectedAttrBs "CfvType" x++readCfValue :: (CfValue -> a) -> [a] -> [a] -> Cursor -> [a]+readCfValue f minVal maxVal c = do+  vType <- fromAttribute "type" c+  case vType of+    CfvtNum -> do+      v <- fromAttribute "val" c+      return . f $ CfValue v+    CfvtFormula -> do+      v <- fromAttribute "val" c+      return . f $ CfFormula v+    CfvtPercent -> do+      v <- fromAttribute "val" c+      return . f $ CfPercent v+    CfvtPercentile -> do+      v <- fromAttribute "val" c+      return . f $ CfPercentile v+    CfvtMin -> minVal+    CfvtMax -> maxVal++readCfValueX ::+     (CfValue -> a)+  -> Either Text a+  -> Either Text a+  -> Xeno.Node+  -> Either Text a+readCfValueX f minVal maxVal root =+  parseAttributes root $ do+    vType <- fromAttr "type"+    case vType of+      CfvtNum -> do+        v <- fromAttr "val"+        return . f $ CfValue v+      CfvtFormula -> do+        v <- fromAttr "val"+        return . f $ CfFormula v+      CfvtPercent -> do+        v <- fromAttr "val"+        return . f $ CfPercent v+      CfvtPercentile -> do+        v <- fromAttr "val"+        return . f $ CfPercentile v+      CfvtMin -> toAttrParser minVal+      CfvtMax -> toAttrParser maxVal++failMinCfvType :: [a]+failMinCfvType = fail "unexpected 'min' type"++failMinCfvTypeX :: Either Text a+failMinCfvTypeX = Left "unexpected 'min' type"++failMaxCfvType :: [a]+failMaxCfvType = fail "unexpected 'max' type"++failMaxCfvTypeX :: Either Text a+failMaxCfvTypeX = Left "unexpected 'max' type"++instance FromCursor CfValue where+  fromCursor = readCfValue id failMinCfvType failMaxCfvType++instance FromXenoNode CfValue where+  fromXenoNode root = readCfValueX id failMinCfvTypeX failMaxCfvTypeX root++instance FromCursor MinCfValue where+  fromCursor = readCfValue MinCfValue (return CfvMin) failMaxCfvType++instance FromXenoNode MinCfValue where+  fromXenoNode root =+    readCfValueX MinCfValue (return CfvMin) failMaxCfvTypeX root++instance FromCursor MaxCfValue where+  fromCursor = readCfValue MaxCfValue failMinCfvType (return CfvMax)++instance FromXenoNode MaxCfValue where+  fromXenoNode root =+    readCfValueX MaxCfValue failMinCfvTypeX (return CfvMax) root++defaultIconSet :: IconSetType+defaultIconSet =  IconSet3TrafficLights1++instance FromCursor IconSetOptions where+  fromCursor cur = do+    _isoIconSet <- fromAttributeDef "iconSet" defaultIconSet cur+    let _isoValues = cur $/ element (addSmlNamespace "cfvo") >=> fromCursor+    _isoReverse <- fromAttributeDef "reverse" False cur+    _isoShowValue <- fromAttributeDef "showValue" True cur+    return IconSetOptions {..}++instance FromXenoNode IconSetOptions where+  fromXenoNode root = do+    (_isoIconSet, _isoReverse, _isoShowValue) <-+      parseAttributes root $ (,,) <$> fromAttrDef "iconSet" defaultIconSet+                                  <*> fromAttrDef "reverse" False+                                  <*> fromAttrDef "showValue" True+    _isoValues <- collectChildren root $ fromChildList "cfvo"+    return IconSetOptions {..}++instance FromAttrVal IconSetType where+  fromAttrVal "3Arrows" = readSuccess IconSet3Arrows+  fromAttrVal "3ArrowsGray" = readSuccess IconSet3ArrowsGray+  fromAttrVal "3Flags" = readSuccess IconSet3Flags+  fromAttrVal "3Signs" = readSuccess IconSet3Signs+  fromAttrVal "3Symbols" = readSuccess IconSet3Symbols+  fromAttrVal "3Symbols2" = readSuccess IconSet3Symbols2+  fromAttrVal "3TrafficLights1" = readSuccess IconSet3TrafficLights1+  fromAttrVal "3TrafficLights2" = readSuccess IconSet3TrafficLights2+  fromAttrVal "4Arrows" = readSuccess IconSet4Arrows+  fromAttrVal "4ArrowsGray" = readSuccess IconSet4ArrowsGray+  fromAttrVal "4Rating" = readSuccess IconSet4Rating+  fromAttrVal "4RedToBlack" = readSuccess IconSet4RedToBlack+  fromAttrVal "4TrafficLights" = readSuccess IconSet4TrafficLights+  fromAttrVal "5Arrows" = readSuccess IconSet5Arrows+  fromAttrVal "5ArrowsGray" = readSuccess IconSet5ArrowsGray+  fromAttrVal "5Quarters" = readSuccess IconSet5Quarters+  fromAttrVal "5Rating" = readSuccess IconSet5Rating+  fromAttrVal t = invalidText "IconSetType" t++instance FromAttrBs IconSetType where+  fromAttrBs "3Arrows" = return IconSet3Arrows+  fromAttrBs "3ArrowsGray" = return IconSet3ArrowsGray+  fromAttrBs "3Flags" = return IconSet3Flags+  fromAttrBs "3Signs" = return IconSet3Signs+  fromAttrBs "3Symbols" = return IconSet3Symbols+  fromAttrBs "3Symbols2" = return IconSet3Symbols2+  fromAttrBs "3TrafficLights1" = return IconSet3TrafficLights1+  fromAttrBs "3TrafficLights2" = return IconSet3TrafficLights2+  fromAttrBs "4Arrows" = return IconSet4Arrows+  fromAttrBs "4ArrowsGray" = return IconSet4ArrowsGray+  fromAttrBs "4Rating" = return IconSet4Rating+  fromAttrBs "4RedToBlack" = return IconSet4RedToBlack+  fromAttrBs "4TrafficLights" = return IconSet4TrafficLights+  fromAttrBs "5Arrows" = return IconSet5Arrows+  fromAttrBs "5ArrowsGray" = return IconSet5ArrowsGray+  fromAttrBs "5Quarters" = return IconSet5Quarters+  fromAttrBs "5Rating" = return IconSet5Rating+  fromAttrBs x = unexpectedAttrBs "IconSetType" x++instance FromCursor DataBarOptions where+  fromCursor cur = do+    _dboMaxLength <- fromAttributeDef "maxLength" defaultDboMaxLength cur+    _dboMinLength <- fromAttributeDef "minLength" defaultDboMinLength cur+    _dboShowValue <- fromAttributeDef "showValue" True cur+    let cfvos = cur $/ element (addSmlNamespace "cfvo") &| node+    case cfvos of+      [nMin, nMax] -> do+        _dboMinimum <- fromCursor (fromNode nMin)+        _dboMaximum <- fromCursor (fromNode nMax)+        _dboColor <- cur $/ element (addSmlNamespace "color") >=> fromCursor+        return DataBarOptions{..}+      ns -> do+        fail $ "expected minimum and maximum cfvo nodes but see instead " +++          show (length ns) ++ " cfvo nodes"++instance FromXenoNode DataBarOptions where+  fromXenoNode root = do+    (_dboMaxLength, _dboMinLength, _dboShowValue) <-+      parseAttributes root $ (,,) <$> fromAttrDef "maxLength" defaultDboMaxLength+                                  <*> fromAttrDef "minLength" defaultDboMinLength+                                  <*> fromAttrDef "showValue" True+    (_dboMinimum, _dboMaximum, _dboColor) <-+      collectChildren root $ (,,) <$> fromChild "cfvo"+                                  <*> fromChild "cfvo"+                                  <*> fromChild "color"+    return DataBarOptions{..}++instance FromAttrVal Inclusion where+  fromAttrVal = right (first $ bool Exclusive Inclusive) . fromAttrVal++instance FromAttrBs Inclusion where+  fromAttrBs = fmap (bool Exclusive Inclusive) . fromAttrBs++instance FromAttrVal NStdDev where+  fromAttrVal = right (first NStdDev) . fromAttrVal++instance FromAttrBs NStdDev where+  fromAttrBs = fmap NStdDev . fromAttrBs+ {-------------------------------------------------------------------------------   Rendering -------------------------------------------------------------------------------}@@ -252,18 +811,60 @@            }  conditionData :: Condition -> (Text, Map Name Text, [Node])+conditionData (AboveAverage i sDevs) =+  ("aboveAverage", M.fromList $ ["aboveAverage" .= True] +++                   catMaybes [ "equalAverage" .=? justNonDef Exclusive i+                             , "stdDev" .=? sDevs], []) conditionData (BeginsWith t)         = ("beginsWith", M.fromList [ "text" .= t], [])+conditionData (BelowAverage i sDevs) =+  ("aboveAverage", M.fromList $ ["aboveAverage" .= False] +++                   catMaybes [ "equalAverage" .=? justNonDef Exclusive i+                             , "stdDev" .=? sDevs], [])+conditionData (BottomNPercent n)     = ("top10", M.fromList [ "bottom" .= True, "rank" .= n, "percent" .= True ], [])+conditionData (BottomNValues n)      = ("top10", M.fromList [ "bottom" .= True, "rank" .= n ], []) conditionData (CellIs opExpr)        = ("cellIs", M.fromList [ "operator" .= op], formulas)     where (op, formulas) = operatorExpressionData opExpr+conditionData (ColorScale2 minv minc maxv maxc) =+  ( "colorScale"+  , M.empty+  , [ NodeElement $+      elementListSimple+        "colorScale"+        [ toElement "cfvo" minv+        , toElement "cfvo" maxv+        , toElement "color" minc+        , toElement "color" maxc+        ]+    ])+conditionData (ColorScale3 minv minc midv midc maxv maxc) =+  ( "colorScale"+  , M.empty+  , [ NodeElement $+      elementListSimple+        "colorScale"+        [ toElement "cfvo" minv+        , toElement "cfvo" midv+        , toElement "cfvo" maxv+        , toElement "color" minc+        , toElement "color" midc+        , toElement "color" maxc+        ]+    ]) conditionData ContainsBlanks         = ("containsBlanks", M.empty, []) conditionData ContainsErrors         = ("containsErrors", M.empty, []) conditionData (ContainsText t)       = ("containsText", M.fromList [ "text" .= t], [])+conditionData (DataBar dbOpts)       = ("dataBar", M.empty, [toNode "dataBar" dbOpts]) conditionData DoesNotContainBlanks   = ("notContainsBlanks", M.empty, []) conditionData DoesNotContainErrors   = ("notContainsErrors", M.empty, []) conditionData (DoesNotContainText t) = ("notContainsText", M.fromList [ "text" .= t], [])+conditionData DuplicateValues        = ("duplicateValues", M.empty, []) conditionData (EndsWith t)           = ("endsWith", M.fromList [ "text" .= t], []) conditionData (Expression formula)   = ("expression", M.empty, [formulaNode formula]) conditionData (InTimePeriod period)  = ("timePeriod", M.fromList [ "timePeriod" .= period ], [])+conditionData (IconSet isOptions)    = ("iconSet", M.empty, [toNode "iconSet" isOptions])+conditionData (TopNPercent n)        = ("top10", M.fromList [ "rank" .= n, "percent" .= True ], [])+conditionData (TopNValues n)         = ("top10", M.fromList [ "rank" .= n ], [])+conditionData UniqueValues           = ("uniqueValues", M.empty, [])  operatorExpressionData :: OperatorExpression -> (Text, [Node]) operatorExpressionData (OpBeginsWith f)          = ("beginsWith", [formulaNode f])@@ -279,8 +880,79 @@ operatorExpressionData (OpNotContains f)         = ("notContains", [formulaNode f]) operatorExpressionData (OpNotEqual f)            = ("notEqual", [formulaNode  f]) +instance ToElement MinCfValue where+  toElement nm CfvMin = leafElement nm ["type" .= CfvtMin]+  toElement nm (MinCfValue cfv) = toElement nm cfv++instance ToElement MaxCfValue where+  toElement nm CfvMax = leafElement nm ["type" .= CfvtMax]+  toElement nm (MaxCfValue cfv) = toElement nm cfv++instance ToElement CfValue where+  toElement nm (CfValue v) = leafElement nm ["type" .= CfvtNum, "val" .= v]+  toElement nm (CfPercent v) =+    leafElement nm ["type" .= CfvtPercent, "val" .= v]+  toElement nm (CfPercentile v) =+    leafElement nm ["type" .= CfvtPercentile, "val" .= v]+  toElement nm (CfFormula f) =+    leafElement nm ["type" .= CfvtFormula, "val" .= unFormula f]++instance ToAttrVal CfvType where+  toAttrVal CfvtNum = "num"+  toAttrVal CfvtPercent = "percent"+  toAttrVal CfvtMax = "max"+  toAttrVal CfvtMin = "min"+  toAttrVal CfvtFormula = "formula"+  toAttrVal CfvtPercentile = "percentile"++instance ToElement IconSetOptions where+  toElement nm IconSetOptions {..} =+    elementList nm attrs $ map (toElement "cfvo") _isoValues+    where+      attrs = catMaybes+        [ "iconSet" .=? justNonDef defaultIconSet _isoIconSet+        , "reverse" .=? justTrue _isoReverse+        , "showValue" .=? justFalse _isoShowValue+        ]++instance ToAttrVal IconSetType where+  toAttrVal IconSet3Arrows = "3Arrows"+  toAttrVal IconSet3ArrowsGray = "3ArrowsGray"+  toAttrVal IconSet3Flags = "3Flags"+  toAttrVal IconSet3Signs = "3Signs"+  toAttrVal IconSet3Symbols = "3Symbols"+  toAttrVal IconSet3Symbols2 = "3Symbols2"+  toAttrVal IconSet3TrafficLights1 = "3TrafficLights1"+  toAttrVal IconSet3TrafficLights2 = "3TrafficLights2"+  toAttrVal IconSet4Arrows = "4Arrows"+  toAttrVal IconSet4ArrowsGray = "4ArrowsGray"+  toAttrVal IconSet4Rating = "4Rating"+  toAttrVal IconSet4RedToBlack = "4RedToBlack"+  toAttrVal IconSet4TrafficLights = "4TrafficLights"+  toAttrVal IconSet5Arrows = "5Arrows"+  toAttrVal IconSet5ArrowsGray = "5ArrowsGray"+  toAttrVal IconSet5Quarters = "5Quarters"+  toAttrVal IconSet5Rating = "5Rating"++instance ToElement DataBarOptions where+  toElement nm DataBarOptions {..} = elementList nm attrs elements+    where+      attrs = catMaybes+        [ "maxLength" .=? justNonDef defaultDboMaxLength _dboMaxLength+        , "minLength" .=? justNonDef defaultDboMinLength _dboMinLength+        , "showValue" .=? justFalse _dboShowValue+        ]+      elements =+        [ toElement "cfvo" _dboMinimum+        , toElement "cfvo" _dboMaximum+        , toElement "color" _dboColor+        ]++toNode :: ToElement a => Name -> a -> Node+toNode nm = NodeElement . toElement nm+ formulaNode :: Formula -> Node-formulaNode = NodeElement . toElement "formula"+formulaNode = toNode "formula"  instance ToAttrVal TimePeriod where     toAttrVal PerLast7Days = "last7Days"@@ -293,3 +965,9 @@     toAttrVal PerToday     = "today"     toAttrVal PerTomorrow  = "tomorrow"     toAttrVal PerYesterday = "yesterday"++instance ToAttrVal Inclusion where+  toAttrVal = toAttrVal . (== Inclusive)++instance ToAttrVal NStdDev where+  toAttrVal (NStdDev n) = toAttrVal n
src/Codec/Xlsx/Types/DataValidation.hs view
@@ -1,23 +1,54 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TemplateHaskell   #-}-module Codec.Xlsx.Types.DataValidation where+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Codec.Xlsx.Types.DataValidation+  ( ValidationExpression(..)+    , ValidationType(..)+    , dvAllowBlank+    , dvError+    , dvErrorStyle+    , dvErrorTitle+    , dvPrompt+    , dvPromptTitle+    , dvShowDropDown+    , dvShowErrorMessage+    , dvShowInputMessage+    , dvValidationType+    , ErrorStyle(..)+    , DataValidation(..)+    , ListOrRangeExpression(..)+    , ValidationList+    , maybePlainValidationList+    , maybeValidationRange+    , readValidationType+    , readListFormulas+    , readOpExpression2+    , readValidationTypeOpExp+    , readValExpression+    , viewValidationExpression+  ) where -import           Control.Lens.TH            (makeLenses)-import           Control.Monad              ((>=>))-import           Data.Char                  (isSpace)-import           Data.Default-import qualified Data.Map                   as M-import           Data.Maybe                 (catMaybes)-import           Data.Monoid                ((<>))-import           Data.Text                  (Text)-import qualified Data.Text                  as T-import           Text.XML                   (Node (..), Element (..))-import           Text.XML.Cursor            (Cursor, ($/), element)+import Control.Applicative ((<|>))+import Control.DeepSeq (NFData)+import Codec.Xlsx.LensCompat (makeLenses)+import Control.Monad ((>=>), guard)+import Data.ByteString (ByteString)+import Data.Char (isSpace)+import Data.Default+import qualified Data.Map as M+import Data.Maybe (catMaybes, maybeToList)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Text.XML (Element(..), Node(..))+import Text.XML.Cursor (Cursor, ($/), element) -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Common-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Writer.Internal  -- See 18.18.20 "ST_DataValidationOperator (Data Validation Operator)" (p. 2439/2449) data ValidationExpression@@ -29,7 +60,8 @@     | ValLessThanOrEqual Formula    -- ^ "Less than or equal to" operator     | ValNotBetween Formula Formula -- ^ "Not between" operator     | ValNotEqual Formula           -- ^ "Not equal to" operator-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+instance NFData ValidationExpression  -- See 18.18.21 "ST_DataValidationType (Data Validation Type)" (p. 2440/2450) data ValidationType@@ -37,18 +69,28 @@     | ValidationTypeCustom     Formula     | ValidationTypeDate       ValidationExpression     | ValidationTypeDecimal    ValidationExpression-    | ValidationTypeList       [Text]+    | ValidationTypeList       ListOrRangeExpression     | ValidationTypeTextLength ValidationExpression     | ValidationTypeTime       ValidationExpression     | ValidationTypeWhole      ValidationExpression-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+instance NFData ValidationType +type ValidationList = [Text]++data ListOrRangeExpression+  = ListExpression ValidationList -- ^ a plain list of elements+  | RangeExpression Range -- ^ a cell or range reference+  deriving (Eq, Show, Generic)+instance NFData ListOrRangeExpression+ -- See 18.18.18 "ST_DataValidationErrorStyle (Data Validation Error Styles)" (p. 2438/2448) data ErrorStyle     = ErrorStyleInformation     | ErrorStyleStop     | ErrorStyleWarning-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+instance NFData ErrorStyle  -- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624) data DataValidation = DataValidation@@ -59,10 +101,14 @@     , _dvPrompt           :: Maybe Text     , _dvPromptTitle      :: Maybe Text     , _dvShowDropDown     :: Bool+    -- ^ A boolean value indicating whether to display a dropdown combo box for a list type data validation.+    -- Note that it has an inverted logic, false shows the dropdown list and true will render the dropdown as+    -- plain text instead.     , _dvShowErrorMessage :: Bool     , _dvShowInputMessage :: Bool     , _dvValidationType   :: ValidationType-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance NFData DataValidation  makeLenses ''DataValidation @@ -80,6 +126,12 @@     fromAttrVal "warning"     = readSuccess ErrorStyleWarning     fromAttrVal t             = invalidText "ErrorStyle" t +instance FromAttrBs ErrorStyle where+    fromAttrBs "information" = return ErrorStyleInformation+    fromAttrBs "stop"        = return ErrorStyleStop+    fromAttrBs "warning"     = return ErrorStyleWarning+    fromAttrBs x             = unexpectedAttrBs "ErrorStyle" x+ instance FromCursor DataValidation where     fromCursor cur = do         _dvAllowBlank       <- fromAttributeDef "allowBlank"       False          cur@@ -96,42 +148,115 @@         _dvValidationType   <- readValidationType mop mtype                       cur         return DataValidation{..} +instance FromXenoNode DataValidation where+  fromXenoNode root = do+    (op, atype, genDV) <- parseAttributes root $ do+      _dvAllowBlank <- fromAttrDef "allowBlank" False+      _dvError <- maybeAttr "error"+      _dvErrorStyle <- fromAttrDef "errorStyle" ErrorStyleStop+      _dvErrorTitle <- maybeAttr "errorTitle"+      _dvPrompt <- maybeAttr "prompt"+      _dvPromptTitle <- maybeAttr "promptTitle"+      _dvShowDropDown <- fromAttrDef "showDropDown" False+      _dvShowErrorMessage <- fromAttrDef "showErrorMessage" False+      _dvShowInputMessage <- fromAttrDef "showInputMessage" False+      op <- fromAttrDef "operator" "between"+      typ <- fromAttrDef "type" "none"+      return (op, typ, \_dvValidationType -> DataValidation {..})+    valType <- parseValidationType op atype+    return $ genDV valType+    where+      parseValidationType :: ByteString -> ByteString -> Either Text ValidationType+      parseValidationType op atype =+        case atype of+          "none" -> return ValidationTypeNone+          "custom" ->+            ValidationTypeCustom <$> formula1+          "list" -> do+            f <- formula1+            case readListFormulas f of+              Nothing -> Left "validation of type \"list\" with empty formula list"+              Just fs -> return $ ValidationTypeList fs+          "date" ->+            ValidationTypeDate <$> readOpExpression op+          "decimal"    ->+            ValidationTypeDecimal <$> readOpExpression op+          "textLength" ->+            ValidationTypeTextLength <$> readOpExpression op+          "time"       ->+            ValidationTypeTime <$> readOpExpression op+          "whole"      ->+            ValidationTypeWhole <$> readOpExpression op+          unexpected ->+            Left $ "unexpected type of data validation " <> T.pack (show unexpected)+      readOpExpression "between" = uncurry ValBetween <$> formulaPair+      readOpExpression "notBetween" = uncurry ValNotBetween <$> formulaPair+      readOpExpression "equal" = ValEqual <$> formula1+      readOpExpression "greaterThan" = ValGreaterThan <$> formula1+      readOpExpression "greaterThanOrEqual" = ValGreaterThanOrEqual <$> formula1+      readOpExpression "lessThan" = ValLessThan <$> formula1+      readOpExpression "lessThanOrEqual" = ValLessThanOrEqual <$> formula1+      readOpExpression "notEqual" = ValNotEqual <$> formula1+      readOpExpression op = Left $ "data validation, unexpected operator " <> T.pack (show op)+      formula1 = collectChildren root $ fromChild "formula1"+      formulaPair =+        collectChildren root $ (,) <$> fromChild "formula1" <*> fromChild "formula2"+ readValidationType :: Text -> Text -> Cursor -> [ValidationType] readValidationType _ "none"   _   = return ValidationTypeNone readValidationType _ "custom" cur = do     f <- fromCursor cur     return $ ValidationTypeCustom f readValidationType _ "list" cur = do-    f  <- cur $/ element (n_ "formula1") >=> fromCursor-    as <- readListFormula f+    f  <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor+    as <- maybeToList $ readListFormulas f     return $ ValidationTypeList as readValidationType op ty cur = do     opExp <- readOpExpression2 op cur     readValidationTypeOpExp ty opExp -readListFormula :: Formula -> [[Text]]-readListFormula (Formula f) = catMaybes [readQuotedList f]+-- | Attempt to obtain a plain list expression+maybePlainValidationList :: ValidationType -> Maybe ValidationList+maybePlainValidationList (ValidationTypeList (ListExpression le)) = Just le+maybePlainValidationList _ = Nothing++-- | Attempt to obtain a range expression+maybeValidationRange :: ValidationType -> Maybe Range+maybeValidationRange (ValidationTypeList (RangeExpression re)) = Just re+maybeValidationRange _ = Nothing++readListFormulas :: Formula -> Maybe ListOrRangeExpression+readListFormulas (Formula f) = readQuotedList f <|> readUnquotedCellRange f   where     readQuotedList t         | Just t'  <- T.stripPrefix "\"" (T.dropAround isSpace t)         , Just t'' <- T.stripSuffix "\"" t'-        = Just $ map (T.dropAround isSpace) $ T.splitOn "," t''+        = Just . ListExpression $ map (T.dropAround isSpace) $ T.splitOn "," t''         | otherwise = Nothing+    readUnquotedCellRange t =+      -- a CellRef expression of a range (this is not validated beyond the absence of quotes)+      -- note that the foreign sheet name can be 'single-quoted'+      let stripped = T.dropAround isSpace t+        in RangeExpression (CellRef stripped) <$ guard (not (T.null stripped))   -- This parser expects a comma-separated list surrounded by quotation marks.   -- Spaces around the quotation marks and commas are removed, but inner spaces   -- are kept.   --   -- The parser seems to be consistent with how Excel treats list formulas, but   -- I wasn't able to find a specification of the format.+  --+  -- Addendum: <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 (n_ "formula1") >=> fromCursor-        f2 <- cur $/ element (n_ "formula2") >=> fromCursor+        f1 <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor+        f2 <- cur $/ element (addSmlNamespace "formula2") >=> fromCursor         readValExpression op [f1,f2] readOpExpression2 op cur = do-    f <- cur $/ element (n_ "formula1") >=> fromCursor+    f <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor     readValExpression op [f]  readValidationTypeOpExp :: Text -> ValidationExpression -> [ValidationType]@@ -207,7 +332,14 @@           ValidationTypeTime f       -> opExp $ viewValidationExpression f           ValidationTypeWhole f      -> opExp $ viewValidationExpression f           ValidationTypeList as      ->-            let f = Formula $ "\"" <> T.intercalate "," as <> "\""+            let renderPlainList l =+                  let csvFy = T.intercalate ","+                      reQuote x = '"' `T.cons`  x `T.snoc` '"'+                    in reQuote (csvFy l)+                f = Formula $+                      case as of+                        RangeExpression re -> unCellRef re+                        ListExpression le -> renderPlainList le             in  (Nothing, Just f, Nothing)  viewValidationExpression :: ValidationExpression -> (Text, Formula, Maybe Formula)@@ -219,4 +351,3 @@ viewValidationExpression (ValLessThanOrEqual f)     = ("lessThanOrEqual",    f,  Nothing) viewValidationExpression (ValNotBetween f1 f2)      = ("notBetween",         f1, Just f2) viewValidationExpression (ValNotEqual f)            = ("notEqual",           f,  Nothing)-
src/Codec/Xlsx/Types/Drawing.hs view
@@ -1,52 +1,54 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE CPP                  #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE OverloadedStrings    #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE TemplateHaskell      #-}-{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Drawing where -import           Control.Lens.TH-import           Data.ByteString.Lazy                    (ByteString)-import           Data.Default-import qualified Data.Map                                as M-import           Data.Maybe                              (catMaybes,-                                                          listToMaybe)-import           Data.Text                               (Text)-import           Text.XML-import           Text.XML.Cursor--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Control.Arrow (first)+import Control.DeepSeq (NFData)+import Codec.Xlsx.LensCompat (makeLenses)+import Data.ByteString.Lazy (ByteString)+import Data.Default+import qualified Data.Map as M+import Data.Maybe (catMaybes, listToMaybe, mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Drawing.Common-import           Codec.Xlsx.Types.Drawing.Chart-import           Codec.Xlsx.Types.Internal-import           Codec.Xlsx.Types.Internal.Relationships-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Drawing.Chart+import Codec.Xlsx.Types.Drawing.Common+import Codec.Xlsx.Types.Internal+import Codec.Xlsx.Types.Internal.Relationships+import Codec.Xlsx.Writer.Internal  -- | information about image file as a par of a drawing data FileInfo = FileInfo     { _fiFilename    :: FilePath-    -- ^ image filename, images are assumed to be stored under path "xl/media/"+    -- ^ image filename, images are assumed to be stored under path "xl\/media\/"     , _fiContentType :: Text-    -- ^ image content type, ECMA-376 advises to use "image/png" or "image/jpeg"+    -- ^ image content type, ECMA-376 advises to use "image\/png" or "image\/jpeg"     -- if interoperability is wanted     , _fiContents    :: ByteString     -- ^ image file contents-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance NFData FileInfo  data Marker = Marker     { _mrkCol    :: Int     , _mrkColOff :: Coordinate     , _mrkRow    :: Int     , _mrkRowOff :: Coordinate-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance NFData Marker  unqMarker :: (Int, Int) -> (Int, Int) -> Marker unqMarker (col, colOff) (row, rowOff) =@@ -56,7 +58,8 @@     = EditAsTwoCell     | EditAsOneCell     | EditAsAbsolute-    deriving (Eq,Show)+    deriving (Eq, Show, Generic)+instance NFData EditAs  data Anchoring     = AbsoluteAnchor@@ -72,7 +75,8 @@       , tcaTo     :: Marker       , tcaEditAs :: EditAs       }-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+instance NFData Anchoring  data DrawingObject p g   = Picture { _picMacro :: Maybe Text@@ -86,8 +90,55 @@            ,  _grChartSpace :: g            ,  _grTransform :: Transform2D}     -- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance (NFData p, NFData g) => NFData (DrawingObject p g) +-- | basic function to create picture drawing object+--+-- /Note:/ specification says that drawing element ids need to be+-- unique within 1 document, otherwise /...document shall be+-- considered non-conformant/.+picture :: DrawingElementId -> FileInfo -> DrawingObject FileInfo c+picture dId fi =+  Picture+  { _picMacro = Nothing+  , _picPublished = False+  , _picNonVisual = nonVis+  , _picBlipFill = bfProps+  , _picShapeProperties = shProps+  }+  where+    nonVis =+      PicNonVisual $+      NonVisualDrawingProperties+      { _nvdpId = dId+      , _nvdpName = T.pack $ _fiFilename fi+      , _nvdpDescription = Nothing+      , _nvdpHidden = False+      , _nvdpTitle = Nothing+      }+    bfProps =+      BlipFillProperties+      {_bfpImageInfo = Just fi, _bfpFillMode = Just FillStretch}+    shProps =+      ShapeProperties+      { _spXfrm = Nothing+      , _spGeometry = Nothing+      , _spFill = Just NoFill+      , _spOutline = Just $ def {_lnFill = Just NoFill}+      }++-- | helper to retrive information about all picture files in+-- particular drawing alongside with their anchorings (i.e. sizes and+-- positions)+extractPictures :: Drawing -> [(Anchoring, FileInfo)]+extractPictures dr = mapMaybe maybePictureInfo $ _xdrAnchors dr+  where+    maybePictureInfo Anchor {..} =+      case _anchObject of+        Picture {..} -> (_anchAnchoring,) <$> _bfpImageInfo _picBlipFill+        _ -> Nothing+ -- | This element is used to set certain properties related to a drawing -- element on the client spreadsheet application. --@@ -99,21 +150,29 @@     , _cldPrintsWithSheet :: Bool     -- ^ This attribute indicates whether to print drawing elements     -- when printing the sheet.-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance NFData ClientData  data PicNonVisual = PicNonVisual   { _pnvDrawingProps :: NonVisualDrawingProperties     -- TODO: cNvPicPr-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData PicNonVisual  data GraphNonVisual = GraphNonVisual   { _gnvDrawingProps :: NonVisualDrawingProperties     -- TODO cNvGraphicFramePr-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData GraphNonVisual +newtype DrawingElementId = DrawingElementId+  { unDrawingElementId :: Int+  } deriving (Eq, Show, Generic)+instance NFData DrawingElementId+ -- see 20.1.2.2.8 "cNvPr (Non-Visual Drawing Properties)" (p. 2731) data NonVisualDrawingProperties = NonVisualDrawingProperties-    { _nvdpId          :: Int+    { _nvdpId          :: DrawingElementId     -- ^ Specifies a unique identifier for the current     -- DrawingML object within the current     --@@ -126,13 +185,15 @@     -- ^ Alternative Text for Object     , _nvdpHidden      :: Bool     , _nvdpTitle       :: Maybe Text-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance NFData NonVisualDrawingProperties  data BlipFillProperties a = BlipFillProperties     { _bfpImageInfo :: Maybe a     , _bfpFillMode  :: Maybe FillMode     -- TODO: dpi, rotWithShape, srcRect-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance NFData a => NFData (BlipFillProperties a)  -- see @a_EG_FillModeProperties@ (p. 4319) data FillMode@@ -140,18 +201,21 @@     = FillTile    -- TODO: tx, ty, sx, sy, flip, algn     -- See 20.1.8.56 "stretch (Stretch)" (p. 2879)     | FillStretch -- TODO: srcRect-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+instance NFData FillMode  -- See @EG_Anchor@ (p. 4052) data Anchor p g = Anchor     { _anchAnchoring  :: Anchoring     , _anchObject     :: DrawingObject p g     , _anchClientData :: ClientData-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance (NFData p, NFData g) => NFData (Anchor p g)  data GenericDrawing p g = Drawing     { _xdrAnchors :: [Anchor p g]-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance (NFData p, NFData g) => NFData (GenericDrawing p g)  -- See 20.5.2.35 "wsDr (Worksheet Drawing)" (p. 3176) type Drawing = GenericDrawing FileInfo ChartSpace@@ -163,6 +227,22 @@ makeLenses ''BlipFillProperties makeLenses ''GenericDrawing +-- | simple drawing object anchoring using one cell as a top lelft+-- corner and dimensions of that object+simpleAnchorXY :: (Int, Int) -- ^ x+y coordinates of a cell used as+                             -- top left anchoring corner+               -> PositiveSize2D -- ^ size of drawing object to be+                                 -- anchored+               -> DrawingObject p g+               -> Anchor p g+simpleAnchorXY (x, y) sz obj =+  Anchor+  { _anchAnchoring =+      OneCellAnchor {onecaFrom = unqMarker (x, 0) (y, 0), onecaExt = sz}+  , _anchObject = obj+  , _anchClientData = def+  }+ {-------------------------------------------------------------------------------   Default instances -------------------------------------------------------------------------------}@@ -256,6 +336,9 @@         _nvdpTitle <- maybeAttribute "title" cur         return NonVisualDrawingProperties{..} +instance FromAttrVal DrawingElementId where+  fromAttrVal = fmap (first DrawingElementId) . fromAttrVal+ instance FromCursor (BlipFillProperties RefId) where     fromCursor cur = do         let _bfpImageInfo = listToMaybe $ cur $/ element (a_ "blip") >=>@@ -358,8 +441,10 @@         ]  instance ToElement PicNonVisual where-    toElement nm PicNonVisual{..} =-        elementListSimple nm [toElement "cNvPr" _pnvDrawingProps]+  toElement nm PicNonVisual {..} =+    elementListSimple+      nm+      [toElement "cNvPr" _pnvDrawingProps, emptyElement "cNvPicPr"]  instance ToElement GraphNonVisual where   toElement nm GraphNonVisual {..} =@@ -376,6 +461,9 @@                 catMaybes [ "descr"  .=? _nvdpDescription                           , "hidden" .=? justTrue _nvdpHidden                           , "title"  .=? _nvdpTitle ]++instance ToAttrVal DrawingElementId where+  toAttrVal = toAttrVal . unDrawingElementId  instance ToElement (BlipFillProperties RefId) where     toElement nm BlipFillProperties{..} =
src/Codec/Xlsx/Types/Drawing/Chart.hs view
@@ -1,22 +1,23 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Drawing.Chart where -import           Data.Default-import           Data.Maybe                        (catMaybes, maybeToList)-import           Data.Text                         (Text)-import           Text.XML-import           Text.XML.Cursor+import GHC.Generics (Generic) -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Codec.Xlsx.LensCompat (makeLenses)+import Control.DeepSeq (NFData)+import Data.Default+import Data.Maybe (catMaybes, listToMaybe, maybeToList)+import Data.Text (Text)+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Common-import           Codec.Xlsx.Types.Drawing.Common-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.Drawing.Common+import Codec.Xlsx.Writer.Internal  -- | Main Chart holder, combines -- TODO: title, autoTitleDeleted, pivotFmts@@ -27,14 +28,16 @@   , _chspLegend :: Maybe Legend   , _chspPlotVisOnly :: Maybe Bool   , _chspDispBlanksAs :: Maybe DispBlanksAs-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData ChartSpace  -- | Chart title -- -- TODO: layout, overlay, spPr, txPr, extLst newtype ChartTitle =-  ChartTitle TextBody-  deriving (Eq, Show)+  ChartTitle (Maybe TextBody)+  deriving (Eq, Show, Generic)+instance NFData ChartTitle  -- | This simple type specifies the possible ways to display blanks. --@@ -46,13 +49,15 @@     -- ^ Specifies that blank values shall be spanned with a line.   | DispBlanksAsZero     -- ^ Specifies that blank values shall be treated as zero.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData DispBlanksAs  -- TODO: legendEntry, layout, overlay, spPr, txPr, extLst data Legend = Legend     { _legendPos     :: Maybe LegendPos     , _legendOverlay :: Maybe Bool-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)+instance NFData Legend  -- See 21.2.3.24 "ST_LegendPos (Legend Position)" (p. 3449) data LegendPos@@ -71,24 +76,39 @@   | LegendTopRight     -- ^ tr (Top Right) Specifies that the legend shall be drawn at     -- the top right of the chart.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData LegendPos  -- | Specific Chart -- TODO:---   areaChart, area3DChart, line3DChart, stockChart, radarChart, scatterChart,---   pieChart, pie3DChart, doughnutChart, barChart, bar3DChart, ofPieChart,+--   area3DChart, line3DChart, stockChart, radarChart,+--   pie3DChart, doughnutChart, bar3DChart, ofPieChart, --   surfaceChart, surface3DChart, bubbleChart-data Chart = LineChart-  { _lnchGrouping :: ChartGrouping-  , _lnchSeries :: [LineSeries]-  , _lnchMarker :: Maybe Bool-    -- ^ specifies that the marker shall be shown-  , _lnchSmooth :: Maybe Bool-    -- ^ specifies the line connecting the points on the chart shall be-    -- smoothed using Catmull-Rom splines-  } deriving (Eq, Show)+data Chart+  = LineChart { _lnchGrouping :: ChartGrouping+              , _lnchSeries :: [LineSeries]+              , _lnchMarker :: Maybe Bool+                -- ^ specifies that the marker shall be shown+              , _lnchSmooth :: Maybe Bool+                -- ^ specifies the line connecting the points on the chart shall be+                -- smoothed using Catmull-Rom splines+              }+  | AreaChart { _archGrouping :: Maybe ChartGrouping+              , _archSeries :: [AreaSeries]+              }+  | BarChart { _brchDirection :: BarDirection+             , _brchGrouping :: Maybe BarChartGrouping+             , _brchSeries :: [BarSeries]+             }+  | PieChart { _pichSeries :: [PieSeries]+             }+  | ScatterChart { _scchStyle :: ScatterStyle+                 , _scchSeries :: [ScatterSeries]+                 }+  deriving (Eq, Show, Generic)+instance NFData Chart --- | Possible groupings for a bar chart+-- | Possible groupings for a chart -- -- See 21.2.3.17 "ST_Grouping (Grouping)" (p. 3446) data ChartGrouping@@ -101,8 +121,65 @@   | StandardGrouping     -- ^(Standard) Specifies that the chart series are drawn on the value     -- axis.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData ChartGrouping +-- | Possible groupings for a bar chart+--+-- See 21.2.3.4 "ST_BarGrouping (Bar Grouping)" (p. 3441)+data BarChartGrouping+  = BarClusteredGrouping+    -- ^ Specifies that the chart series are drawn next to each other+    -- along the category axis.+  | BarPercentStackedGrouping+    -- ^ (100% Stacked) Specifies that the chart series are drawn next to each+    -- other along the value axis and scaled to total 100%.+  | BarStackedGrouping+    -- ^ (Stacked) Specifies that the chart series are drawn next to each+    -- other on the value axis.+  | BarStandardGrouping+    -- ^(Standard) Specifies that the chart series are drawn on the value+    -- axis.+  deriving (Eq, Show, Generic)+instance NFData BarChartGrouping++-- | Possible directions for a bar chart+--+-- See 21.2.3.3 "ST_BarDir (Bar Direction)" (p. 3441)+data BarDirection+  = DirectionBar+  | DirectionColumn+  deriving (Eq, Show, Generic)+instance NFData BarDirection++-- | Possible styles of scatter chart+--+-- /Note:/ It appears that even for 'ScatterMarker' style Exel draws a+-- line between chart points if otline fill for '_scserShared' isn't+-- set to so it's not quite clear how could Excel use this property+--+-- See 21.2.3.40 "ST_ScatterStyle (Scatter Style)" (p. 3455)+data ScatterStyle+  = ScatterNone+  | ScatterLine+  | ScatterLineMarker+  | ScatterMarker+  | ScatterSmooth+  | ScatterSmoothMarker+  deriving (Eq, Show, Generic)+instance NFData ScatterStyle++-- | Single data point options+--+-- TODO:  invertIfNegative,  bubble3D, explosion, pictureOptions, extLst+--+-- See 21.2.2.52 "dPt (Data Point)" (p. 3384)+data DataPoint = DataPoint+  { _dpMarker :: Maybe DataMarker+  , _dpShapeProperties :: Maybe ShapeProperties+  } deriving (Eq, Show, Generic)+instance NFData DataPoint+ -- | Specifies common series options -- TODO: spPr --@@ -111,7 +188,9 @@   { _serTx :: Maybe Formula     -- ^ specifies text for a series name, without rich text formatting     -- currently only reference formula is supported-  } deriving (Eq, Show)+  , _serShapeProperties :: Maybe ShapeProperties+  } deriving (Eq, Show, Generic)+instance NFData Series  -- | A series on a line chart --@@ -125,14 +204,71 @@   , _lnserVal :: Maybe Formula     -- ^ currently only reference formula is supported   , _lnserSmooth :: Maybe Bool-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData LineSeries +-- | A series on an area chart+--+-- TODO: pictureOptions, dPt, trendline, errBars, cat, extLst+--+-- See @CT_AreaSer@ (p. 4065)+data AreaSeries = AreaSeries+  { _arserShared :: Series+  , _arserDataLblProps :: Maybe DataLblProps+  , _arserVal :: Maybe Formula+  } deriving (Eq, Show, Generic)+instance NFData AreaSeries++-- | A series on a bar chart+--+-- TODO: invertIfNegative, pictureOptions, dPt, trendline, errBars,+-- cat, shape, extLst+--+-- See @CT_BarSer@ (p. 4064)+data BarSeries = BarSeries+  { _brserShared :: Series+  , _brserDataLblProps :: Maybe DataLblProps+  , _brserVal :: Maybe Formula+  } deriving (Eq, Show, Generic)+instance NFData BarSeries++-- | A series on a pie chart+--+-- TODO: explosion, cat, extLst+--+-- See @CT_PieSer@ (p. 4065)+data PieSeries = PieSeries+  { _piserShared :: Series+  , _piserDataPoints :: [DataPoint]+  -- ^ normally you should set fill for chart datapoints to make them+  -- properly colored+  , _piserDataLblProps :: Maybe DataLblProps+  , _piserVal :: Maybe Formula+  } deriving (Eq, Show, Generic)+instance NFData PieSeries++-- | A series on a scatter chart+--+-- TODO: dPt, trendline, errBars, smooth, extLst+--+-- See @CT_ScatterSer@ (p. 4064)+data ScatterSeries = ScatterSeries+  { _scserShared :: Series+  , _scserMarker :: Maybe DataMarker+  , _scserDataLblProps :: Maybe DataLblProps+  , _scserXVal :: Maybe Formula+  , _scserYVal :: Maybe Formula+  , _scserSmooth :: Maybe Bool+  } deriving (Eq, Show, Generic)+instance NFData ScatterSeries+ -- See @CT_Marker@ (p. 4061) data DataMarker = DataMarker   { _dmrkSymbol :: Maybe DataMarkerSymbol   , _dmrkSize :: Maybe Int     -- ^ integer between 2 and 72, specifying a size in points-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData DataMarker  data DataMarkerSymbol   = DataMarkerCircle@@ -147,7 +283,8 @@   | DataMarkerTriangle   | DataMarkerX   | DataMarkerAuto-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData DataMarkerSymbol  -- | Settings for the data labels for an entire series or the -- entire chart@@ -161,7 +298,8 @@   , _dlblShowCatName :: Maybe Bool   , _dlblShowSerName :: Maybe Bool   , _dlblShowPercent :: Maybe Bool-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData DataLblProps  -- | Specifies the possible positions for tick marks. @@ -175,9 +313,19 @@     -- ^ (None) Specifies there shall be no tick marks.   | TickMarkOut     -- ^ (Outside) Specifies the tick marks shall be outside the plot area.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData TickMark +makeLenses ''DataPoint+ {-------------------------------------------------------------------------------+  Default instances+-------------------------------------------------------------------------------}++instance Default DataPoint where+    def = DataPoint Nothing Nothing++{-------------------------------------------------------------------------------   Parsing -------------------------------------------------------------------------------} @@ -200,6 +348,23 @@     _lnchMarker <- maybeBoolElementValue (c_ "marker") cur     _lnchSmooth <- maybeBoolElementValue (c_ "smooth") cur     return LineChart {..}+  | n `nodeElNameIs` (c_ "areaChart") = do+    _archGrouping <- maybeElementValue (c_ "grouping") cur+    let _archSeries = cur $/ element (c_ "ser") >=> fromCursor+    return AreaChart {..}+  | n `nodeElNameIs` (c_ "barChart") = do+    _brchDirection <- fromElementValue (c_ "barDir") cur+    _brchGrouping <-+      maybeElementValueDef (c_ "grouping") BarClusteredGrouping cur+    let _brchSeries = cur $/ element (c_ "ser") >=> fromCursor+    return BarChart {..}+  | n `nodeElNameIs` (c_ "pieChart") = do+    let _pichSeries = cur $/ element (c_ "ser") >=> fromCursor+    return PieChart {..}+  | n `nodeElNameIs` (c_ "scatterChart") = do+    _scchStyle <- fromElementValue (c_ "scatterStyle") cur+    let _scchSeries = cur $/ element (c_ "ser") >=> fromCursor+    return ScatterChart {..}   | otherwise = fail "no matching chart node"   where     cur = fromNode n@@ -215,12 +380,55 @@     _lnserSmooth <- maybeElementValueDef (c_ "smooth") True cur     return LineSeries {..} +instance FromCursor AreaSeries where+  fromCursor cur = do+    _arserShared <- fromCursor cur+    _arserDataLblProps <- maybeFromElement (c_ "dLbls") cur+    _arserVal <-+      cur $/ element (c_ "val") &/ element (c_ "numRef") >=>+      maybeFromElement (c_ "f")+    return AreaSeries {..}++instance FromCursor BarSeries where+  fromCursor cur = do+    _brserShared <- fromCursor cur+    _brserDataLblProps <- maybeFromElement (c_ "dLbls") cur+    _brserVal <-+      cur $/ element (c_ "val") &/ element (c_ "numRef") >=>+      maybeFromElement (c_ "f")+    return BarSeries {..}++instance FromCursor PieSeries where+  fromCursor cur = do+    _piserShared <- fromCursor cur+    let _piserDataPoints = cur $/ element (c_ "dPt") >=> fromCursor+    _piserDataLblProps <- maybeFromElement (c_ "dLbls") cur+    _piserVal <-+      cur $/ element (c_ "val") &/ element (c_ "numRef") >=>+      maybeFromElement (c_ "f")+    return PieSeries {..}++instance FromCursor ScatterSeries where+  fromCursor cur = do+    _scserShared <- fromCursor cur+    _scserMarker <- maybeFromElement (c_ "marker") cur+    _scserDataLblProps <- maybeFromElement (c_ "dLbls") cur+    _scserXVal <-+      cur $/ element (c_ "xVal") &/ element (c_ "numRef") >=>+      maybeFromElement (c_ "f")+    _scserYVal <-+      cur $/ element (c_ "yVal") &/ element (c_ "numRef") >=>+      maybeFromElement (c_ "f")+    _scserSmooth <- maybeElementValueDef (c_ "smooth") True cur+    return ScatterSeries {..}+ -- should we respect idx and order? instance FromCursor Series where   fromCursor cur = do     _serTx <-       cur $/ element (c_ "tx") &/ element (c_ "strRef") >=>       maybeFromElement (c_ "f")+    _serShapeProperties <- maybeFromElement (c_ "spPr") cur     return Series {..}  instance FromCursor DataMarker where@@ -229,6 +437,12 @@     _dmrkSize <- maybeElementValue (c_ "size") cur     return DataMarker {..} +instance FromCursor DataPoint where+  fromCursor cur = do+    _dpMarker <- maybeFromElement (c_ "marker") cur+    _dpShapeProperties <- maybeFromElement (c_ "spPr") cur+    return DataPoint {..}+ instance FromAttrVal DataMarkerSymbol where   fromAttrVal "circle" = readSuccess DataMarkerCircle   fromAttrVal "dash" = readSuccess DataMarkerDash@@ -244,6 +458,20 @@   fromAttrVal "auto" = readSuccess DataMarkerAuto   fromAttrVal t = invalidText "DataMarkerSymbol" t +instance FromAttrVal BarDirection where+  fromAttrVal "bar" = readSuccess DirectionBar+  fromAttrVal "col" = readSuccess DirectionColumn+  fromAttrVal t = invalidText "BarDirection" t++instance FromAttrVal ScatterStyle where+  fromAttrVal "none" = readSuccess ScatterNone+  fromAttrVal "line" = readSuccess ScatterLine+  fromAttrVal "lineMarker" = readSuccess ScatterLineMarker+  fromAttrVal "marker" = readSuccess ScatterMarker+  fromAttrVal "smooth" = readSuccess ScatterSmooth+  fromAttrVal "smoothMarker" = readSuccess ScatterSmoothMarker+  fromAttrVal t = invalidText "ScatterStyle" t+ instance FromCursor DataLblProps where   fromCursor cur = do     _dlblShowLegendKey <- maybeBoolElementValue (c_ "showLegendKey") cur@@ -259,9 +487,18 @@   fromAttrVal "stacked" = readSuccess StackedGrouping   fromAttrVal t = invalidText "ChartGrouping" t +instance FromAttrVal BarChartGrouping where+  fromAttrVal "clustered" = readSuccess BarClusteredGrouping+  fromAttrVal "percentStacked" = readSuccess BarPercentStackedGrouping+  fromAttrVal "standard" = readSuccess BarStandardGrouping+  fromAttrVal "stacked" = readSuccess BarStackedGrouping+  fromAttrVal t = invalidText "BarChartGrouping" t+ instance FromCursor ChartTitle where-  fromCursor cur =-    cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fmap ChartTitle . fromCursor+  fromCursor cur = do+    let mTitle = listToMaybe $+          cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fromCursor+    return $ ChartTitle mTitle  instance FromCursor Legend where   fromCursor cur = do@@ -305,7 +542,7 @@     where       -- no such element gives a chart space with rounded corners       nonRounded = elementValue "roundedCorners" False-      chSpPr = toElement "spPr" $ def {_spFill = Just SolidFill}+      chSpPr = toElement "spPr" $ def {_spFill = Just $ solidRgb "ffffff"}       chartEl = elementListSimple "chart" elements       elements =         catMaybes@@ -317,90 +554,155 @@           , elementValue "plotVisOnly" <$> _chspPlotVisOnly           , elementValue "dispBlanksAs" <$> _chspDispBlanksAs           ]-      -- we reserve 2 axes - X and Y for line charts-      -- this needs to be reworked when other chart types will be added-      enumCharts = zip [1,3 ..] _chspCharts-      charts = [chartToElement ch i (i + 1) | (i, ch) <- enumCharts]-      areaEls = charts ++ valAxes ++ catAxes-      catAxes = [catAxEl i (i + 1) | (i, _) <- enumCharts]-      valAxes = [valAxEl (i + 1) i | (i, _) <- enumCharts]-      catAxEl :: Int -> Int -> Element-      catAxEl i cr =-        elementListSimple "catAx" $-        [ elementValue "axId" i-        , emptyElement "scaling"-        , elementValue "delete" False-        , elementValue "axPos" ("b" :: Text)-        , elementValue "majorTickMark" TickMarkNone-        , elementValue "minorTickMark" TickMarkNone-        , toElement "spPr" noFill-        , elementValue "crossAx" cr-        , elementValue "auto" True-        ]-      valAxEl :: Int -> Int -> Element-      valAxEl i cr =-        elementListSimple "valAx" $-        [ elementValue "axId" i-        , emptyElement "scaling"-        , elementValue "delete" False-        , elementValue "axPos" ("l" :: Text)-        , gridLinesEl-        , elementValue "majorTickMark" TickMarkNone-        , elementValue "minorTickMark" TickMarkNone-        , toElement "spPr" noFill-        , elementValue "crossAx" cr-        ]-      noFill =-        def-        { _spFill = Just NoFill-        , _spOutline = Just . LineProperties $ Just NoFill-        }-      gridLinesEl =-        elementListSimple "majorGridlines" [toElement "spPr" lineFill]-      lineFill = def { _spOutline = Just . LineProperties $ Just SolidFill }+      areaEls = charts ++ axes+      (_, charts, axes) = foldr addChart (1, [], []) _chspCharts+      addChart ch (i, cs, as) =+        let (c, as') = chartToElements ch i+        in (i + length as', c : cs, as' ++ as) -chartToElement :: Chart -> Int -> Int -> Element-chartToElement LineChart {..} cId vId = elementListSimple "lineChart" elements+chartToElements :: Chart -> Int -> (Element, [Element])+chartToElements chart axId =+  case chart of+    LineChart {..} ->+      chartElement+        "lineChart"+        stdAxes+        (Just _lnchGrouping)+        _lnchSeries+        []+        (catMaybes+           [ elementValue "marker" <$> _lnchMarker+           , elementValue "smooth" <$> _lnchSmooth+           ])+    AreaChart {..} ->+      chartElement "areaChart" stdAxes _archGrouping _archSeries [] []+    BarChart {..} ->+      chartElement+        "barChart"+        stdAxes+        _brchGrouping+        _brchSeries+        [elementValue "barDir" _brchDirection]+        []+    PieChart {..} -> chartElement "pieChart" [] noGrouping _pichSeries [] []+    ScatterChart {..} ->+      chartElement+        "scatterChart"+        xyAxes+        noGrouping+        _scchSeries+        [elementValue "scatterStyle" _scchStyle]+        []   where-    elements =-      (grouping : varyColors : series) ++-      catMaybes-        [ elementValue "marker" <$> _lnchMarker-        , elementValue "smooth" <$> _lnchSmooth-        ] ++-      map (elementValue "axId") [cId, vId]-    grouping = elementValue "grouping" _lnchGrouping+    noGrouping :: Maybe ChartGrouping+    noGrouping = Nothing+    chartElement+      :: (ToElement s, ToAttrVal gr)+      => Name+      -> [Element]+      -> Maybe gr+      -> [s]+      -> [Element]+      -> [Element]+      -> (Element, [Element])+    chartElement nm axes mGrouping series prepended appended =+      ( elementListSimple nm $+        prepended +++        (maybeToList $ elementValue "grouping" <$> mGrouping) +++        (varyColors : seriesEls series) +++        appended ++ zipWith (\n _ -> elementValue "axId" n) [axId ..] axes+      , axes)     -- no element seems to be equal to varyColors=true in Excel Online     varyColors = elementValue "varyColors" False-    series = [indexedSeriesEl i s | (i, s) <- zip [0 ..] _lnchSeries]-    indexedSeriesEl :: Int -> LineSeries -> Element+    seriesEls series = [indexedSeriesEl i s | (i, s) <- zip [0 ..] series]+    indexedSeriesEl+      :: ToElement a+      => Int -> a -> Element     indexedSeriesEl i s = prependI i $ toElement "ser" s     prependI i e@Element {..} = e {elementNodes = iNodes i ++ elementNodes}     iNodes i = map NodeElement [elementValue n i | n <- ["idx", "order"]] +    stdAxes = [catAx axId (axId + 1), valAx "l" (axId + 1) axId]+    xyAxes = [valAx "b" axId (axId + 1), valAx "l" (axId + 1) axId]+    catAx :: Int -> Int -> Element+    catAx i cr =+      elementListSimple "catAx" $+      [ elementValue "axId" i+      , emptyElement "scaling"+      , elementValue "delete" False+      , elementValue "axPos" ("b" :: Text)+      , elementValue "majorTickMark" TickMarkNone+      , elementValue "minorTickMark" TickMarkNone+      , toElement "spPr" grayLines+      , elementValue "crossAx" cr+      , elementValue "auto" True+      ]+    valAx :: Text -> Int -> Int -> Element+    valAx pos i cr =+      elementListSimple "valAx" $+      [ elementValue "axId" i+      , emptyElement "scaling"+      , elementValue "delete" False+      , elementValue "axPos" pos+      , gridLinesEl+      , elementValue "majorTickMark" TickMarkNone+      , elementValue "minorTickMark" TickMarkNone+      , toElement "spPr" grayLines+      , elementValue "crossAx" cr+      ]+    grayLines = def {_spOutline = Just def {_lnFill = Just $ solidRgb "b3b3b3"}}+    gridLinesEl =+      elementListSimple "majorGridlines" [toElement "spPr" grayLines]+ instance ToAttrVal ChartGrouping where   toAttrVal PercentStackedGrouping = "percentStacked"   toAttrVal StandardGrouping = "standard"   toAttrVal StackedGrouping = "stacked" +instance ToAttrVal BarChartGrouping where+  toAttrVal BarClusteredGrouping = "clustered"+  toAttrVal BarPercentStackedGrouping = "percentStacked"+  toAttrVal BarStandardGrouping = "standard"+  toAttrVal BarStackedGrouping = "stacked"++instance ToAttrVal BarDirection where+  toAttrVal DirectionBar = "bar"+  toAttrVal DirectionColumn = "col"++instance ToAttrVal ScatterStyle where+  toAttrVal ScatterNone = "none"+  toAttrVal ScatterLine = "line"+  toAttrVal ScatterLineMarker = "lineMarker"+  toAttrVal ScatterMarker = "marker"+  toAttrVal ScatterSmooth = "smooth"+  toAttrVal ScatterSmoothMarker = "smoothMarker"+ instance ToElement LineSeries where-  toElement nm LineSeries {..} = serEl-      { elementNodes = elementNodes serEl ++-                     map NodeElement elements }+  toElement nm LineSeries {..} = simpleSeries nm _lnserShared _lnserVal pr ap     where-      serEl = toElement nm _lnserShared-      elements =+      pr =         catMaybes           [ toElement "marker" <$> _lnserMarker           , toElement "dLbls" <$> _lnserDataLblProps-          , Just $ valEl _lnserVal-          , elementValue "smooth" <$> _lnserSmooth           ]-      valEl v =-        elementListSimple-          "val"-          [elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)]+      ap = maybeToList $ elementValue "smooth" <$> _lnserSmooth +simpleSeries :: Name+             -> Series+             -> Maybe Formula+             -> [Element]+             -> [Element]+             -> Element+simpleSeries nm shared val prepended appended =+  serEl {elementNodes = elementNodes serEl ++ map NodeElement elements}+  where+    serEl = toElement nm shared+    elements = prepended ++ (valEl val : appended)+    valEl v =+      elementListSimple+        "val"+        [elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)]+ instance ToElement DataMarker where   toElement nm DataMarker {..} = elementListSimple nm elements     where@@ -436,21 +738,62 @@           , elementValue "showPercent" <$> _dlblShowPercent           ] +instance ToElement AreaSeries where+  toElement nm AreaSeries {..} = simpleSeries nm _arserShared _arserVal pr []+    where+      pr = maybeToList $ fmap (toElement "dLbls") _arserDataLblProps++instance ToElement BarSeries where+  toElement nm BarSeries {..} = simpleSeries nm _brserShared _brserVal pr []+    where+      pr = maybeToList $ fmap (toElement "dLbls") _brserDataLblProps++instance ToElement PieSeries where+  toElement nm PieSeries {..} = simpleSeries nm _piserShared _piserVal pr []+    where+      pr = dPts ++ maybeToList (fmap (toElement "dLbls") _piserDataLblProps)+      dPts = zipWith dPtEl [(0 :: Int) ..] _piserDataPoints+      dPtEl i DataPoint {..} =+        elementListSimple+          "dPt"+          (elementValue "idx" i :+           catMaybes+             [ toElement "marker" <$> _dpMarker+             , toElement "spPr" <$> _dpShapeProperties+             ])++instance ToElement ScatterSeries where+  toElement nm ScatterSeries {..} =+    serEl {elementNodes = elementNodes serEl ++ map NodeElement elements}+    where+      serEl = toElement nm _scserShared+      elements =+        catMaybes+          [ toElement "marker" <$> _scserMarker+          , toElement "dLbls" <$> _scserDataLblProps+          ] +++        [valEl "xVal" _scserXVal, valEl "yVal" _scserYVal] +++        (maybeToList $ fmap (elementValue "smooth") _scserSmooth)+      valEl vnm v =+        elementListSimple+          vnm+          [elementListSimple "numRef" $ maybeToList (toElement "f" <$> v)]+ -- should we respect idx and order? instance ToElement Series where   toElement nm Series {..} =-    elementListSimple-      nm-      [ elementListSimple-          "tx"-          [elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)]-      ]+    elementListSimple nm $+    [ elementListSimple+        "tx"+        [elementListSimple "strRef" $ maybeToList (toElement "f" <$> _serTx)]+    ] +++    maybeToList (toElement "spPr" <$> _serShapeProperties)  instance ToElement ChartTitle where   toElement nm (ChartTitle body) =     elementListSimple nm [txEl, elementValue "overlay" False]     where-      txEl = elementListSimple "tx" [toElement (c_ "rich") body]+      txEl = elementListSimple "tx" $ catMaybes [toElement (c_ "rich") <$> body]  instance ToElement Legend where   toElement nm Legend{..} = elementListSimple nm elements@@ -459,10 +802,10 @@                             , elementValue "overlay" <$>_legendOverlay]  instance ToAttrVal LegendPos where-  toAttrVal LegendBottom   = "b" -  toAttrVal LegendLeft     = "l" -  toAttrVal LegendRight    = "r" -  toAttrVal LegendTop      = "t" +  toAttrVal LegendBottom   = "b"+  toAttrVal LegendLeft     = "l"+  toAttrVal LegendRight    = "r"+  toAttrVal LegendTop      = "t"   toAttrVal LegendTopRight = "tr"  instance ToAttrVal DispBlanksAs where
src/Codec/Xlsx/Types/Drawing/Common.hs view
@@ -1,32 +1,35 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Drawing.Common where -import           Control.Arrow              (first)-import           Control.Monad              (join)-import           Data.Default-import           Data.Maybe                 (catMaybes, listToMaybe)-import           Data.Monoid                ((<>))-import           Data.Text                  (Text)-import qualified Data.Text                  as T-import qualified Data.Text.Read             as T-import           Text.XML-import           Text.XML.Cursor+import GHC.Generics (Generic) -#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Control.Arrow (first)+import Codec.Xlsx.LensCompat (makeLenses)+import Control.Monad (join)+import Control.Monad.Fail (MonadFail)+import Control.DeepSeq (NFData)+import Data.Default+import Data.Maybe (catMaybes, listToMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Read as T+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Writer.Internal  -- | This simple type represents an angle in 60,000ths of a degree. -- Positive angles are clockwise (i.e., towards the positive y axis); negative -- angles are counter-clockwise (i.e., towards the negative y axis). newtype Angle =   Angle Int-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData Angle  -- | A string with rich text formatting --@@ -56,8 +59,10 @@     -- aligns the text within the "bounds box" for the text.   , _txbdParagraphs :: [TextParagraph]     -- ^ Paragraphs of text within the containing text body-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData TextBody + -- | Text vertical overflow -- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083) data TextVertOverflow@@ -69,7 +74,8 @@     -- there is text which is not visible.   | TextVertOverflow     -- ^ Overflow the text and pay no attention to top and bottom barriers.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData TextVertOverflow  -- | If there is vertical text, determines what kind of vertical text is going to be used. --@@ -98,7 +104,8 @@   | TextVerticalWordArtRtl     -- ^  Specifies that vertical WordArt should be shown from right to left rather than     -- left to right.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData TextVertical  -- | Text wrapping types --@@ -109,7 +116,8 @@     -- paying attention to the bounding rectangle boundaries.     | TextWrapSquare     -- ^ Determines whether we wrap words within the bounding rectangle.-    deriving (Eq, Show)+    deriving (Eq, Show, Generic)+instance NFData TextWrap  -- | This type specifies a list of available anchoring types for text. --@@ -135,13 +143,15 @@     -- text in a line, it does not justify.   | TextAnchoringTop     -- ^ Anchor the text at the top of the bounding rectangle.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData TextAnchoring  -- See 21.1.2.2.6 "p (Text Paragraphs)" (p. 3211) data TextParagraph = TextParagraph   { _txpaDefCharProps :: Maybe TextCharacterProperties   , _txpaRuns :: [TextRun]-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData TextParagraph  -- | Text character properties --@@ -156,7 +166,8 @@   { _txchBold :: Bool   , _txchItalic :: Bool   , _txchUnderline :: Bool-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData TextCharacterProperties  -- | Text run --@@ -164,7 +175,8 @@ data TextRun = RegularRun   { _txrCharProps :: Maybe TextCharacterProperties   , _txrText :: Text-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData TextRun  -- | This simple type represents a one dimensional position or length --@@ -175,7 +187,8 @@   | UniversalMeasure UnitIdentifier                      Double     -- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793)-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData Coordinate  -- | Units used in "Universal measure" coordinates -- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793)@@ -186,13 +199,15 @@   | UnitPt -- "pt" 1 pt = 1/72 in (informative)   | UnitPc -- "pc" 1 pc = 12 pt (informative)   | UnitPi -- "pi" 1 pi = 12 pt (informative)-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData UnitIdentifier  -- See @CT_Point2D@ (p. 3989) data Point2D = Point2D   { _pt2dX :: Coordinate   , _pt2dY :: Coordinate-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData Point2D  unqPoint2D :: Int -> Int -> Point2D unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y)@@ -201,13 +216,25 @@ -- see 20.1.10.41 "ST_PositiveCoordinate (Positive Coordinate)" (p. 2942) newtype PositiveCoordinate =   PositiveCoordinate Integer-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic)+instance NFData PositiveCoordinate  data PositiveSize2D = PositiveSize2D   { _ps2dX :: PositiveCoordinate   , _ps2dY :: PositiveCoordinate-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData PositiveSize2D +positiveSize2D :: Integer -> Integer -> PositiveSize2D+positiveSize2D x y =+  PositiveSize2D (PositiveCoordinate x) (PositiveCoordinate y)++cmSize2D :: Integer -> Integer -> PositiveSize2D+cmSize2D x y = positiveSize2D (cm2emu x) (cm2emu y)++cm2emu :: Integer -> Integer+cm2emu cm = 360000 * cm+ -- See 20.1.7.6 "xfrm (2D Transform for Individual Objects)" (p. 2849) data Transform2D = Transform2D   { _trRot :: Angle@@ -223,14 +250,16 @@   , _trExtents :: Maybe PositiveSize2D     -- ^ See 20.1.7.3 "ext (Extents)" (p. 2846) or     -- 20.5.2.14 "ext (Shape Extent)" (p. 3165)-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData Transform2D  -- TODO: custGeom data Geometry =   PresetGeometry   -- TODO: prst, avList   -- currently uses "rect" with empty avList-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData Geometry  -- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751) data ShapeProperties = ShapeProperties@@ -239,25 +268,56 @@   , _spFill :: Maybe FillProperties   , _spOutline :: Maybe LineProperties     -- TODO: bwMode, a_EG_EffectProperties, scene3d, sp3d, extLst-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData ShapeProperties +-- | Specifies an outline style that can be applied to a number of+-- different objects such as shapes and text.+--+-- TODO: cap, cmpd, algn, a_EG_LineDashProperties,+--   a_EG_LineJoinProperties, headEnd, tailEnd, extLst+-- -- See 20.1.2.2.24 "ln (Outline)" (p. 2744) data LineProperties = LineProperties   { _lnFill :: Maybe FillProperties-    -- TODO: w, cap, cmpd, algn, a_EG_LineDashProperties,-    --   a_EG_LineJoinProperties, headEnd, tailEnd, extLst-  } deriving (Eq, Show)+  , _lnWidth :: Int+  -- ^ Specifies the width to be used for the underline stroke.  The+  -- value is in EMU, is greater of equal to 0 and maximum value is+  -- 20116800.+  } deriving (Eq, Show, Generic)+instance NFData LineProperties +-- | Color choice for some drawing element+--+-- TODO: scrgbClr, hslClr, sysClr, schemeClr, prstClr+--+-- See @EG_ColorChoice@ (p. 3996)+data ColorChoice =+  RgbColor Text+  -- ^ Specifies a color using the red, green, blue RGB color+  -- model. Red, green, and blue is expressed as sequence of hex+  -- digits, RRGGBB. A perceptual gamma of 2.2 is used.+  --+  -- See 20.1.2.3.32 "srgbClr (RGB Color Model - Hex Variant)" (p. 2773)+  deriving (Eq, Show, Generic)+instance NFData ColorChoice+ -- TODO: gradFill, pattFill data FillProperties =   NoFill   -- ^ See 20.1.8.44 "noFill (No Fill)" (p. 2872)-  | SolidFill+  | SolidFill (Maybe ColorChoice)   -- ^ Solid fill-  -- TODO: colors   -- See 20.1.8.54 "solidFill (Solid Fill)" (p. 2879)-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData FillProperties +-- | solid fill with color specified by hexadecimal RGB color+solidRgb :: Text -> FillProperties+solidRgb t = SolidFill . Just $ RgbColor t++makeLenses ''ShapeProperties+ {-------------------------------------------------------------------------------   Default instances -------------------------------------------------------------------------------}@@ -265,6 +325,9 @@ instance Default ShapeProperties where     def = ShapeProperties Nothing Nothing Nothing Nothing +instance Default LineProperties where+  def = LineProperties Nothing 0+ {-------------------------------------------------------------------------------   Parsing -------------------------------------------------------------------------------}@@ -366,6 +429,7 @@ instance FromCursor LineProperties where     fromCursor cur = do         let _lnFill = listToMaybe $ cur $/ anyElement >=> fromCursor+        _lnWidth <- fromAttributeDef "w" 0 cur         return LineProperties{..}  instance FromCursor Point2D where@@ -384,11 +448,22 @@     fromCursor = fillPropsFromNode . node  fillPropsFromNode :: Node -> [FillProperties]-fillPropsFromNode n | n `nodeElNameIs` a_ "noFill" = return NoFill-                    | n `nodeElNameIs` a_ "solidFill" = return SolidFill-                    | otherwise = fail "no matching line fill node"+fillPropsFromNode n+  | n `nodeElNameIs` a_ "noFill" = return NoFill+  | n `nodeElNameIs` a_ "solidFill" = do+    let color =+          listToMaybe $ fromNode n $/ anyElement >=> colorChoiceFromNode . node+    return $ SolidFill color+  | otherwise = fail "no matching line fill node" -coordinate :: Monad m => Text -> m Coordinate+colorChoiceFromNode :: Node -> [ColorChoice]+colorChoiceFromNode n+  | n `nodeElNameIs` a_ "srgbClr" = do+    val <- fromAttribute "val" $ fromNode n+    return $ RgbColor val+  | otherwise = fail "no matching color choice node"++coordinate :: MonadFail m => Text -> m Coordinate coordinate t =  case T.decimal t of   Right (d, leftover) | leftover == T.empty ->       return $ UnqCoordinate d@@ -517,15 +592,23 @@                              , toElement (a_ "ext") <$> _trExtents ]  geometryToElement :: Geometry -> Element-geometryToElement PresetGeometry = emptyElement (a_ "prstGeom")+geometryToElement PresetGeometry =+  leafElement (a_ "prstGeom") ["prst" .= ("rect" :: Text)]  instance ToElement LineProperties where-    toElement nm LineProperties{..} =-      elementListSimple nm $ catMaybes [ fillPropsToElement <$> _lnFill ]+  toElement nm LineProperties {..} = elementList nm attrs elements+    where+      attrs = catMaybes ["w" .=? justNonDef 0 _lnWidth]+      elements = catMaybes [fillPropsToElement <$> _lnFill]  fillPropsToElement :: FillProperties -> Element fillPropsToElement NoFill = emptyElement (a_ "noFill")-fillPropsToElement SolidFill = emptyElement (a_ "solidFill")+fillPropsToElement (SolidFill color) =+  elementListSimple (a_ "solidFill") $ catMaybes [colorChoiceToElement <$> color]++colorChoiceToElement :: ColorChoice -> Element+colorChoiceToElement (RgbColor color) =+  leafElement (a_ "srgbClr") ["val" .= color]  -- | Add DrawingML namespace to name a_ :: Text -> Name
src/Codec/Xlsx/Types/Internal.hs view
@@ -1,20 +1,3 @@-{-# LANGUAGE CPP #-}-module Codec.Xlsx.Types.Internal where--import           Control.Arrow-import           Data.Text                  (Text)--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif--import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Writer.Internal--newtype RefId = RefId { unRefId :: Text } deriving (Show, Eq, Ord)--instance ToAttrVal RefId where-    toAttrVal = toAttrVal . unRefId+module Codec.Xlsx.Types.Internal (module Codec.Xlsx.Types.RefId) where -instance FromAttrVal RefId where-    fromAttrVal t = first RefId <$> fromAttrVal t+import Codec.Xlsx.Types.RefId
src/Codec/Xlsx/Types/Internal/CfPair.hs view
@@ -1,13 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.CfPair where -import           Text.XML.Cursor--import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Common-import           Codec.Xlsx.Types.ConditionalFormatting-import           Codec.Xlsx.Writer.Internal+import GHC.Generics (Generic)+import Text.XML.Cursor +import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.ConditionalFormatting+import Codec.Xlsx.Writer.Internal  -- | Internal helper type for parsing "conditionalFormatting recods -- TODO: pivot, extList@@ -16,13 +17,19 @@ -- See 18.3.1.18 "conditionalFormatting (Conditional Formatting)" (p. 1610) newtype CfPair = CfPair     { unCfPair :: (SqRef, ConditionalFormatting)-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  instance FromCursor CfPair where     fromCursor cur = do         sqref <- fromAttribute "sqref" cur-        let cfRules = cur $/ element (n_ "cfRule") >=> fromCursor+        let cfRules = cur $/ element (addSmlNamespace "cfRule") >=> fromCursor         return $ CfPair (sqref, cfRules)++instance FromXenoNode CfPair where+  fromXenoNode root = do+    sqref <- parseAttributes root $ fromAttr "sqref"+    cfRules <- collectChildren root $ fromChildList "cfRule"+    return $ CfPair (sqref, cfRules)  instance ToElement CfPair where     toElement nm (CfPair (sqRef, cfRules)) =
src/Codec/Xlsx/Types/Internal/CommentTable.hs view
@@ -1,33 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.CommentTable where -import           Data.ByteString.Lazy       (ByteString)-import qualified Data.ByteString.Lazy       as LB+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy.Char8 as LBC8-import           Data.List.Extra            (nubOrd)-import           Data.Map                   (Map)-import qualified Data.Map                   as M-import           Data.Text                  (Text)-import           Data.Text.Lazy             (toStrict)-import qualified Data.Text.Lazy.Builder     as B+import Data.List.Extra (nubOrd)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Lazy (toStrict)+import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.Builder.Int as B-import           Safe-import           Text.XML-import           Text.XML.Cursor+import GHC.Generics (Generic)+import Safe+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Comment-import           Codec.Xlsx.Types.Common-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Comment+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Writer.Internal  newtype CommentTable = CommentTable     { _commentsTable :: Map CellRef Comment }-    deriving (Show, Eq)+    deriving (Eq, Show, Generic) +tshow :: Show a => a -> Text+tshow = Text.pack . show+ fromList :: [(CellRef, Comment)] -> CommentTable fromList = CommentTable . M.fromList +toList :: CommentTable -> [(CellRef, Comment)]+toList = M.toList . _commentsTable+ lookupComment :: CellRef -> CommentTable -> Maybe Comment lookupComment ref = M.lookup ref . _commentsTable @@ -46,7 +55,8 @@       commentToEl (ref, Comment{..}) = Element           { elementName = "comment"           , elementAttributes = M.fromList [ ("ref" .= ref)-                                           , ("authorId" .= lookupAuthor _commentAuthor)]+                                           , ("authorId" .= lookupAuthor _commentAuthor)+                                           , ("visible" .= tshow _commentVisible)]           , elementNodes      = [NodeElement $ toElement "text" _commentText]           }       lookupAuthor a = fromJustNote "author lookup" $ M.lookup a authorIds@@ -58,18 +68,20 @@  instance FromCursor CommentTable where   fromCursor cur = do-    let authorNames = cur $/ element (n_ "authors") &/ element (n_ "author") >=> contentOrEmpty+    let authorNames = cur $/ element (addSmlNamespace "authors") &/ element (addSmlNamespace "author") >=> contentOrEmpty         authors = M.fromList $ zip [0..] authorNames-        items = cur $/ element (n_ "commentList") &/ element (n_ "comment") >=> parseComment authors+        items = cur $/ element (addSmlNamespace "commentList") &/ element (addSmlNamespace "comment") >=> parseComment authors     return . CommentTable $ M.fromList items  parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)] parseComment authors cur = do     ref <- fromAttribute "ref" cur-    txt <- cur $/ element (n_ "text") >=> fromCursor+    txt <- cur $/ element (addSmlNamespace "text") >=> fromCursor     authorId <- cur $| attribute "authorId" >=> decimal+    visible <- (read . Text.unpack :: Text -> Bool)+      <$> (fromAttribute "visible" cur :: [Text])     let author = fromJustNote "authorId" $ M.lookup authorId authors-    return (ref, Comment txt author True)+    return (ref, Comment txt author visible)  -- | helper to render comment baloons vml file, -- currently uses fixed shape@@ -90,7 +102,8 @@         , "<v:path gradientshapeok=\"t\" o:connecttype=\"rect\"></v:path>"         , "</v:shapetype>"         ]-    fromRef = fromJustNote "Invalid comment ref" . fromSingleCellRef+    fromRef cr =+      fromJustNote ("Invalid comment ref: " <> show cr) $ fromSingleCellRef cr     commentShapes = [ commentShape (fromRef ref) (_commentVisible cmnt)                     | (ref, cmnt) <- M.toList m ]     commentShape (r, c) v = LB.concat
src/Codec/Xlsx/Types/Internal/ContentTypes.hs view
@@ -1,38 +1,35 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.ContentTypes where -import           Control.Arrow-import           Data.Foldable              (asum)-import           Data.Map                   (Map)-import qualified Data.Map                   as M-import           Data.Text                  (Text)-import qualified Data.Text                  as T-import           System.FilePath.Posix      (takeExtension)-import           Text.XML-import           Text.XML.Cursor--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Control.Arrow+import Data.Foldable (asum)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import System.FilePath.Posix (takeExtension)+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Parser.Internal  data CtDefault = CtDefault     { dfltExtension   :: FilePath     , dfltContentType :: Text-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  data Override = Override     { ovrPartName    :: FilePath     , ovrContentType :: Text-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  data ContentTypes = ContentTypes     { ctDefaults :: Map FilePath Text     , ctTypes    :: Map FilePath Text-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  lookup :: FilePath -> ContentTypes -> Maybe Text lookup path ContentTypes{..} =
src/Codec/Xlsx/Types/Internal/CustomProperties.hs view
@@ -1,18 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.CustomProperties where -import           Data.Map                   (Map)-import qualified Data.Map                   as M-import           Data.Text                  (Text)-import           Text.XML-import           Text.XML.Cursor+import Data.Map (Map)+import qualified Data.Map as M+import Data.Text (Text)+import GHC.Generics (Generic)+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Variant-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Variant+import Codec.Xlsx.Writer.Internal  newtype CustomProperties = CustomProperties (Map Text Variant)-    deriving (Show, Eq)+    deriving (Eq, Show, Generic)  fromList :: [(Text, Variant)] -> CustomProperties fromList = CustomProperties . M.fromList
src/Codec/Xlsx/Types/Internal/DvPair.hs view
@@ -1,27 +1,34 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.DvPair where -import qualified Data.Map                   as M-import           Text.XML                   (Element (..))--import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Common-import           Codec.Xlsx.Types.DataValidation-import           Codec.Xlsx.Writer.Internal+import qualified Data.Map as M+import GHC.Generics (Generic)+import Text.XML (Element(..)) +import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.DataValidation+import Codec.Xlsx.Writer.Internal  -- | Internal helper type for parsing data validation records -- -- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624) newtype DvPair = DvPair     { unDvPair :: (SqRef, DataValidation)-    } deriving (Eq, Show)+    } deriving (Eq, Show, Generic)  instance FromCursor DvPair where     fromCursor cur = do         sqref <- fromAttribute "sqref" cur         dv    <- fromCursor cur         return $ DvPair (sqref, dv)++instance FromXenoNode DvPair where+  fromXenoNode root = do+    sqref <- parseAttributes root $ fromAttr "sqref"+    dv <- fromXenoNode root+    return $ DvPair (sqref, dv)  instance ToElement DvPair where     toElement nm (DvPair (sqRef,dv)) = e
+ 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/NumFmtPair.hs 
@@ -1,25 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Codec.Xlsx.Types.Internal.NumFmtPair where--import           Data.Text                  (Text)--import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Writer.Internal---- | Internal helper type for parsing "numFmt" recods------ See 18.8.30 "numFmt (Number Format)" (p. 1777)-newtype NumFmtPair = NumFmtPair-    { unNumFmtPair :: (Int, Text)-    } deriving (Eq, Show)--instance FromCursor NumFmtPair where-    fromCursor cur = do-        fId <- fromAttribute "numFmtId" cur-        fCode <- fromAttribute "formatCode" cur-        return $ NumFmtPair (fId, fCode)--instance ToElement NumFmtPair where-    toElement nm (NumFmtPair (fId, fCode)) =-        leafElement nm [ "numFmtId"   .= toAttrVal fId-                       , "formatCode" .= toAttrVal fCode ]
src/Codec/Xlsx/Types/Internal/Relationships.hs view
@@ -1,32 +1,29 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.Relationships where -import           Data.List                  (find)-import           Data.Map                   (Map)-import qualified Data.Map                   as Map-import           Data.Monoid                ((<>))-import           Data.Text                  (Text)-import qualified Data.Text                  as T-import           Network.URI                hiding (path)-import           Prelude                    hiding (abs, lookup)-import           Safe-import           Text.XML-import           Text.XML.Cursor--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Data.List (find)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Network.URI hiding (path)+import Prelude hiding (abs, lookup)+import Safe+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Internal-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Internal+import Codec.Xlsx.Writer.Internal  data Relationship = Relationship     { relType   :: Text     , relTarget :: FilePath-    } deriving (Show, Eq)+    } deriving (Eq, Show, Generic)  -- | Describes relationships according to Open Packaging Convention --@@ -34,7 +31,7 @@ -- Conventions newtype Relationships = Relationships     { relMap :: Map RefId Relationship-    } deriving (Show, Eq)+    } deriving (Eq, Show, Generic)  fromList :: [(RefId, Relationship)] -> Relationships fromList = Relationships . Map.fromList
src/Codec/Xlsx/Types/Internal/SharedStringTable.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal.SharedStringTable (     -- * Main types     SharedStringTable(..)@@ -10,22 +11,22 @@   , sstEmpty   ) where -import           Control.Monad--import qualified Data.Map                   as Map-import           Data.Maybe                 (mapMaybe)-import qualified Data.Set                   as Set-import           Data.Text                  (Text)-import           Data.Vector                (Vector)-import qualified Data.Vector                as V-import           Numeric.Search.Range       (searchFromTo)-import           Safe                       (fromJustNote)-import           Text.XML-import           Text.XML.Cursor+import Control.Monad+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Vector (Vector)+import qualified Data.Vector as V+import GHC.Generics (Generic)+import Numeric.Search.Range (searchFromTo)+import Safe (fromJustNote)+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types+import Codec.Xlsx.Writer.Internal  -- | Shared string table --@@ -36,7 +37,7 @@ -- reading and writing the repetitive information once. -- -- Relevant parts of the EMCA standard (2nd edition, part 1,--- <http://www.ecma-international.org/publications/standards/Ecma-376.htm>),+-- <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): --@@ -47,7 +48,7 @@ newtype SharedStringTable = SharedStringTable {     sstTable :: Vector XlsxText   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)  sstEmpty :: SharedStringTable sstEmpty = SharedStringTable V.empty@@ -81,7 +82,7 @@ instance FromCursor SharedStringTable where   fromCursor cur = do     let-      items = cur $/ element (n_ "si") >=> fromCursor+      items = cur $/ element (addSmlNamespace "si") >=> fromCursor     return (SharedStringTable (V.fromList items))  {-------------------------------------------------------------------------------@@ -116,5 +117,5 @@     fromJustNote ("SST entry for " ++ show si ++ " not found") $     searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1) -sstItem :: SharedStringTable -> Int -> XlsxText-sstItem (SharedStringTable shared) = (V.!) shared+sstItem :: SharedStringTable -> Int -> Maybe XlsxText+sstItem (SharedStringTable shared) = (V.!?) shared
src/Codec/Xlsx/Types/PageSetup.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell   #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.PageSetup (     -- * Main types     PageSetup(..)---  , renderPageSetup     -- * Enumerations   , CellComments(..)   , PrintErrors(..)@@ -34,12 +34,14 @@   , pageSetupVerticalDpi   ) where -import Control.Lens (makeLenses)+import Codec.Xlsx.LensCompat (makeLenses)+import Control.DeepSeq (NFData) import Data.Default+import qualified Data.Map as Map import Data.Maybe (catMaybes) import Data.Text (Text)+import GHC.Generics (Generic) import Text.XML-import qualified Data.Map as Map  import Codec.Xlsx.Writer.Internal import Codec.Xlsx.Parser.Internal@@ -134,7 +136,8 @@     -- | Vertical print resolution of the device.   , _pageSetupVerticalDpi :: Maybe Int   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData PageSetup  {-------------------------------------------------------------------------------   Enumerations@@ -155,7 +158,8 @@      -- | Do not print cell comments   | CellCommentsNone-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData CellComments  -- | Print errors --@@ -173,14 +177,16 @@       -- | Display cell errors as @#N/A@    | PrintErrorsNA-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData PrintErrors  -- | Print orientation for this sheet data Orientation =     OrientationDefault   | OrientationLandscape   | OrientationPortrait-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData Orientation  -- | Specifies printed page order data PageOrder =@@ -189,7 +195,8 @@      -- | Order pages horizontally first, then move vertically   | PageOrderOverThenDown-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData PageOrder  -- | Paper size data PaperSize =@@ -259,7 +266,8 @@   | EnvelopeInvite               -- ^ Invite envelope (220 mm by 220 mm)   | EnvelopeItaly                -- ^ Italy envelope (110 mm by 230 mm)   | EnvelopeMonarch              -- ^ Monarch envelope (3.875 in. by 7.5 in.).-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData PaperSize  {-------------------------------------------------------------------------------   Default instances@@ -298,10 +306,6 @@   Rendering -------------------------------------------------------------------------------} ----- | Render page setup---renderPageSetup :: PageSetup -> RawPageSetup---renderPageSetup = RawPageSetup . NodeElement . toElement "pageSetup"- -- | See @CT_PageSetup@, p. 3922 instance ToElement PageSetup where   toElement nm PageSetup{..} = Element {@@ -450,6 +454,30 @@       _pageSetupId                  <- maybeAttribute "id" cur       return PageSetup{..} +instance FromXenoNode PageSetup where+  fromXenoNode root =+    parseAttributes root $ do+      _pageSetupPaperSize <- maybeAttr "paperSize"+      _pageSetupPaperHeight <- maybeAttr "paperHeight"+      _pageSetupPaperWidth <- maybeAttr "paperWidth"+      _pageSetupScale <- maybeAttr "scale"+      _pageSetupFirstPageNumber <- maybeAttr "firstPageNumber"+      _pageSetupFitToWidth <- maybeAttr "fitToWidth"+      _pageSetupFitToHeight <- maybeAttr "fitToHeight"+      _pageSetupPageOrder <- maybeAttr "pageOrder"+      _pageSetupOrientation <- maybeAttr "orientation"+      _pageSetupUsePrinterDefaults <- maybeAttr "usePrinterDefaults"+      _pageSetupBlackAndWhite <- maybeAttr "blackAndWhite"+      _pageSetupDraft <- maybeAttr "draft"+      _pageSetupCellComments <- maybeAttr "cellComments"+      _pageSetupUseFirstPageNumber <- maybeAttr "useFirstPageNumber"+      _pageSetupErrors <- maybeAttr "errors"+      _pageSetupHorizontalDpi <- maybeAttr "horizontalDpi"+      _pageSetupVerticalDpi <- maybeAttr "verticalDpi"+      _pageSetupCopies <- maybeAttr "copies"+      _pageSetupId <- maybeAttr "id"+      return PageSetup {..}+ -- | See @paperSize@ (attribute of @pageSetup@), p. 1659 instance FromAttrVal PaperSize where     fromAttrVal "1"  = readSuccess PaperLetter@@ -520,12 +548,86 @@     fromAttrVal "68" = readSuccess PaperA3ExtraTransverse     fromAttrVal t    = invalidText "PaperSize" t +instance FromAttrBs PaperSize where+    fromAttrBs "1"  = return PaperLetter+    fromAttrBs "2"  = return PaperLetterSmall+    fromAttrBs "3"  = return PaperTabloid+    fromAttrBs "4"  = return PaperLedger+    fromAttrBs "5"  = return PaperLegal+    fromAttrBs "6"  = return PaperStatement+    fromAttrBs "7"  = return PaperExecutive+    fromAttrBs "8"  = return PaperA3+    fromAttrBs "9"  = return PaperA4+    fromAttrBs "10" = return PaperA4Small+    fromAttrBs "11" = return PaperA5+    fromAttrBs "12" = return PaperB4+    fromAttrBs "13" = return PaperB5+    fromAttrBs "14" = return PaperFolio+    fromAttrBs "15" = return PaperQuarto+    fromAttrBs "16" = return PaperStandard10_14+    fromAttrBs "17" = return PaperStandard11_17+    fromAttrBs "18" = return PaperNote+    fromAttrBs "19" = return Envelope9+    fromAttrBs "20" = return Envelope10+    fromAttrBs "21" = return Envelope11+    fromAttrBs "22" = return Envelope12+    fromAttrBs "23" = return Envelope14+    fromAttrBs "24" = return PaperC+    fromAttrBs "25" = return PaperD+    fromAttrBs "26" = return PaperE+    fromAttrBs "27" = return EnvelopeDL+    fromAttrBs "28" = return EnvelopeC5+    fromAttrBs "29" = return EnvelopeC3+    fromAttrBs "30" = return EnvelopeC4+    fromAttrBs "31" = return EnvelopeC6+    fromAttrBs "32" = return EnvelopeC65+    fromAttrBs "33" = return EnvelopeB4+    fromAttrBs "34" = return EnvelopeB5+    fromAttrBs "35" = return EnvelopeB6+    fromAttrBs "36" = return EnvelopeItaly+    fromAttrBs "37" = return EnvelopeMonarch+    fromAttrBs "38" = return Envelope6_3_4+    fromAttrBs "39" = return PaperFanfoldUsStandard+    fromAttrBs "40" = return PaperFanfoldGermanStandard+    fromAttrBs "41" = return PaperFanfoldGermanLegal+    fromAttrBs "42" = return PaperIsoB4+    fromAttrBs "43" = return PaperJapaneseDoublePostcard+    fromAttrBs "44" = return PaperStandard9_11+    fromAttrBs "45" = return PaperStandard10_11+    fromAttrBs "46" = return PaperStandard15_11+    fromAttrBs "47" = return EnvelopeInvite+    fromAttrBs "50" = return PaperLetterExtra+    fromAttrBs "51" = return PaperLegalExtra+    fromAttrBs "52" = return PaperTabloidExtra+    fromAttrBs "53" = return PaperA4Extra+    fromAttrBs "54" = return PaperLetterTransverse+    fromAttrBs "55" = return PaperA4Transverse+    fromAttrBs "56" = return PaperLetterExtraTransverse+    fromAttrBs "57" = return PaperSuperA+    fromAttrBs "58" = return PaperSuperB+    fromAttrBs "59" = return PaperLetterPlus+    fromAttrBs "60" = return PaperA4Plus+    fromAttrBs "61" = return PaperA5Transverse+    fromAttrBs "62" = return PaperJisB5Transverse+    fromAttrBs "63" = return PaperA3Extra+    fromAttrBs "64" = return PaperA5Extra+    fromAttrBs "65" = return PaperIsoB5Extra+    fromAttrBs "66" = return PaperA2+    fromAttrBs "67" = return PaperA3Transverse+    fromAttrBs "68" = return PaperA3ExtraTransverse+    fromAttrBs x    = unexpectedAttrBs "PaperSize" x+ -- | See @ST_PageOrder@, p. 3923 instance FromAttrVal PageOrder where     fromAttrVal "downThenOver" = readSuccess PageOrderDownThenOver     fromAttrVal "overThenDown" = readSuccess PageOrderOverThenDown     fromAttrVal t              = invalidText "PageOrder" t +instance FromAttrBs PageOrder where+    fromAttrBs "downThenOver" = return PageOrderDownThenOver+    fromAttrBs "overThenDown" = return PageOrderOverThenDown+    fromAttrBs x              = unexpectedAttrBs "PageOrder" x+ -- | See @ST_CellComments@, p. 3923 instance FromAttrVal CellComments where     fromAttrVal "none"        = readSuccess CellCommentsNone@@ -533,6 +635,12 @@     fromAttrVal "atEnd"       = readSuccess CellCommentsAtEnd     fromAttrVal t             = invalidText "CellComments" t +instance FromAttrBs CellComments where+    fromAttrBs "none"        = return CellCommentsNone+    fromAttrBs "asDisplayed" = return CellCommentsAsDisplayed+    fromAttrBs "atEnd"       = return CellCommentsAtEnd+    fromAttrBs x             = unexpectedAttrBs "CellComments" x+ -- | See @ST_PrintError@, p. 3923 instance FromAttrVal PrintErrors where     fromAttrVal "displayed" = readSuccess PrintErrorsDisplayed@@ -541,9 +649,22 @@     fromAttrVal "NA"        = readSuccess PrintErrorsNA     fromAttrVal t           = invalidText "PrintErrors" t +instance FromAttrBs PrintErrors where+    fromAttrBs "displayed" = return PrintErrorsDisplayed+    fromAttrBs "blank"     = return PrintErrorsBlank+    fromAttrBs "dash"      = return PrintErrorsDash+    fromAttrBs "NA"        = return PrintErrorsNA+    fromAttrBs x           = unexpectedAttrBs "PrintErrors" x+ -- | See @ST_Orientation@, p. 3923 instance FromAttrVal Orientation where     fromAttrVal "default"   = readSuccess OrientationDefault     fromAttrVal "portrait"  = readSuccess OrientationPortrait     fromAttrVal "landscape" = readSuccess OrientationLandscape     fromAttrVal t           = invalidText "Orientation" t++instance FromAttrBs Orientation where+    fromAttrBs "default"   = return OrientationDefault+    fromAttrBs "portrait"  = return OrientationPortrait+    fromAttrBs "landscape" = return OrientationLandscape+    fromAttrBs x           = unexpectedAttrBs "Orientation" x
src/Codec/Xlsx/Types/PivotTable.hs view
@@ -1,16 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.PivotTable   ( PivotTable(..)   , PivotFieldName(..)   , PivotFieldInfo(..)+  , FieldSortType(..)   , PositionedField(..)   , DataField(..)   , ConsolidateFunction(..)   ) where  import Control.Arrow (first)+import Control.DeepSeq (NFData) import Data.Text (Text)+import GHC.Generics (Generic)  import Codec.Xlsx.Types.Common import Codec.Xlsx.Parser.Internal@@ -30,27 +34,44 @@   , _pvtLocation :: CellRef   , _pvtSrcSheet :: Text   , _pvtSrcRef :: Range-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData PivotTable  data PivotFieldInfo = PivotFieldInfo-  { _pfiName :: PivotFieldName+  { _pfiName :: Maybe PivotFieldName   , _pfiOutline :: Bool-  } deriving (Eq, Show)+  , _pfiSortType :: FieldSortType+  , _pfiHiddenItems :: [CellValue]+  } deriving (Eq, Show, Generic)+instance NFData PivotFieldInfo +-- | Sort orders that can be applied to fields in a PivotTable+--+-- See 18.18.28 "ST_FieldSortType (Field Sort Type)" (p. 2454)+data FieldSortType+  = FieldSortAscending+  | FieldSortDescending+  | FieldSortManual+  deriving (Eq, Ord, Show, Generic)+instance NFData FieldSortType+ newtype PivotFieldName =   PivotFieldName Text-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic)+instance NFData PivotFieldName  data PositionedField   = DataPosition   | FieldPosition PivotFieldName-  deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show, Generic)+instance NFData PositionedField  data DataField = DataField   { _dfField :: PivotFieldName   , _dfName :: Text   , _dfFunction :: ConsolidateFunction-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic)+instance NFData DataField  -- | Data consolidation functions specified by the user and used to -- consolidate ranges of data@@ -87,7 +108,8 @@   | ConsolidateVarP     -- ^ The variance of a population, where the population is all of     -- the data to be summarized.-  deriving (Eq, Show)+  deriving (Eq, Show, Generic)+instance NFData ConsolidateFunction  {-------------------------------------------------------------------------------   Rendering@@ -109,6 +131,11 @@ instance ToAttrVal PivotFieldName where   toAttrVal (PivotFieldName n) = toAttrVal n +instance ToAttrVal FieldSortType where+  toAttrVal FieldSortManual = "manual"+  toAttrVal FieldSortAscending = "ascending"+  toAttrVal FieldSortDescending = "descending"+ {-------------------------------------------------------------------------------   Parsing -------------------------------------------------------------------------------}@@ -129,3 +156,9 @@  instance FromAttrVal PivotFieldName where   fromAttrVal = fmap (first PivotFieldName) . fromAttrVal++instance FromAttrVal FieldSortType where+  fromAttrVal "manual" = readSuccess FieldSortManual+  fromAttrVal "ascending" = readSuccess FieldSortAscending+  fromAttrVal "descending" = readSuccess FieldSortDescending+  fromAttrVal t = invalidText "FieldSortType" t
src/Codec/Xlsx/Types/PivotTable/Internal.hs view
@@ -1,16 +1,102 @@-module Codec.Xlsx.Types.PivotTable.Internal (-   CacheId(..)-) where+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-}+module Codec.Xlsx.Types.PivotTable.Internal+  ( CacheId(..)+  , CacheField(..)+  , CacheRecordValue(..)+  , CacheRecord+  , recordValueFromNode+  ) where +import GHC.Generics (Generic)+ import Control.Arrow (first)+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Text.XML+import Text.XML.Cursor  import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.PivotTable+import Codec.Xlsx.Writer.Internal -newtype CacheId = CacheId Int deriving Eq+newtype CacheId = CacheId Int deriving (Eq, Generic) +data CacheField = CacheField+  { cfName :: PivotFieldName+  , cfItems :: [CellValue]+  } deriving (Eq, Show, Generic)++data CacheRecordValue+  = CacheText Text+  | CacheNumber Double+  | CacheIndex Int+  deriving (Eq, Show, Generic)++type CacheRecord = [CacheRecordValue]+ {-------------------------------------------------------------------------------   Parsing -------------------------------------------------------------------------------}  instance FromAttrVal CacheId where   fromAttrVal = fmap (first CacheId) . fromAttrVal++instance FromCursor CacheField where+  fromCursor cur = do+    cfName <- fromAttribute "name" cur+    let cfItems =+          cur $/ element (addSmlNamespace "sharedItems") &/ anyElement >=>+          cellValueFromNode . node+    return CacheField {..}++cellValueFromNode :: Node -> [CellValue]+cellValueFromNode n+  | n `nodeElNameIs` (addSmlNamespace "s") = CellText <$> attributeV+  | n `nodeElNameIs` (addSmlNamespace "n") = CellDouble <$> attributeV+  | otherwise = fail "no matching shared item"+  where+    cur = fromNode n+    attributeV :: FromAttrVal a => [a]+    attributeV = fromAttribute "v" cur++recordValueFromNode :: Node -> [CacheRecordValue]+recordValueFromNode n+  | n `nodeElNameIs` (addSmlNamespace "s") = CacheText <$> attributeV+  | n `nodeElNameIs` (addSmlNamespace "n") = CacheNumber <$> attributeV+  | n `nodeElNameIs` (addSmlNamespace "x") = CacheIndex <$> attributeV+  | otherwise = fail "not valid cache record value"+  where+    cur = fromNode n+    attributeV :: FromAttrVal a => [a]+    attributeV = fromAttribute "v" cur++{-------------------------------------------------------------------------------+  Rendering+-------------------------------------------------------------------------------}++instance ToElement CacheField where+  toElement nm CacheField {..} =+    elementList nm ["name" .= cfName] [sharedItems]+    where+      -- Excel doesn't like embedded integer sharedImes in cache+      sharedItems = elementList "sharedItems" typeAttrs $+        if containsString then map cvToItem cfItems else []+      cvToItem (CellText t) = leafElement "s" ["v" .= t]+      cvToItem (CellDouble n) = leafElement "n" ["v" .= n]+      cvToItem _ = error "Only string and number values are currently supported"+      typeAttrs =+        catMaybes+          [ "containsNumber" .=? justTrue containsNumber+          , "containsString" .=? justFalse containsString+          , "containsSemiMixedTypes" .=? justFalse containsString+          , "containsMixedTypes" .=? justTrue (containsNumber && containsString)+          ]+      containsNumber = any isNumber cfItems+      isNumber (CellDouble _) = True+      isNumber _ = False+      containsString = any isString cfItems+      isString (CellText _) = True+      isString _ = False
+ 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
@@ -1,7 +1,8 @@-{-# LANGUAGE CPP                #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE RecordWildCards    #-} {-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.RichText (     -- * Main types     RichTextRun(..)@@ -29,8 +30,11 @@   , runPropertiesVertAlign   ) where -import Control.Lens hiding (element)+import GHC.Generics (Generic)++import Codec.Xlsx.LensCompat (makeLenses) import Control.Monad+import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes) import Data.Text (Text)@@ -42,11 +46,6 @@ import Codec.Xlsx.Types.StyleSheet import Codec.Xlsx.Writer.Internal -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-import Data.Monoid-#endif- -- | Rich Text Run -- -- This element represents a run of rich text. A rich text run is a region of@@ -66,8 +65,10 @@     -- Section 18.4.12, "t (Text)" (p. 1727)   , _richTextRunText :: Text   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData RichTextRun+ -- | Run properties -- -- Section 18.4.7, "rPr (Run Properties)" (p. 1725)@@ -171,8 +172,10 @@     -- Section 18.4.14, "vertAlign (Vertical Alignment)" (p. 1728)   , _runPropertiesVertAlign :: Maybe FontVerticalAlignment   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData RunProperties+ {-------------------------------------------------------------------------------   Lenses -------------------------------------------------------------------------------}@@ -242,7 +245,8 @@         , elementValue "extend"    <$> _runPropertiesExtend         , toElement    "color"     <$> _runPropertiesColor         , elementValue "sz"        <$> _runPropertiesSize-        , elementValue "u"         <$> _runPropertiesUnderline+        , elementValueDef "u" FontUnderlineSingle+                                   <$> _runPropertiesUnderline         , elementValue "vertAlign" <$> _runPropertiesVertAlign         , elementValue "scheme"    <$> _runPropertiesScheme         ]@@ -255,33 +259,84 @@ -- | See @CT_RElt@, p. 3903 instance FromCursor RichTextRun where   fromCursor cur = do-    _richTextRunText <- cur $/ element (n_ "t") &/ content-    _richTextRunProperties <- maybeFromElement (n_ "rPr") cur+    _richTextRunText <- cur $/ element (addSmlNamespace "t") &/ content+    _richTextRunProperties <- maybeFromElement (addSmlNamespace "rPr") cur     return RichTextRun{..} +instance FromXenoNode RichTextRun where+  fromXenoNode root = do+    (prNode, tNode) <- collectChildren root $ (,) <$> maybeChild "rPr" <*> requireChild "t"+    _richTextRunProperties <- mapM fromXenoNode prNode+    _richTextRunText <- contentX tNode+    return RichTextRun {..}+ -- | See @CT_RPrElt@, p. 3903 instance FromCursor RunProperties where   fromCursor cur = do-    _runPropertiesFont          <- maybeElementValue (n_ "rFont") cur-    _runPropertiesCharset       <- maybeElementValue (n_ "charset") cur-    _runPropertiesFontFamily    <- maybeElementValue (n_ "family") cur-    _runPropertiesBold          <- maybeElementValue (n_ "b") cur-    _runPropertiesItalic        <- maybeElementValue (n_ "i") cur-    _runPropertiesStrikeThrough <- maybeElementValue (n_ "strike") cur-    _runPropertiesOutline       <- maybeElementValue (n_ "outline") cur-    _runPropertiesShadow        <- maybeElementValue (n_ "shadow") cur-    _runPropertiesCondense      <- maybeElementValue (n_ "condense") cur-    _runPropertiesExtend        <- maybeElementValue (n_ "extend") cur-    _runPropertiesColor         <- maybeFromElement  (n_ "color") cur-    _runPropertiesSize          <- maybeElementValue (n_ "sz") cur-    _runPropertiesUnderline     <- maybeElementValue (n_ "u") cur-    _runPropertiesVertAlign     <- maybeElementValue (n_ "vertAlign") cur-    _runPropertiesScheme        <- maybeElementValue (n_ "scheme") cur+    _runPropertiesFont          <- maybeElementValue (addSmlNamespace "rFont") cur+    _runPropertiesCharset       <- maybeElementValue (addSmlNamespace "charset") cur+    _runPropertiesFontFamily    <- maybeElementValue (addSmlNamespace "family") cur+    _runPropertiesBold          <- maybeBoolElementValue (addSmlNamespace "b") cur+    _runPropertiesItalic        <- maybeBoolElementValue (addSmlNamespace "i") cur+    _runPropertiesStrikeThrough <- maybeBoolElementValue (addSmlNamespace "strike") cur+    _runPropertiesOutline       <- maybeBoolElementValue (addSmlNamespace "outline") cur+    _runPropertiesShadow        <- maybeBoolElementValue (addSmlNamespace "shadow") cur+    _runPropertiesCondense      <- maybeBoolElementValue (addSmlNamespace "condense") cur+    _runPropertiesExtend        <- maybeBoolElementValue (addSmlNamespace "extend") cur+    _runPropertiesColor         <- maybeFromElement  (addSmlNamespace "color") cur+    _runPropertiesSize          <- maybeElementValue (addSmlNamespace "sz") cur+    _runPropertiesUnderline     <- maybeElementValueDef (addSmlNamespace "u") FontUnderlineSingle cur+    _runPropertiesVertAlign     <- maybeElementValue (addSmlNamespace "vertAlign") cur+    _runPropertiesScheme        <- maybeElementValue (addSmlNamespace "scheme") cur     return RunProperties{..} +instance FromXenoNode RunProperties where+  fromXenoNode root = collectChildren root $ do+    _runPropertiesFont          <- maybeElementVal "rFont"+    _runPropertiesCharset       <- maybeElementVal "charset"+    _runPropertiesFontFamily    <- maybeElementVal "family"+    _runPropertiesBold          <- maybeElementVal "b"+    _runPropertiesItalic        <- maybeElementVal "i"+    _runPropertiesStrikeThrough <- maybeElementVal "strike"+    _runPropertiesOutline       <- maybeElementVal "outline"+    _runPropertiesShadow        <- maybeElementVal "shadow"+    _runPropertiesCondense      <- maybeElementVal "condense"+    _runPropertiesExtend        <- maybeElementVal "extend"+    _runPropertiesColor         <- maybeFromChild "color"+    _runPropertiesSize          <- maybeElementVal "sz"+    _runPropertiesUnderline     <- maybeElementVal "u"+    _runPropertiesVertAlign     <- maybeElementVal "vertAlign"+    _runPropertiesScheme        <- maybeElementVal "scheme"+    return RunProperties{..}+ {-------------------------------------------------------------------------------   Applying formatting -------------------------------------------------------------------------------}++#if (MIN_VERSION_base(4,11,0))+instance Semigroup RunProperties where+  a <> b = RunProperties {+      _runPropertiesBold          = override _runPropertiesBold+    , _runPropertiesCharset       = override _runPropertiesCharset+    , _runPropertiesColor         = override _runPropertiesColor+    , _runPropertiesCondense      = override _runPropertiesCondense+    , _runPropertiesExtend        = override _runPropertiesExtend+    , _runPropertiesFontFamily    = override _runPropertiesFontFamily+    , _runPropertiesItalic        = override _runPropertiesItalic+    , _runPropertiesOutline       = override _runPropertiesOutline+    , _runPropertiesFont          = override _runPropertiesFont+    , _runPropertiesScheme        = override _runPropertiesScheme+    , _runPropertiesShadow        = override _runPropertiesShadow+    , _runPropertiesStrikeThrough = override _runPropertiesStrikeThrough+    , _runPropertiesSize          = override _runPropertiesSize+    , _runPropertiesUnderline     = override _runPropertiesUnderline+    , _runPropertiesVertAlign     = override _runPropertiesVertAlign+    }+    where+      override :: (RunProperties -> Maybe x) -> Maybe x+      override f = f b `mplus` f a++#endif  -- | The 'Monoid' instance for 'RunProperties' is biased: later properties -- override earlier ones.
src/Codec/Xlsx/Types/SheetViews.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.SheetViews (     -- * Structured type to construct 'SheetViews'     SheetView(..)@@ -46,17 +46,16 @@   , paneYSplit   ) where -import Control.Lens (makeLenses)+import GHC.Generics (Generic)++import Codec.Xlsx.LensCompat (makeLenses)+import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes, maybeToList, listToMaybe) import Text.XML import Text.XML.Cursor import qualified Data.Map  as Map -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ()-#endif- import Codec.Xlsx.Types.Common import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Writer.Internal@@ -176,7 +175,8 @@     -- Minimum of 0, maximum of 4 elements   , _sheetViewSelection :: [Selection]   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData SheetView  -- | Worksheet view selection. --@@ -199,7 +199,8 @@     -- | Range of the selection. Can be non-contiguous set of ranges.   , _selectionSqref :: Maybe SqRef   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData Selection  -- | Worksheet view pane --@@ -226,7 +227,8 @@     -- the left pane.   , _paneYSplit :: Maybe Double   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData Pane  {-------------------------------------------------------------------------------   Enumerations@@ -244,7 +246,8 @@      -- | Page layout view   | SheetViewTypePageLayout-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData SheetViewType  -- | Pane type --@@ -277,7 +280,8 @@     -- dividing the pane into right and left regions. In that case, this value     -- specifies the right pane.   | PaneTypeTopRight-  deriving (Eq, Show, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData PaneType  -- | State of the sheet's pane. --@@ -295,7 +299,8 @@     -- | Panes are split, but not frozen. In this state, the split bars are     -- adjustable by the user.   | PaneStateSplit-  deriving (Eq, Show, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData PaneState  {-------------------------------------------------------------------------------   Lenses@@ -461,10 +466,36 @@     _sheetViewZoomScaleSheetLayoutView <- maybeAttribute "zoomScaleSheetLayoutView" cur     _sheetViewZoomScalePageLayoutView  <- maybeAttribute "zoomScalePageLayoutView" cur     _sheetViewWorkbookViewId           <- fromAttribute "workbookViewId" cur-    let _sheetViewPane = listToMaybe $ cur $/ element (n_ "pane") >=> fromCursor-        _sheetViewSelection = cur $/ element (n_ "selection") >=> fromCursor+    let _sheetViewPane = listToMaybe $ cur $/ element (addSmlNamespace "pane") >=> fromCursor+        _sheetViewSelection = cur $/ element (addSmlNamespace "selection") >=> fromCursor     return SheetView{..} +instance FromXenoNode SheetView where+  fromXenoNode root = parseAttributes root $ do+    _sheetViewWindowProtection         <- maybeAttr "windowProtection"+    _sheetViewShowFormulas             <- maybeAttr "showFormulas"+    _sheetViewShowGridLines            <- maybeAttr "showGridLines"+    _sheetViewShowRowColHeaders        <- maybeAttr "showRowColHeaders"+    _sheetViewShowZeros                <- maybeAttr "showZeros"+    _sheetViewRightToLeft              <- maybeAttr "rightToLeft"+    _sheetViewTabSelected              <- maybeAttr "tabSelected"+    _sheetViewShowRuler                <- maybeAttr "showRuler"+    _sheetViewShowOutlineSymbols       <- maybeAttr "showOutlineSymbols"+    _sheetViewDefaultGridColor         <- maybeAttr "defaultGridColor"+    _sheetViewShowWhiteSpace           <- maybeAttr "showWhiteSpace"+    _sheetViewType                     <- maybeAttr "view"+    _sheetViewTopLeftCell              <- maybeAttr "topLeftCell"+    _sheetViewColorId                  <- maybeAttr "colorId"+    _sheetViewZoomScale                <- maybeAttr "zoomScale"+    _sheetViewZoomScaleNormal          <- maybeAttr "zoomScaleNormal"+    _sheetViewZoomScaleSheetLayoutView <- maybeAttr "zoomScaleSheetLayoutView"+    _sheetViewZoomScalePageLayoutView  <- maybeAttr "zoomScalePageLayoutView"+    _sheetViewWorkbookViewId           <- fromAttr "workbookViewId"+    (_sheetViewPane, _sheetViewSelection) <-+      toAttrParser . collectChildren root $+      (,) <$> maybeFromChild "pane" <*> fromChildList "selection"+    return SheetView {..}+ -- | See @CT_Pane@, p. 3913 instance FromCursor Pane where   fromCursor cur = do@@ -475,6 +506,16 @@     _paneState       <- maybeAttribute "state" cur     return Pane{..} +instance FromXenoNode Pane where+  fromXenoNode root =+    parseAttributes root $ do+      _paneXSplit <- maybeAttr "xSplit"+      _paneYSplit <- maybeAttr "ySplit"+      _paneTopLeftCell <- maybeAttr "topLeftCell"+      _paneActivePane <- maybeAttr "activePane"+      _paneState <- maybeAttr "state"+      return Pane {..}+ -- | See @CT_Selection@, p. 3914 instance FromCursor Selection where   fromCursor cur = do@@ -484,6 +525,15 @@     _selectionSqref        <- maybeAttribute "sqref" cur     return Selection{..} +instance FromXenoNode Selection where+  fromXenoNode root =+    parseAttributes root $ do+      _selectionPane <- maybeAttr "pane"+      _selectionActiveCell <- maybeAttr "activeCell"+      _selectionActiveCellId <- maybeAttr "activeCellId"+      _selectionSqref <- maybeAttr "sqref"+      return Selection {..}+ -- | See @ST_SheetViewType@, p. 3913 instance FromAttrVal SheetViewType where   fromAttrVal "normal"           = readSuccess SheetViewTypeNormal@@ -491,6 +541,12 @@   fromAttrVal "pageLayout"       = readSuccess SheetViewTypePageLayout   fromAttrVal t                  = invalidText "SheetViewType" t +instance FromAttrBs SheetViewType where+  fromAttrBs "normal"           = return SheetViewTypeNormal+  fromAttrBs "pageBreakPreview" = return SheetViewTypePageBreakPreview+  fromAttrBs "pageLayout"       = return SheetViewTypePageLayout+  fromAttrBs x                  = unexpectedAttrBs "SheetViewType" x+ -- | See @ST_Pane@, p. 3914 instance FromAttrVal PaneType where   fromAttrVal "bottomRight" = readSuccess PaneTypeBottomRight@@ -499,9 +555,22 @@   fromAttrVal "topLeft"     = readSuccess PaneTypeTopLeft   fromAttrVal t             = invalidText "PaneType" t +instance FromAttrBs PaneType where+  fromAttrBs "bottomRight" = return PaneTypeBottomRight+  fromAttrBs "topRight"    = return PaneTypeTopRight+  fromAttrBs "bottomLeft"  = return PaneTypeBottomLeft+  fromAttrBs "topLeft"     = return PaneTypeTopLeft+  fromAttrBs x             = unexpectedAttrBs "PaneType" x+ -- | See @ST_PaneState@, p. 3929 instance FromAttrVal PaneState where   fromAttrVal "split"       = readSuccess PaneStateSplit   fromAttrVal "frozen"      = readSuccess PaneStateFrozen   fromAttrVal "frozenSplit" = readSuccess PaneStateFrozenSplit   fromAttrVal t             = invalidText "PaneState" t++instance FromAttrBs PaneState where+  fromAttrBs "split"       = return PaneStateSplit+  fromAttrBs "frozen"      = return PaneStateFrozen+  fromAttrBs "frozenSplit" = return PaneStateFrozenSplit+  fromAttrBs x             = unexpectedAttrBs "PaneState" x
src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE DeriveGeneric #-} -- | Support for writing (but not reading) style sheets module Codec.Xlsx.Types.StyleSheet (     -- * The main two types@@ -18,8 +18,9 @@   , FillPattern(..)   , Font(..)   , NumberFormat(..)+  , NumFmt(..)   , ImpliedNumberFormat (..)-  , NumFmt+  , FormatCode   , Protection(..)     -- * Supporting enumerations   , CellHorizontalAlignment(..)@@ -60,6 +61,7 @@   , dxfBorder   , dxfFill   , dxfFont+  , dxfNumFmt   , dxfProtection     -- ** Alignment   , alignmentHorizontal@@ -126,26 +128,21 @@   , firstUserNumFmtId   ) where -import           Control.Lens                         hiding (element, elements,-                                                       (.=))-import           Data.Default-import           Data.Map.Strict                      (Map)-import qualified Data.Map.Strict                      as M-import           Data.Maybe                           (catMaybes)-import           Data.Monoid-import           Data.Text                            (Text)-import qualified Data.Text                            as T-import           Text.XML-import           Text.XML.Cursor---#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import Codec.Xlsx.LensCompat (makeLenses, (&), (.~))+import Control.DeepSeq (NFData)+import Data.Default+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (catMaybes, maybeToList)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Types.Internal.NumFmtPair-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Writer.Internal  {-------------------------------------------------------------------------------   The main types@@ -154,15 +151,15 @@ -- | StyleSheet for an XML document -- -- Relevant parts of the EMCA standard (4th edition, part 1,--- <http://www.ecma-international.org/publications/standards/Ecma-376.htm>),+-- <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)+-- * Chapter 12, \"SpreadsheetML\" (p. 74) --   In particular Section 12.3.20, "Styles Part" (p. 104)--- * Chapter 18, "SpreadsheetML Reference Material" (p. 1528)---   In particular Section 18.8, "Styles" (p. 1754) and Section 18.8.39---   "styleSheet" (Style Sheet)" (p. 1796); it is the latter section that+-- * Chapter 18, \"SpreadsheetML Reference Material\" (p. 1528)+--   In particular Section 18.8, \"Styles\" (p. 1754) and Section 18.8.39+--   \"styleSheet\" (Style Sheet)\" (p. 1796); it is the latter section that --   specifies the top-level style sheet format. -- -- TODO: the following child elements:@@ -173,7 +170,13 @@ -- * extLst -- * tableStyles ----- NOTE: You will probably want to base your style sheet on 'minimalStyleSheet'.+-- NOTE: Because of undocumented Excel requirements you will probably want to base+-- your style sheet on 'minimalStyleSheet' (a proper style sheet should have some+-- contents for details see+-- <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'@@ -223,14 +226,16 @@     --     -- Section 18.8.15, "dxfs (Formats)" (p. 1765) -    , _styleSheetNumFmts :: Map Int NumFmt+    , _styleSheetNumFmts :: Map Int FormatCode     -- ^ Number formats     --     -- This element contains custom number formats defined in this style sheet     --     -- Section 18.8.31, "numFmts (Number Formats)" (p. 1784)-    } deriving (Eq, Ord, Show)+    } deriving (Eq, Ord, Show, Generic) +instance NFData StyleSheet+ -- | Cell formatting -- -- TODO: The @extLst@ field is currently unsupported.@@ -316,8 +321,10 @@     -- not take effect unless the sheet has been protected.   , _cellXfProtection        :: Maybe Protection   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData CellXf+ {-------------------------------------------------------------------------------   Supporting record types -------------------------------------------------------------------------------}@@ -365,8 +372,10 @@     -- within the cell.   , _alignmentWrapText        :: Maybe Bool   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData Alignment+ -- | Expresses a single set of cell border formats (left, right, top, bottom, -- diagonal). Color is optional. When missing, 'automatic' is implied. --@@ -423,16 +432,20 @@     -- | Vertical inner border   , _borderVertical     :: Maybe BorderStyle   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData Border+ -- | Border style -- See @CT_BorderPr@ (p. 3934) data BorderStyle = BorderStyle {     _borderStyleColor :: Maybe Color   , _borderStyleLine  :: Maybe LineStyle   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData BorderStyle+ -- | One of the colors associated with the data bar or color scale. -- -- The 'indexed' attribute (used for backwards compatibility only) is not@@ -465,8 +478,10 @@     -- 100% darken and 1.0 means 100% lighten. Also, 0.0 means no change.   , _colorTint      :: Maybe Double   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData Color+ -- | This element specifies fill formatting. -- -- TODO: Gradient fills (18.8.4) are currently unsupported. If we add them,@@ -477,8 +492,10 @@ data Fill = Fill {     _fillPattern :: Maybe FillPattern   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData Fill+ -- | This element is used to specify cell fill information for pattern and solid -- color cell fills. For solid cell fills (no pattern), fgColor is used. For -- cell fills with patterns specified, then the cell fill color is specified by@@ -490,8 +507,10 @@   , _fillPatternFgColor :: Maybe Color   , _fillPatternType    :: Maybe PatternType   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData FillPattern+ -- | This element defines the properties for one of the fonts used in this -- workbook. --@@ -592,32 +611,56 @@     -- is available) accordingly.   , _fontVertAlign     :: Maybe FontVerticalAlignment   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData Font+ -- | A single dxf record, expressing incremental formatting to be applied. -- -- Section 18.8.14, "dxf (Formatting)" (p. 1765) data Dxf = Dxf     { _dxfFont       :: Maybe Font-    -- TODO: numFmt+      -- | It seems to be required that this number format entry is duplicated+      -- in '_styleSheetNumFmts' of the style sheet, though the spec says+      -- nothing explicitly about it.+    , _dxfNumFmt     :: Maybe NumFmt     , _dxfFill       :: Maybe Fill     , _dxfAlignment  :: Maybe Alignment     , _dxfBorder     :: Maybe Border     , _dxfProtection :: Maybe Protection     -- TODO: extList-    } deriving (Eq, Ord, Show)+    } deriving (Eq, Ord, Show, Generic) -type NumFmt = Text+instance NFData Dxf +-- | A number format code.+--+-- Section 18.8.30, "numFmt (Number Format)" (p. 1777)+type FormatCode = Text+ -- | This element specifies number format properties which indicate -- how to format and render the numeric value of a cell. ----- Section 18.2.30 "numFmt (Number Format)" (p. 1777)+-- Section 18.8.30 "numFmt (Number Format)" (p. 1777)+data NumFmt = NumFmt+  { _numFmtId :: Int+  , _numFmtCode :: FormatCode+  } deriving (Eq, Ord, Show, Generic)++instance NFData NumFmt++mkNumFmtPair :: NumFmt -> (Int, FormatCode)+mkNumFmtPair NumFmt{..} = (_numFmtId, _numFmtCode)++-- | This type gives a high-level version of representation of number format+-- used in 'Codec.Xlsx.Formatted.Format'. data NumberFormat     = StdNumberFormat ImpliedNumberFormat-    | UserNumberFormat NumFmt-    deriving (Eq, Ord, Show)+    | UserNumberFormat FormatCode+    deriving (Eq, Ord, Show, Generic) +instance NFData NumberFormat+ -- | Basic number format with predefined number of decimals -- as format code of number format in xlsx should be less than 255 characters -- number of decimals shouldn't be more than 253@@ -658,15 +701,17 @@   | NfThousandsNegativeParens         -- ^> 37 #,##0 ;(#,##0)   | NfThousandsNegativeRed            -- ^> 38 #,##0 ;[Red](#,##0)   | NfThousands2DecimalNegativeParens -- ^> 39 #,##0.00;(#,##0.00)-  | NfTousands2DecimalNEgativeRed     -- ^> 40 #,##0.00;[Red](#,##0.00)+  | NfThousands2DecimalNegativeRed    -- ^> 40 #,##0.00;[Red](#,##0.00)   | NfMmSs                            -- ^> 45 mm:ss   | NfOptHMmSs                        -- ^> 46 [h]:mm:ss   | NfMmSs1Decimal                    -- ^> 47 mmss.0   | NfExponent1Decimal                -- ^> 48 ##0.0E+0   | NfTextPlaceHolder                 -- ^> 49 @   | NfOtherImplied Int                -- ^ other (non local-neutral?) built-in format (id < 164)-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic) +instance NFData ImpliedNumberFormat+ stdNumberFormatId :: ImpliedNumberFormat -> Int stdNumberFormatId NfGeneral                         = 0 -- General stdNumberFormatId NfZero                            = 1 -- 0@@ -690,7 +735,7 @@ stdNumberFormatId NfThousandsNegativeParens         = 37 -- #,##0 ;(#,##0) stdNumberFormatId NfThousandsNegativeRed            = 38 -- #,##0 ;[Red](#,##0) stdNumberFormatId NfThousands2DecimalNegativeParens = 39 -- #,##0.00;(#,##0.00)-stdNumberFormatId NfTousands2DecimalNEgativeRed     = 40 -- #,##0.00;[Red](#,##0.00)+stdNumberFormatId NfThousands2DecimalNegativeRed    = 40 -- #,##0.00;[Red](#,##0.00) stdNumberFormatId NfMmSs                            = 45 -- mm:ss stdNumberFormatId NfOptHMmSs                        = 46 -- [h]:mm:ss stdNumberFormatId NfMmSs1Decimal                    = 47 -- mmss.0@@ -721,7 +766,7 @@ idToStdNumberFormat 37 = Just NfThousandsNegativeParens         -- #,##0 ;(#,##0) idToStdNumberFormat 38 = Just NfThousandsNegativeRed            -- #,##0 ;[Red](#,##0) idToStdNumberFormat 39 = Just NfThousands2DecimalNegativeParens -- #,##0.00;(#,##0.00)-idToStdNumberFormat 40 = Just NfTousands2DecimalNEgativeRed     -- #,##0.00;[Red](#,##0.00)+idToStdNumberFormat 40 = Just NfThousands2DecimalNegativeRed    -- #,##0.00;[Red](#,##0.00) idToStdNumberFormat 45 = Just NfMmSs                            -- mm:ss idToStdNumberFormat 46 = Just NfOptHMmSs                        -- [h]:mm:ss idToStdNumberFormat 47 = Just NfMmSs1Decimal                    -- mmss.0@@ -743,7 +788,8 @@     _protectionHidden :: Maybe Bool   , _protectionLocked :: Maybe Bool   }-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData Protection  {-------------------------------------------------------------------------------   Enumerations@@ -761,7 +807,8 @@   | CellHorizontalAlignmentJustify   | CellHorizontalAlignmentLeft   | CellHorizontalAlignmentRight-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData CellHorizontalAlignment  -- | Vertical alignment in cells --@@ -772,7 +819,8 @@   | CellVerticalAlignmentDistributed   | CellVerticalAlignmentJustify   | CellVerticalAlignmentTop-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData CellVerticalAlignment  -- | Font family --@@ -796,7 +844,8 @@      -- | Novelty font   | FontFamilyDecorative-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData FontFamily  -- | Font scheme --@@ -810,7 +859,8 @@      -- | This font is not a theme font.   | FontSchemeNone-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData FontScheme  -- | Font underline property --@@ -821,7 +871,8 @@   | FontUnderlineSingleAccounting   | FontUnderlineDoubleAccounting   | FontUnderlineNone-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData FontUnderline  -- | Vertical alignment --@@ -830,7 +881,8 @@     FontVerticalAlignmentBaseline   | FontVerticalAlignmentSubscript   | FontVerticalAlignmentSuperscript-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData FontVerticalAlignment  data LineStyle =     LineStyleDashDot@@ -847,7 +899,8 @@   | LineStyleSlantDashDot   | LineStyleThick   | LineStyleThin-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData LineStyle  -- | Indicates the style of fill pattern being used for a cell format. --@@ -872,7 +925,8 @@   | PatternTypeMediumGray   | PatternTypeNone   | PatternTypeSolid-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData PatternType  -- | Reading order --@@ -881,7 +935,8 @@     ReadingOrderContextDependent   | ReadingOrderLeftToRight   | ReadingOrderRightToLeft-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Show, Generic)+instance NFData ReadingOrder  {-------------------------------------------------------------------------------   Lenses@@ -982,6 +1037,7 @@ instance Default Dxf where     def = Dxf           { _dxfFont       = Nothing+          , _dxfNumFmt     = Nothing           , _dxfFill       = Nothing           , _dxfAlignment  = Nothing           , _dxfBorder     = Nothing@@ -1086,19 +1142,19 @@ instance ToElement StyleSheet where   toElement nm StyleSheet{..} = elementListSimple nm elements     where-      elements = [ countedElementList "numFmts" $ map (toElement "numFmt") numFmts-                 , countedElementList "fonts"   $ map (toElement "font")   _styleSheetFonts-                 , countedElementList "fills"   $ map (toElement "fill")   _styleSheetFills-                 , countedElementList "borders" $ map (toElement "border") _styleSheetBorders+      countedElementList' nm' xs = maybeToList $ nonEmptyCountedElementList nm' xs+      elements = countedElementList' "numFmts" (map (toElement "numFmt") numFmts) +++                 countedElementList' "fonts"   (map (toElement "font")   _styleSheetFonts) +++                 countedElementList' "fills"   (map (toElement "fill")   _styleSheetFills) +++                 countedElementList' "borders" (map (toElement "border") _styleSheetBorders) ++                    -- TODO: cellStyleXfs-                 , countedElementList "cellXfs" $ map (toElement "xf")     _styleSheetCellXfs+                 countedElementList' "cellXfs" (map (toElement "xf")     _styleSheetCellXfs) ++                  -- TODO: cellStyles-                 , countedElementList "dxfs"    $ map (toElement "dxf")    _styleSheetDxfs+                 countedElementList' "dxfs"    (map (toElement "dxf")    _styleSheetDxfs)                  -- TODO: tableStyles                  -- TODO: colors                  -- TODO: extLst-                 ]-      numFmts = map NumFmtPair $ M.toList _styleSheetNumFmts+      numFmts = map (uncurry NumFmt) $ M.toList _styleSheetNumFmts  -- | See @CT_Xf@, p. 4486 instance ToElement CellXf where@@ -1132,6 +1188,7 @@         { elementName       = nm         , elementNodes      = map NodeElement $                               catMaybes [ toElement "font"       <$> _dxfFont+                                        , toElement "numFmt"     <$> _dxfNumFmt                                         , toElement "fill"       <$> _dxfFill                                         , toElement "alignment"  <$> _dxfAlignment                                         , toElement "border"     <$> _dxfBorder@@ -1252,6 +1309,14 @@         ]     } +-- | See @CT_NumFmt@, p. 3936+instance ToElement NumFmt where+  toElement nm (NumFmt {..}) =+    leafElement nm+      [ "numFmtId"   .= toAttrVal _numFmtId+      , "formatCode" .= toAttrVal _numFmtCode+      ]+ -- | See @CT_CellProtection@, p. 4484 instance ToElement Protection where   toElement nm Protection{..} = Element {@@ -1359,15 +1424,15 @@ instance FromCursor StyleSheet where   fromCursor cur = do     let-      _styleSheetFonts = cur $/ element (n_ "fonts") &/ element (n_ "font") >=> fromCursor-      _styleSheetFills = cur $/ element (n_ "fills") &/ element (n_ "fill") >=> fromCursor-      _styleSheetBorders = cur $/ element (n_ "borders") &/ element (n_ "border") >=> fromCursor+      _styleSheetFonts = cur $/ element (addSmlNamespace "fonts") &/ element (addSmlNamespace "font") >=> fromCursor+      _styleSheetFills = cur $/ element (addSmlNamespace "fills") &/ element (addSmlNamespace "fill") >=> fromCursor+      _styleSheetBorders = cur $/ element (addSmlNamespace "borders") &/ element (addSmlNamespace "border") >=> fromCursor          -- TODO: cellStyleXfs-      _styleSheetCellXfs = cur $/ element (n_ "cellXfs") &/ element (n_ "xf") >=> fromCursor+      _styleSheetCellXfs = cur $/ element (addSmlNamespace "cellXfs") &/ element (addSmlNamespace "xf") >=> fromCursor          -- TODO: cellStyles-      _styleSheetDxfs = cur $/ element (n_ "dxfs") &/ element (n_ "dxf") >=> fromCursor-      _styleSheetNumFmts = M.fromList . map unNumFmtPair $-          cur $/ element (n_ "numFmts")&/ element (n_ "numFmt") >=> fromCursor+      _styleSheetDxfs = cur $/ element (addSmlNamespace "dxfs") &/ element (addSmlNamespace "dxf") >=> fromCursor+      _styleSheetNumFmts = M.fromList . map mkNumFmtPair $+          cur $/ element (addSmlNamespace "numFmts")&/ element (addSmlNamespace "numFmt") >=> fromCursor          -- TODO: tableStyles          -- TODO: colors          -- TODO: extLst@@ -1376,21 +1441,21 @@ -- | See @CT_Font@, p. 4489 instance FromCursor Font where   fromCursor cur = do-    _fontName         <- maybeElementValue (n_ "name") cur-    _fontCharset      <- maybeElementValue (n_ "charset") cur-    _fontFamily       <- maybeElementValue (n_ "family") cur-    _fontBold         <- maybeBoolElementValue (n_ "b") cur-    _fontItalic       <- maybeBoolElementValue (n_ "i") cur-    _fontStrikeThrough<- maybeBoolElementValue (n_ "strike") cur-    _fontOutline      <- maybeBoolElementValue (n_ "outline") cur-    _fontShadow       <- maybeBoolElementValue (n_ "shadow") cur-    _fontCondense     <- maybeBoolElementValue (n_ "condense") cur-    _fontExtend       <- maybeBoolElementValue (n_ "extend") cur-    _fontColor        <- maybeFromElement  (n_ "color") cur-    _fontSize         <- maybeElementValue (n_ "sz") cur-    _fontUnderline    <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur-    _fontVertAlign    <- maybeElementValue (n_ "vertAlign") cur-    _fontScheme       <- maybeElementValue (n_ "scheme") cur+    _fontName         <- maybeElementValue (addSmlNamespace "name") cur+    _fontCharset      <- maybeElementValue (addSmlNamespace "charset") cur+    _fontFamily       <- maybeElementValue (addSmlNamespace "family") cur+    _fontBold         <- maybeBoolElementValue (addSmlNamespace "b") cur+    _fontItalic       <- maybeBoolElementValue (addSmlNamespace "i") cur+    _fontStrikeThrough<- maybeBoolElementValue (addSmlNamespace "strike") cur+    _fontOutline      <- maybeBoolElementValue (addSmlNamespace "outline") cur+    _fontShadow       <- maybeBoolElementValue (addSmlNamespace "shadow") cur+    _fontCondense     <- maybeBoolElementValue (addSmlNamespace "condense") cur+    _fontExtend       <- maybeBoolElementValue (addSmlNamespace "extend") cur+    _fontColor        <- maybeFromElement  (addSmlNamespace "color") cur+    _fontSize         <- maybeElementValue (addSmlNamespace "sz") cur+    _fontUnderline    <- maybeElementValueDef (addSmlNamespace "u") FontUnderlineSingle cur+    _fontVertAlign    <- maybeElementValue (addSmlNamespace "vertAlign") cur+    _fontScheme       <- maybeElementValue (addSmlNamespace "scheme") cur     return Font{..}  -- | See 18.18.94 "ST_FontFamily (Font Family)" (p. 2517)@@ -1403,6 +1468,15 @@   fromAttrVal "5" = readSuccess FontFamilyDecorative   fromAttrVal t   = invalidText "FontFamily" t +instance FromAttrBs FontFamily where+  fromAttrBs "0" = return FontFamilyNotApplicable+  fromAttrBs "1" = return FontFamilyRoman+  fromAttrBs "2" = return FontFamilySwiss+  fromAttrBs "3" = return FontFamilyModern+  fromAttrBs "4" = return FontFamilyScript+  fromAttrBs "5" = return FontFamilyDecorative+  fromAttrBs x   = unexpectedAttrBs "FontFamily" x+ -- | See @CT_Color@, p. 4484 instance FromCursor Color where   fromCursor cur = do@@ -1412,6 +1486,15 @@     _colorTint      <- maybeAttribute "tint" cur     return Color{..} +instance FromXenoNode Color where+  fromXenoNode root =+    parseAttributes root $ do+      _colorAutomatic <- maybeAttr "auto"+      _colorARGB <- maybeAttr "rgb"+      _colorTheme <- maybeAttr "theme"+      _colorTint <- maybeAttr "tint"+      return Color {..}+ -- See @ST_UnderlineValues@, p. 3940 instance FromAttrVal FontUnderline where   fromAttrVal "single"           = readSuccess FontUnderlineSingle@@ -1421,30 +1504,50 @@   fromAttrVal "none"             = readSuccess FontUnderlineNone   fromAttrVal t                  = invalidText "FontUnderline" t +instance FromAttrBs FontUnderline where+  fromAttrBs "single"           = return FontUnderlineSingle+  fromAttrBs "double"           = return FontUnderlineDouble+  fromAttrBs "singleAccounting" = return FontUnderlineSingleAccounting+  fromAttrBs "doubleAccounting" = return FontUnderlineDoubleAccounting+  fromAttrBs "none"             = return FontUnderlineNone+  fromAttrBs x                  = unexpectedAttrBs "FontUnderline" x+ instance FromAttrVal FontVerticalAlignment where   fromAttrVal "baseline"    = readSuccess FontVerticalAlignmentBaseline   fromAttrVal "subscript"   = readSuccess FontVerticalAlignmentSubscript   fromAttrVal "superscript" = readSuccess FontVerticalAlignmentSuperscript   fromAttrVal t             = invalidText "FontVerticalAlignment" t +instance FromAttrBs FontVerticalAlignment where+  fromAttrBs "baseline"    = return FontVerticalAlignmentBaseline+  fromAttrBs "subscript"   = return FontVerticalAlignmentSubscript+  fromAttrBs "superscript" = return FontVerticalAlignmentSuperscript+  fromAttrBs x             = unexpectedAttrBs "FontVerticalAlignment" x+ instance FromAttrVal FontScheme where   fromAttrVal "major" = readSuccess FontSchemeMajor   fromAttrVal "minor" = readSuccess FontSchemeMinor   fromAttrVal "none"  = readSuccess FontSchemeNone   fromAttrVal t       = invalidText "FontScheme" t +instance FromAttrBs FontScheme where+  fromAttrBs "major" = return FontSchemeMajor+  fromAttrBs "minor" = return FontSchemeMinor+  fromAttrBs "none"  = return FontSchemeNone+  fromAttrBs x       = unexpectedAttrBs "FontScheme" x+ -- | See @CT_Fill@, p. 4484 instance FromCursor Fill where   fromCursor cur = do-    _fillPattern <- maybeFromElement (n_ "patternFill") cur+    _fillPattern <- maybeFromElement (addSmlNamespace "patternFill") cur     return Fill{..}  -- | See @CT_PatternFill@, p. 4484 instance FromCursor FillPattern where   fromCursor cur = do     _fillPatternType <- maybeAttribute "patternType" cur-    _fillPatternFgColor <- maybeFromElement (n_ "fgColor") cur-    _fillPatternBgColor <- maybeFromElement (n_ "bgColor") cur+    _fillPatternFgColor <- maybeFromElement (addSmlNamespace "fgColor") cur+    _fillPatternBgColor <- maybeFromElement (addSmlNamespace "bgColor") cur     return FillPattern{..}  instance FromAttrVal PatternType where@@ -1475,21 +1578,21 @@     _borderDiagonalUp   <- maybeAttribute "diagonalUp" cur     _borderDiagonalDown <- maybeAttribute "diagonalDown" cur     _borderOutline      <- maybeAttribute "outline" cur-    _borderStart      <- maybeFromElement (n_ "start") cur-    _borderEnd        <- maybeFromElement (n_ "end") cur-    _borderLeft       <- maybeFromElement (n_ "left") cur-    _borderRight      <- maybeFromElement (n_ "right") cur-    _borderTop        <- maybeFromElement (n_ "top") cur-    _borderBottom     <- maybeFromElement (n_ "bottom") cur-    _borderDiagonal   <- maybeFromElement (n_ "diagonal") cur-    _borderVertical   <- maybeFromElement (n_ "vertical") cur-    _borderHorizontal <- maybeFromElement (n_ "horizontal") cur+    _borderStart      <- maybeFromElement (addSmlNamespace "start") cur+    _borderEnd        <- maybeFromElement (addSmlNamespace "end") cur+    _borderLeft       <- maybeFromElement (addSmlNamespace "left") cur+    _borderRight      <- maybeFromElement (addSmlNamespace "right") cur+    _borderTop        <- maybeFromElement (addSmlNamespace "top") cur+    _borderBottom     <- maybeFromElement (addSmlNamespace "bottom") cur+    _borderDiagonal   <- maybeFromElement (addSmlNamespace "diagonal") cur+    _borderVertical   <- maybeFromElement (addSmlNamespace "vertical") cur+    _borderHorizontal <- maybeFromElement (addSmlNamespace "horizontal") cur     return Border{..}  instance FromCursor BorderStyle where   fromCursor cur = do     _borderStyleLine  <- maybeAttribute "style" cur-    _borderStyleColor <- maybeFromElement (n_ "color") cur+    _borderStyleColor <- maybeFromElement (addSmlNamespace "color") cur     return BorderStyle{..}  instance FromAttrVal LineStyle where@@ -1512,8 +1615,8 @@ -- | See @CT_Xf@, p. 4486 instance FromCursor CellXf where   fromCursor cur = do-    _cellXfAlignment  <- maybeFromElement (n_ "alignment") cur-    _cellXfProtection <- maybeFromElement (n_ "protection") cur+    _cellXfAlignment  <- maybeFromElement (addSmlNamespace "alignment") cur+    _cellXfProtection <- maybeFromElement (addSmlNamespace "protection") cur     _cellXfNumFmtId          <- maybeAttribute "numFmtId" cur     _cellXfFontId            <- maybeAttribute "fontId" cur     _cellXfFillId            <- maybeAttribute "fillId" cur@@ -1532,12 +1635,20 @@ -- | See @CT_Dxf@, p. 3937 instance FromCursor Dxf where     fromCursor cur = do-      _dxfFont         <- maybeFromElement (n_ "font") cur-      _dxfFill         <- maybeFromElement (n_ "fill") cur-      _dxfAlignment    <- maybeFromElement (n_ "alignment") cur-      _dxfBorder       <- maybeFromElement (n_ "border") cur-      _dxfProtection   <- maybeFromElement (n_ "protection") cur+      _dxfFont         <- maybeFromElement (addSmlNamespace "font") cur+      _dxfNumFmt       <- maybeFromElement (addSmlNamespace "numFmt") cur+      _dxfFill         <- maybeFromElement (addSmlNamespace "fill") cur+      _dxfAlignment    <- maybeFromElement (addSmlNamespace "alignment") cur+      _dxfBorder       <- maybeFromElement (addSmlNamespace "border") cur+      _dxfProtection   <- maybeFromElement (addSmlNamespace "protection") cur       return Dxf{..}++-- | See @CT_NumFmt@, p. 3936+instance FromCursor NumFmt where+  fromCursor cur = do+    _numFmtCode <- fromAttribute "formatCode" cur+    _numFmtId   <- fromAttribute "numFmtId" cur+    return NumFmt{..}  -- | See @CT_CellAlignment@, p. 4482 instance FromCursor Alignment where
+ 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
@@ -1,16 +1,20 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Variant where -import           Data.ByteString            (ByteString)-import           Data.ByteString.Base64     as B64-import           Data.Text                  (Text)-import qualified Data.Text                  as T-import qualified Data.Text.Encoding         as T-import           Text.XML-import           Text.XML.Cursor+import Control.DeepSeq (NFData)+import Control.Monad.Fail (MonadFail)+import Data.ByteString (ByteString)+import Data.ByteString.Base64 as B64+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.Generics (Generic)+import Text.XML+import Text.XML.Cursor -import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Writer.Internal  data Variant     = VtBlob ByteString@@ -22,8 +26,10 @@     -- vt_i4, vt_i8, vt_ui1, vt_ui2, vt_ui4, vt_ui8, vt_uint, vt_r4, vt_r8,     -- vt_lpstr, vt_bstr, vt_date, vt_filetime, vt_cy, vt_error, vt_stream,     -- vt_ostream, vt_storage, vt_ostorage, vt_vstream, vt_clsid-    deriving (Eq, Show)+    deriving (Eq, Show, Generic) +instance NFData Variant+ {-------------------------------------------------------------------------------   Parsing -------------------------------------------------------------------------------}@@ -47,7 +53,7 @@ killWhitespace :: Text -> Text killWhitespace = T.filter (/=' ') -decodeBase64 :: Monad m => Text -> m ByteString+decodeBase64 :: MonadFail m => Text -> m ByteString decodeBase64 t = case B64.decode (T.encodeUtf8 t) of   Right bs -> return bs   Left err -> fail $ "invalid base64 value: " ++ err
src/Codec/Xlsx/Writer.hs view
@@ -1,54 +1,53 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveGeneric #-} -- | This module provides a function for serializing structured `Xlsx` into lazy bytestring module Codec.Xlsx.Writer-    ( fromXlsx-    ) where+  ( fromXlsx+  ) where -import qualified Codec.Archive.Zip                           as Zip-import           Control.Arrow                               (second)-import           Control.Lens                                hiding (transform, (.=))-import           Control.Monad                               (forM)-import qualified Data.ByteString.Lazy                        as L-import           Data.ByteString.Lazy.Char8                  ()-import           Data.List                                   (foldl', mapAccumL)-import           Data.Map                                    (Map)-import           Data.STRef-import           Control.Monad.ST-import qualified Data.Map                                    as M-import           Data.Maybe-import           Data.Monoid                                 ((<>))-import           Data.Text                                   (Text)+import qualified "zip-archive" Codec.Archive.Zip as Zip+import Control.Arrow (second)+import Codec.Xlsx.LensCompat ((^.), mapped, (%~), (&), (?~))+import Control.Monad (forM)+import Control.Monad.ST+import Control.Monad.State (evalState, get, put)+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Lazy.Char8 ()+import Data.List (foldl', mapAccumL)+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid ((<>))+import Data.STRef+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)+import Data.Time.Format (formatTime)+import Data.Time.Format (defaultTimeLocale) import Data.Tuple.Extra (fst3, snd3, thd3)-import qualified Data.Text                                   as T-import           Data.Time                                   (UTCTime)-import           Data.Time.Clock.POSIX                       (POSIXTime, posixSecondsToUTCTime)-import           Data.Time.Format                            (formatTime)-#if MIN_VERSION_time(1,5,0)-import           Data.Time.Format                            (defaultTimeLocale)-#else-import           System.Locale                               (defaultTimeLocale)-#endif-import           Safe-import           Text.XML--#if !MIN_VERSION_base(4,8,0)-import           Control.Applicative-#endif+import GHC.Generics (Generic)+import Safe+import Text.XML -import           Codec.Xlsx.Types-import           Codec.Xlsx.Types.Internal-import           Codec.Xlsx.Types.Internal.CfPair-import qualified Codec.Xlsx.Types.Internal.CommentTable      as CommentTable-import           Codec.Xlsx.Types.Internal.CustomProperties-import           Codec.Xlsx.Types.Internal.DvPair-import           Codec.Xlsx.Types.Internal.Relationships     as Relationships hiding (lookup)-import           Codec.Xlsx.Types.Internal.SharedStringTable-import           Codec.Xlsx.Types.PivotTable.Internal-import           Codec.Xlsx.Writer.Internal-import           Codec.Xlsx.Writer.Internal.PivotTable+import Codec.Xlsx.Types+import Codec.Xlsx.Types.Cell (applySharedFormulaOpts)+import Codec.Xlsx.Types.Internal+import Codec.Xlsx.Types.Internal.CfPair+import qualified Codec.Xlsx.Types.Internal.CommentTable+       as CommentTable+import Codec.Xlsx.Types.Internal.CustomProperties+import Codec.Xlsx.Types.Internal.DvPair+import Codec.Xlsx.Types.Internal.Relationships as Relationships+       hiding (lookup)+import Codec.Xlsx.Types.Internal.SharedStringTable+import Codec.Xlsx.Types.PivotTable.Internal+import Codec.Xlsx.Writer.Internal+import Codec.Xlsx.Writer.Internal.PivotTable  -- | Writes `Xlsx' to raw data (lazy bytestring) fromXlsx :: POSIXTime -> Xlsx -> L.ByteString@@ -85,16 +84,26 @@                     (customPropsXml (CustomProperties customProps)) ],                   [ ("custom-properties", "docProps/custom.xml") ])     workbookFiles = bookFiles xlsx-    sheetNames = xlsx ^. xlSheets . to (map fst)+    sheetNames = xlsx ^. xlSheets & mapped %~ fst -singleSheetFiles :: Int -> Cells -> [FileData] -> Worksheet -> (FileData, [FileData])-singleSheetFiles n cells pivFileDatas ws = runST $ do+singleSheetFiles :: Int+                 -> Cells+                 -> [FileData]+                 -> Worksheet+                 -> STRef s Int+                 -> ST s (FileData, [FileData])+singleSheetFiles n cells pivFileDatas ws tblIdRef = do     ref <- newSTRef 1     mCmntData <- genComments n cells ref     mDrawingData <- maybe (return Nothing) (fmap Just . genDrawing n ref) (ws ^. wsDrawing)     pivRefs <- forM pivFileDatas $ \fd -> do       refId <- nextRefId ref       return (refId, fd)+    refTables <- forM (_wsTables ws) $ \tbl -> do+      refId <- nextRefId ref+      tblId <- readSTRef tblIdRef+      modifySTRef' tblIdRef (+1)+      return (refId, genTable tbl tblId)     let sheetFilePath = "xl/worksheets/sheet" <> show n <> ".xml"         sheetFile = FileData sheetFilePath             "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml"@@ -106,21 +115,22 @@             elementListSimple "worksheet" rootEls         rootEls = catMaybes $             [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews-            , nonEmptyElListSimple "cols" . map cwEl $ ws ^. wsColumns-            , Just . elementListSimple "sheetData" $ sheetDataXml cells (ws ^. wsRowPropertiesMap)+            , nonEmptyElListSimple "cols" . map (toElement "col") $ ws ^. wsColumnsProperties+            , Just . elementListSimple "sheetData" $+              sheetDataXml cells (ws ^. wsRowPropertiesMap) (ws ^. wsSharedFormulas)+            , toElement "sheetProtection" <$> (ws ^. wsProtection)+            , toElement "autoFilter" <$> (ws ^. wsAutoFilter)             , nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges             ] ++ map (Just . toElement "conditionalFormatting") cfPairs ++             [ nonEmptyElListSimple "dataValidations" $ map (toElement "dataValidation") dvPairs             , toElement "pageSetup" <$> ws ^. wsPageSetup             , fst3 <$> mDrawingData             , fst <$> mCmntData+            , nonEmptyElListSimple "tableParts"+                [leafElement "tablePart" [odr "id" .= rId] | (rId, _) <- refTables]             ]         cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings         dvPairs = map DvPair . M.toList $ ws ^. wsDataValidations-        cwEl cw = leafElement "col" [ ("min", txti $ cwMin cw)-                                    , ("max", txti $ cwMax cw)-                                    , ("width", txtd $ cwWidth cw)-                                    , ("style", txti $ cwStyle cw)]         mergeE1 r = leafElement "mergeCell" [("ref" .= r)]          sheetRels = if null referencedFiles@@ -133,7 +143,8 @@             | (i, FileData{..}) <- referenced ]         referenced = fromMaybe [] (snd <$> mCmntData) ++                      catMaybes [ snd3 <$> mDrawingData ] ++-                     pivRefs+                     pivRefs +++                     refTables         referencedFiles = map snd referenced         extraFiles = maybe [] thd3 mDrawingData         otherFiles = sheetRels ++ referencedFiles ++ extraFiles@@ -146,31 +157,57 @@   modifySTRef' r (+1)   return (unsafeRefId num) -unsafeRefId :: Int -> RefId-unsafeRefId num = RefId $ "rId" <> txti num--sheetDataXml :: Cells -> Map Int RowProperties -> [Element]-sheetDataXml rows rh = map rowEl rows+sheetDataXml ::+     Cells+  -> Map RowIndex RowProperties+  -> Map SharedFormulaIndex SharedFormulaOptions+  -> [Element]+sheetDataXml rows rh sharedFormulas =+  evalState (mapM rowEl rows) sharedFormulas   where-    rowEl (r, cells) = elementList "row"-                       (ht ++ s ++ [("r", txti r) ,("hidden", "false"), ("outlineLevel", "0"),-                                    ("collapsed", "false"), ("customFormat", "true"),-                                    ("customHeight", txtb hasHeight)])-                       $ map (cellEl r) cells-      where-        (ht, hasHeight, s) = case M.lookup r rh of-          Just (RowProps (Just h) (Just st)) -> ([("ht", txtd h)], True,[("s", txti st)])-          Just (RowProps Nothing  (Just st)) -> ([], True, [("s", txti st)])-          Just (RowProps (Just h) Nothing ) -> ([("ht", txtd h)], True,[])-          _ -> ([], False,[])-    cellEl r (icol, cell) =-      elementList "c" (cellAttrs (singleCellRef (r, icol)) cell)-              (catMaybes [ elementContent "v" . value <$> xlsxCellValue cell-                         , toElement "f" <$> xlsxCellFormula cell-                         ])-    cellAttrs ref cell = cellStyleAttr cell ++ [("r" .= ref), ("t" .= xlsxCellType cell)]-    cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = []-    cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)]+    rowEl (r, cells) = do+      let mProps    = M.lookup r rh+          hasHeight = case rowHeight =<< mProps of+                        Just CustomHeight{} -> True+                        _                   -> False+          ht        = do Just height <- [rowHeight =<< mProps]+                         let h = case height of CustomHeight    x -> x+                                                AutomaticHeight x -> x+                         return ("ht", txtd h)+          s         = do Just st <- [rowStyle =<< mProps]+                         return ("s", txti st)+          hidden    = fromMaybe False $ rowHidden <$> mProps+          attrs = ht +++            s +++            [ ("r", txti r)+            , ("hidden", txtb hidden)+            , ("outlineLevel", "0")+            , ("collapsed", "false")+            , ("customFormat", "true")+            , ("customHeight", txtb hasHeight)+            ]+      cellEls <- mapM (cellEl r) cells+      return $ elementList "row" attrs cellEls+    cellEl r (icol, cell) = do+      let cellAttrs ref c =+            cellStyleAttr c ++ [("r" .= ref), ("t" .= xlsxCellType c)]+          cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = []+          cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)]+          formula = xlsxCellFormula cell+          fEl0 = toElement "f" <$> formula+      fEl <- case formula of+        Just CellFormula{_cellfExpression=SharedFormula si} -> do+          shared <- get+          case M.lookup si shared of+            Just fOpts -> do+              put $ M.delete si shared+              return $ applySharedFormulaOpts fOpts <$> fEl0+            Nothing ->+              return fEl0+        _ ->+          return fEl0+      return $ elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) $+        catMaybes [fEl, elementContent "v" . value <$> xlsxCellValue cell]  genComments :: Int -> Cells -> STRef s Int -> ST s (Maybe (Element, [ReferencedFileData])) genComments n cells ref =@@ -208,7 +245,8 @@   return (el, (rId, drawingFile), referenced)   where     drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml"-    drawingFile = FileData drawingFilePath (smlCT "drawing") "drawing" drawingXml+    drawingCT = "application/vnd.openxmlformats-officedocument.drawing+xml"+    drawingFile = FileData drawingFilePath drawingCT "drawing" drawingXml     drawingXml = renderLBS def{rsNamespaces=nss} $ toDocument dr'     nss = [ ("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing")           , ("a",   "http://schemas.openxmlformats.org/drawingml/2006/main")@@ -285,8 +323,8 @@   , pvgOthers :: [FileData]   } -generatePivotFiles :: [[PivotTable]] -> PvGenerated-generatePivotFiles tables = PvGenerated cacheFiles shTableFiles others+generatePivotFiles :: [(CellMap, [PivotTable])] -> PvGenerated+generatePivotFiles cmTables = PvGenerated cacheFiles shTableFiles others   where     cacheFiles = [cacheFile | (cacheFile, _, _) <- flatRendered]     shTableFiles = map (map (\(_, tableFile, _) -> tableFile)) rendered@@ -295,11 +333,11 @@     flatRendered = concat rendered     (_, rendered) =       mapAccumL-        (\c ts -> mapAccumL (\c' t -> (c' + 1, render c' t)) c ts)+        (\c (cm, ts) -> mapAccumL (\c' t -> (c' + 1, render cm c' t)) c ts)         firstCacheId-        tables-    render cacheIdRaw tbl =-      let PivotTableFiles {..} = renderPivotTableFiles cacheIdRaw tbl+        cmTables+    render cm cacheIdRaw tbl =+      let PivotTableFiles {..} = renderPivotTableFiles cm cacheIdRaw tbl           cacheId = CacheId cacheIdRaw           cacheIdStr = show cacheIdRaw           cachePath =@@ -310,6 +348,20 @@               (smlCT "pivotCacheDefinition")               "pivotCacheDefinition"               pvtfCacheDefinition+          recordsPath =+            "xl/pivotCache/pivotCacheRecords" <> cacheIdStr <> ".xml"+          recordsFile =+            FileData+            recordsPath+            (smlCT "pivotCacheRecords")+            "pivotCacheRecords"+            pvtfCacheRecords+          cacheRelsFile =+            FileData+            ("xl/pivotCache/_rels/pivotCacheDefinition" <> cacheIdStr <> ".xml.rels")+            relsCT+            "relationships" $+            renderRels [refFileDataToRel cachePath (unsafeRefId 1, recordsFile)]           renderRels = renderLBS def . toDocument . Relationships.fromList           tablePath = "xl/pivotTables/pivotTable" <> cacheIdStr <> ".xml"           tableFile =@@ -320,8 +372,16 @@               relsCT               "relationships" $             renderRels [refFileDataToRel tablePath (unsafeRefId 1, cacheFile)]-      in ((cacheId, cacheFile), tableFile, [tableRels])+      in ((cacheId, cacheFile), tableFile, [tableRels, cacheRelsFile, recordsFile]) +genTable :: Table -> Int -> FileData+genTable tbl tblId = FileData{..}+  where+    fdPath = "xl/tables/table" <> show tblId <> ".xml"+    fdContentType = smlCT "table"+    fdRelType = "table"+    fdContents = renderLBS def $ tableToDocument tbl tblId+ data FileData = FileData { fdPath        :: FilePath                          , fdContentType :: Text                          , fdRelType     :: Text@@ -333,7 +393,7 @@ refFileDataToRel basePath (i, FileData {..}) =     relEntry i fdRelType (fdPath `relFrom` basePath) -type Cells = [(Int, [(Int, XlsxCell)])]+type Cells = [(RowIndex, [(ColumnIndex, XlsxCell)])]  coreXml :: UTCTime -> Text -> L.ByteString coreXml created creator =@@ -381,20 +441,24 @@     vTypeEl0 n = vTypeEl n M.empty     vTypeEl = nEl . nm "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" -data XlsxCellData = XlsxSS Int-                  | XlsxDouble Double-                  | XlsxBool Bool-                    deriving (Show, Eq)+data XlsxCellData+  = XlsxSS Int+  | XlsxDouble Double+  | XlsxBool Bool+  | XlsxError ErrorType+  deriving (Eq, Show, Generic)+ data XlsxCell = XlsxCell     { xlsxCellStyle   :: Maybe Int     , xlsxCellValue   :: Maybe XlsxCellData     , xlsxComment     :: Maybe Comment     , xlsxCellFormula :: Maybe CellFormula-    } deriving (Show, Eq)+    } deriving (Eq, Show, Generic)  xlsxCellType :: XlsxCell -> Text xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxSS _)} = "s" xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxBool _)} = "b"+xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxError _)} = "e" xlsxCellType _ = "n" -- default in SpreadsheetML schema, TODO: add other types  value :: XlsxCellData -> Text@@ -402,6 +466,7 @@ value (XlsxDouble d)   = txtd d value (XlsxBool True)  = "1" value (XlsxBool False) = "0"+value (XlsxError eType) = toAttrVal eType  transformSheetData :: SharedStringTable -> Worksheet -> Cells transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells)@@ -413,12 +478,13 @@     transformValue (CellDouble dbl) =  XlsxDouble dbl     transformValue (CellBool b) = XlsxBool b     transformValue (CellRich r) = XlsxSS (sstLookupRich shared r)+    transformValue (CellError e) = XlsxError e  bookFiles :: Xlsx -> [FileData] bookFiles xlsx = runST $ do   ref <- newSTRef 1   ssRId <- nextRefId ref-  let sheets = xlsx ^. xlSheets . to (map snd)+  let sheets = xlsx ^. xlSheets & mapped %~ snd       shared = sstConstruct sheets       sharedStrings =         (ssRId, FileData "xl/sharedStrings.xml" (smlCT "sharedStrings") "sharedStrings" $@@ -427,19 +493,26 @@   let style =         (stRId, FileData "xl/styles.xml" (smlCT "styles") "styles" $               unStyles (xlsx ^. xlStyles))-  let PvGenerated-        {pvgCacheFiles=cacheIdFiles,-         pvgOthers=pivotOtherFiles,-         pvgSheetTableFiles=sheetPivotTables} =-        generatePivotFiles (xlsx ^. xlSheets . to (map (^. _2 . wsPivotTables)))+  let PvGenerated { pvgCacheFiles = cacheIdFiles+                  , pvgOthers = pivotOtherFiles+                  , pvgSheetTableFiles = sheetPivotTables+                  } =+        generatePivotFiles+          [ (_wsCells, _wsPivotTables)+          | (_, Worksheet {..}) <- xlsx ^. xlSheets+          ]       sheetCells = map (transformSheetData shared) sheets       sheetInputs = zip3 sheetCells sheetPivotTables sheets+  tblIdRef <- newSTRef 1   allSheetFiles <- forM (zip [1..] sheetInputs) $ \(i, (cells, pvTables, sheet)) -> do     rId <- nextRefId ref-    let (sheetFile, others) = singleSheetFiles i cells pvTables sheet+    (sheetFile, others) <- singleSheetFiles i cells pvTables sheet tblIdRef     return ((rId, sheetFile), others)   let sheetFiles = map fst allSheetFiles-      sheetNameByRId = zip (map fst sheetFiles) (xlsx ^. xlSheets . to (map fst))+      sheetAttrsByRId =+        zipWith (\(rId, _) (name, sheet) -> (rId, name, sheet ^. wsState))+          sheetFiles+          (xlsx ^. xlSheets)       sheetOthers = concatMap snd allSheetFiles   cacheRefFDsById <- forM cacheIdFiles $ \(cacheId, fd) -> do       refId <- nextRefId ref@@ -447,7 +520,7 @@   let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ]       cacheRefs = map snd cacheRefFDsById       bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $-                 bookXml sheetNameByRId (xlsx ^. xlDefinedNames) cacheRefsById+                 bookXml sheetAttrsByRId (xlsx ^. xlDefinedNames) cacheRefsById (xlsx ^. xlDateBase)       rels = FileData "xl/_rels/workbook.xml.rels"              "application/vnd.openxmlformats-package.relationships+xml"              "relationships" relsXml@@ -458,13 +531,15 @@       otherFiles = concat [rels:(map snd referenced), pivotOtherFiles, sheetOthers]   return $ bookFile:otherFiles -bookXml :: [(RefId, Text)]+bookXml :: [(RefId, Text, SheetState)]         -> DefinedNames         -> [(CacheId, RefId)]+        -> DateBase         -> L.ByteString-bookXml rIdNames (DefinedNames names) cacheIdRefs =-  renderLBS def $ Document (Prologue [] Nothing []) root []+bookXml rIdAttrs (DefinedNames names) cacheIdRefs dateBase =+  renderLBS def {rsNamespaces = nss} $ Document (Prologue [] Nothing []) root []   where+    nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ]     -- The @bookViews@ element is not required according to the schema, but its     -- absence can cause Excel to crash when opening the print preview     -- (see <https://phpexcel.codeplex.com/workitem/2935>). It suffices however@@ -474,22 +549,24 @@       addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $       elementListSimple         "workbook"-        ([ elementListSimple "bookViews" [emptyElement "workbookView"]-         , elementListSimple-             "sheets"-             [ leafElement-               "sheet"-               ["name" .= name, "sheetId" .= i, (odr "id") .= rId]-             | (i, (rId, name)) <- zip [(1 :: Int) ..] rIdNames-             ]-         , elementListSimple-             "definedNames"-             [ elementContent0 "definedName" (definedName name lsId) val-             | (name, lsId, val) <- names-             ]-         ] ++-         maybeToList-           (nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs))+        ( [ leafElement "workbookPr" (catMaybes ["date1904" .=? justTrue (dateBase == DateBase1904) ])+          , elementListSimple "bookViews" [emptyElement "workbookView"]+          , elementListSimple+            "sheets"+            [ leafElement+              "sheet"+              ["name" .= name, "sheetId" .= i, "state" .= state, (odr "id") .= rId]+            | (i, (rId, name, state)) <- zip [(1 :: Int) ..] rIdAttrs+            ]+          , elementListSimple+            "definedNames"+            [ elementContent0 "definedName" (definedName name lsId) val+            | (name, lsId, val) <- names+            ]+          ] +++          maybeToList+          (nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs)+        )      pivotCacheEl (CacheId cId, refId) =       leafElement "pivotCache" ["cacheId" .= cId, (odr "id") .= refId]
src/Codec/Xlsx/Writer/Internal.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE RecordWildCards     #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveGeneric #-}+ module Codec.Xlsx.Writer.Internal (     -- * Rendering documents     ToDocument(..)@@ -11,6 +13,7 @@     -- * Rendering elements   , ToElement(..)   , countedElementList+  , nonEmptyCountedElementList   , elementList   , elementListSimple   , nonEmptyElListSimple@@ -20,6 +23,7 @@   , elementContent   , elementContentPreserved   , elementValue+  , elementValueDef     -- * Rendering attributes   , ToAttrVal(..)   , (.=)@@ -37,16 +41,16 @@   , justFalse   ) where -import           Data.Text                        (Text)-import qualified Data.Text                        as T-import           Data.Text.Lazy                   (toStrict)-import           Data.Text.Lazy.Builder           (toLazyText)-import           Data.Text.Lazy.Builder.Int-import           Data.Text.Lazy.Builder.RealFloat--import qualified Data.Map                         as Map-import           Data.String                      (fromString)-import           Text.XML+import qualified Data.Map as Map+import Data.Maybe (catMaybes)+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Lazy.Builder.Int+import Data.Text.Lazy.Builder.RealFloat+import Text.XML  {-------------------------------------------------------------------------------   Rendering documents@@ -84,6 +88,11 @@ countedElementList :: Name -> [Element] -> Element countedElementList nm as = elementList nm [ "count" .= length as ] as +nonEmptyCountedElementList :: Name -> [Element] -> Maybe Element+nonEmptyCountedElementList nm as = case as of+  [] -> Nothing+  _ -> Just $ countedElementList nm as+ elementList :: Name -> [(Name, Text)] -> [Element] -> Element elementList nm attrs els = Element {       elementName       = nm@@ -136,19 +145,19 @@ instance ToAttrVal String  where toAttrVal = fromString instance ToAttrVal Int     where toAttrVal = txti instance ToAttrVal Integer where toAttrVal = txti-instance ToAttrVal Double  where toAttrVal = fromString . show+instance ToAttrVal Double  where toAttrVal = txtd  instance ToAttrVal Bool where   toAttrVal True  = "1"   toAttrVal False = "0"  elementValue :: ToAttrVal a => Name -> a -> Element-elementValue nm a = Element {-      elementName       = nm-    , elementAttributes = Map.fromList [ "val" .= a ]-    , elementNodes      = []-    }+elementValue nm a = leafElement nm [ "val" .= a ] +elementValueDef :: (Eq a, ToAttrVal a) => Name -> a -> a -> Element+elementValueDef nm defVal a =+  leafElement nm $ catMaybes [ "val" .=? justNonDef defVal a ]+ (.=) :: ToAttrVal a => Name -> a -> (Name, Text) nm .= a = (nm, toAttrVal a) @@ -195,8 +204,11 @@   txtd :: Double -> Text-txtd v | v - fromInteger (floor v) == 0 = toStrict . toLazyText $ formatRealFloat Generic (Just 0) v-       | otherwise = toStrict . toLazyText $ realFloat v+txtd v+  | v - fromInteger v' == 0 = txti v'+  | otherwise = toStrict . toLazyText $ realFloat v+  where+    v' = floor v  txtb :: Bool -> Text txtb = T.toLower . T.pack . show
src/Codec/Xlsx/Writer/Internal/PivotTable.hs view
@@ -1,50 +1,57 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Writer.Internal.PivotTable   ( PivotTableFiles(..)   , renderPivotTableFiles   ) where  import Data.ByteString.Lazy (ByteString)+import Data.List (elemIndex, transpose)+import Data.List.Extra (nubOrd) import qualified Data.Map as M-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Text (Text)+import GHC.Generics (Generic) import Safe (fromJustNote) import Text.XML +import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.Internal+import Codec.Xlsx.Types.Internal.Relationships (odr) import Codec.Xlsx.Types.PivotTable+import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Writer.Internal  data PivotTableFiles = PivotTableFiles   { pvtfTable :: ByteString   , pvtfCacheDefinition :: ByteString-  } deriving (Eq, Show)--newtype CacheField =-  CacheField Text-  deriving (Eq, Show)+  , pvtfCacheRecords :: ByteString+  } deriving (Eq, Show, Generic)  data CacheDefinition = CacheDefinition   { cdSourceRef :: CellRef   , cdSourceSheet :: Text   , cdFields :: [CacheField]-  } deriving (Eq, Show)+  } deriving (Eq, Show, Generic) -renderPivotTableFiles :: Int -> PivotTable -> PivotTableFiles-renderPivotTableFiles cacheId t = PivotTableFiles {..}+renderPivotTableFiles :: CellMap -> Int -> PivotTable -> PivotTableFiles+renderPivotTableFiles cm cacheId t = PivotTableFiles {..}   where-    pvtfTable = renderLBS def $ ptDefinitionDocument cacheId t-    cacheDefinition = generateCache t-    pvtfCacheDefinition = renderLBS def $ toDocument cacheDefinition+    pvtfTable = renderLBS def $ ptDefinitionDocument cacheId cache t+    cache = generateCache cm t+    (cacheDoc, cacheRecordsDoc) = writeCache cache+    pvtfCacheDefinition = renderLBS def cacheDoc+    pvtfCacheRecords = renderLBS def cacheRecordsDoc -ptDefinitionDocument :: Int -> PivotTable -> Document-ptDefinitionDocument cacheId t =+ptDefinitionDocument :: Int -> CacheDefinition -> PivotTable -> Document+ptDefinitionDocument cacheId cache t =     documentFromElement "Pivot table generated by xlsx" $-    ptDefinitionElement "pivotTableDefinition" cacheId t+    ptDefinitionElement "pivotTableDefinition" cacheId cache t -ptDefinitionElement :: Name -> Int -> PivotTable -> Element-ptDefinitionElement nm cacheId PivotTable {..} =+ptDefinitionElement :: Name -> Int -> CacheDefinition -> PivotTable -> Element+ptDefinitionElement nm cacheId cache PivotTable {..} =   elementList nm attrs elements   where     attrs =@@ -52,7 +59,7 @@         [ "colGrandTotals" .=? justFalse _pvtColumnGrandTotals         , "rowGrandTotals" .=? justFalse _pvtRowGrandTotals         , "outline" .=? justTrue _pvtOutline-        , "outlineData" .=? justTrue  _pvtOutlineData+        , "outlineData" .=? justTrue _pvtOutlineData         ] ++       [ "name" .= _pvtName       , "dataCaption" .= _pvtDataCaption@@ -69,34 +76,49 @@         , "firstDataRow" .= (2 :: Int)         , "firstDataCol" .= (1 :: Int)         ]-    name2x = M.fromList $ zip (map _pfiName _pvtFields) [0 ..]+    name2x = M.fromList $ zip (mapMaybe _pfiName _pvtFields) [0 ..]     mapFieldToX f = fromJustNote "no field" $ M.lookup f name2x-    pivotFields =-      elementListSimple "pivotFields" $ map pFieldEl _pvtFields-    pFieldEl PivotFieldInfo{_pfiName=fName, _pfiOutline=outline}-      | FieldPosition fName `elem` _pvtRowFields =-        pFieldEl' fName outline ("axisRow" :: Text)-      | FieldPosition fName `elem` _pvtColumnFields =-        pFieldEl' fName outline ("axisCol" :: Text)+    pivotFields = elementListSimple "pivotFields" $ map pFieldEl _pvtFields+    maybeFieldIn Nothing _ = False+    maybeFieldIn (Just name) positions = FieldPosition name `elem` positions+    pFieldEl PivotFieldInfo { _pfiName = fName+                            , _pfiOutline = outline+                            , _pfiSortType = sortType+                            , _pfiHiddenItems = hidden+                            }+      | fName `maybeFieldIn` _pvtRowFields =+        pFieldEl' fName outline ("axisRow" :: Text) hidden sortType+      | fName `maybeFieldIn` _pvtColumnFields =+        pFieldEl' fName outline ("axisCol" :: Text) hidden sortType       | otherwise =-        leafElement-          "pivotField"-          [ "name" .= fName-          , "dataField" .= True-          , "showAll" .= False-          , "outline" .= outline-          ]-    pFieldEl' fName outline axis =+        leafElement "pivotField" $+        [ "dataField" .= True+        , "showAll" .= False+        , "outline" .= outline] +++        catMaybes ["name" .=? fName]+    pFieldEl' fName outline axis hidden sortType =       elementList         "pivotField"-        [ "name" .= fName-        , "axis" .= axis-        , "showAll" .= False-        , "outline" .= outline-        ]+        ([ "axis" .= axis+         , "showAll" .= False+         , "outline" .= outline+         ] +++         catMaybes [ "name" .=? fName+                   , "sortType" .=? justNonDef FieldSortManual sortType])         [ elementListSimple "items" $+          items fName hidden ++           [leafElement "item" ["t" .= ("default" :: Text)]]         ]+    items Nothing _ = []+    items (Just fName) hidden =+      [ itemEl x item hidden+      | (x, item) <- zip [0 ..] . fromMaybe [] $ M.lookup fName cachedItems+      ]+    itemEl x item hidden =+      leafElement "item" $+      ["x" .= (x :: Int)] ++ catMaybes ["h" .=? justTrue (item `elem` hidden)]+    cachedItems =+      M.fromList $ [(cfName, cfItems) | CacheField {..} <- cdFields cache]     rowFields =       elementListSimple "rowFields" . map fieldEl $       if length _pvtDataFields > 1@@ -115,26 +137,39 @@         , "subtotal" .=? justNonDef ConsolidateSum _dfFunction         ] -generateCache :: PivotTable -> CacheDefinition-generateCache PivotTable {..} =+generateCache :: CellMap -> PivotTable -> CacheDefinition+generateCache cm PivotTable {..} =   CacheDefinition   { cdSourceRef = _pvtSrcRef   , cdSourceSheet = _pvtSrcSheet   , cdFields = cachedFields   }   where-    cachedFields = map (cache . _pfiName) _pvtFields-    cache (PivotFieldName name) = CacheField name--instance ToDocument CacheDefinition where-  toDocument =-    documentFromElement "Pivot cache definition generated by xlsx" .-    toElement "pivotCacheDefinition"+    cachedFields = mapMaybe (fmap cache . _pfiName) _pvtFields+    cache name =+      CacheField+      { cfName = name+      , cfItems =+          fromJustNote "specified pivot table field does not exist" $+          M.lookup name itemsByName+      }+    ((r1, c1), (r2, c2)) =+      fromJustNote "Invalid src ref of pivot table " $ fromRange _pvtSrcRef+    getCellValue ix = M.lookup ix cm >>= _cellValue+    itemsByName =+      M.fromList $+      flip mapMaybe [c1 .. c2] $ \c -> do+        CellText nm <- getCellValue (r1, c)+        let values = mapMaybe (\r -> getCellValue (r, c)) [(r1 + 1) .. r2]+        return (PivotFieldName nm, nubOrd values) -instance ToElement CacheDefinition where- toElement nm CacheDefinition {..} = elementList nm attrs elements+writeCache :: CacheDefinition -> (Document, Document)+writeCache CacheDefinition {..} = (cacheDefDoc, cacheRecordsDoc)   where-    attrs = ["invalid" .= True, "refreshOnLoad" .= True]+    cacheDefDoc =+      documentFromElement "Pivot cache definition generated by xlsx" $+      elementList "pivotCacheDefinition" attrs elements+    attrs = ["invalid" .= True, "refreshOnLoad" .= True, odr "id" .= unsafeRefId 1]     elements = [worksheetSource, cacheFields]     worksheetSource =       elementList@@ -146,7 +181,24 @@         ]     cacheFields =       elementListSimple "cacheFields" $ map (toElement "cacheField") cdFields--instance ToElement CacheField where-  toElement nm (CacheField fieldName) = leafElement nm ["name" .= fieldName]-+    cacheRecordsDoc =+      documentFromElement "Pivot cache records generated by xlsx" .+      elementListSimple "pivotCacheRecords" $+      map (elementListSimple "r" . map recordValueToEl) cacheRecords+    recordValueToEl (CacheText t) = leafElement "s" ["v" .= t]+    recordValueToEl (CacheNumber n) = leafElement "n" ["v" .= n]+    recordValueToEl (CacheIndex i) = leafElement "x" ["v" .= i]+    cacheRecords = transpose $ map (itemsToRecordValues . cfItems) cdFields+    itemsToRecordValues vals =+      if all isText vals+        then indexes vals+        else map itemToRecordValue vals+    isText (CellText _) = True+    isText _ = False+    indexes vals =+      [ CacheIndex . fromJustNote "inconsistend definition" $ elemIndex v vals+      | v <- vals+      ]+    itemToRecordValue (CellDouble d) = CacheNumber d+    itemToRecordValue (CellText t) = CacheText t+    itemToRecordValue v = error $ "Unsupported value for pivot tables: " ++ show v
+ 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"
+ 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,850 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE QuasiQuotes       #-}-module Main (main) where--import           Control.Lens-import           Control.Monad.State.Lazy-import           Data.ByteString.Lazy                        (ByteString)-import qualified Data.ByteString.Lazy as LB-import           Data.Map                                    (Map)-import qualified Data.Map                                    as M-import           Data.Maybe                                  (mapMaybe)-import qualified Data.Text                                   as T-import           Data.Time.Clock.POSIX                       (POSIXTime)-import qualified Data.Vector                                 as V-import           Text.RawString.QQ-import           Text.XML-import           Text.XML.Cursor--import           Test.Tasty                                  (defaultMain,-                                                              testGroup)-import           Test.Tasty.HUnit                            (testCase)-import           Test.Tasty.SmallCheck                       (testProperty)--import           Test.SmallCheck.Series                      (Positive (..))-import           Test.Tasty.HUnit                            (HUnitFailure (..),-                                                              (@=?))--import           Codec.Xlsx-import           Codec.Xlsx.Formatted-import           Codec.Xlsx.Parser.Internal-import           Codec.Xlsx.Parser.Internal.PivotTable-import           Codec.Xlsx.Types.Internal-import           Codec.Xlsx.Types.Internal.CommentTable-import           Codec.Xlsx.Types.Internal.CustomProperties  as CustomProperties-import           Codec.Xlsx.Types.Internal.SharedStringTable-import           Codec.Xlsx.Types.PivotTable.Internal-import           Codec.Xlsx.Types.StyleSheet-import           Codec.Xlsx.Writer.Internal-import           Codec.Xlsx.Writer.Internal.PivotTable--import           Diff--main :: IO ()-main = defaultMain $-  testGroup "Tests"-    [ testProperty "col2int . int2col == id" $-        \(Positive i) -> i == col2int (int2col i)-    , testCase "write . read == id" $ do-        let bs = fromXlsx testTime testXlsx-        LB.writeFile "data-test.xlsx" bs-        testXlsx @==? toXlsx (fromXlsx testTime testXlsx)-    , testCase "fromRows . toRows == id" $-        testCellMap1 @=? fromRows (toRows testCellMap1)-    , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $-        testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet  testStyleSheet))-    , testCase "correct shared strings parsing" $-        [testSharedStringTable] @=? parseBS testStrings-    , testCase "correct shared strings parsing even when one of the shared strings entry is just <t/>" $-        [testSharedStringTableWithEmpty] @=? parseBS testStringsWithEmpty-    , testCase "correct comments parsing" $-        [testCommentTable] @=? parseBS testComments-    , testCase "correct drawing parsing" $-        [testDrawing] @==? parseBS testDrawingFile-    , testCase "write . read == id for Drawings" $-        [testDrawing] @==? parseBS testWrittenDrawing-    , testCase "correct chart parsing" $-        [testChartSpace] @==? parseBS testChartFile-    , testCase "write . read == id for Charts" $-        [testChartSpace] @==? parseBS testWrittenChartSpace-    , testCase "correct custom properties parsing" $-        [testCustomProperties] @==? parseBS testCustomPropertiesXml-    , testCase "proper results from `formatted`" $-        testFormattedResult @==? testRunFormatted-    , testCase "formatted . toFormattedCells = id" $ do-        let fmtd = formatted testFormattedCells minimalStyleSheet-        testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd)-                                                 (formattedStyleSheet fmtd)-    , testCase "proper results from `conditionalltyFormatted`" $-        testCondFormattedResult @==? testRunCondFormatted-    , testCase "toXlsxEither: properly formatted" $-        Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx)-    , testCase "toXlsxEither: invalid format" $-        Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file"-    , testCase "proper pivot table rendering" $ do-      let ptFiles = renderPivotTableFiles 3 testPivotTable-      parseLBS_ def (pvtfTable ptFiles) @==?-        stripContentSpaces (parseLBS_ def testPivotTableDefinition)-      parseLBS_ def (pvtfCacheDefinition ptFiles) @==?-        stripContentSpaces (parseLBS_ def testPivotCacheDefinition)-    , testCase "proper pivot table parsing" $ do-      let sheetName = "Sheet1"-          ref = CellRef "A1:D5"-          fields =-            [ PivotFieldName "Color"-            , PivotFieldName "Year"-            , PivotFieldName "Price"-            , PivotFieldName "Count"-            ]-          forCacheId (CacheId 3) = Just (sheetName, ref, fields)-          forCacheId _ = Nothing-      Just (sheetName, ref, fields) @==? parseCache testPivotCacheDefinition-      Just testPivotTable @==? parsePivotTable forCacheId testPivotTableDefinition-    ]--parseBS :: FromCursor a => ByteString -> [a]-parseBS = fromCursor . fromDocument . parseLBS_ def--testXlsx :: Xlsx-testXlsx = Xlsx sheets minimalStyles definedNames customProperties-  where-    sheets =-      [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)]-    sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges sheetViews pageSetup cFormatting validations []-    sheet2 = def & wsCells .~ testCellMap2-    pvSheet = sheetWithPvCells & wsPivotTables .~ [testPivotTable]-    sheetWithPvCells = flip execState def $ do-      forM_ (zip [1..] ["Color", "Year", "Price", "Count"]) $ \(c, n) ->-        cellValueAt (1, c) ?= CellText n-      cellValueAt (2, 1) ?= CellText "brown"-      cellValueAt (2, 2) ?= CellDouble 2016-      cellValueAt (2, 3) ?= CellDouble 12.34-      cellValueAt (2, 4) ?= CellDouble 42-    rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))]-    cols = [ColumnsWidth 1 10 15 1]-    drawing = Just $ testDrawing { _xdrAnchors = map resolve $ _xdrAnchors testDrawing }-    resolve :: Anchor RefId RefId -> Anchor FileInfo ChartSpace-    resolve Anchor {..} =-      let obj =-            case _anchObject of-              Picture {..} ->-                let picBlipFill = (_picBlipFill & bfpImageInfo ?~ fileInfo)-                in Picture-                   { _picMacro = _picMacro-                   , _picPublished = _picPublished-                   , _picNonVisual = _picNonVisual-                   , _picBlipFill = picBlipFill-                   , _picShapeProperties = _picShapeProperties-                   }-              Graphic nv _ tr ->-                Graphic nv testChartSpace tr-      in Anchor-         { _anchAnchoring = _anchAnchoring-         , _anchObject = obj-         , _anchClientData = _anchClientData-         }-    fileInfo = FileInfo "dummy.png" "image/png" "fake contents"-    ranges = [mkRange (1,1) (1,2), mkRange (2,2) (10, 5)]-    minimalStyles = renderStyleSheet minimalStyleSheet-    definedNames = DefinedNames [("SampleName", Nothing, "A10:A20")]-    sheetViews = Just [sheetView1, sheetView2]-    sheetView1 = def & sheetViewRightToLeft ?~ True-                     & sheetViewTopLeftCell ?~ CellRef "B5"-    sheetView2 = def & sheetViewType ?~ SheetViewTypePageBreakPreview-                     & sheetViewWorkbookViewId .~ 5-                     & sheetViewSelection .~ [ def & selectionActiveCell ?~ CellRef "C2"-                                                   & selectionPane ?~ PaneTypeBottomRight-                                             , def & selectionActiveCellId ?~ 1-                                                   & selectionSqref ?~ SqRef [ CellRef "A3:A10"-                                                                             , CellRef "B1:G3"]-                                             ]-    pageSetup = Just $ def & pageSetupBlackAndWhite ?~  True-                           & pageSetupCopies ?~ 2-                           & pageSetupErrors ?~ PrintErrorsDash-                           & pageSetupPaperSize ?~ PaperA4-    customProperties = M.fromList [("some_prop", VtInt 42)]-    cFormatting = M.fromList [(SqRef [CellRef "A1:B3"], rules1), (SqRef [CellRef "C1:C10"], rules2)]-    cfRule c d = CfRule { _cfrCondition  = c-                        , _cfrDxfId      = Just d-                        , _cfrPriority   = topCfPriority-                        , _cfrStopIfTrue = Nothing-                        }-    rules1 = [ cfRule ContainsBlanks 1-             , cfRule (ContainsText "foo") 2-             , cfRule (CellIs (OpBetween (Formula "A1") (Formula "B10"))) 3-             ]-    rules2 = [ cfRule ContainsErrors 3 ]--testCellMap1 :: CellMap-testCellMap1 = M.fromList [ ((1, 2), cd1_2), ((1, 5), cd1_5)-                          , ((3, 1), cd3_1), ((3, 2), cd3_2), ((3, 7), cd3_7)-                          , ((4, 1), cd4_1), ((4, 2), cd4_2), ((4, 3), cd4_3)-                          ]-  where-    cd v = def {_cellValue=Just v}-    cd1_2 = cd (CellText "just a text")-    cd1_5 = cd (CellDouble 42.4567)-    cd3_1 = cd (CellText "another text")-    cd3_2 = def -- shouldn't it be skipped?-    cd3_7 = cd (CellBool True)-    cd4_1 = cd (CellDouble 1)-    cd4_2 = cd (CellDouble 2)-    cd4_3 = (cd (CellDouble (1+2))) { _cellFormula =-                                            Just $ simpleCellFormula "A4+B4"-                                    }--testCellMap2 :: CellMap-testCellMap2 = M.fromList [ ((1, 2), def & cellValue ?~ CellText "something here")-                          , ((3, 5), def & cellValue ?~ CellDouble 123.456)-                          , ((2, 4),-                             def & cellValue ?~ CellText "value"-                                 & cellComment ?~ comment1-                            )-                          , ((10, 7),-                             def & cellValue ?~ CellText "value"-                                 & cellComment ?~ comment2-                            )-                          ]-  where-    comment1 = Comment (XlsxText "simple comment") "bob" True-    comment2 = Comment (XlsxRichText [rich1, rich2]) "alice" False-    rich1 = def & richTextRunText.~ "Look ma!"-                & richTextRunProperties ?~ (-                   def & runPropertiesBold ?~ True-                       & runPropertiesFont ?~ "Tahoma")-    rich2 = def & richTextRunText .~ "It's blue!"-                & richTextRunProperties ?~ (-                   def & runPropertiesItalic ?~ True-                       & runPropertiesColor ?~ (def & colorARGB ?~ "FF000080"))--testTime :: POSIXTime-testTime = 123--fromRight :: Either a b -> b-fromRight (Right b) = b--testStyleSheet :: StyleSheet-testStyleSheet = minimalStyleSheet & styleSheetDxfs .~ [dxf1, dxf2]-                                   & styleSheetNumFmts .~ M.fromList [(164, "0.000")]-                                   & styleSheetCellXfs %~ (++ [cellXf1, cellXf2])-  where-    dxf1 = def & dxfFont ?~ (def & fontBold ?~ True-                                 & fontSize ?~ 12)-    dxf2 = def & dxfFill ?~ (def & fillPattern ?~ (def & fillPatternBgColor ?~ red))-    red = def & colorARGB ?~ "FFFF0000"-    cellXf1 = def-        { _cellXfApplyNumberFormat = Just True-        , _cellXfNumFmtId          = Just 2 }-    cellXf2 = def-        { _cellXfApplyNumberFormat = Just True-        , _cellXfNumFmtId          = Just 164 }--testSharedStringTable :: SharedStringTable-testSharedStringTable = SharedStringTable $ V.fromList items-  where-    items = [text, rich]-    text = XlsxText "plain text"-    rich = XlsxRichText [ RichTextRun Nothing "Just "-                        , RichTextRun (Just props) "example" ]-    props = def & runPropertiesBold .~ Just True-                & runPropertiesUnderline .~ Just FontUnderlineSingle-                & runPropertiesSize .~ Just 10-                & runPropertiesFont .~ Just "Arial"-                & runPropertiesFontFamily .~ Just FontFamilySwiss--testSharedStringTableWithEmpty :: SharedStringTable-testSharedStringTableWithEmpty =-  SharedStringTable $ V.fromList [XlsxText ""]--testCommentTable = CommentTable $ M.fromList-    [ (CellRef "D4", Comment (XlsxRichText rich) "Bob" True)-    , (CellRef "A2", Comment (XlsxText "Some comment here") "CBR" True) ]-  where-    rich = [ RichTextRun-             { _richTextRunProperties =-               Just $ def & runPropertiesCharset ?~ 1-                          & runPropertiesColor ?~ def -- TODO: why not Nothing here?-                          & runPropertiesFont ?~ "Calibri"-                          & runPropertiesScheme ?~ FontSchemeMinor-                          & runPropertiesSize ?~ 8.0-             , _richTextRunText = "Bob:"}-           , RichTextRun-             { _richTextRunProperties =-               Just $ def & runPropertiesCharset ?~ 1-                          & runPropertiesColor ?~ def-                          & runPropertiesFont ?~ "Calibri"-                          & runPropertiesScheme ?~ FontSchemeMinor-                          & runPropertiesSize ?~ 8.0-             , _richTextRunText = "Why such high expense?"}]--testStrings :: ByteString-testStrings = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\-  \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\-  \<si><t>plain text</t></si>\-  \<si><r><t>Just </t></r><r><rPr><b val=\"true\"/><u val=\"single\"/>\-  \<sz val=\"10\"/><rFont val=\"Arial\"/><family val=\"2\"/></rPr><t>example</t></r></si>\-  \</sst>"--testStringsWithEmpty :: ByteString-testStringsWithEmpty = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\-  \<sst xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\" count=\"2\" uniqueCount=\"2\">\-  \<si><t/></si>\-  \</sst>"--testComments :: ByteString-testComments = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<comments xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">-  <authors>-    <author>Bob</author>-    <author>CBR</author>-  </authors>-  <commentList>-    <comment ref="D4" authorId="0">-      <text>-        <r>-          <rPr>-            <b/><sz val="8"/><color indexed="81"/><rFont val="Calibri"/>-            <charset val="1"/><scheme val="minor"/>-          </rPr>-          <t>Bob:</t>-        </r>-        <r>-          <rPr>-            <sz val="8"/><color indexed="81"/><rFont val="Calibri"/>-            <charset val="1"/> <scheme val="minor"/>-          </rPr>-          <t xml:space="preserve">Why such high expense?</t>-        </r>-      </text>-    </comment>-    <comment ref="A2" authorId="1">-      <text><t>Some comment here</t></text>-    </comment>-  </commentList>-</comments>-|]--testDrawing :: UnresolvedDrawing-testDrawing = Drawing [anchor1, anchor2]-  where-    anchor1 =-      Anchor-      {_anchAnchoring = anchoring1, _anchObject = pic, _anchClientData = def}-    anchoring1 =-      TwoCellAnchor-      { tcaFrom = unqMarker (0, 0) (0, 0)-      , tcaTo = unqMarker (12, 320760) (33, 38160)-      , tcaEditAs = EditAsAbsolute-      }-    pic =-      Picture-      { _picMacro = Nothing-      , _picPublished = False-      , _picNonVisual = nonVis1-      , _picBlipFill = bfProps-      , _picShapeProperties = shProps-      }-    nonVis1 =-      PicNonVisual $-      NonVisualDrawingProperties-      { _nvdpId = 0-      , _nvdpName = "Picture 1"-      , _nvdpDescription = Just ""-      , _nvdpHidden = False-      , _nvdpTitle = Nothing-      }-    bfProps =-      BlipFillProperties-      {_bfpImageInfo = Just (RefId "rId1"), _bfpFillMode = Just FillStretch}-    shProps =-      ShapeProperties-      { _spXfrm = Just trnsfrm-      , _spGeometry = Just PresetGeometry-      , _spFill = Nothing-      , _spOutline = Just $ LineProperties (Just NoFill)-      }-    trnsfrm =-      Transform2D-      { _trRot = Angle 0-      , _trFlipH = False-      , _trFlipV = False-      , _trOffset = Just (unqPoint2D 0 0)-      , _trExtents =-          Just-            (PositiveSize2D-               (PositiveCoordinate 10074240)-               (PositiveCoordinate 5402520))-      }-    anchor2 =-      Anchor-      { _anchAnchoring = anchoring2-      , _anchObject = graphic-      , _anchClientData = def-      }-    anchoring2 =-      TwoCellAnchor-      { tcaFrom = unqMarker (0, 87840) (21, 131040)-      , tcaTo = unqMarker (7, 580320) (38, 132480)-      , tcaEditAs = EditAsOneCell-      }-    graphic =-      Graphic-      { _grNonVisual = nonVis2-      , _grChartSpace = RefId "rId2"-      , _grTransform = transform-      }-    nonVis2 = GraphNonVisual $-      NonVisualDrawingProperties-      { _nvdpId = 1-      , _nvdpName = ""-      , _nvdpDescription = Nothing-      , _nvdpHidden = False-      , _nvdpTitle = Nothing-      }-    transform =-      Transform2D-      { _trRot = Angle 0-      , _trFlipH = False-      , _trFlipV = False-      , _trOffset = Just (unqPoint2D 0 0)-      , _trExtents =-          Just-            (PositiveSize2D-               (PositiveCoordinate 10074240)-               (PositiveCoordinate 5402520))-      }---testDrawingFile :: ByteString-testDrawingFile = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<xdr:wsDr xmlns:xdr="http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">-  <xdr:twoCellAnchor editAs="absolute">-    <xdr:from>-      <xdr:col>0</xdr:col><xdr:colOff>0</xdr:colOff>-      <xdr:row>0</xdr:row><xdr:rowOff>0</xdr:rowOff>-    </xdr:from>-    <xdr:to>-      <xdr:col>12</xdr:col><xdr:colOff>320760</xdr:colOff>-      <xdr:row>33</xdr:row><xdr:rowOff>38160</xdr:rowOff>-    </xdr:to>-    <xdr:pic>-      <xdr:nvPicPr><xdr:cNvPr id="0" name="Picture 1" descr=""/><xdr:cNvPicPr/></xdr:nvPicPr>-      <xdr:blipFill><a:blip r:embed="rId1"></a:blip><a:stretch/></xdr:blipFill>-      <xdr:spPr>-        <a:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></a:xfrm>-        <a:prstGeom prst="rect"><a:avLst/></a:prstGeom><a:ln><a:noFill/></a:ln>-      </xdr:spPr>-    </xdr:pic>-    <xdr:clientData/>-  </xdr:twoCellAnchor>-  <xdr:twoCellAnchor editAs="oneCell">-    <xdr:from>-      <xdr:col>0</xdr:col><xdr:colOff>87840</xdr:colOff>-      <xdr:row>21</xdr:row><xdr:rowOff>131040</xdr:rowOff>-    </xdr:from>-    <xdr:to>-      <xdr:col>7</xdr:col><xdr:colOff>580320</xdr:colOff>-      <xdr:row>38</xdr:row><xdr:rowOff>132480</xdr:rowOff>-    </xdr:to>-    <xdr:graphicFrame>-      <xdr:nvGraphicFramePr><xdr:cNvPr id="1" name=""/><xdr:cNvGraphicFramePr/></xdr:nvGraphicFramePr>-      <xdr:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></xdr:xfrm>-      <a:graphic>-        <a:graphicData uri="http://schemas.openxmlformats.org/drawingml/2006/chart">-          <c:chart xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" r:id="rId2"/>-        </a:graphicData>-      </a:graphic>-    </xdr:graphicFrame>-    <xdr:clientData/>-  </xdr:twoCellAnchor>-</xdr:wsDr>-|]--testWrittenDrawing :: ByteString-testWrittenDrawing = renderLBS def $ toDocument testDrawing--testCustomProperties :: CustomProperties-testCustomProperties = CustomProperties.fromList-    [ ("testTextProp", VtLpwstr "test text property value")-    , ("prop2", VtLpwstr "222")-    , ("bool", VtBool False)-    , ("prop333", VtInt 1)-    , ("decimal", VtDecimal 1.234) ]--testCustomPropertiesXml :: ByteString-testCustomPropertiesXml = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<Properties xmlns="http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">-  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="2" name="prop2">-    <vt:lpwstr>222</vt:lpwstr>-  </property>-  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="3" name="prop333">-    <vt:int>1</vt:int>-  </property>-  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="4" name="testTextProp">-    <vt:lpwstr>test text property value</vt:lpwstr>-  </property>-  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="5" name="decimal">-    <vt:decimal>1.234</vt:decimal>-  </property>-  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="6" name="bool">-    <vt:bool>false</vt:bool>-  </property>-  <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="7" name="blob">-    <vt:blob>-    ZXhhbXBs-    ZSBibG9i-    IGNvbnRl-    bnRz-    </vt:blob>-  </property>-</Properties>-|]--testFormattedResult :: Formatted-testFormattedResult = Formatted cm styleSheet merges-  where-    cm = M.fromList [ ((1, 1), cell11)-                    , ((1, 2), cell12)-                    , ((2, 5), cell25) ]-    cell11 = Cell-        { _cellStyle   = Just 1-        , _cellValue   = Just (CellText "text at A1")-        , _cellComment = Nothing-        , _cellFormula = Nothing }-    cell12 = Cell-        { _cellStyle   = Just 2-        , _cellValue   = Just (CellDouble 1.23)-        , _cellComment = Nothing-        , _cellFormula = Nothing }-    cell25 = Cell-        { _cellStyle   = Just 3-        , _cellValue   = Just (CellDouble 1.23456)-        , _cellComment = Nothing-        , _cellFormula = Nothing }-    merges = []-    styleSheet =-        minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3])-                          & styleSheetFonts   %~ (++ [font1, font2])-                          & styleSheetNumFmts .~ numFmts-    nextFontId = length (minimalStyleSheet ^. styleSheetFonts)-    cellXf1 = def-        { _cellXfApplyFont = Just True-        , _cellXfFontId    = Just nextFontId }-    font1 = def-        { _fontName = Just "Calibri"-        , _fontBold = Just True }-    cellXf2 = def-        { _cellXfApplyFont         = Just True-        , _cellXfFontId            = Just (nextFontId + 1)-        , _cellXfApplyNumberFormat = Just True-        , _cellXfNumFmtId          = Just 164 }-    font2 = def-        { _fontItalic = Just True }-    cellXf3 = def-        { _cellXfApplyNumberFormat = Just True-        , _cellXfNumFmtId          = Just 2 }-    numFmts = M.fromList [(164, "0.0000")]--testRunFormatted :: Formatted-testRunFormatted = formatted formattedCellMap minimalStyleSheet-  where-    formattedCellMap = flip execState def $ do-        let font1 = def & fontBold ?~ True-                        & fontName ?~ "Calibri"-        at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1"-                          & formattedFormat . formatFont  ?~ font1)-        at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23-                          & formattedFormat . formatFont . non def . fontItalic ?~ True-                          & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4)-        at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456-                          & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal)--testCondFormattedResult :: CondFormatted-testCondFormattedResult = CondFormatted styleSheet formattings-  where-    styleSheet =-        minimalStyleSheet & styleSheetDxfs .~ dxfs-    dxfs = [ def & dxfFont ?~ (def & fontUnderline ?~ FontUnderlineSingle)-           , def & dxfFont ?~ (def & fontStrikeThrough ?~ True)-           , def & dxfFont ?~ (def & fontBold ?~ True) ]-    formattings = M.fromList [ (SqRef [CellRef "A1:A2", CellRef "B2:B3"], [cfRule1, cfRule2])-                             , (SqRef [CellRef "C3:E10"], [cfRule1])-                             , (SqRef [CellRef "F1:G10"], [cfRule3]) ]-    cfRule1 = CfRule-        { _cfrCondition  = ContainsBlanks-        , _cfrDxfId      = Just 0-        , _cfrPriority   = 1-        , _cfrStopIfTrue = Nothing }-    cfRule2 = CfRule-        { _cfrCondition  = BeginsWith "foo"-        , _cfrDxfId      = Just 1-        , _cfrPriority   = 1-        , _cfrStopIfTrue = Nothing }-    cfRule3 = CfRule-        { _cfrCondition  = CellIs (OpGreaterThan (Formula "A1"))-        , _cfrDxfId      = Just 2-        , _cfrPriority   = 1-        , _cfrStopIfTrue = Nothing }--testFormattedCells :: Map (Int, Int) FormattedCell-testFormattedCells = flip execState def $ do-    at (1,1) ?= (def & formattedRowSpan .~ 5-                     & formattedColSpan .~ 5-                     & formattedFormat . formatBorder . non def . borderTop .-                                                        non def . borderStyleLine ?~ LineStyleDashed-                     & formattedFormat . formatBorder . non def . borderBottom .-                                                        non def . borderStyleLine ?~ LineStyleDashed)-    at (10,2) ?= (def & formattedFormat . formatFont . non def . fontBold ?~ True)--testRunCondFormatted :: CondFormatted-testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet-  where-    condFmts = flip execState def $ do-        let cfRule1 = def & condfmtCondition .~ ContainsBlanks-                          & condfmtDxf . dxfFont . non def . fontUnderline ?~ FontUnderlineSingle-            cfRule2 = def & condfmtCondition .~ BeginsWith "foo"-                          & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True-            cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1"))-                          & condfmtDxf . dxfFont . non def . fontBold ?~ True-        at (CellRef "A1:A2")  ?= [cfRule1, cfRule2]-        at (CellRef "B2:B3")  ?= [cfRule1, cfRule2]-        at (CellRef "C3:E10") ?= [cfRule1]-        at (CellRef "F1:G10") ?= [cfRule3]--testChartFile :: ByteString-testChartFile = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<c:chartSpace xmlns:c="http://schemas.openxmlformats.org/drawingml/2006/chart" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">-<c:chart>-<c:title>- <c:tx><c:rich><a:bodyPr rot="0" anchor="b"/><a:p><a:r><a:t>Line chart title</a:t></a:r></a:p></c:rich></c:tx>-</c:title>-<c:plotArea>-<c:lineChart>-<c:grouping val="standard"/>-<c:ser>-  <c:idx val="0"/><c:order val="0"/>-  <c:tx><c:strRef><c:f>Sheet1!$A$1</c:f></c:strRef></c:tx>-  <c:marker><c:symbol val="none"/></c:marker>-  <c:val><c:numRef><c:f>Sheet1!$B$1:$D$1</c:f></c:numRef></c:val>-  <c:smooth val="0"/>-</c:ser>-<c:ser>-  <c:idx val="1"/><c:order val="1"/>-  <c:tx><c:strRef><c:f>Sheet1!$A$2</c:f></c:strRef></c:tx>-  <c:marker><c:symbol val="none"/></c:marker>-  <c:val><c:numRef><c:f>Sheet1!$B$2:$D$2</c:f></c:numRef></c:val>-  <c:smooth val="0"/>-</c:ser>-<c:marker val="0"/>-<c:smooth val="0"/>-</c:lineChart>-</c:plotArea>-<c:plotVisOnly val="1"/>-<c:dispBlanksAs val="gap"/>-</c:chart>-</c:chartSpace>-|]--testChartSpace :: ChartSpace-testChartSpace =-  ChartSpace-  { _chspTitle = Just $ ChartTitle titleBody-  , _chspCharts = charts-  , _chspLegend = Nothing-  , _chspPlotVisOnly = Just True-  , _chspDispBlanksAs = Just DispBlanksAsGap-  }-  where-    titleBody =-      TextBody-      { _txbdRotation = Angle 0-      , _txbdSpcFirstLastPara = False-      , _txbdVertOverflow = TextVertOverflow-      , _txbdVertical = TextVerticalHorz-      , _txbdWrap = TextWrapSquare-      , _txbdAnchor = TextAnchoringBottom-      , _txbdAnchorCenter = False-      , _txbdParagraphs =-          [TextParagraph Nothing [RegularRun Nothing "Line chart title"]]-      }-    charts =-      [ LineChart-        { _lnchGrouping = StandardGrouping-        , _lnchSeries = series-        , _lnchMarker = Just False-        , _lnchSmooth = Just False-        }-      ]-    series =-      [ LineSeries-        { _lnserShared = Series . Just $ Formula "Sheet1!$A$1"-        , _lnserMarker = Just markerNone-        , _lnserDataLblProps = Nothing-        , _lnserVal = Just $ Formula "Sheet1!$B$1:$D$1"-        , _lnserSmooth = Just False-        }-      , LineSeries-        { _lnserShared = Series . Just $ Formula "Sheet1!$A$2"-        , _lnserMarker = Just markerNone-        , _lnserDataLblProps = Nothing-        , _lnserVal = Just $ Formula "Sheet1!$B$2:$D$2"-        , _lnserSmooth = Just False-        }-      ]-    markerNone =-      DataMarker {_dmrkSymbol = Just DataMarkerNone, _dmrkSize = Nothing}--testWrittenChartSpace :: ByteString-testWrittenChartSpace = renderLBS def{rsNamespaces=nss} $ toDocument testChartSpace-  where-    nss = [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart")-          , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") ]---validations :: Map SqRef DataValidation-validations = M.fromList-    [ ( SqRef [CellRef "A1"], def-      )-      , ( SqRef [CellRef "A1", CellRef "B2:C3"], def-        { _dvAllowBlank       = True-        , _dvError            = Just "incorrect data"-        , _dvErrorStyle       = ErrorStyleInformation-        , _dvErrorTitle       = Just "error title"-        , _dvPrompt           = Just "enter data"-        , _dvPromptTitle      = Just "prompt title"-        , _dvShowDropDown     = True-        , _dvShowErrorMessage = True-        , _dvShowInputMessage = True-        , _dvValidationType   = ValidationTypeList ["aaaa","bbbb","cccc"]-        }-      )-    , ( SqRef [CellRef "A6", CellRef "I2"], def-        { _dvAllowBlank       = False-        , _dvError            = Just "aaa"-        , _dvErrorStyle       = ErrorStyleWarning-        , _dvErrorTitle       = Just "bbb"-        , _dvPrompt           = Just "ccc"-        , _dvPromptTitle      = Just "ddd"-        , _dvShowDropDown     = False-        , _dvShowErrorMessage = False-        , _dvShowInputMessage = False-        , _dvValidationType   = ValidationTypeDecimal $ ValGreaterThan $ Formula "10"-        }-      )-    , ( SqRef [CellRef "A7"], def-        { _dvAllowBlank       = False-        , _dvError            = Just "aaa"-        , _dvErrorStyle       = ErrorStyleStop-        , _dvErrorTitle       = Just "bbb"-        , _dvPrompt           = Just "ccc"-        , _dvPromptTitle      = Just "ddd"-        , _dvShowDropDown     = False-        , _dvShowErrorMessage = False-        , _dvShowInputMessage = False-        , _dvValidationType   = ValidationTypeWhole $ ValNotBetween (Formula "10") (Formula "12")-        }-      )-    ]--testPivotTable :: PivotTable-testPivotTable =-  PivotTable-  { _pvtName = "PivotTable1"-  , _pvtDataCaption = "Values"-  , _pvtLocation = CellRef "A3:D12"-  , _pvtSrcRef = CellRef "A1:D5"-  , _pvtSrcSheet = "Sheet1"-  , _pvtRowFields = [FieldPosition colorField, DataPosition]-  , _pvtColumnFields = [FieldPosition yearField]-  , _pvtDataFields =-      [ DataField-        { _dfName = "Sum of field Price"-        , _dfField = priceField-        , _dfFunction = ConsolidateSum-        }-      , DataField-        { _dfName = "Sum of field Count"-        , _dfField = countField-        , _dfFunction = ConsolidateSum-        }-      ]-  , _pvtFields =-      [ PivotFieldInfo colorField False-      , PivotFieldInfo yearField True-      , PivotFieldInfo priceField False-      , PivotFieldInfo countField False-      ]-  , _pvtRowGrandTotals = True-  , _pvtColumnGrandTotals = False-  , _pvtOutline = False-  , _pvtOutlineData = False-  }-  where-    colorField = PivotFieldName "Color"-    yearField = PivotFieldName "Year"-    priceField = PivotFieldName "Price"-    countField = PivotFieldName "Count"--testPivotTableDefinition :: ByteString-testPivotTableDefinition = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot table generated by xlsx-->-<pivotTableDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main" name="PivotTable1" cacheId="3" dataOnRows="1" colGrandTotals="0" dataCaption="Values">-  <location ref="A3:D12" firstHeaderRow="1" firstDataRow="2" firstDataCol="1"/>-  <pivotFields>-    <pivotField name="Color" axis="axisRow" showAll="0" outline="0">-      <items>-        <item t="default"/>-      </items>-    </pivotField>-    <pivotField name="Year" axis="axisCol" showAll="0" outline="1">-      <items>-        <item t="default"/>-      </items>-    </pivotField>-    <pivotField name="Price" dataField="1" showAll="0" outline="0"/>-    <pivotField name="Count" dataField="1" showAll="0" outline="0"/>-  </pivotFields>-  <rowFields><field x="0"/><field x="-2"/></rowFields>-  <colFields><field x="1"/></colFields>-  <dataFields>-    <dataField name="Sum of field Price" fld="2"/>-    <dataField name="Sum of field Count" fld="3"/>-  </dataFields>-</pivotTableDefinition>-|]--testPivotCacheDefinition :: ByteString-testPivotCacheDefinition = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?><!--Pivot cache definition generated by xlsx-->-<pivotCacheDefinition xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main"-    invalid="1" refreshOnLoad="1"-    xmlns:ns="http://schemas.openxmlformats.org/officeDocument/2006/relationships">-  <cacheSource type="worksheet">-    <worksheetSource ref="A1:D5" sheet="Sheet1"/>-  </cacheSource>-  <cacheFields>-    <cacheField name="Color"/>-    <cacheField name="Year"/>-    <cacheField name="Price"/>-    <cacheField name="Count"/>-  </cacheFields>-</pivotCacheDefinition>-|]--stripContentSpaces :: Document -> Document-stripContentSpaces doc@Document {documentRoot = root} =-  doc {documentRoot = go root}-  where-    go e@Element {elementNodes = nodes} =-      e {elementNodes = mapMaybe goNode nodes}-    goNode (NodeElement el) = Just $ NodeElement (go el)-    goNode t@(NodeContent txt) =-      if T.strip txt == T.empty-        then Nothing-        else Just t-    goNode other = Just $ other
test/Diff.hs view
@@ -3,11 +3,11 @@ import           Data.Algorithm.Diff       (Diff (..), getGroupedDiff) import           Data.Algorithm.DiffOutput (ppDiff) import           Data.Monoid               ((<>))-import           Test.Tasty.HUnit          (Assertion, assertBool)+import           Test.Tasty.HUnit          (Assertion, HasCallStack, assertBool) import           Text.Groom                (groom)  -- | Like '@=?' but producing a diff on failure.-(@==?) :: (Eq a, Show a) => a -> a -> Assertion+(@==?) :: HasCallStack => (Eq a, Show a) => a -> a -> Assertion x @==? y =     assertBool ("Expected:\n" <> groom x <> "\nDifference:\n" <> msg) (x == y)   where
+ 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.4.1+Version:             1.2.0  Synopsis:            Simple and incomplete Excel file parser/writer Description:@@ -10,12 +10,14 @@     For examples look into "Codec.Xlsx".     .     Format is covered by ECMA-376 standard:-    <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.markdown-+                     data/inline-strings.xlsx+                     data/floats.xlsx+                     data/absolute_relationships.xlsx  Homepage:            https://github.com/qrilka/xlsx Bug-Reports:         https://github.com/qrilka/xlsx/issues@@ -26,15 +28,28 @@  Category:            Codec Build-type:          Simple-Tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+Tested-with:         GHC == 9.2.8, GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4 Cabal-version:       >=1.10 +Flag microlens+  default: False+  description: Use microlens instead of lens + Library   Hs-source-dirs:    src   ghc-options:       -Wall   Exposed-modules:   Codec.Xlsx                    , Codec.Xlsx.Types+                   , Codec.Xlsx.Formatted+                   , Codec.Xlsx.Lens+                   , Codec.Xlsx.Parser+                   , Codec.Xlsx.Parser.Internal+                   , Codec.Xlsx.Parser.Internal.Fast+                   , Codec.Xlsx.Parser.Internal.Util+                   , Codec.Xlsx.Parser.Internal.PivotTable+                   , Codec.Xlsx.Types.AutoFilter+                   , Codec.Xlsx.Types.Cell                    , Codec.Xlsx.Types.Comment                    , Codec.Xlsx.Types.Common                    , Codec.Xlsx.Types.ConditionalFormatting@@ -48,37 +63,53 @@                    , Codec.Xlsx.Types.Internal.ContentTypes                    , Codec.Xlsx.Types.Internal.CustomProperties                    , Codec.Xlsx.Types.Internal.DvPair-                   , Codec.Xlsx.Types.Internal.NumFmtPair+                   , Codec.Xlsx.Types.Internal.FormulaData                    , Codec.Xlsx.Types.Internal.Relationships                    , Codec.Xlsx.Types.Internal.SharedStringTable+                   , Codec.Xlsx.Types.PageSetup                    , Codec.Xlsx.Types.PivotTable                    , Codec.Xlsx.Types.PivotTable.Internal+                   , Codec.Xlsx.Types.Protection+                   , Codec.Xlsx.Types.RefId                    , Codec.Xlsx.Types.RichText                    , Codec.Xlsx.Types.SheetViews-                   , Codec.Xlsx.Types.PageSetup                    , Codec.Xlsx.Types.StyleSheet+                   , Codec.Xlsx.Types.Table                    , Codec.Xlsx.Types.Variant-                   , Codec.Xlsx.Lens-                   , Codec.Xlsx.Parser-                   , Codec.Xlsx.Parser.Internal-                   , Codec.Xlsx.Parser.Internal.PivotTable-                   , Codec.Xlsx.Formatted                    , Codec.Xlsx.Writer                    , Codec.Xlsx.Writer.Internal                    , Codec.Xlsx.Writer.Internal.PivotTable+                   , Codec.Xlsx.Parser.Stream+                   , Codec.Xlsx.Writer.Stream+                   , Codec.Xlsx.Parser.Stream.Row+                   , Codec.Xlsx.Parser.Stream.SheetInfo+                   , Codec.Xlsx.Parser.Stream.SheetItem+                   , Codec.Xlsx.Writer.Internal.Stream -  Build-depends:     base         == 4.*+  -- The only function it exports is also hidden by the upstream library: https://github.com/the-real-blackh/hexpat/blob/master/Text/XML/Expat/SAX.hs#L227+  -- We could expose it but then this function is in the xlsx API for a long time.+  -- It be better to expose it in the upstream library instead I think. It was copied here so the parser can use it.+  Other-modules:     Codec.Xlsx.Parser.Stream.HexpatInternal+                   , Codec.Xlsx.Parser.Internal.Memoize+                   , Codec.Xlsx.Parser.Stream.SheetIdentifier+                   , Codec.Xlsx.Parser.Stream.SheetIndex+                   , Codec.Xlsx.LensCompat++  Build-depends:     base         >= 4.9.0.0 && < 5.0+                   , attoparsec+                   , base64-bytestring                    , binary-search-                   , bytestring   >= 0.10.0.2+                   , bytestring   >= 0.10.8.0                    , conduit      >= 1.0.0                    , containers   >= 0.5.0.0                    , data-default+                   , deepseq      >= 1.4+                   , dlist                    , errors                    , extra                    , filepath-                   , lens         >= 3.8 && < 5+                   , hexpat                    , mtl          >= 2.1-                   , mtl-compat                    , network-uri                    , old-locale   >= 1.0.0.5                    , safe         >= 0.3@@ -86,13 +117,30 @@                    , time         >= 1.4.0.1                    , transformers >= 0.3.0.0                    , vector       >= 0.10+                   , xeno         >= 0.3.2                    , xml-conduit  >= 1.1.0                    , zip-archive  >= 0.2                    , zlib         >= 0.5.4.0-                   , base64-bytestring+                   , zip+                   , zip-stream   >= 0.2.0.1+                   , xml-types+                   , exceptions+                   , transformers-base+                   , monad-control+  if flag(microlens)+    Build-depends:     microlens    >= 0.4 && < 0.5+                     , microlens-mtl+                     , microlens-ghc+                     , microlens-th+                     , profunctors+                     , microlens-platform+                     , indexed-traversable+    cpp-options: -DUSE_MICROLENS+  else+    Build-depends:     lens         >= 3.8 && < 5.4+   Default-Language:     Haskell2010-  Other-Extensions:  CPP-                     DeriveDataTypeable+  Other-Extensions:  DeriveDataTypeable                      FlexibleInstances                      NoMonomorphismRestriction                      OverloadedStrings@@ -103,15 +151,25 @@  test-suite data-test   type: exitcode-stdio-1.0-  main-is:  DataTest.hs+  main-is:  Main.hs   hs-source-dirs: test/-  other-modules: Diff+  other-modules: AutoFilterTests+               , Common+               , CommonTests+               , CommonTests.CellRefTests+               , CondFmtTests+               , Diff+               , DrawingTests+               , PivotTableTests+               , StreamTests+               , Test.SmallCheck.Series.Instances+               , TestXlsx   Build-Depends: base                , bytestring                , containers                , Diff >= 0.3.0+               , directory                , groom-               , lens                , mtl                , raw-strings-qq                , smallcheck@@ -123,8 +181,33 @@                , vector                , xlsx                , xml-conduit >= 1.1.0+               , conduit+               , filepath+               , deepseq+               , zip+  if flag(microlens)+    Build-depends:     microlens    >= 0.4 && < 0.5+                     , microlens-mtl+                     , microlens-platform+                     , microlens-th+    cpp-options: -DUSE_MICROLENS+  else+    Build-depends:     lens         >= 3.8 && < 5.4   Default-Language:     Haskell2010  source-repository head   type:     git   location: git://github.com/qrilka/xlsx.git++benchmark bench+  type: exitcode-stdio-1.0+  hs-source-dirs: benchmarks+  main-is: Main.hs+  build-depends: base+               , bytestring+               , criterion+               , xlsx+               , deepseq+               , conduit+               , lens+  default-language: Haskell2010