diff --git a/.DS_Store b/.DS_Store new file mode 100644 index 00000000..4367fbc2 Binary files /dev/null and b/.DS_Store differ diff --git a/.gitignore b/.gitignore index 02d18a82..5d2a7368 100644 --- a/.gitignore +++ b/.gitignore @@ -1,10 +1,15 @@ TAGS cabal-dev dist +dist-newstyle *sandbox* #*# *.*~ specs samples .stack-work -*.lock \ No newline at end of file +*.lock + +# nix +result +result-doc diff --git a/Streamin.md b/Streamin.md new file mode 100644 index 00000000..13e3f251 --- /dev/null +++ b/Streamin.md @@ -0,0 +1,31 @@ +Simple xlsx parser/writer, only basic functionality at the moment + +This is a draft PR so ya'll can see what I'm doing and have an opportunity to voice concerns early. + +I'm going to do reading from stream first (our company needs both reading and writing). +I'll work on writing stream support once the reading is implemented. + +Okay the strat is to index by + +``` +SheetItem = { + cellRow + allKnownSheetStaticProps +} + +XslxItem = { + sheetItem + allKnownStaticProps +} + +result :: Conduit + ByteString -- Input + XslxItem -- Output + m +``` + + So the conduit pipes gets bytestring chuncks and produces XslxItems which contain a single excell row. + Nested within a sheet, nested within an excell item. + If we can figure out other properties before starting the stream we'll just add that information to the pipeline and copy it. + + https://hackage.haskell.org/package/xml-conduit-1.9.0.0/docs/Text-XML-Stream-Parse.html diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs new file mode 100644 index 00000000..ec0072f5 --- /dev/null +++ b/benchmarks/Stream.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Codec.Xlsx +import Codec.Xlsx.Parser.Stream +import Conduit +import qualified Conduit as C +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import qualified Data.Conduit.Combinators as C +import Data.Function +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Debug.Trace +import Prelude hiding (foldl) + +celVal :: CellValue -> Text +celVal = \case + CellText x -> x + CellDouble x -> Text.pack $ show x + CellBool x -> Text.pack $ show x + CellRich x -> Text.pack $ show x + CellError x -> Text.pack $ show x + +format :: SheetItem -> Text +format x = Text.pack $ show (_si_sheet x, _si_row_index x, maybe "" celVal . _cellValue <$> _si_cell_row x) + +parseFileStream :: FilePath -> IO () +parseFileStream filepath = do + input <- + sourceFile filepath + & readXlsxC + & runResourceT + _ <- runResourceT $ runConduit (parseConduit input) + pure () + where + parseConduit + :: Monad m + => ConduitM a SheetItem m () + -> ConduitM a Void m [SheetItem] + parseConduit input = + input + .| C.filter (("sheet1.xml" ==) . _si_sheet) + .| C.foldl (\a b -> a <> [b]) [] + +parseFile :: FilePath -> IO () +parseFile filepath = do + contents <- LB.readFile filepath + let !_ = toXlsx contents + pure () + +parseFileFast :: FilePath -> IO () +parseFileFast filepath = do + contents <- LB.readFile filepath + let !_ = toXlsxFast contents + pure () + +main :: IO () +main = let + files = + [ "data/simple.xlsx" + , "data/testInput.xlsx" + , "data/6000.rows.x.26.cols.xlsx" + ] + benchFiles parse filename = bench ("parsing " <> filename) . nfIO $ parse filename + in defaultMain + [ bgroup "stream" $ benchFiles parseFileStream <$> files + , bgroup "canonical" $ benchFiles parseFile <$> files + , bgroup "canonical fast" $ benchFiles parseFileFast <$> files + ] diff --git a/cabal.project.local b/cabal.project.local new file mode 100644 index 00000000..f59b26fa --- /dev/null +++ b/cabal.project.local @@ -0,0 +1,7 @@ +with-compiler: ghc-8.8.4 +optimization: 2 +ignore-project: False +library-profiling: False +executable-profiling: False +tests: True +benchmarks: True \ No newline at end of file diff --git a/data/simple.xlsx b/data/simple.xlsx new file mode 100644 index 00000000..bb39f9e4 Binary files /dev/null and b/data/simple.xlsx differ diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..71d1a80a --- /dev/null +++ b/default.nix @@ -0,0 +1,3 @@ +(import (fetchTarball https://github.com/edolstra/flake-compat/archive/master.tar.gz) { + src = ./.; +}).defaultNix diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..1e607441 --- /dev/null +++ b/flake.lock @@ -0,0 +1,61 @@ +{ + "nodes": { + "flake-utils": { + "locked": { + "lastModified": 1614513358, + "narHash": "sha256-LakhOx3S1dRjnh0b5Dg3mbZyH0ToC9I8Y2wKSkBaTzU=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "5466c5bbece17adaab2d82fae80b46e807611bf3", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "rev": "5466c5bbece17adaab2d82fae80b46e807611bf3", + "type": "github" + } + }, + "gitignore": { + "flake": false, + "locked": { + "lastModified": 1611672876, + "narHash": "sha256-qHu3uZ/o9jBHiA3MEKHJ06k7w4heOhA+4HCSIvflRxo=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "211907489e9f198594c0eb0ca9256a1949c9d412", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "211907489e9f198594c0eb0ca9256a1949c9d412", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1619033689, + "narHash": "sha256-ABoYZ4ftAum8PTw5i5k/9c1S5Cj0goMFqpuOcdNJdGw=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "52b2fec43ba8d39c003627fe5f7fa59195bd40f2", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "gitignore": "gitignore", + "nixpkgs": "nixpkgs" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..68c7a9bc --- /dev/null +++ b/flake.nix @@ -0,0 +1,43 @@ +{ + description = "xlsx"; + + inputs = { + nixpkgs.url = "github:NixOS/nixpkgs"; + flake-utils.url = "github:numtide/flake-utils/5466c5bbece17adaab2d82fae80b46e807611bf3"; + gitignore = { + url = "github:hercules-ci/gitignore.nix/211907489e9f198594c0eb0ca9256a1949c9d412"; + flake = false; + }; + }; + + outputs = { self, nixpkgs, flake-utils, gitignore }: + flake-utils.lib.eachDefaultSystem (system: + let + packageName = "xlsx"; + compiler = "ghc884"; + + pkgs = nixpkgs.legacyPackages.${system}; + jailbreakUnbreak = pkg: + pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); + + gitignore = pkgs.nix-gitignore.gitignoreSourcePure [ ./.gitignore ]; + + in { + packages.${packageName} = + pkgs.haskell.packages.${compiler}.callCabal2nix packageName (gitignore ./.) rec { }; + + defaultPackage = self.packages.${system}.${packageName}; + + devShell = pkgs.mkShell { + buildInputs = with pkgs; [ + haskell-language-server + stylish-haskell + ghcid + zlib + cabal-install + ]; + inputsFrom = builtins.attrValues self.packages.${system}; + # shellHook = "cabal v2-repl"; + }; + }); +} \ No newline at end of file diff --git a/shell.nix b/shell.nix new file mode 100644 index 00000000..6d7f42b0 --- /dev/null +++ b/shell.nix @@ -0,0 +1 @@ +(import ./.).devShell."${builtins.currentSystem}" \ No newline at end of file diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs index a210c5b7..62c1034e 100644 --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -71,7 +71,7 @@ import Codec.Xlsx.Types.PivotTable.Internal 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 @@ toXlsxEitherBase :: -> 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 diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs new file mode 100644 index 00000000..c77f4658 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -0,0 +1,619 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Codex.Xlsx.Parser.Stream +-- Description : Stream parser for xlsx files +-- Copyright : +-- (c) Jappie Klooster, 2021 +-- Adam, 2021 +-- License : MIT +-- Stability : experimental +-- Portability : POSIX +-- +-- Parse @.xlsx@ using conduit streaming capabilities. +-- +-- == Goal +-- The prime goal of this module was to be able to use stream processing +-- capabilities of `conduit` library to be able to parse @.xlsx@ files in +-- constant memory. Below I explain why this is problematic. +-- +-- == Implementation +-- A @.xlsx@ file is essentially an archive with a bunch of @.xml@'s underneath. +-- +-- Here's a sample of how data looks internally: +-- +-- @ +-- . +-- ├── [Content_Types].xml +-- ├── _rels +-- ├── docProps +-- │ ├── app.xml +-- │ └── core.xml +-- └── xl +-- ├── _rels +-- │ └── workbook.xml.rels +-- ├── calcChain.xml +-- ├── sharedStrings.xml +-- ├── styles.xml +-- ├── theme +-- │ └── theme1.xml +-- ├── workbook.xml +-- └── worksheets +-- ├── sheet1.xml +-- └── sheet2.xml +-- @ +-- +-- Here we mostly pay attention to @sharedStrings.xml@ and @workesheets/@ subdirectory. +-- +-- The @sharedStrings.xml@ file stores all the unique strings in all of the worksheets +-- @.xlsx@ file and all (actually not all, some of the numbers are not stored in shared +-- strings table for reason I could find explanation for) strings are referenced from this +-- shared strings table. This is used mostly to safe space and causes a problem for us to +-- use conduits in first place, since to be able to parse sheets we have to store this table +-- in memory which does not agree with our only requirement. +-- +-- The parsing is then separated to two stages: +-- +-- 1. We parse shared string table in @parseSharedStringsC@ conduit and collect entries +-- using strict state monad. This is done that way because @xml-types@ library uses +-- eventful approach on separating xml structures. +-- 2. We parse the sheets using shared string table that is loaded onto memory in +-- @readXlsxWithSharedStringMapC@. +-- +-- Well, actually we do not parse things in this module, just construct conduit for it, +-- for the example usage of this parser you can refer to @benchmarks/Stream.hs@ file or read +-- the subsection explaining its @parseFileStream@ below. +-- +-- == How to use this parser +-- +-- The starting point of parsing @.xlsx@ via conduits is `readXlsxC` parser. +-- Basically what it does is that it constructs a conduit parser for some +-- existing conduit (or sink if you prefer in this case) that produces `BS.ByteString` +-- which is then passed to our parser conduits and wrapped into some @PrimMonad m@ monad. +-- +-- Consider the type of conduits +-- +-- @ +-- ConduitT a b m r +-- ^------- The value conduit consumes +-- ^------ The intermediate result that is passed to other conduits in the pipeline +-- ^----- The base monad that tells what kind of effects we can perform with the value +-- ^---- The result of the entire pipeline +-- @ +-- +-- If you're doing it in @IO@ it could be simply invoked from @sourceFile@ that constructs +-- the needed conduit from the source filepath it was given and later the conduit can be +-- evaluated by calling @runResourceT@ that takes the given @ResourceT@ +-- (produced by `readXlsxC` function) and returns the value in base monad it was specified. +-- +-- In types +-- +-- @ +-- parseFileC :: FilePath -> IO ByteString +-- parseFileC filePath = do +-- (inputC :: ConduitT () SheetItem (ResourceT IO) ()) <- +-- (sourceFile filepath :: ConduitT () ByteString (ResourceT IO) ()) +-- -- ^ Construct a conduit that returns @ByteString@ with @IO@ based effects +-- & \s -> (readXlsxC s :: ResourceT IO (ConduitT () SheetItem (ResourceT IO) ())) +-- -- ^ Construct a conduit that parses the given chunk of @ByteString@ value +-- -- and parses it to @SheetItem@ +-- & \s -> (runResourceT s :: IO (ConduitT () SheetItem (ResourceT IO) ())) +-- -- ^ This is needed because we want to allocate the needed resources and be able +-- -- to safely clean up after +-- res <- +-- (parseConduit inputC :: ConduitT () Void (ResourceT IO) [SheetItem]) +-- -- ^ Construct a conduit that only returns resulting value out of the +-- -- given @inputC@ conduit so that we can collect all the values it parses +-- & \s -> (runConduit s :: ResourceT IO [SheetItem]) +-- & \s -> (runResourceT s :: IO [SheetItem]) +-- pure res +-- where +-- -- Fold all the intermediate results of the given conduit and +-- -- return the conduit that only returns resulting value. +-- parseConduit +-- :: Monad m +-- => ConduitM a SheetItem m () -> ConduitM () Void m [SheetItem] +-- +-- @ +{-# LANGUAGE TypeApplications #-} +module Codec.Xlsx.Parser.Stream + ( -- * Parsers + readXlsxC + , readXlsxWithSharedStringMapC + , parseSharedStringsC + , parseSharedStringsIntoMapC + -- * Structs + , CellRow + , SheetItem(..) + -- ** `SheetItem` lens + , si_sheet + , si_row_index + , si_cell_row + ) where + +import Codec.Archive.Zip.Conduit.UnZip +import Codec.Xlsx.Types.Cell +import Codec.Xlsx.Types.Common +import Conduit (PrimMonad, await, yield, (.|)) +import qualified Conduit as C +import Control.Lens +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.State.Strict +import Data.Bifunctor +import qualified Data.ByteString as BS +import Data.Conduit (ConduitT) +import qualified Data.Conduit.Combinators as C +import Data.Foldable +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Read as Read +import Data.XML.Types +import Debug.Trace +import GHC.Generics +import NoThunks.Class +import Text.Read +import Text.XML.Stream.Parse + +type CellRow = Map Int Cell + +-- | Sheet item +-- +-- The current sheet at a time, every sheet is constructed of these items. +data SheetItem = MkSheetItem + { _si_sheet :: Text -- ^ Name of the sheet + , _si_row_index :: Int -- ^ Row number + , _si_cell_row :: ~CellRow -- ^ Row itself + } deriving stock (Generic, Show) +makeLenses 'MkSheetItem + +deriving via AllowThunksIn + '[ "_si_cell_row" + ] SheetItem + instance NoThunks SheetItem + +-- | File tags that we match with zip entries to be able to separate them and use needed +-- http://officeopenxml.com/anatomyofOOXML-xlsx.php +data PsFileTag = + Ignored Text -- ^ Files that appear in workbook, but get ignored + | Sheet Text -- ^ Sheet itself + | InitialNoFile -- ^ Initial state, not related to excel files and hence should be moved to some other data + | SharedStrings -- ^ Shared strings file + | Styles + | Workbook -- ^ Contains names of the tabs and shared string ids + | ContentTypes + | Relationships + | FormulaChain -- ^ Contains all the formulas in the sheet + | SheetRel Text -- ^ Contains relations between internal ids and paths + deriving stock (Generic, Show) + deriving anyclass NoThunks + +makePrisms ''PsFileTag + +type SharedStringMap = Map Int 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 -- ^ original string + | TN -- ^ number + | TB -- ^ boolean + | Untyped -- ^ Not all values are types + deriving stock (Generic, Show) + deriving anyclass NoThunks + +-- | State for parsing sheets +data SheetState = MkSheetState + { _ps_file :: PsFileTag -- ^ File tag that we associate from `tagFilesC` + , _ps_row :: ~CellRow -- ^ Current row + , _ps_sheet_name :: Text -- ^ Current sheet name + , _ps_cell_row_index :: Int -- ^ Current row number + , _ps_cell_col_index :: Int -- ^ Current column number + , _ps_is_in_val :: Bool -- ^ Flag for indexing wheter the parser is in value or not + , _ps_shared_strings :: SharedStringMap -- ^ Shared string map + , _ps_type :: ExcelValueType -- ^ The last detected value type + } deriving stock (Generic, Show) +makeLenses 'MkSheetState + +deriving via AllowThunksIn + '[ "_ps_row" + ] SheetState + instance NoThunks SheetState + +-- | State for parsing shared strings +data SharedStringState = MkSharedStringState + { _ss_file :: PsFileTag -- ^ File tag of the current file we are in + , _ss_shared_ix :: Int -- ^ Id of a shared string, int is okay, because bigger int blows up memory anyway + , _ss_string :: Text -- ^ String we are parsing + } deriving stock (Generic, Show) + deriving anyclass NoThunks +makeLenses 'MkSharedStringState + +type HasSheetState = MonadState SheetState +type HasSharedStringState = MonadState SharedStringState + +class HasPSFiles a where + fileLens :: Lens' a PsFileTag + +instance HasPSFiles SheetState where + fileLens = ps_file +instance HasPSFiles SharedStringState where + fileLens = ss_file + +-- | Initial parsing state +initialSheetState :: SheetState +initialSheetState = MkSheetState + { _ps_file = InitialNoFile + , _ps_row = mempty + , _ps_sheet_name = mempty + , _ps_cell_row_index = 0 + , _ps_cell_col_index = 0 + , _ps_is_in_val = False + , _ps_shared_strings = mempty + , _ps_type = Untyped + } + +-- | Initial parsing state +initialSharedString :: SharedStringState +initialSharedString = MkSharedStringState + { _ss_file = InitialNoFile + , _ss_shared_ix = 0 + , _ss_string = mempty + } + +-- | Classify zip entries +getFileTag :: Text -> PsFileTag +getFileTag = \case + "xl/sharedStrings.xml" -> SharedStrings + "xl/styles.xml" -> Styles + "xl/workbook.xml" -> Workbook + "xl/calcChain.xml" -> FormulaChain + "[Content_Types].xml" -> ContentTypes + "_rels/.rels" -> Relationships + unknown + | ws `Text.isPrefixOf` unknown -> + let unknown' = Text.drop (Text.length ws) unknown + in if + | rel `Text.isPrefixOf` unknown' -> + SheetRel $ Text.drop (Text.length rel) unknown' + | otherwise -> Sheet unknown' + | otherwise -> Ignored unknown + where + ws = "xl/worksheets" + rel = "_rels/" + +-- | Conduit for parsing shared strings +-- +-- This is essentially parsing a zip stream with each entry stored as bytestring +-- that we tag before proceeding with parsing the elements. +parseSharedStringsC + :: ( MonadThrow m + , PrimMonad m + ) + => ConduitT BS.ByteString (Int, Text) m () +parseSharedStringsC = (() <$ unZipStream) .| C.evalStateLC initialSharedString go + where + go = (await >>= tagFilesC) + .| C.filterM (const $ has _SharedStrings <$> use fileLens) + .| parseBytes def + .| C.concatMapM parseSharedString + +-- | Conduit that returns shared strings map +-- +-- This is used mostly for testing. +parseSharedStringsIntoMapC + :: ( MonadThrow m + , PrimMonad m + ) + => ConduitT BS.ByteString C.Void m (Map Int Text) +parseSharedStringsIntoMapC = parseSharedStringsC .| C.foldMap (uncurry Map.singleton) + +-- | Parse shared string entry from xml event and return it once +-- we've reached the end of given element +parseSharedString + :: ( MonadThrow m + , HasSharedStringState m + ) + => Event -> m (Maybe (Int, Text)) +parseSharedString = \case + EventBeginElement Name {nameLocalName = "t"} _ -> Nothing <$ (ss_string .= "") + EventEndElement Name {nameLocalName = "t"} -> do + !idx <- use ss_shared_ix + ss_shared_ix += 1 + !txt <- use ss_string + pure $ Just (idx, txt) + EventContent (ContentText txt) -> Nothing <$ (ss_string <>= txt) + _ -> pure Nothing + +-- | Parse sheet with shared strings map provided +-- +-- This is essentially parsing of a zip stream in which we ignore all unrecognised +-- files, literally just parsing @worksheets/*.xml@ here. +readXlsxWithSharedStringMapC + :: ( MonadThrow m + , PrimMonad m + ) + => SharedStringMap + -> ConduitT BS.ByteString SheetItem m () +readXlsxWithSharedStringMapC sstate = (() <$ unZipStream) .| C.evalStateLC initial parseFileCState + where + parseFileCState = (await >>= tagFilesC) + .| C.filterM (const $ not . has _Ignored <$> use fileLens) + .| parseBytes def + .| parseFileC + initial = set ps_shared_strings sstate initialSheetState + +-- | Parse xlsx file from a bytestring +-- +-- This first reads the shared string table, then it provides another conduit +-- for parsing the rest of the data. Reading happens twice. All shared strings +-- are stored into memory wrapped in state monad. +readXlsxC + :: ( MonadThrow m + , PrimMonad m + ) + => ConduitT () BS.ByteString m () + -> m (ConduitT () SheetItem m ()) +readXlsxC input = do + ssState <- C.runConduit $ + input + .| parseSharedStringsC + .| C.foldMap (uncurry Map.singleton) + pure $ + input + .| readXlsxWithSharedStringMapC ssState + +-- | Tag zip entries with `PsFileTags` +-- +-- Essentiall @.xlsx@ file is a zip archive with bunch of @.xml@s stored +-- inside. This conduit ensures that we recognise all the needed files to +-- work with later. All of the tags are pushed in a state monad. +tagFilesC + :: ( HasPSFiles env + , MonadState env m + , MonadThrow m + ) + => Maybe (Either ZipEntry BS.ByteString) + -> ConduitT (Either ZipEntry BS.ByteString) BS.ByteString m () +tagFilesC = \case + Just (Left zipEntry) -> do + let !filePath = either id Text.decodeUtf8 (zipEntryName zipEntry) + fileLens .= getFileTag filePath + await >>= tagFilesC + Just (Right fdata) -> do + -- strange behaviour indeed, why it does not await already yielded data? + yield fdata + await >>= tagFilesC + Nothing -> pure () + +-- | Parse a xml event +parseFileC + :: ( MonadThrow m + , HasSheetState m + ) + => ConduitT Event SheetItem m () +parseFileC = await >>= parseEventLoop + where + parseEventLoop + :: ( MonadThrow m + , HasSheetState m + ) + => Maybe Event + -> ConduitT Event SheetItem m () + parseEventLoop = \case + Nothing -> pure () + Just evt -> use fileLens >>= \case + Sheet name -> parseSheetC evt name + _ -> await >>= parseEventLoop + +-- | Parse sheet +-- +-- We extract previous sheet name from the state and as well +-- as a current row index. If we're still in the same sheet +-- then we're returning currently stored row. +-- If we're on a different sheet, then parse the event and +-- return newly generated sheet item. +parseSheetC + :: ( MonadThrow m + , HasSheetState m + ) + => Event + -> Text + -> ConduitT Event SheetItem m () +parseSheetC event name = do + prevSheetName <- use ps_sheet_name + rix <- use ps_cell_row_index + unless (prevSheetName == name) $ + popRow >>= yieldSheetItem name rix + + parseRes <- runExceptT $ matchEvent name event + rix' <- use ps_cell_row_index + case parseRes of + Left err -> C.throwM err + Right mResult -> do + traverse_ (yieldSheetItem name rix') mResult + parseFileC + +-- | @SheetItem@ constructor +yieldSheetItem + :: MonadThrow m + => Text + -> Int + -> CellRow + -> ConduitT Event SheetItem m () +yieldSheetItem name rix' row = + unless (row == mempty) $ yield (MkSheetItem name rix' row) + +-- | 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 + | SharedStringNotFound -- ^ Could not find string by index in shared string table + Int -- ^ Given index + (Map Int Text) -- ^ Given map 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 +parseValue :: SharedStringMap -> Text -> ExcelValueType -> Either AddCellErrors CellValue +parseValue sstrings txt = \case + TS -> do + (idx, _) <- ReadError txt `first` Read.decimal @Int txt + string <- maybe (Left $ SharedStringNotFound idx sstrings) Right $ sstrings ^? ix idx + Right $ CellText string + TStr -> pure $ CellText txt + TN -> bimap (ReadError txt) (CellDouble . fst) $ Read.double txt + TB -> bimap (ReadError txt) CellBool . readEither $ Text.unpack txt + 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 +addCellToRow + :: ( MonadError SheetErrors m + , HasSheetState m + ) + => Text -> m () +addCellToRow txt = do + inVal <- use ps_is_in_val + when inVal $ do + type' <- use ps_type + sstrings <- use ps_shared_strings + val <- liftEither $ first ParseCellError $ parseValue sstrings txt type' + + col <- use ps_cell_col_index + ps_row <>= (Map.singleton col $ Cell + { _cellStyle = Nothing + , _cellValue = Just val + , _cellComment = Nothing + , _cellFormula = Nothing + }) + +data SheetErrors + = ParseCoordinateError CoordinateErrors -- ^ Error while parsing coordinates + | ParseTypeError TypeError -- ^ Error while parsing types + | ParseCellError AddCellErrors -- ^ Error while parsing cells + deriving stock Show + deriving anyclass Exception + +type SheetValue = (Name, [Content]) +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 + +contentTextPrims :: Prism' Content Text +contentTextPrims = prism' ContentText (\case ContentText x -> Just x + _ -> Nothing) + +-- | Update state coordinates accordingly to @parseCoordinates@ +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 :: Text -> SheetValues -> Maybe SheetValue +findName name = find ((name ==) . nameLocalName . fst) + +-- | Parse value type +parseType :: SheetValues -> Either TypeError ExcelValueType +parseType list = + case findName "t" list of + Nothing -> pure Untyped + Just nameValPair -> do + valContent <- maybe (Left $ TypeNoListElement nameValPair list) Right $ nameValPair ^? _2 . ix 0 + valText <- maybe (Left $ TypeNoTextContent valContent list) Right $ valContent ^? contentTextPrims + case valText of + "n" -> Right TN + "s" -> Right TS + "str" -> Right TStr + "b" -> Right TS -- For some reason bools are also indexed + other -> Left $ UnkownType other list + +-- | Parse coordinates from a list of xml elements if such were found on "r" key +parseCoordinates :: SheetValues -> Either CoordinateErrors (Int, Int) +parseCoordinates list = do + nameValPair <- maybe (Left $ CoordinateNotFound list) Right $ findName "r" list + valContent <- maybe (Left $ NoListElement nameValPair list) Right $ nameValPair ^? _2 . ix 0 + valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims + maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText + +-- | Update state accordingly the xml event given, basically parse a xml and return row +-- if we've ended parsing. +-- (I wish xml docs were more elaborate on their structures) +matchEvent + :: ( MonadError SheetErrors m + , HasSheetState m + ) + => Text -> Event -> m (Maybe CellRow) +matchEvent _currentSheet = \case + EventContent (ContentText txt) -> Nothing <$ addCellToRow txt + EventBeginElement Name{nameLocalName = "c"} vals -> Nothing <$ (setCoord vals >> setType vals) + EventBeginElement Name {nameLocalName = "v"} _ -> Nothing <$ (ps_is_in_val .= True) + EventEndElement Name {nameLocalName = "v"} -> Nothing <$ (ps_is_in_val .= False) + EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow + EventEndElement Name{nameLocalName = "row"} -> Just <$> popRow + _ -> pure Nothing diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs index 61d73e1c..fc2150d2 100644 --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + module Codec.Xlsx.Types.Common ( CellRef(..) , singleCellRef @@ -19,6 +21,16 @@ module Codec.Xlsx.Types.Common , dateToNumber , int2col , col2int + , RowIndex + , ColIndex + -- ** prisms + , _XlsxText + , _XlsxRichText + , _CellText + , _CellDouble + , _CellBool + , _CellRich + , _CellError ) where import GHC.Generics (Generic) @@ -28,6 +40,7 @@ import Control.DeepSeq (NFData) import Control.Monad (forM, guard) import qualified Data.ByteString as BS import Data.Char +import Data.Coerce import Data.Ix (inRange) import qualified Data.Map as Map import Data.Text (Text) @@ -39,6 +52,7 @@ import Safe import Text.XML import Text.XML.Cursor +import Control.Lens(makePrisms) import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.RichText import Codec.Xlsx.Writer.Internal @@ -71,15 +85,15 @@ instance NFData CellRef -- | Render position in @(row, col)@ format to an Excel reference. -- -- > mkCellRef (2, 4) == "D2" -singleCellRef :: (Int, Int) -> CellRef +singleCellRef :: (RowIndex, ColIndex) -> CellRef singleCellRef = CellRef . singleCellRefRaw singleCellRefRaw :: (Int, Int) -> Text singleCellRefRaw (row, col) = T.concat [int2col col, T.pack (show row)] -- | reverse to 'mkCellRef' -fromSingleCellRef :: CellRef -> Maybe (Int, Int) -fromSingleCellRef = fromSingleCellRefRaw . unCellRef +fromSingleCellRef :: CellRef -> Maybe (RowIndex, ColIndex) +fromSingleCellRef = fromSingleCellRefRaw . coerce fromSingleCellRefRaw :: Text -> Maybe (Int, Int) fromSingleCellRefRaw t = do @@ -93,7 +107,7 @@ fromSingleCellRefRaw t = do fromSingleCellRefNoting :: CellRef -> (Int, Int) fromSingleCellRefNoting ref = fromJustNote errMsg $ fromSingleCellRefRaw txt where - txt = unCellRef ref + txt = coerce ref errMsg = "Bad cell reference '" ++ T.unpack txt ++ "'" -- | Excel range (e.g. @D13:H14@), actually store as as 'CellRef' in @@ -109,7 +123,7 @@ mkRange fr to = CellRef $ T.concat [singleCellRefRaw fr, T.pack ":", singleCellR -- | reverse to 'mkRange' fromRange :: Range -> Maybe ((Int, Int), (Int, Int)) fromRange r = - case T.split (== ':') (unCellRef r) of + case T.split (== ':') (coerce r) of [from, to] -> (,) <$> fromSingleCellRefRaw from <*> fromSingleCellRefRaw to _ -> Nothing @@ -143,6 +157,7 @@ data XlsxText = XlsxText Text | XlsxRichText [RichTextRun] deriving (Eq, Ord, Show, Generic) + instance NFData XlsxText xlsxTextToCellValue :: XlsxText -> CellValue @@ -169,6 +184,7 @@ data CellValue | CellError ErrorType deriving (Eq, Ord, Show, Generic) + instance NFData CellValue -- | The evaluation of an expression can result in an error having one @@ -385,3 +401,9 @@ instance ToAttrVal ErrorType where toAttrVal ErrorNum = "#NUM!" toAttrVal ErrorRef = "#REF!" toAttrVal ErrorValue = "#VALUE!" + +type RowIndex = Int +type ColIndex = Int + +makePrisms ''XlsxText +makePrisms ''CellValue diff --git a/stack-lts-12.yaml b/stack-lts-12.yaml deleted file mode 100644 index 0843c9d2..00000000 --- a/stack-lts-12.yaml +++ /dev/null @@ -1,3 +0,0 @@ -resolver: lts-12.26 -packages: -- '.' diff --git a/stack-lts-14.yaml b/stack-lts-14.yaml index 3732cb9c..e0141f35 100644 --- a/stack-lts-14.yaml +++ b/stack-lts-14.yaml @@ -1,3 +1,5 @@ resolver: lts-14.27 packages: - '.' +extra-deps: + - nothunks-0.1.2@sha256:ec366664bb611ba8ce3a48aee626804039ea53517de7788b8705c76be0dcfa72,2235 diff --git a/stack-lts-16.yaml b/stack-lts-16.yaml index 525436d4..487dffbe 100644 --- a/stack-lts-16.yaml +++ b/stack-lts-16.yaml @@ -1,3 +1,5 @@ resolver: lts-16.31 packages: - '.' +extra-deps: + - nothunks-0.1.2@sha256:ec366664bb611ba8ce3a48aee626804039ea53517de7788b8705c76be0dcfa72,2235 diff --git a/stack-lts-17.yaml b/stack-lts-17.yaml index 819dd785..85adddc5 100644 --- a/stack-lts-17.yaml +++ b/stack-lts-17.yaml @@ -1,3 +1,5 @@ resolver: lts-17.8 packages: - '.' +extra-deps: + - nothunks-0.1.2@sha256:ec366664bb611ba8ce3a48aee626804039ea53517de7788b8705c76be0dcfa72,2235 diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 8dba7f85..359fcb8a 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,3 +1,5 @@ resolver: nightly-2019-10-31 packages: - '.' +extra-deps: + - nothunks-0.1.2@sha256:ec366664bb611ba8ce3a48aee626804039ea53517de7788b8705c76be0dcfa72,2235 diff --git a/test/Main.hs b/test/Main.hs index 3ef7f173..c439ad56 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} module Main @@ -10,6 +10,7 @@ import Control.Lens import Control.Monad.State.Lazy import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LB +import qualified StreamTests import Data.Map (Map) import qualified Data.Map as M import Data.Time.Clock.POSIX (POSIXTime) @@ -21,6 +22,7 @@ import Test.Tasty (defaultMain, testGroup) import Test.Tasty.HUnit (testCase) import Test.Tasty.HUnit ((@=?)) +import TestXlsx import Codec.Xlsx import Codec.Xlsx.Formatted @@ -78,527 +80,12 @@ main = defaultMain $ , 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 + , StreamTests.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 = "\ - \\ - \plain text\ - \Just \ - \example\ - \" - -testStringsWithSingleUnderline :: ByteString -testStringsWithSingleUnderline = "\ - \\ - \plain text\ - \Just \ - \example\ - \" - -testStringsWithDoubleUnderline :: ByteString -testStringsWithDoubleUnderline = "\ - \\ - \plain text\ - \Just \ - \example\ - \" - -testStringsWithEmpty :: ByteString -testStringsWithEmpty = "\ - \\ - \\ - \" - -testComments :: ByteString -testComments = [r| - - - - Bob - CBR - - - - - - - - - - Bob: - - - - - - - Why such high expense? - - - - - Some comment here - - - -|] - -testCustomProperties :: CustomProperties -testCustomProperties = CustomProperties.fromList - [ ("testTextProp", VtLpwstr "test text property value") - , ("prop2", VtLpwstr "222") - , ("bool", VtBool False) - , ("prop333", VtInt 1) - , ("decimal", VtDecimal 1.234) ] - -testCustomPropertiesXml :: ByteString -testCustomPropertiesXml = [r| - - - - 222 - - - 1 - - - test text property value - - - 1.234 - - - false - - - - ZXhhbXBs - ZSBibG9i - IGNvbnRl - bnRz - - - -|] - -testFormattedResult :: Formatted -testFormattedResult = Formatted cm styleSheet merges - where - cm = M.fromList [ ((1, 1), cell11) - , ((1, 2), cell12) - , ((2, 5), cell25) ] - cell11 = Cell - { _cellStyle = Just 1 - , _cellValue = Just (CellText "text at A1") - , _cellComment = Nothing - , _cellFormula = Nothing } - cell12 = Cell - { _cellStyle = Just 2 - , _cellValue = Just (CellDouble 1.23) - , _cellComment = Nothing - , _cellFormula = Nothing } - cell25 = Cell - { _cellStyle = Just 3 - , _cellValue = Just (CellDouble 1.23456) - , _cellComment = Nothing - , _cellFormula = Nothing } - merges = [] - styleSheet = - minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3]) - & styleSheetFonts %~ (++ [font1, font2]) - & styleSheetNumFmts .~ numFmts - nextFontId = length (minimalStyleSheet ^. styleSheetFonts) - cellXf1 = def - { _cellXfApplyFont = Just True - , _cellXfFontId = Just nextFontId } - font1 = def - { _fontName = Just "Calibri" - , _fontBold = Just True } - cellXf2 = def - { _cellXfApplyFont = Just True - , _cellXfFontId = Just (nextFontId + 1) - , _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 164 } - font2 = def - { _fontItalic = Just True } - cellXf3 = def - { _cellXfApplyNumberFormat = Just True - , _cellXfNumFmtId = Just 2 } - numFmts = M.fromList [(164, "0.0000")] - -testRunFormatted :: Formatted -testRunFormatted = formatted formattedCellMap minimalStyleSheet - where - formattedCellMap = flip execState def $ do - let font1 = def & fontBold ?~ True - & fontName ?~ "Calibri" - at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1" - & formattedFormat . formatFont ?~ font1) - at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23 - & formattedFormat . formatFont . non def . fontItalic ?~ True - & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4) - at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456 - & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) - -testFormatWorkbookResult :: Xlsx -testFormatWorkbookResult = def & xlSheets .~ sheets - & xlStyles .~ renderStyleSheet style - where - 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") - } - ) - ] diff --git a/test/StreamTests.hs b/test/StreamTests.hs new file mode 100644 index 00000000..919b5a2b --- /dev/null +++ b/test/StreamTests.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} + +module StreamTests + ( tests + ) where + +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.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Map (Map) +import qualified Data.Map as M +import qualified Data.Map as Map +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.FilePath.Posix +import Test.Tasty (TestName, + TestTree, + testGroup) +import Test.Tasty.HUnit (testCase) +import TestXlsx +import Text.RawString.QQ +import Text.XML + +tempPath :: FilePath +tempPath = "test" "temp" + +mkTestCase :: TestName -> FilePath -> Xlsx -> TestTree +mkTestCase testName filename xlsx = testCase testName $ do + let filepath = tempPath filename + let bs = fromXlsx testTime xlsx + LB.writeFile filepath bs + res <- C.runResourceT $ C.runConduit $ C.sourceFile filepath .| parseSharedStringsIntoMapC + + let + testSst :: Vector XlsxText + testSst = sstTable $ sstConstruct (xlsx ^.. xlSheets . traversed . _2) + + testTexts :: Vector (Maybe Text) + testTexts = preview _XlsxText <$> testSst + + testMap :: Map Int Text + testMap = Map.fromList $ do + (x, my) <- toList $ indexed testTexts + maybe [] (pure . (x,)) my + + testMap @==? res + + +tests :: TestTree +tests = + testGroup + "Stream tests" + [ mkTestCase "Get's out the shared strings" "data-test.xlsx" testXlsx + , mkTestCase "Workbook is parsed correctly" "format-workbook-test.xlsx" testFormatWorkbook + ] diff --git a/test/TestXlsx.hs b/test/TestXlsx.hs new file mode 100644 index 00000000..c57c05a9 --- /dev/null +++ b/test/TestXlsx.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE QuasiQuotes #-} +module TestXlsx where + +import Control.Lens +import Control.Monad.State.Lazy +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Map (Map) +import qualified Data.Map as M +import Data.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 = "\ + \\ + \plain text\ + \Just \ + \example\ + \" + +testStringsWithSingleUnderline :: ByteString +testStringsWithSingleUnderline = "\ + \\ + \plain text\ + \Just \ + \example\ + \" + +testStringsWithDoubleUnderline :: ByteString +testStringsWithDoubleUnderline = "\ + \\ + \plain text\ + \Just \ + \example\ + \" + +testStringsWithEmpty :: ByteString +testStringsWithEmpty = "\ + \\ + \\ + \" + +testComments :: ByteString +testComments = [r| + + + + Bob + CBR + + + + + + + + + + Bob: + + + + + + + Why such high expense? + + + + + Some comment here + + + +|] + +testCustomProperties :: CustomProperties +testCustomProperties = CustomProperties.fromList + [ ("testTextProp", VtLpwstr "test text property value") + , ("prop2", VtLpwstr "222") + , ("bool", VtBool False) + , ("prop333", VtInt 1) + , ("decimal", VtDecimal 1.234) ] + +testCustomPropertiesXml :: ByteString +testCustomPropertiesXml = [r| + + + + 222 + + + 1 + + + test text property value + + + 1.234 + + + false + + + + ZXhhbXBs + ZSBibG9i + IGNvbnRl + bnRz + + + +|] + +testFormattedResult :: Formatted +testFormattedResult = Formatted cm styleSheet merges + where + cm = M.fromList [ ((1, 1), cell11) + , ((1, 2), cell12) + , ((2, 5), cell25) ] + cell11 = Cell + { _cellStyle = Just 1 + , _cellValue = Just (CellText "text at A1") + , _cellComment = Nothing + , _cellFormula = Nothing } + cell12 = Cell + { _cellStyle = Just 2 + , _cellValue = Just (CellDouble 1.23) + , _cellComment = Nothing + , _cellFormula = Nothing } + cell25 = Cell + { _cellStyle = Just 3 + , _cellValue = Just (CellDouble 1.23456) + , _cellComment = Nothing + , _cellFormula = Nothing } + merges = [] + styleSheet = + minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3]) + & styleSheetFonts %~ (++ [font1, font2]) + & styleSheetNumFmts .~ numFmts + nextFontId = length (minimalStyleSheet ^. styleSheetFonts) + cellXf1 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just nextFontId } + font1 = def + { _fontName = Just "Calibri" + , _fontBold = Just True } + cellXf2 = def + { _cellXfApplyFont = Just True + , _cellXfFontId = Just (nextFontId + 1) + , _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 164 } + font2 = def + { _fontItalic = Just True } + cellXf3 = def + { _cellXfApplyNumberFormat = Just True + , _cellXfNumFmtId = Just 2 } + numFmts = M.fromList [(164, "0.0000")] + +testRunFormatted :: Formatted +testRunFormatted = formatted formattedCellMap minimalStyleSheet + where + formattedCellMap = flip execState def $ do + let font1 = def & fontBold ?~ True + & fontName ?~ "Calibri" + at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1" + & formattedFormat . formatFont ?~ font1) + at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23 + & formattedFormat . formatFont . non def . fontItalic ?~ True + & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4) + at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456 + & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) + +testFormatWorkbookResult :: Xlsx +testFormatWorkbookResult = def & xlSheets .~ sheets + & xlStyles .~ renderStyleSheet style + where + 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") + } + ) + ] diff --git a/xlsx.cabal b/xlsx.cabal index c52c7d7a..f9a66377 100644 --- a/xlsx.cabal +++ b/xlsx.cabal @@ -76,6 +76,7 @@ Library , Codec.Xlsx.Writer , Codec.Xlsx.Writer.Internal , Codec.Xlsx.Writer.Internal.PivotTable + , Codec.Xlsx.Parser.Stream Build-depends: base >= 4.9.0.0 && < 5.0 , attoparsec @@ -101,6 +102,10 @@ Library , xml-conduit >= 1.1.0 , zip-archive >= 0.2 , zlib >= 0.5.4.0 + , zip-stream >= 0.2.0.1 + , xml-types + , exceptions + , nothunks if flag(microlens) Build-depends: microlens >= 0.4 && < 0.5 , microlens-mtl @@ -131,7 +136,9 @@ test-suite data-test , Diff , DrawingTests , PivotTableTests + , StreamTests , Test.SmallCheck.Series.Instances + , TestXlsx Build-Depends: base , bytestring , containers @@ -149,6 +156,8 @@ test-suite data-test , vector , xlsx , xml-conduit >= 1.1.0 + , conduit + , filepath Default-Language: Haskell2010 source-repository head @@ -163,4 +172,18 @@ benchmark bench , bytestring , criterion , xlsx + default-language: Haskell2010 + +executable streaming + hs-source-dirs: benchmarks + main-is: Stream.hs + ghc-options: + -threaded + build-depends: base + , bytestring + , criterion + , xlsx + , conduit + , containers + , text default-language: Haskell2010 \ No newline at end of file