xlsx 0.8.4 → 1.0.0
raw patch · 17 files changed
+2326/−563 lines, 17 filesdep +directorydep +dlistdep +exceptionsdep ~conduitdep ~deepseqdep ~lens
Dependencies added: directory, dlist, exceptions, hexpat, indexed-traversable, microlens-platform, monad-control, profunctors, transformers-base, xml-types, zip, zip-stream
Dependency ranges changed: conduit, deepseq, lens, xml-conduit
Files
- CHANGELOG.markdown +6/−0
- benchmarks/Main.hs +27/−0
- src/Codec/Xlsx/Parser.hs +5/−5
- src/Codec/Xlsx/Parser/Internal/Memoize.hs +53/−0
- src/Codec/Xlsx/Parser/Stream.hs +708/−0
- src/Codec/Xlsx/Parser/Stream/HexpatInternal.hs +95/−0
- src/Codec/Xlsx/Types.hs +51/−1
- src/Codec/Xlsx/Types/Common.hs +129/−9
- src/Codec/Xlsx/Writer.hs +2/−1
- src/Codec/Xlsx/Writer/Internal.hs +1/−0
- src/Codec/Xlsx/Writer/Internal/Stream.hs +51/−0
- src/Codec/Xlsx/Writer/Stream.hs +360/−0
- test/CommonTests.hs +18/−3
- test/Main.hs +9/−540
- test/StreamTests.hs +208/−0
- test/TestXlsx.hs +568/−0
- xlsx.cabal +35/−4
CHANGELOG.markdown view
@@ -1,3 +1,9 @@+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.*
benchmarks/Main.hs view
@@ -2,9 +2,17 @@ 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@@ -12,10 +20,29 @@ -- "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 ] ]
src/Codec/Xlsx/Parser.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}@@ -16,7 +17,7 @@ , Parser ) where -import qualified Codec.Archive.Zip as Zip+import qualified "zip-archive" Codec.Archive.Zip as Zip import Control.Applicative import Control.Arrow (left) import Control.Error.Safe (headErr)@@ -27,7 +28,7 @@ #else import Control.Lens hiding ((<.>), element, views) #endif-import Control.Monad (forM, join, void)+import Control.Monad (join, void) import Control.Monad.Except (catchError, throwError) import Data.Bool (bool) import Data.ByteString (ByteString)@@ -54,7 +55,6 @@ import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types import Codec.Xlsx.Types.Cell (formulaDataFromCursor)-import Codec.Xlsx.Types.Common (xlsxTextToCellValue) import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair import Codec.Xlsx.Types.Internal.CommentTable as CommentTable@@ -71,7 +71,7 @@ toXlsx :: L.ByteString -> Xlsx toXlsx = either (error . show) id . toXlsxEither -data ParseError = InvalidZipArchive+data ParseError = InvalidZipArchive String | MissingFile FilePath | InvalidFile FilePath Text | InvalidRef FilePath RefId@@ -106,7 +106,7 @@ -> L.ByteString -> Parser Xlsx toXlsxEitherBase parseSheet bs = do- ar <- left (const InvalidZipArchive) $ Zip.toArchiveOrFail bs+ ar <- left InvalidZipArchive $ Zip.toArchiveOrFail bs sst <- getSharedStrings ar contentTypes <- getContentTypes ar (wfs, names, cacheSources, dateBase) <- readWorkbook ar
+ 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/Stream.hs view
@@ -0,0 +1,708 @@+{-# LANGUAGE CPP #-}+{-# 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 #-}++-- |+-- 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+ , getWorkbookInfo+ , CellRow+ , readSheet+ , countRowsInSheet+ , collectItems+ -- ** Index+ , SheetIndex+ , makeIndex+ , makeIndexFromName+ -- ** 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+#ifdef USE_MICROLENS+import Lens.Micro+import Lens.Micro.GHC ()+import Lens.Micro.Mtl+import Lens.Micro.Platform+import Lens.Micro.TH+#else+import Control.Lens+#endif+import Codec.Xlsx.Parser.Internal+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 Data.IntMap.Strict (IntMap)+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 Control.DeepSeq+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++#ifdef USE_MICROLENS+(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m ()+l <>= a = modify (l <>~ a)+#else+#endif++type CellRow = IntMap Cell++-- | 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++data Row = MkRow+ { _ri_row_index :: Int -- ^ Row number+ , _ri_cell_row :: ~CellRow -- ^ Row itself+ } deriving stock (Generic, Show)+ deriving anyclass NFData++makeLenses 'MkSheetItem+makeLenses 'MkRow++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 SheetState = MkSheetState+ { _ps_row :: ~CellRow -- ^ Current row+ , _ps_sheet_index :: Int -- ^ Current sheet ID (AKA 'sheetInfoSheetId')+ , _ps_cell_row_index :: Int -- ^ Current row number+ , _ps_cell_col_index :: Int -- ^ 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 'MkSheetState++-- | State for parsing shared strings+data SharedStringsState = MkSharedStringsState+ { _ss_string :: TB.Builder -- ^ String we are parsing+ , _ss_list :: DL.DList Text -- ^ list of shared strings+ } deriving stock (Generic, Show)+makeLenses 'MkSharedStringsState++type HasSheetState = MonadState SheetState+type HasSharedStringsState = MonadState SharedStringsState++-- | Represents sheets from the workbook.xml file. E.g.+-- <sheet name="Data" sheetId="1" state="hidden" r:id="rId2" /+data SheetInfo = SheetInfo+ { sheetInfoName :: Text,+ -- | The r:id attribute value.+ sheetInfoRelId :: RefId,+ -- | The sheetId attribute value+ sheetInfoSheetId :: Int+ } deriving (Show, Eq)++-- | 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+initialSheetState :: SheetState+initialSheetState = MkSheetState+ { _ps_row = mempty+ , _ps_sheet_index = 0+ , _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+ StartElement "t" _ -> Nothing <$ (ss_string .= mempty)+ EndElement "t" -> 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+ 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+ sheetNum <- either (throwM . ParseDecimalError sheetId) pure $ eitherDecimal sheetId+ modify' (SheetInfo nm (RefId rId) sheetNum :)+ _ -> 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++sheetIdToRelId :: Int -> XlsxM (Maybe RefId)+sheetIdToRelId sheetId = do+ WorkbookInfo sheets <- getWorkbookInfo+ pure $ sheetInfoRelId <$> find ((== sheetId) . sheetInfoSheetId) sheets++sheetIdToEntrySelector :: Int -> XlsxM (Maybe Zip.EntrySelector)+sheetIdToEntrySelector sheetId = do+ sheetIdToRelId sheetId >>= \case+ Nothing -> pure Nothing+ Just rid -> relIdToEntrySelector rid++-- 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) =>+ Int ->+ XlsxM (Maybe (ConduitT () ByteString m ()))+getSheetXmlSource 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 <- sheetIdToEntrySelector sheetId+ 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 ::+ SheetState ->+ ConduitT () ByteString (C.ResourceT IO) () ->+ (SheetItem -> IO ()) ->+ XlsxM ()+runExpatForSheet initState byteSource inner =+ void $ liftIO $ runExpat initState byteSource handler+ where+ sheetName = _ps_sheet_index initState+ 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 $ MkSheetItem sheetName $ 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.+collectItems ::+ SheetIndex ->+ XlsxM [SheetItem]+collectItems sheetId = do+ res <- liftIO $ newIORef []+ void $ readSheet sheetId $ \item ->+ liftIO (modifyIORef' res (item :))+ fmap reverse $ liftIO $ readIORef res++-- | 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++-- | 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++-- | Look up the index of a case insensitive sheet name+makeIndexFromName :: Text -> XlsxM (Maybe SheetIndex)+makeIndexFromName 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 $ makeIndex . sheetInfoSheetId <$> findRes++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 = do+ mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <-+ getSheetXmlSource sheetId+ let+ case mSrc of+ Nothing -> pure False+ Just sourceSheetXml -> do+ sharedStrs <- getOrParseSharedStringss+ let sheetState0 = initialSheetState+ & ps_shared_strings .~ sharedStrs+ & ps_sheet_index .~ sheetId+ 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'.+countRowsInSheet :: SheetIndex -> XlsxM (Maybe Int)+countRowsInSheet (MkSheetIndex sheetId) = do+ mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <-+ getSheetXmlSource sheetId+ 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 :: HasSheetState 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+ , HasSheetState 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 (_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+ deriving Show+ deriving anyclass Exception++{-# SCC matchHexpatEvent #-}+matchHexpatEvent ::+ ( MonadError SheetErrors m,+ HasSheetState 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, HasSheetState 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+ , HasSheetState 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+ , HasSheetState 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, HasSheetState 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+ Nothing -> pure Untyped+ 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 (Int, Int)+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/Types.hs view
@@ -4,6 +4,8 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE RankNTypes #-}+ module Codec.Xlsx.Types ( -- * The main types Xlsx(..)@@ -48,6 +50,10 @@ , Cell.cellStyle , Cell.cellComment , Cell.cellFormula+ -- ** Row properties+ , rowHeightLens+ , _CustomHeight+ , _AutomaticHeight -- * Style helpers , emptyStyles , renderStyleSheet@@ -64,8 +70,9 @@ import Control.Exception (SomeException, toException) #ifdef USE_MICROLENS import Lens.Micro.TH+import Data.Profunctor(dimap)+import Data.Profunctor.Choice #else-import Control.Lens.TH #endif import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as L@@ -99,6 +106,12 @@ import Codec.Xlsx.Types.Table as X import Codec.Xlsx.Types.Variant as X import Codec.Xlsx.Writer.Internal+#ifdef USE_MICROLENS+import Lens.Micro+#else+import Control.Lens (lens, Lens', makeLenses)+import Control.Lens.TH (makePrisms)+#endif -- | Height of a row in points (1/72in) data RowHeight@@ -109,6 +122,40 @@ deriving (Eq, Ord, Show, Read, Generic) instance NFData RowHeight +#ifdef USE_MICROLENS+-- 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.+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'++_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 #-}++_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 #-}++#else+makePrisms ''RowHeight+#endif++ -- | Properties of a row. See §18.3.1.73 "row (Row)" for more details data RowProperties = RowProps { rowHeight :: Maybe RowHeight@@ -119,6 +166,9 @@ -- ^ Whether row is visible or not } deriving (Eq, Ord, Show, Read, Generic) instance NFData RowProperties++rowHeightLens :: Lens' RowProperties (Maybe RowHeight)+rowHeightLens = lens rowHeight $ \x y -> x{rowHeight=y} instance Default RowProperties where def = RowProps { rowHeight = Nothing
src/Codec/Xlsx/Types/Common.hs view
@@ -1,5 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+ module Codec.Xlsx.Types.Common ( CellRef(..) , singleCellRef@@ -19,6 +24,14 @@ , dateToNumber , int2col , col2int+ -- ** prisms+ , _XlsxText+ , _XlsxRichText+ , _CellText+ , _CellDouble+ , _CellBool+ , _CellRich+ , _CellError ) where import GHC.Generics (Generic)@@ -42,6 +55,15 @@ import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.RichText import Codec.Xlsx.Writer.Internal+#ifdef USE_MICROLENS+import Lens.Micro+import Lens.Micro.Internal+import Lens.Micro.GHC ()+import Data.Profunctor.Choice+import Data.Profunctor(dimap)+#else+import Control.Lens(makePrisms)+#endif -- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\") int2col :: Int -> Text@@ -169,6 +191,7 @@ | CellError ErrorType deriving (Eq, Ord, Show, Generic) + instance NFData CellValue -- | The evaluation of an expression can result in an error having one@@ -251,23 +274,45 @@ baseDate DateBase1900 = fromGregorian 1899 12 30 baseDate DateBase1904 = fromGregorian 1904 1 1 --- | Convertts serial value into datetime according to the specified--- date base+-- | 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"-dateFromNumber :: RealFrac t => DateBase -> t -> UTCTime-dateFromNumber b d = UTCTime day diffTime+-- > 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- (numberOfDays, fractionOfOneDay) = properFraction d- day = addDays numberOfDays $ baseDate b- diffTime = picosecondsToDiffTime (round (fractionOfOneDay * 24*60*60*1E12))+ 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+-- | 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 day $ baseDate b)+ 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@@ -385,3 +430,78 @@ toAttrVal ErrorNum = "#NUM!" toAttrVal ErrorRef = "#REF!" toAttrVal ErrorValue = "#VALUE!"++#ifdef USE_MICROLENS+-- 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.+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'++_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 #-}++#else+makePrisms ''XlsxText+makePrisms ''CellValue+#endif
src/Codec/Xlsx/Writer.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE PackageImports #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveGeneric #-} -- | This module provides a function for serializing structured `Xlsx` into lazy bytestring@@ -9,7 +10,7 @@ ( fromXlsx ) where -import qualified Codec.Archive.Zip as Zip+import qualified "zip-archive" Codec.Archive.Zip as Zip import Control.Arrow (second) #ifdef USE_MICROLENS import Lens.Micro
src/Codec/Xlsx/Writer/Internal.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-}+ module Codec.Xlsx.Writer.Internal ( -- * Rendering documents ToDocument(..)
+ src/Codec/Xlsx/Writer/Internal/Stream.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE CPP #-}+{-# 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+++#ifdef USE_MICROLENS+import Lens.Micro.Platform+#else+import Control.Lens+#endif+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,360 @@+{-# LANGUAGE CPP #-}+{-# 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+ , writeXlsxWithSharedStrings+ , SheetWriteSettings(..)+ , defaultSettings+ , wsSheetView+ , wsZip+ , wsColumnProperties+ , wsRowProperties+ , wsStyles+ -- *** Shared strings+ , sharedStrings+ , sharedStringsStream+ ) where++import Codec.Archive.Zip.Conduit.UnZip+import Codec.Archive.Zip.Conduit.Zip+import Codec.Xlsx.Parser.Internal (n_)+import Codec.Xlsx.Parser.Stream+import Codec.Xlsx.Types (ColumnsProperties (..), RowProperties (..),+ Styles (..), _AutomaticHeight, _CustomHeight,+ emptyStyles, rowHeightLens)+import Codec.Xlsx.Types.Cell+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.Internal.Relationships (odr, pr)+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+#ifdef USE_MICROLENS+import Data.Traversable.WithIndex+import Lens.Micro.Platform+#else+import Control.Lens+#endif+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)+++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.+--+-- Note that the current implementation concatenates everything into a single sheet.+-- In other words there is no support for writing multiple sheets+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+ sstrings <- sheetC .| sharedStrings+ writeXlsxWithSharedStrings settings sstrings sheetC+++-- 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+ -> ConduitT () Row m ()+ -> ConduitT () ByteString m Word64+writeXlsxWithSharedStrings settings sharedStrings' items =+ combinedFiles settings sharedStrings' items .| zipStream (settings ^. wsZip)++-- massive amount of boilerplate needed for excel to function+boilerplate :: forall m . PrimMonad m => SheetWriteSettings -> Map Text Int -> [(ZipEntry, ZipData m)]+boilerplate settings sharedStrings' =+ [ (zipEntry "xl/sharedStrings.xml", ZipDataSource $ writeSst sharedStrings' .| eventsToBS)+ , (zipEntry "[Content_Types].xml", ZipDataSource $ writeContentTypes .| eventsToBS)+ , (zipEntry "xl/workbook.xml", ZipDataSource $ writeWorkbook .| eventsToBS)+ , (zipEntry "xl/styles.xml", ZipDataByteString $ coerce $ settings ^. wsStyles)+ , (zipEntry "xl/_rels/workbook.xml.rels", ZipDataSource $ writeWorkbookRels .| eventsToBS)+ , (zipEntry "_rels/.rels", ZipDataSource $ writeRootRels .| eventsToBS)+ ]++combinedFiles :: PrimMonad m+ => SheetWriteSettings+ -> Map Text Int+ -> ConduitT () Row m ()+ -> ConduitT () (ZipEntry, ZipData m) m ()+combinedFiles settings sharedStrings' items =+ C.yieldMany $+ boilerplate settings sharedStrings' <>+ [(zipEntry "xl/worksheets/sheet1.xml", ZipDataSource $+ items .| C.runReaderC settings (writeWorkSheet sharedStrings') .| eventsToBS )]++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 => forall i. ConduitT i Event m ()+writeWorkbook = doc (n_ "workbook") $ do+ el (n_ "sheets") $ do+ tag (n_ "sheet")+ (attr "name" "Sheet1"+ <> attr "sheetId" "1" <>+ attr (odr "id") "rId3") $+ pure ()++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. ConduitT i Event m ()+writeWorkbookRels = doc (pr "Relationships") $ do+ relationship "sharedStrings.xml" 1 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings"+ relationship "worksheets/sheet1.xml" 3 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet"+ relationship "styles.xml" 2 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles"++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 (n_ "sst") $+ void $ traverse (el (n_ "si") . el (n_ "t") . content . fst+ ) $ sortBy (\(_, i) (_, y :: Int) -> compare i y) $ Map.toList sharedStrings'++writeEvents :: PrimMonad m => ConduitT Event Builder m ()+writeEvents = renderBuilder (def {rsPretty=False})++sheetViews :: forall m . MonadReader SheetWriteSettings m => forall i . ConduitT i Event m ()+sheetViews = do+ sheetView <- view wsSheetView++ unless (null sheetView) $ el (n_ "sheetViews") $ do+ let+ view' :: [Element]+ view' = setNameSpaceRec spreadSheetNS . toXMLElement . toElement (n_ "sheetView") <$> sheetView++ C.yieldMany $ elementToEvents =<< view'++spreadSheetNS :: Text+spreadSheetNS = fold $ nameNamespace $ n_ ""++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 (n_ "cols") $ map (toElement (n_ "col")) colProps+ traverse_ (C.yieldMany . elementToEvents . toXMLElement) cols++writeWorkSheet :: MonadReader SheetWriteSettings m => Map Text Int -> ConduitT Row Event m ()+writeWorkSheet sharedStrings' = doc (n_ "worksheet") $ do+ sheetViews+ columns+ el (n_ "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 rowIx . rowHeightLens . _Just . failing _CustomHeight _AutomaticHeight+ let rowAttr :: Attributes+ rowAttr = ixAttr <> fold (attr "ht" . txtd <$> mRowProp)+ tag (n_ "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 -> Int -> Int -> Cell -> ConduitT Row Event m ()+mapCell sharedStrings' rix cix cell =+ when (has (cellValue . _Just) cell || has (cellStyle . _Just) cell) $+ tag (n_ "c") celAttr $+ when (has (cellValue . _Just) cell) $+ el (n_ "v") $+ content $ renderCell sharedStrings' cell+ where+ 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/CommonTests.hs view
@@ -7,6 +7,8 @@ ) 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 (Positive(..), Serial(..), newtypeCons, cons0, (\/))@@ -22,18 +24,31 @@ [ testProperty "col2int . int2col == id" $ \(Positive i) -> i == col2int (int2col i) , testCase "date conversions" $ do- dateFromNumber DateBase1900 (- 2338.0) @?= read "1893-08-05 00:00:00 UTC"- dateFromNumber DateBase1900 2.0 @?= read "1900-01-01 00:00:00 UTC"+ 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" $- \b (n :: Pico) -> n == dateToNumber b (dateFromNumber b $ n)+ -- 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) ] instance Monad m => Serial m (Fixed E12) where
test/Main.hs view
@@ -1,18 +1,9 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE QuasiQuotes #-} module Main ( main ) where -#ifdef USE_MICROLENS-import Lens.Micro-import Lens.Micro.Mtl-#else-import Control.Lens-#endif import Control.Monad.State.Lazy import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LB@@ -20,6 +11,7 @@ import qualified Data.Map as M import Data.Time.Clock.POSIX (POSIXTime) import qualified Data.Vector as V+import qualified StreamTests import Text.RawString.QQ import Text.XML @@ -27,13 +19,13 @@ import Test.Tasty.HUnit (testCase) import Test.Tasty.HUnit ((@=?))+import TestXlsx 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.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.SharedStringTable import AutoFilterTests@@ -41,13 +33,14 @@ import CommonTests import CondFmtTests import Diff-import PivotTableTests import DrawingTests+import PivotTableTests main :: IO () main = defaultMain $ testGroup "Tests"- [ testCase "write . read == id" $ do+ [+ testCase "write . read == id" $ do let bs = fromXlsx testTime testXlsx LB.writeFile "data-test.xlsx" bs testXlsx @==? toXlsx (fromXlsx testTime testXlsx)@@ -84,535 +77,11 @@ , testCase "toXlsxEither: properly formatted" $ Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) , testCase "toXlsxEither: invalid format" $- Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file"+ Left (InvalidZipArchive "Did not find end of central directory signature") @==? toXlsxEither "this is not a valid XLSX file" , CommonTests.tests , CondFmtTests.tests , PivotTableTests.tests , DrawingTests.tests , AutoFilterTests.tests- ]--testXlsx :: Xlsx-testXlsx = Xlsx sheets minimalStyles definedNames customProperties DateBase1904- where- sheets =- [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)]- sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges- sheetViews pageSetup cFormatting validations [] (Just autoFilter)- tables (Just protection) sharedFormulas- 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- 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)--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" True)- , (CellRef "A2", Comment (XlsxText "Some comment here") "CBR" True) ]- where- rich = [ RichTextRun- { _richTextRunProperties =- Just $ def & runPropertiesBold ?~ True- & runPropertiesCharset ?~ 1- & runPropertiesColor ?~ def -- TODO: why not Nothing here?- & runPropertiesFont ?~ "Calibri"- & runPropertiesScheme ?~ FontSchemeMinor- & runPropertiesSize ?~ 8.0- , _richTextRunText = "Bob:"}- , RichTextRun- { _richTextRunProperties =- Just $ def & runPropertiesCharset ?~ 1- & runPropertiesColor ?~ def- & runPropertiesFont ?~ "Calibri"- & runPropertiesScheme ?~ FontSchemeMinor- & runPropertiesSize ?~ 8.0- , _richTextRunText = "Why such high expense?"}]--testStrings :: ByteString-testStrings = [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">- <text>- <r>- <rPr>- <b/><sz val="8"/><color indexed="81"/><rFont val="Calibri"/>- <charset val="1"/><scheme val="minor"/>- </rPr>- <t>Bob:</t>- </r>- <r>- <rPr>- <sz val="8"/><color indexed="81"/><rFont val="Calibri"/>- <charset val="1"/> <scheme val="minor"/>- </rPr>- <t xml:space="preserve">Why such high expense?</t>- </r>- </text>- </comment>- <comment ref="A2" authorId="1">- <text><t>Some comment here</t></text>- </comment>- </commentList>-</comments>-|]--testCustomProperties :: CustomProperties-testCustomProperties = CustomProperties.fromList- [ ("testTextProp", VtLpwstr "test text property value")- , ("prop2", VtLpwstr "222")- , ("bool", VtBool False)- , ("prop333", VtInt 1)- , ("decimal", VtDecimal 1.234) ]--testCustomPropertiesXml :: ByteString-testCustomPropertiesXml = [r|-<?xml version="1.0" encoding="UTF-8" standalone="yes"?>-<Properties xmlns="http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="2" name="prop2">- <vt:lpwstr>222</vt:lpwstr>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="3" name="prop333">- <vt:int>1</vt:int>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="4" name="testTextProp">- <vt:lpwstr>test text property value</vt:lpwstr>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="5" name="decimal">- <vt:decimal>1.234</vt:decimal>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="6" name="bool">- <vt:bool>false</vt:bool>- </property>- <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="7" name="blob">- <vt:blob>- ZXhhbXBs- ZSBibG9i- IGNvbnRl- bnRz- </vt:blob>- </property>-</Properties>-|]--testFormattedResult :: Formatted-testFormattedResult = Formatted cm styleSheet merges- where- cm = M.fromList [ ((1, 1), cell11)- , ((1, 2), cell12)- , ((2, 5), cell25) ]- cell11 = Cell- { _cellStyle = Just 1- , _cellValue = Just (CellText "text at A1")- , _cellComment = Nothing- , _cellFormula = Nothing }- cell12 = Cell- { _cellStyle = Just 2- , _cellValue = Just (CellDouble 1.23)- , _cellComment = Nothing- , _cellFormula = Nothing }- cell25 = Cell- { _cellStyle = Just 3- , _cellValue = Just (CellDouble 1.23456)- , _cellComment = Nothing- , _cellFormula = Nothing }- merges = []- styleSheet =- minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3])- & styleSheetFonts %~ (++ [font1, font2])- & styleSheetNumFmts .~ numFmts- nextFontId = length (minimalStyleSheet ^. styleSheetFonts)- cellXf1 = def- { _cellXfApplyFont = Just True- , _cellXfFontId = Just nextFontId }- font1 = def- { _fontName = Just "Calibri"- , _fontBold = Just True }- cellXf2 = def- { _cellXfApplyFont = Just True- , _cellXfFontId = Just (nextFontId + 1)- , _cellXfApplyNumberFormat = Just True- , _cellXfNumFmtId = Just 164 }- font2 = def- { _fontItalic = Just True }- cellXf3 = def- { _cellXfApplyNumberFormat = Just True- , _cellXfNumFmtId = Just 2 }- numFmts = M.fromList [(164, "0.0000")]--testRunFormatted :: Formatted-testRunFormatted = formatted formattedCellMap minimalStyleSheet- where- formattedCellMap = flip execState def $ do- let font1 = def & fontBold ?~ True- & fontName ?~ "Calibri"- at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1"- & formattedFormat . formatFont ?~ font1)- at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23- & formattedFormat . formatFont . non def . fontItalic ?~ True- & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4)- at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456- & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal)--testFormatWorkbookResult :: Xlsx-testFormatWorkbookResult = def & xlSheets .~ sheets- & xlStyles .~ renderStyleSheet style- where- testCellMap1 = M.fromList [((1, 1), Cell { _cellStyle = Nothing- , _cellValue = Just (CellText "text at A1 Sheet1")- , _cellComment = Nothing- , _cellFormula = Nothing })]- testCellMap2 = M.fromList [((2, 3), Cell { _cellStyle = Just 1- , _cellValue = Just (CellDouble 1.23456)- , _cellComment = Nothing- , _cellFormula = Nothing })]- sheets = [ ("Sheet1", def & wsCells .~ testCellMap1)- , ("Sheet2", def & wsCells .~ testCellMap2)- ]- 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 (Int, Int) FormattedCell-testFormattedCells = flip execState def $ do- at (1,1) ?= (def & formattedRowSpan .~ 5- & formattedColSpan .~ 5- & formattedFormat . formatBorder . non def . borderTop .- non def . borderStyleLine ?~ LineStyleDashed- & formattedFormat . formatBorder . non def . borderBottom .- non def . borderStyleLine ?~ LineStyleDashed)- at (10,2) ?= (def & formattedFormat . formatFont . non def . fontBold ?~ True)--testRunCondFormatted :: CondFormatted-testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet- where- condFmts = flip execState def $ do- let cfRule1 = def & condfmtCondition .~ ContainsBlanks- & condfmtDxf . dxfFont . non def . fontUnderline ?~ FontUnderlineSingle- cfRule2 = def & condfmtCondition .~ BeginsWith "foo"- & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True- cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1"))- & condfmtDxf . dxfFont . non def . fontBold ?~ True- at (CellRef "A1:A2") ?= [cfRule1, cfRule2]- at (CellRef "B2:B3") ?= [cfRule1, cfRule2]- at (CellRef "C3:E10") ?= [cfRule1]- at (CellRef "F1:G10") ?= [cfRule3]--validations :: Map SqRef DataValidation-validations = M.fromList- [ ( SqRef [CellRef "A1"], def- )- , ( SqRef [CellRef "A1", CellRef "B2:C3"], def- { _dvAllowBlank = True- , _dvError = Just "incorrect data"- , _dvErrorStyle = ErrorStyleInformation- , _dvErrorTitle = Just "error title"- , _dvPrompt = Just "enter data"- , _dvPromptTitle = Just "prompt title"- , _dvShowDropDown = True- , _dvShowErrorMessage = True- , _dvShowInputMessage = True- , _dvValidationType = ValidationTypeList ["aaaa","bbbb","cccc"]- }- )- , ( SqRef [CellRef "A6", CellRef "I2"], def- { _dvAllowBlank = False- , _dvError = Just "aaa"- , _dvErrorStyle = ErrorStyleWarning- , _dvErrorTitle = Just "bbb"- , _dvPrompt = Just "ccc"- , _dvPromptTitle = Just "ddd"- , _dvShowDropDown = False- , _dvShowErrorMessage = False- , _dvShowInputMessage = False- , _dvValidationType = ValidationTypeDecimal $ ValGreaterThan $ Formula "10"- }- )- , ( SqRef [CellRef "A7"], def- { _dvAllowBlank = False- , _dvError = Just "aaa"- , _dvErrorStyle = ErrorStyleStop- , _dvErrorTitle = Just "bbb"- , _dvPrompt = Just "ccc"- , _dvPromptTitle = Just "ddd"- , _dvShowDropDown = False- , _dvShowErrorMessage = False- , _dvShowInputMessage = False- , _dvValidationType = ValidationTypeWhole $ ValNotBetween (Formula "10") (Formula "12")- }- )+ , StreamTests.tests ]
+ test/StreamTests.hs view
@@ -0,0 +1,208 @@+{-# 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.Xlsx+import Codec.Xlsx.Parser.Stream+import Codec.Xlsx.Types.Common+import Codec.Xlsx.Types.Internal.SharedStringTable+import Conduit ((.|))+import qualified Conduit as C+import Control.Exception (bracket)+import Control.Lens hiding (indexed)+import Data.Set.Lens+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString as BS+import Data.Map (Map)+import qualified Data.Map as M+import qualified Data.Map as Map+import qualified Data.IntMap.Strict as IM+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text as Text+import Data.Vector (Vector, indexed, toList)+import Diff+import System.Directory (getTemporaryDirectory)+import System.FilePath.Posix+import Test.Tasty (TestName, TestTree, testGroup)+import Test.Tasty.HUnit (testCase)+import TestXlsx+import Text.RawString.QQ+import Text.XML+import qualified Codec.Xlsx.Writer.Stream as SW+import qualified Codec.Xlsx.Writer.Internal.Stream as SW+import Control.Monad.State.Lazy+import Test.Tasty.SmallCheck+import qualified Data.Set as Set+import Data.Set (Set)+import Text.Printf+import Debug.Trace+import Control.DeepSeq+import Data.Conduit+import Codec.Xlsx.Formatted++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/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 sqaure" $ 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 "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+ ]+ ]++readWrite :: Xlsx -> IO ()+readWrite input = do+ BS.writeFile "testinput.xlsx" (toBs input)+ items <- fmap (toListOf (traversed . si_row)) $ runXlsxM "testinput.xlsx" $ collectItems $ makeIndex 1+ 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++-- 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 = set xlSheets sheets def+ where+ sheets = [("Sheet1" , toWs [((1,1), a1), ((1,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 = set xlSheets sheets def+ where+ sheets = [("Sheet1" , toWs [((1,1), a1), ((2,1), cellValue ?~ CellText "text at A2 Sheet1" $ def)])]+++tshow :: Show a => a -> Text+tshow = Text.pack . show++toWs :: [((Int,Int), Cell)] -> Worksheet+toWs x = set wsCells (M.fromList x) def++-- can we do xxx+-- xxx+-- .+-- .+smallWorkbook :: Xlsx+smallWorkbook = set xlSheets sheets def+ where+ sheets = [("Sheet1" , 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)+ ]+ )]+bigWorkbook :: Xlsx+bigWorkbook = set xlSheets sheets def+ where+ sheets = [("Sheet1" , 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")+ ]+ )]++inlineStringsAreParsed :: IO ()+inlineStringsAreParsed = do+ items <- runXlsxM "data/inline-strings.xlsx" $ collectItems $ makeIndex 1+ 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 . si_row . ri_cell_row)++#endif
+ test/TestXlsx.hs view
@@ -0,0 +1,568 @@+{-# 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 qualified Data.ByteString.Lazy as LB+import Data.Map (Map)+import qualified Data.Map as M+import Data.Time.Clock.POSIX (POSIXTime)+import qualified Data.Vector as V+import Text.RawString.QQ+import Text.XML++import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.HUnit (testCase)++import Test.Tasty.HUnit ((@=?))++import Codec.Xlsx+import Codec.Xlsx.Formatted+import Codec.Xlsx.Types.Internal+import Codec.Xlsx.Types.Internal.CommentTable+import Codec.Xlsx.Types.Internal.CustomProperties+ as CustomProperties+import Codec.Xlsx.Types.Internal.SharedStringTable++import AutoFilterTests+import Common+import CommonTests+import CondFmtTests+import Diff+import PivotTableTests+import DrawingTests++testXlsx :: Xlsx+testXlsx = Xlsx sheets minimalStyles definedNames customProperties DateBase1904+ where+ sheets =+ [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)]+ sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges+ sheetViews pageSetup cFormatting validations [] (Just autoFilter)+ tables (Just protection) sharedFormulas+ 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+ 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)++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" True)+ , (CellRef "A2", Comment (XlsxText "Some comment here") "CBR" True) ]+ where+ rich = [ RichTextRun+ { _richTextRunProperties =+ Just $ def & runPropertiesBold ?~ True+ & runPropertiesCharset ?~ 1+ & runPropertiesColor ?~ def -- TODO: why not Nothing here?+ & runPropertiesFont ?~ "Calibri"+ & runPropertiesScheme ?~ FontSchemeMinor+ & runPropertiesSize ?~ 8.0+ , _richTextRunText = "Bob:"}+ , RichTextRun+ { _richTextRunProperties =+ Just $ def & runPropertiesCharset ?~ 1+ & runPropertiesColor ?~ def+ & runPropertiesFont ?~ "Calibri"+ & runPropertiesScheme ?~ FontSchemeMinor+ & runPropertiesSize ?~ 8.0+ , _richTextRunText = "Why such high expense?"}]++testStrings :: ByteString+testStrings = [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">+ <text>+ <r>+ <rPr>+ <b/><sz val="8"/><color indexed="81"/><rFont val="Calibri"/>+ <charset val="1"/><scheme val="minor"/>+ </rPr>+ <t>Bob:</t>+ </r>+ <r>+ <rPr>+ <sz val="8"/><color indexed="81"/><rFont val="Calibri"/>+ <charset val="1"/> <scheme val="minor"/>+ </rPr>+ <t xml:space="preserve">Why such high expense?</t>+ </r>+ </text>+ </comment>+ <comment ref="A2" authorId="1">+ <text><t>Some comment here</t></text>+ </comment>+ </commentList>+</comments>+|]++testCustomProperties :: CustomProperties+testCustomProperties = CustomProperties.fromList+ [ ("testTextProp", VtLpwstr "test text property value")+ , ("prop2", VtLpwstr "222")+ , ("bool", VtBool False)+ , ("prop333", VtInt 1)+ , ("decimal", VtDecimal 1.234) ]++testCustomPropertiesXml :: ByteString+testCustomPropertiesXml = [r|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<Properties xmlns="http://schemas.openxmlformats.org/officeDocument/2006/custom-properties" xmlns:vt="http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes">+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="2" name="prop2">+ <vt:lpwstr>222</vt:lpwstr>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="3" name="prop333">+ <vt:int>1</vt:int>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="4" name="testTextProp">+ <vt:lpwstr>test text property value</vt:lpwstr>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="5" name="decimal">+ <vt:decimal>1.234</vt:decimal>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="6" name="bool">+ <vt:bool>false</vt:bool>+ </property>+ <property fmtid="{D5CDD505-2E9C-101B-9397-08002B2CF9AE}" pid="7" name="blob">+ <vt:blob>+ ZXhhbXBs+ ZSBibG9i+ IGNvbnRl+ bnRz+ </vt:blob>+ </property>+</Properties>+|]++testFormattedResult :: Formatted+testFormattedResult = Formatted cm styleSheet merges+ where+ cm = M.fromList [ ((1, 1), cell11)+ , ((1, 2), cell12)+ , ((2, 5), cell25) ]+ cell11 = Cell+ { _cellStyle = Just 1+ , _cellValue = Just (CellText "text at A1")+ , _cellComment = Nothing+ , _cellFormula = Nothing }+ cell12 = Cell+ { _cellStyle = Just 2+ , _cellValue = Just (CellDouble 1.23)+ , _cellComment = Nothing+ , _cellFormula = Nothing }+ cell25 = Cell+ { _cellStyle = Just 3+ , _cellValue = Just (CellDouble 1.23456)+ , _cellComment = Nothing+ , _cellFormula = Nothing }+ merges = []+ styleSheet =+ minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3])+ & styleSheetFonts %~ (++ [font1, font2])+ & styleSheetNumFmts .~ numFmts+ nextFontId = length (minimalStyleSheet ^. styleSheetFonts)+ cellXf1 = def+ { _cellXfApplyFont = Just True+ , _cellXfFontId = Just nextFontId }+ font1 = def+ { _fontName = Just "Calibri"+ , _fontBold = Just True }+ cellXf2 = def+ { _cellXfApplyFont = Just True+ , _cellXfFontId = Just (nextFontId + 1)+ , _cellXfApplyNumberFormat = Just True+ , _cellXfNumFmtId = Just 164 }+ font2 = def+ { _fontItalic = Just True }+ cellXf3 = def+ { _cellXfApplyNumberFormat = Just True+ , _cellXfNumFmtId = Just 2 }+ numFmts = M.fromList [(164, "0.0000")]++testRunFormatted :: Formatted+testRunFormatted = formatted formattedCellMap minimalStyleSheet+ where+ formattedCellMap = flip execState def $ do+ let font1 = def & fontBold ?~ True+ & fontName ?~ "Calibri"+ at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1"+ & formattedFormat . formatFont ?~ font1)+ at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23+ & formattedFormat . formatFont . non def . fontItalic ?~ True+ & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4)+ at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456+ & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal)++testFormatWorkbookResult :: Xlsx+testFormatWorkbookResult = def & xlSheets .~ sheets+ & xlStyles .~ renderStyleSheet style+ where+ testCellMap1 = M.fromList [((1, 1), Cell { _cellStyle = Nothing+ , _cellValue = Just (CellText "text at A1 Sheet1")+ , _cellComment = Nothing+ , _cellFormula = Nothing })]+ testCellMap2 = M.fromList [((2, 3), Cell { _cellStyle = Just 1+ , _cellValue = Just (CellDouble 1.23456)+ , _cellComment = Nothing+ , _cellFormula = Nothing })]+ sheets = [ ("Sheet1", def & wsCells .~ testCellMap1)+ , ("Sheet2", def & wsCells .~ testCellMap2)+ ]+ 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 (Int, Int) FormattedCell+testFormattedCells = flip execState def $ do+ at (1,1) ?= (def & formattedRowSpan .~ 5+ & formattedColSpan .~ 5+ & formattedFormat . formatBorder . non def . borderTop .+ non def . borderStyleLine ?~ LineStyleDashed+ & formattedFormat . formatBorder . non def . borderBottom .+ non def . borderStyleLine ?~ LineStyleDashed)+ at (10,2) ?= (def & formattedFormat . formatFont . non def . fontBold ?~ True)++testRunCondFormatted :: CondFormatted+testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet+ where+ condFmts = flip execState def $ do+ let cfRule1 = def & condfmtCondition .~ ContainsBlanks+ & condfmtDxf . dxfFont . non def . fontUnderline ?~ FontUnderlineSingle+ cfRule2 = def & condfmtCondition .~ BeginsWith "foo"+ & condfmtDxf . dxfFont . non def . fontStrikeThrough ?~ True+ cfRule3 = def & condfmtCondition .~ CellIs (OpGreaterThan (Formula "A1"))+ & condfmtDxf . dxfFont . non def . fontBold ?~ True+ at (CellRef "A1:A2") ?= [cfRule1, cfRule2]+ at (CellRef "B2:B3") ?= [cfRule1, cfRule2]+ at (CellRef "C3:E10") ?= [cfRule1]+ at (CellRef "F1:G10") ?= [cfRule3]++validations :: Map SqRef DataValidation+validations = M.fromList+ [ ( SqRef [CellRef "A1"], def+ )+ , ( SqRef [CellRef "A1", CellRef "B2:C3"], def+ { _dvAllowBlank = True+ , _dvError = Just "incorrect data"+ , _dvErrorStyle = ErrorStyleInformation+ , _dvErrorTitle = Just "error title"+ , _dvPrompt = Just "enter data"+ , _dvPromptTitle = Just "prompt title"+ , _dvShowDropDown = True+ , _dvShowErrorMessage = True+ , _dvShowInputMessage = True+ , _dvValidationType = ValidationTypeList ["aaaa","bbbb","cccc"]+ }+ )+ , ( SqRef [CellRef "A6", CellRef "I2"], def+ { _dvAllowBlank = False+ , _dvError = Just "aaa"+ , _dvErrorStyle = ErrorStyleWarning+ , _dvErrorTitle = Just "bbb"+ , _dvPrompt = Just "ccc"+ , _dvPromptTitle = Just "ddd"+ , _dvShowDropDown = False+ , _dvShowErrorMessage = False+ , _dvShowInputMessage = False+ , _dvValidationType = ValidationTypeDecimal $ ValGreaterThan $ Formula "10"+ }+ )+ , ( SqRef [CellRef "A7"], def+ { _dvAllowBlank = False+ , _dvError = Just "aaa"+ , _dvErrorStyle = ErrorStyleStop+ , _dvErrorTitle = Just "bbb"+ , _dvPrompt = Just "ccc"+ , _dvPromptTitle = Just "ddd"+ , _dvShowDropDown = False+ , _dvShowErrorMessage = False+ , _dvShowInputMessage = False+ , _dvValidationType = ValidationTypeWhole $ ValNotBetween (Formula "10") (Formula "12")+ }+ )+ ]
xlsx.cabal view
@@ -1,6 +1,6 @@ Name: xlsx -Version: 0.8.4+Version: 1.0.0 Synopsis: Simple and incomplete Excel file parser/writer Description:@@ -26,7 +26,7 @@ Category: Codec Build-type: Simple-Tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.1+Tested-with: GHC == 8.8.4, GHC == 8.10.4, GHC == 9.0.2, GHC == 9.2.2 Cabal-version: >=1.10 Flag microlens@@ -76,7 +76,16 @@ , Codec.Xlsx.Writer , Codec.Xlsx.Writer.Internal , Codec.Xlsx.Writer.Internal.PivotTable+ , Codec.Xlsx.Parser.Stream+ , Codec.Xlsx.Writer.Stream+ , Codec.Xlsx.Writer.Internal.Stream + -- 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+ Build-depends: base >= 4.9.0.0 && < 5.0 , attoparsec , base64-bytestring@@ -86,9 +95,11 @@ , containers >= 0.5.0.0 , data-default , deepseq >= 1.4+ , dlist , errors , extra , filepath+ , hexpat , mtl >= 2.1 , network-uri , old-locale >= 1.0.0.5@@ -101,14 +112,23 @@ , xml-conduit >= 1.1.0 , zip-archive >= 0.2 , zlib >= 0.5.4.0+ , zip+ , zip-stream >= 0.2.0.1+ , xml-types+ , exceptions+ , transformers-base+ , monad-control if flag(microlens) Build-depends: microlens >= 0.4 && < 0.5 , microlens-mtl , microlens-ghc , microlens-th+ , profunctors+ , microlens-platform+ , indexed-traversable cpp-options: -DUSE_MICROLENS else- Build-depends: lens >= 3.8 && < 5.1+ Build-depends: lens >= 3.8 && < 5.2 Default-Language: Haskell2010 Other-Extensions: DeriveDataTypeable@@ -131,11 +151,14 @@ , Diff , DrawingTests , PivotTableTests+ , StreamTests , Test.SmallCheck.Series.Instances+ , TestXlsx Build-Depends: base , bytestring , containers , Diff >= 0.3.0+ , directory , groom , mtl , raw-strings-qq@@ -148,12 +171,17 @@ , vector , xlsx , xml-conduit >= 1.1.0+ , conduit+ , filepath+ , deepseq 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.1+ Build-depends: lens >= 3.8 && < 5.2 Default-Language: Haskell2010 source-repository head@@ -168,4 +196,7 @@ , bytestring , criterion , xlsx+ , deepseq+ , conduit+ , lens default-language: Haskell2010