From ff539de64b8425f4cb8c8b64330613242177e3b3 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 27 Jan 2021 14:15:09 -0400 Subject: [PATCH 01/37] Change type alias for CellMap This allows us to add stream support per row. Which should be good enough --- src/Codec/Xlsx/Formatted.hs | 11 ++++--- src/Codec/Xlsx/Lens.hs | 13 ++++++-- src/Codec/Xlsx/Parser.hs | 17 ++++++---- src/Codec/Xlsx/Types.hs | 17 +++------- src/Codec/Xlsx/Types/Cell.hs | 31 ++++++++++++++++++- .../Xlsx/Types/Internal/SharedStringTable.hs | 2 +- src/Codec/Xlsx/Writer/Internal/PivotTable.hs | 4 ++- 7 files changed, 68 insertions(+), 27 deletions(-) diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs index c1b21715..46bf0004 100644 --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -59,6 +59,7 @@ import Prelude hiding (mapM) import Safe (headNote, fromJustNote) import Codec.Xlsx.Types +import Codec.Xlsx.Types.Cell {------------------------------------------------------------------------------- Internal: formatting state @@ -234,13 +235,13 @@ data Formatted = Formatted { -- -- If you don't already have a 'StyleSheet' you want to use as starting point -- then 'minimalStyleSheet' is a good choice. -formatted :: Map (Int, Int) FormattedCell -> StyleSheet -> Formatted +formatted :: Map (RowIndex, ColIndex) FormattedCell -> StyleSheet -> Formatted formatted cs styleSheet = let initSt = stateFromStyleSheet styleSheet (cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt styleSheet' = updateStyleSheetFromState styleSheet finalSt in Formatted { - formattedCellMap = M.fromList (concat cs') + formattedCellMap = toNested $ M.fromList (concat cs') , formattedStyleSheet = styleSheet' , formattedMerges = reverse (finalSt ^. formattingMerges) } @@ -254,7 +255,7 @@ formatWorkbook nfcss initStyle = extract go cs' <- forM (M.toList fcs) $ \(rc, fc) -> formatCell rc fc merges <- reverse . _formattingMerges <$> get return ( name - , def & wsCells .~ M.fromList (concat cs') + , def & wsCells .~ toNested (M.fromList (concat cs')) & wsMerges .~ merges) extract (sheets, st) = def & xlSheets .~ sheets @@ -263,8 +264,10 @@ formatWorkbook nfcss initStyle = extract go -- | reverse to 'formatted' which allows to get a map of formatted cells -- from an existing worksheet and its workbook's style sheet toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (Int, Int) FormattedCell -toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m +toFormattedCells m merges StyleSheet{..} = applyMerges $ + unNested $ fmap toFormattedCell <$> m where + toFormattedCell :: Cell -> FormattedCell toFormattedCell cell@Cell{..} = FormattedCell { _formattedCell = cell{ _cellStyle = Nothing } -- just to remove confusion diff --git a/src/Codec/Xlsx/Lens.hs b/src/Codec/Xlsx/Lens.hs index 67e8bcb0..0dd3c03c 100644 --- a/src/Codec/Xlsx/Lens.hs +++ b/src/Codec/Xlsx/Lens.hs @@ -16,9 +16,12 @@ module Codec.Xlsx.Lens , cellValueAt , cellValueAtRC , cellValueAtXY + , atRow + , ixRow ) where import Codec.Xlsx.Types +import Codec.Xlsx.Types.Cell #ifdef USE_MICROLENS import Lens.Micro import Lens.Micro.Internal @@ -79,7 +82,7 @@ ixCell = ixCellRC -- | lens to access cell in a worksheet ixCellRC :: (Int, Int) -> Traversal' Worksheet Cell -ixCellRC i = wsCells . ix i +ixCellRC (y, x) = wsCells . ix y . ix x -- | lens to access cell in a worksheet using more traditional -- x+y coordinates @@ -91,9 +94,15 @@ ixCellXY = ixCellRC . swap atCell :: (Int, Int) -> Lens' Worksheet (Maybe Cell) atCell = atCellRC +atRow :: Int -> Lens' Worksheet (Maybe CellRow) +atRow y = wsCells . at y + +ixRow :: Int -> Traversal' Worksheet CellRow +ixRow y = wsCells . ix y + -- | lens to read, write or delete cell in a worksheet atCellRC :: (Int, Int) -> Lens' Worksheet (Maybe Cell) -atCellRC i = wsCells . at i +atCellRC (y,x) = atRow y . non mempty . at x -- | lens to read, write or delete cell in a worksheet -- using more traditional x+y or row+column index diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs index a210c5b7..1e3d5c49 100644 --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -53,7 +53,7 @@ import qualified Xeno.DOM as Xeno import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types -import Codec.Xlsx.Types.Cell (formulaDataFromCursor) +import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common (xlsxTextToCellValue) import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair @@ -216,14 +216,18 @@ extractSheetFast ar sst contentTypes caches wf = do legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< legacyDrRId commentsMap <- fmap join . forM commentTarget $ getComments ar legacyDrPath - let commentCells = + let commentCells :: CellMap + commentCells = toNested $ M.fromList [ (fromSingleCellRefNoting r, def { _cellComment = Just cmnt}) | (r, cmnt) <- maybe [] CommentTable.toList commentsMap ] assignComment withCmnt noCmnt = noCmnt & cellComment .~ (withCmnt ^. cellComment) - mergeComments = M.unionWith assignComment commentCells + mergeCommentRows :: CellRow -> CellRow -> CellRow + mergeCommentRows = M.unionWith assignComment + mergeComments :: CellMap -> CellMap + mergeComments = M.unionWith mergeCommentRows commentCells tables <- forM tableIds $ \rId -> do fp <- lookupRelPath filePath sheetRels rId getTable ar fp @@ -265,7 +269,7 @@ extractSheetFast ar sst contentTypes caches wf = do case mRP of Just rp -> M.insert r rp rowMap Nothing -> rowMap - in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) + in (newRowMap, cellMap <> toNested newCells, sharedF <> newSharedF) parseRow :: Xeno.Node -> Either Text ( Int @@ -422,9 +426,10 @@ extractSheet ar sst contentTypes caches wf = do newRowMap = case mRP of Just rp -> M.insert r rp rowMap Nothing -> rowMap - in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) + in (newRowMap, cellMap <> toNested newCells, sharedF <> newSharedF) - commentCells = + commentCells :: CellMap + commentCells = toNested $ M.fromList [ (fromSingleCellRefNoting r, def {_cellComment = Just cmnt}) | (r, cmnt) <- maybe [] CommentTable.toList commentsMap diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs index a185de28..165f9a40 100644 --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -66,6 +66,7 @@ import Control.Exception (SomeException, toException) import Lens.Micro.TH #else import Control.Lens.TH +import Control.Lens hiding ((.=)) #endif import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as L @@ -298,20 +299,12 @@ parseStyleSheet (Styles bs) = parseLBS def bs >>= parseDoc -- | converts cells mapped by (row, column) into rows which contain -- row index and cells as pairs of column indices and cell values -toRows :: CellMap -> [(Int, [(Int, Cell)])] -toRows cells = - map extractRow $ groupBy ((==) `on` (fst . fst)) $ M.toList cells - where - extractRow row@(((x,_),_):_) = - (x, map (\((_,y),v) -> (y,v)) row) - extractRow _ = error "invalid CellMap row" +toRows :: CellMap -> [(RowIndex, [(ColIndex, Cell)])] +toRows cells = M.toList $ M.toList <$> cells -- | reverse to 'toRows' -fromRows :: [(Int, [(Int, Cell)])] -> CellMap -fromRows rows = M.fromList $ concatMap mapRow rows - where - mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells - +fromRows :: [(RowIndex, [(ColIndex, Cell)])] -> CellMap +fromRows rows = M.fromList $ over (mapped . _2) M.fromList rows instance ToElement ColumnsProperties where toElement nm ColumnsProperties {..} = leafElement nm attrs diff --git a/src/Codec/Xlsx/Types/Cell.hs b/src/Codec/Xlsx/Types/Cell.hs index 8279f773..c82f1f57 100644 --- a/src/Codec/Xlsx/Types/Cell.hs +++ b/src/Codec/Xlsx/Types/Cell.hs @@ -18,6 +18,11 @@ module Codec.Xlsx.Types.Cell , cellComment , cellFormula , CellMap + , CellRow + , RowIndex + , ColIndex + , toNested + , unNested ) where import Control.Arrow (first) @@ -112,10 +117,34 @@ instance Default Cell where makeLenses ''Cell +type RowIndex = Int +type ColIndex = Int + -- | Map containing cell values which are indexed by row and column -- if you need to use more traditional (x,y) indexing please you could -- use corresponding accessors from ''Codec.Xlsx.Lens'' -type CellMap = Map (Int, Int) Cell +type CellMap = Map RowIndex CellRow + +type CellRow = Map ColIndex Cell + +-- | Map (Int, Int) a was the original representation, this was changed +-- to give better support for streaming +-- (we can now stream an individual row) +-- 'toNested' helps you go from that original representation to the new one. +-- 'unNested' helps you go back. +-- toNested . unNested === id +toNested :: Map (RowIndex, ColIndex) a -> Map RowIndex (Map ColIndex a) +toNested old = + M.fromListWith (<>) $ + (\((r,c), v) -> (r, M.singleton c v)) <$> M.toList old + +-- | reverse of 'toNested' +unNested :: Map RowIndex (Map ColIndex a) -> Map (RowIndex, ColIndex) a +unNested old = M.fromList $ do + (row, dict) <- M.toList old + (\(col, val) -> ((row, col), val) ) <$> M.toList dict + + {------------------------------------------------------------------------------- Parsing diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs index 26ea2041..ff390650 100644 --- a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -95,7 +95,7 @@ sstConstruct = SharedStringTable . V.fromList . uniq . concatMap goSheet where goSheet :: Worksheet -> [XlsxText] - goSheet = mapMaybe (_cellValue >=> sstEntry) . Map.elems . _wsCells + goSheet = mapMaybe (_cellValue >=> sstEntry) . join . Map.elems . fmap Map.elems . _wsCells sstEntry :: CellValue -> Maybe XlsxText sstEntry (CellText text) = Just $ XlsxText text diff --git a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs index 627d8b92..aee4fe67 100644 --- a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs @@ -16,6 +16,7 @@ import GHC.Generics (Generic) import Safe (fromJustNote) import Text.XML +import Control.Lens hiding ((.=)) import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common import Codec.Xlsx.Types.Internal @@ -155,7 +156,8 @@ generateCache cm PivotTable {..} = } ((r1, c1), (r2, c2)) = fromJustNote "Invalid src ref of pivot table " $ fromRange _pvtSrcRef - getCellValue ix = M.lookup ix cm >>= _cellValue + getCellValue :: (Int, Int) -> Maybe CellValue + getCellValue (row, col) = cm ^? at row . _Just . at col . _Just . cellValue . _Just itemsByName = M.fromList $ flip mapMaybe [c1 .. c2] $ \c -> do From aadd86cf81f584f72ecfe61e3bc624b94a3f1d6a Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 27 Jan 2021 16:08:19 -0400 Subject: [PATCH 02/37] Try seeing if we can list everything in the test data --- Streamin.md | 31 +++++++++++++++++++++++++++++++ benchmarks/Stream.hs | 19 +++++++++++++++++++ src/Codec/Xlsx/Parser.hs | 4 ++-- src/Codec/Xlsx/Parser/Stream.hs | 31 +++++++++++++++++++++++++++++++ xlsx.cabal | 12 ++++++++++++ 5 files changed, 95 insertions(+), 2 deletions(-) create mode 100644 Streamin.md create mode 100644 benchmarks/Stream.hs create mode 100644 src/Codec/Xlsx/Parser/Stream.hs 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..07738919 --- /dev/null +++ b/benchmarks/Stream.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Codec.Xlsx +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import Conduit +import Data.Conduit.Combinators hiding (print) +import Codec.Xlsx.Parser.Stream + +main :: IO () +main = do + let filename = "data/testInput.xlsx" + -- "data/6000.rows.x.26.cols.xlsx" + bs <- BS.readFile filename + print bs + putStrLn "startin" + runResourceT $ runConduit $ sourceFile filename .| readXlsx .| sinkNull diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs index 1e3d5c49..d6cbf9ce 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..3912d2d5 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -0,0 +1,31 @@ + +-- | Read .xlsx as a stream +module Codec.Xlsx.Parser.Stream + ( readXlsx + , SheetItem(..) + , XlsxItem(..) + ) where + +import Data.Conduit +import Codec.Archive.Zip.Conduit.UnZip +import Codec.Xlsx.Types.Cell +import Conduit +import qualified Data.ByteString as BS + +data SheetItem = MkSheetItem { + siCellRow :: CellRow + } deriving Show + +data XlsxItem = MkXlsxItem { + xiSheet :: SheetItem + } deriving Show + +readXlsx :: MonadIO m => MonadThrow m + => PrimMonad m + => ConduitT BS.ByteString XlsxItem m () +readXlsx = ((() <$ unZipStream) + .| do + x <- await + liftIO $ print x + yield (MkXlsxItem $ MkSheetItem mempty) + ) diff --git a/xlsx.cabal b/xlsx.cabal index c52c7d7a..3c4694cd 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,7 @@ Library , xml-conduit >= 1.1.0 , zip-archive >= 0.2 , zlib >= 0.5.4.0 + , zip-stream >= 0.2.0.1 if flag(microlens) Build-depends: microlens >= 0.4 && < 0.5 , microlens-mtl @@ -163,4 +165,14 @@ benchmark bench , bytestring , criterion , xlsx + default-language: Haskell2010 + +executable streamin + hs-source-dirs: benchmarks + main-is: Stream.hs + build-depends: base + , bytestring + , criterion + , xlsx + , conduit default-language: Haskell2010 \ No newline at end of file From a3440b6e62b67fdb78204c4585d189e02ca53691 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 28 Jan 2021 15:16:03 -0400 Subject: [PATCH 03/37] Loop trough the entire thing --- benchmarks/Stream.hs | 4 +++- src/Codec/Xlsx/Parser/Stream.hs | 13 ++++++++----- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index 07738919..c791bd84 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where +import Prelude hiding (foldl) import Codec.Xlsx import Criterion.Main import qualified Data.ByteString as BS @@ -16,4 +17,5 @@ main = do bs <- BS.readFile filename print bs putStrLn "startin" - runResourceT $ runConduit $ sourceFile filename .| readXlsx .| sinkNull + x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] + print x diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 3912d2d5..a1360168 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -23,9 +23,12 @@ data XlsxItem = MkXlsxItem { readXlsx :: MonadIO m => MonadThrow m => PrimMonad m => ConduitT BS.ByteString XlsxItem m () -readXlsx = ((() <$ unZipStream) +readXlsx = (() <$ unZipStream) .| do - x <- await - liftIO $ print x - yield (MkXlsxItem $ MkSheetItem mempty) - ) + await >>= go + where + go (Just val) = do + liftIO $ print val + yield (MkXlsxItem $ MkSheetItem mempty) + await >>= go + go Nothing = pure () From 28284ae2edd25841ed1321b6479d40c7df6acf79 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 28 Jan 2021 15:32:39 -0400 Subject: [PATCH 04/37] Split of go into seperate function --- src/Codec/Xlsx/Parser/Stream.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index a1360168..477c47a1 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream @@ -25,10 +26,16 @@ readXlsx :: MonadIO m => MonadThrow m => ConduitT BS.ByteString XlsxItem m () readXlsx = (() <$ unZipStream) .| do - await >>= go - where - go (Just val) = do - liftIO $ print val - yield (MkXlsxItem $ MkSheetItem mempty) - await >>= go - go Nothing = pure () + await >>= goRead + +goRead :: MonadIO m => MonadThrow m + => PrimMonad m + => Maybe (Either ZipEntry BS.ByteString) -> ConduitT (Either ZipEntry BS.ByteString) XlsxItem m () +goRead = \case + Just (Left path) -> do + liftIO $ print path + await >>= goRead + Just (Right fdata) -> do + yield (MkXlsxItem $ MkSheetItem mempty) + await >>= goRead + Nothing -> pure () From aa2f4a7f70b7587deaebfc1caabf4574e85fc2eb Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 28 Jan 2021 15:33:11 -0400 Subject: [PATCH 05/37] Don't print the bytestring --- benchmarks/Stream.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index c791bd84..7ca785b6 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -15,7 +15,5 @@ main = do let filename = "data/testInput.xlsx" -- "data/6000.rows.x.26.cols.xlsx" bs <- BS.readFile filename - print bs - putStrLn "startin" x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] print x From e3d7a41c021648e92e3aba2c370d91088e11591b Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 29 Jan 2021 14:23:15 -0400 Subject: [PATCH 06/37] I'm finding out it aint ordered --- benchmarks/Stream.hs | 6 +-- src/Codec/Xlsx/Parser/Stream.hs | 69 ++++++++++++++++++++++++++------- xlsx.cabal | 1 + 3 files changed, 58 insertions(+), 18 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index 7ca785b6..40ea4de4 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -12,8 +12,8 @@ import Codec.Xlsx.Parser.Stream main :: IO () main = do - let filename = "data/testInput.xlsx" + let filename = "data/6000.rows.x.26.cols.xlsx" -- "data/6000.rows.x.26.cols.xlsx" bs <- BS.readFile filename - x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] - print x + _ <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] + pure () diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 477c47a1..367187d8 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,4 +1,6 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream @@ -7,35 +9,72 @@ module Codec.Xlsx.Parser.Stream , XlsxItem(..) ) where -import Data.Conduit +import Control.Monad.State.Lazy +import Data.Conduit(ConduitT) +import Conduit(PrimMonad, MonadThrow, yield, await, (.|)) +import qualified Conduit as C +import qualified Data.Conduit as C +import qualified Data.Conduit.Combinators as C import Codec.Archive.Zip.Conduit.UnZip import Codec.Xlsx.Types.Cell -import Conduit import qualified Data.ByteString as BS +import Text.XML.Stream.Parse +import Data.XML.Types +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Control.Lens data SheetItem = MkSheetItem { - siCellRow :: CellRow + _si_cell_row :: CellRow } deriving Show data XlsxItem = MkXlsxItem { - xiSheet :: SheetItem + _xi_sheet :: SheetItem } deriving Show +data PsFiles = UnkownFile Text + | Sheet Text + | InitialNoFile + + +data PipeState = MkPipeState + { _ps_file :: PsFiles + } +makeLenses 'MkPipeState + readXlsx :: MonadIO m => MonadThrow m => PrimMonad m => ConduitT BS.ByteString XlsxItem m () readXlsx = (() <$ unZipStream) - .| do - await >>= goRead + .| (C.evalStateLC (MkPipeState InitialNoFile) $ (await >>= tagFiles) + .| parseBytes def + .| parseSheet) -goRead :: MonadIO m => MonadThrow m +-- | there are various files in the excell file, which is a glorified zip folder +-- here we tag them with things we know, and push it into the state monad. +-- we need a state monad to make the excell parsing conduit to function +tagFiles :: + MonadState PipeState m + => MonadIO m + => MonadThrow m => PrimMonad m - => Maybe (Either ZipEntry BS.ByteString) -> ConduitT (Either ZipEntry BS.ByteString) XlsxItem m () -goRead = \case - Just (Left path) -> do - liftIO $ print path - await >>= goRead + => Maybe (Either ZipEntry BS.ByteString) -> ConduitT (Either ZipEntry BS.ByteString) BS.ByteString m () +tagFiles = \case + Just (Left zipEntry) -> do + liftIO $ print zipEntry + -- bsf_file .= either id Text.decodeUtf8 (zipEntryName zipEntry) + await >>= tagFiles Just (Right fdata) -> do - yield (MkXlsxItem $ MkSheetItem mempty) - await >>= goRead - Nothing -> pure () + yield fdata + await >>= tagFiles + Nothing -> pure () + +parseSheet :: + MonadIO m + => MonadThrow m + => PrimMonad m + => MonadState PipeState m + => ConduitT Event XlsxItem m () +parseSheet = C.mapM $ \x -> do + -- liftIO $ print x + pure $ MkXlsxItem $ MkSheetItem mempty diff --git a/xlsx.cabal b/xlsx.cabal index 3c4694cd..d939a93b 100644 --- a/xlsx.cabal +++ b/xlsx.cabal @@ -103,6 +103,7 @@ Library , zip-archive >= 0.2 , zlib >= 0.5.4.0 , zip-stream >= 0.2.0.1 + , xml-types if flag(microlens) Build-depends: microlens >= 0.4 && < 0.5 , microlens-mtl From 8bf96d977bf850741870c0a69e26fba37d52ebc6 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 29 Jan 2021 17:12:26 -0400 Subject: [PATCH 07/37] Go a long way towards completion --- benchmarks/Stream.hs | 7 +- src/Codec/Xlsx/Parser/Stream.hs | 115 +++++++++++++++++++++++++++----- 2 files changed, 104 insertions(+), 18 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index 40ea4de4..3666df57 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -12,8 +12,11 @@ import Codec.Xlsx.Parser.Stream main :: IO () main = do - let filename = "data/6000.rows.x.26.cols.xlsx" + let filename = + "../temp/policy-bordereau-template.xlsx" + -- "data/testInput.xlsx" -- "data/6000.rows.x.26.cols.xlsx" bs <- BS.readFile filename - _ <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] + x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] + -- print x pure () diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 367187d8..21de43dc 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,14 +1,16 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream ( readXlsx , SheetItem(..) - , XlsxItem(..) + , SheetItem(..) ) where +import Data.Foldable import Control.Monad.State.Lazy import Data.Conduit(ConduitT) import Conduit(PrimMonad, MonadThrow, yield, await, (.|)) @@ -22,31 +24,65 @@ import Text.XML.Stream.Parse import Data.XML.Types import Data.Text (Text) import qualified Data.Text.Encoding as Text +import qualified Data.Text as Text import Control.Lens -data SheetItem = MkSheetItem { - _si_cell_row :: CellRow - } deriving Show - -data XlsxItem = MkXlsxItem { - _xi_sheet :: SheetItem +data SheetItem = MkSheetItem + { _si_sheet :: Text + , _si_cell_row :: CellRow } deriving Show +-- http://officeopenxml.com/anatomyofOOXML-xlsx.php data PsFiles = UnkownFile Text | Sheet Text | InitialNoFile + | SharedStrings + | Styles + | Workbook + | ContentTypes + | Relationships + | SheetRel Text + deriving Show +makePrisms ''PsFiles +decodeFiles :: Text -> PsFiles +decodeFiles = \case + "xl/sharedStrings.xml" -> SharedStrings + "xl/styles.xml" -> Styles + "xl/workbook.xml" -> Workbook + "[Content_Types].xml" -> ContentTypes + "_rels/.rels" -> Relationships + unkown -> let + ws = "xl/worksheets/" + wsL = Text.length ws + in + if Text.take wsL unkown == ws then + let + known = Text.drop wsL unkown + rel = "_rels/" + relL = Text.length rel + in + if Text.take relL known == rel then + SheetRel $ Text.drop relL known + else + Sheet known + else UnkownFile unkown data PipeState = MkPipeState - { _ps_file :: PsFiles + { _ps_file :: PsFiles + , _ps_row :: CellRow + , _ps_sheet_name :: Text + , _ps_is_in_cell :: Bool + , _ps_is_in_val :: Bool } makeLenses 'MkPipeState readXlsx :: MonadIO m => MonadThrow m => PrimMonad m - => ConduitT BS.ByteString XlsxItem m () + => ConduitT BS.ByteString SheetItem m () readXlsx = (() <$ unZipStream) - .| (C.evalStateLC (MkPipeState InitialNoFile) $ (await >>= tagFiles) + .| (C.evalStateLC (MkPipeState InitialNoFile mempty mempty) $ (await >>= tagFiles) + .| C.filterM (const $ not . has _UnkownFile <$> use ps_file) .| parseBytes def .| parseSheet) @@ -61,8 +97,8 @@ tagFiles :: => Maybe (Either ZipEntry BS.ByteString) -> ConduitT (Either ZipEntry BS.ByteString) BS.ByteString m () tagFiles = \case Just (Left zipEntry) -> do - liftIO $ print zipEntry - -- bsf_file .= either id Text.decodeUtf8 (zipEntryName zipEntry) + let filePath = either id Text.decodeUtf8 (zipEntryName zipEntry) + ps_file .= decodeFiles filePath await >>= tagFiles Just (Right fdata) -> do yield fdata @@ -74,7 +110,54 @@ parseSheet :: => MonadThrow m => PrimMonad m => MonadState PipeState m - => ConduitT Event XlsxItem m () -parseSheet = C.mapM $ \x -> do - -- liftIO $ print x - pure $ MkXlsxItem $ MkSheetItem mempty + => ConduitT Event SheetItem m () +parseSheet = await >>= parseSheetLoop + +-- we significantly +parseSheetLoop :: + MonadIO m + => MonadThrow m + => PrimMonad m + => MonadState PipeState m + => Maybe Event + -> ConduitT Event SheetItem m () +parseSheetLoop = \case + Nothing -> pure () + Just evt -> do + file <- use ps_file + case file of + Sheet name -> do + mingze <- use ps_sheet_name + unless (mingze == name) $ + popRow >>= yield . MkSheetItem name + + liftIO $ print (name, evt) + mResult <- matchEvent name evt + traverse_ (yield . MkSheetItem name) mResult + await >>= parseSheetLoop + _ -> await >>= parseSheetLoop + +popRow :: MonadState PipeState m => m CellRow +popRow = do + row <- use ps_row + ps_row .= mempty + pure row + +popRow :: MonadState PipeState m => Text -> m () +popRow txt = do + val <- use ps_is_in_val + cel <- ps_is_in_cell + when (cel && val) $ do + -- TODO coordinate? + pure () + +matchEvent :: MonadState PipeState m => Text -> Event -> m (Maybe CellRow) +matchEvent currentSheet = \case + EventContent (ContentText txt) -> Nothing <$ setCell txt + EventBeginElement Name {nameLocalName = "v"} _ -> Nothing <$ ps_is_in_val .= True + EventEndElement Name {nameLocalName = "v"} -> Nothing <$ ps_is_in_val .= False + EventBeginElement Name {nameLocalName = "c"} _ -> Nothing <$ ps_is_in_cell .= True + EventEndElement Name {nameLocalName = "c"} -> Nothing <$ ps_is_in_cell .= False + EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow + EventEndElement Name {nameLocalName = "row"} -> Just <$> popRow + _ -> pure Nothing From 35c2c9f596b02035c34a938dec1635be4b9982ad Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 10 Feb 2021 15:15:32 -0400 Subject: [PATCH 08/37] Use coerce for free speed --- src/Codec/Xlsx/Types/Common.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs index 61d73e1c..ddb24ed9 100644 --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -28,6 +28,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) @@ -79,7 +80,7 @@ singleCellRefRaw (row, col) = T.concat [int2col col, T.pack (show row)] -- | reverse to 'mkCellRef' fromSingleCellRef :: CellRef -> Maybe (Int, Int) -fromSingleCellRef = fromSingleCellRefRaw . unCellRef +fromSingleCellRef = fromSingleCellRefRaw . coerce fromSingleCellRefRaw :: Text -> Maybe (Int, Int) fromSingleCellRefRaw t = do @@ -93,7 +94,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 +110,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 From 4a70c013fb09f6c28ad18f08c5a7fd01dfc794bc Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 10 Feb 2021 16:21:11 -0400 Subject: [PATCH 09/37] Do some rundimentary parsing --- benchmarks/Stream.hs | 3 +- src/Codec/Xlsx/Parser/Stream.hs | 91 +++++++++++++++++++++++---------- src/Codec/Xlsx/Types/Cell.hs | 4 -- src/Codec/Xlsx/Types/Common.hs | 9 +++- 4 files changed, 73 insertions(+), 34 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index 3666df57..dc4a25ed 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -18,5 +18,4 @@ main = do -- "data/6000.rows.x.26.cols.xlsx" bs <- BS.readFile filename x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] - -- print x - pure () + print x diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 21de43dc..843617c6 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -10,6 +10,10 @@ module Codec.Xlsx.Parser.Stream , SheetItem(..) ) where +import qualified Data.Map as Map +import Data.Bifunctor +import Codec.Xlsx.Types.Common +import Control.Monad.Except import Data.Foldable import Control.Monad.State.Lazy import Data.Conduit(ConduitT) @@ -28,8 +32,9 @@ import qualified Data.Text as Text import Control.Lens data SheetItem = MkSheetItem - { _si_sheet :: Text - , _si_cell_row :: CellRow + { _si_sheet :: Text + , _si_row_index :: Int + , _si_cell_row :: CellRow } deriving Show -- http://officeopenxml.com/anatomyofOOXML-xlsx.php @@ -69,11 +74,11 @@ decodeFiles = \case else UnkownFile unkown data PipeState = MkPipeState - { _ps_file :: PsFiles - , _ps_row :: CellRow - , _ps_sheet_name :: Text - , _ps_is_in_cell :: Bool - , _ps_is_in_val :: Bool + { _ps_file :: PsFiles + , _ps_row :: CellRow + , _ps_sheet_name :: Text + , _ps_cell_row_index :: Int + , _ps_cell_col_index :: Int } makeLenses 'MkPipeState @@ -81,7 +86,7 @@ readXlsx :: MonadIO m => MonadThrow m => PrimMonad m => ConduitT BS.ByteString SheetItem m () readXlsx = (() <$ unZipStream) - .| (C.evalStateLC (MkPipeState InitialNoFile mempty mempty) $ (await >>= tagFiles) + .| (C.evalStateLC (MkPipeState InitialNoFile mempty mempty 0 0) $ (await >>= tagFiles) .| C.filterM (const $ not . has _UnkownFile <$> use ps_file) .| parseBytes def .| parseSheet) @@ -128,13 +133,18 @@ parseSheetLoop = \case case file of Sheet name -> do mingze <- use ps_sheet_name + rix <- use ps_cell_row_index unless (mingze == name) $ - popRow >>= yield . MkSheetItem name + popRow >>= yield . MkSheetItem name rix liftIO $ print (name, evt) - mResult <- matchEvent name evt - traverse_ (yield . MkSheetItem name) mResult - await >>= parseSheetLoop + parseRes <- runExceptT $ matchEvent name evt + rix' <- use ps_cell_row_index + case parseRes of + Left err -> liftIO $ print err + Right mResult -> do + traverse_ (yield . MkSheetItem name rix') mResult + await >>= parseSheetLoop _ -> await >>= parseSheetLoop popRow :: MonadState PipeState m => m CellRow @@ -143,21 +153,50 @@ popRow = do ps_row .= mempty pure row -popRow :: MonadState PipeState m => Text -> m () -popRow txt = do - val <- use ps_is_in_val - cel <- ps_is_in_cell - when (cel && val) $ do - -- TODO coordinate? +addCell :: MonadState PipeState m => Text -> m () +addCell txt = do + col <- use ps_cell_col_index + ps_row <>= (Map.singleton col $ Cell + { _cellStyle = Nothing + , _cellValue = Just $ CellText txt -- TODO type + , _cellComment = Nothing + , _cellFormula = Nothing + }) pure () -matchEvent :: MonadState PipeState m => Text -> Event -> m (Maybe CellRow) +newtype PipeErrors = MkCoordinate CoordinateErrors + deriving Show + +data CoordinateErrors = CoordinateNotFound [(Name, [Content])] + | NoListElement (Name, [Content]) [(Name, [Content])] + | NoTextContent Content [(Name, [Content])] + | DecodeFailure Text [(Name, [Content])] + deriving Show + +contentTextPrims :: Prism' Content Text +contentTextPrims = prism' ContentText (\case ContentText x -> Just x + _ -> Nothing) + +setCoord :: MonadError PipeErrors m => MonadState PipeState m => [(Name, [Content])] -> m () +setCoord list = do + coordinates <- liftEither $ first MkCoordinate $ parseCoordinates list + ps_cell_col_index .= (coordinates ^. _2) + ps_cell_row_index .= (coordinates ^. _1) + +parseCoordinates :: [(Name, [Content])] -> Either CoordinateErrors (Int, Int) +parseCoordinates list = do + nameValPair <- maybe (Left $ CoordinateNotFound list) Right $ find (("r" ==) . nameLocalName . fst) 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 + +matchEvent :: MonadError PipeErrors m => MonadState PipeState m => Text -> Event -> m (Maybe CellRow) matchEvent currentSheet = \case - EventContent (ContentText txt) -> Nothing <$ setCell txt - EventBeginElement Name {nameLocalName = "v"} _ -> Nothing <$ ps_is_in_val .= True - EventEndElement Name {nameLocalName = "v"} -> Nothing <$ ps_is_in_val .= False - EventBeginElement Name {nameLocalName = "c"} _ -> Nothing <$ ps_is_in_cell .= True - EventEndElement Name {nameLocalName = "c"} -> Nothing <$ ps_is_in_cell .= False - EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow - EventEndElement Name {nameLocalName = "row"} -> Just <$> popRow + EventContent (ContentText txt) -> Nothing <$ addCell txt + EventBeginElement Name {nameLocalName = "c"} vals -> Nothing <$ setCoord vals + -- EventEndElement Name {nameLocalName = "v"} -> Nothing <$ (ps_is_in_val .= False) + -- EventBeginElement Name {nameLocalName = "c"} _ -> Nothing <$ ps_is_in_cell .= True + -- EventEndElement Name {nameLocalName = "c"} -> Nothing <$ ps_is_in_cell .= False + EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow + EventEndElement Name {nameLocalName = "row"} -> Just <$> popRow _ -> pure Nothing diff --git a/src/Codec/Xlsx/Types/Cell.hs b/src/Codec/Xlsx/Types/Cell.hs index c82f1f57..0e9e9534 100644 --- a/src/Codec/Xlsx/Types/Cell.hs +++ b/src/Codec/Xlsx/Types/Cell.hs @@ -19,8 +19,6 @@ module Codec.Xlsx.Types.Cell , cellFormula , CellMap , CellRow - , RowIndex - , ColIndex , toNested , unNested ) where @@ -117,8 +115,6 @@ instance Default Cell where makeLenses ''Cell -type RowIndex = Int -type ColIndex = Int -- | Map containing cell values which are indexed by row and column -- if you need to use more traditional (x,y) indexing please you could diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs index ddb24ed9..7cdd5ee4 100644 --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -19,6 +19,8 @@ module Codec.Xlsx.Types.Common , dateToNumber , int2col , col2int + , RowIndex + , ColIndex ) where import GHC.Generics (Generic) @@ -72,14 +74,14 @@ 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 :: CellRef -> Maybe (RowIndex, ColIndex) fromSingleCellRef = fromSingleCellRefRaw . coerce fromSingleCellRefRaw :: Text -> Maybe (Int, Int) @@ -386,3 +388,6 @@ instance ToAttrVal ErrorType where toAttrVal ErrorNum = "#NUM!" toAttrVal ErrorRef = "#REF!" toAttrVal ErrorValue = "#VALUE!" + +type RowIndex = Int +type ColIndex = Int From 67ce37236c04f8a6d98d32faf2b2e1c0791ac1a6 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 15 Feb 2021 16:50:33 -0400 Subject: [PATCH 10/37] Add styling the binary to see what's going on --- benchmarks/Stream.hs | 22 +++++++++++++++++++--- src/Codec/Xlsx/Parser/Stream.hs | 26 ++++++++++++++++++-------- xlsx.cabal | 1 + 3 files changed, 38 insertions(+), 11 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index dc4a25ed..ef4b9084 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} module Main (main) where import Prelude hiding (foldl) @@ -7,8 +8,22 @@ import Criterion.Main import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LB import Conduit -import Data.Conduit.Combinators hiding (print) import Codec.Xlsx.Parser.Stream +import Data.Text(Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import qualified Data.Conduit.Combinators as C + +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) main :: IO () main = do @@ -17,5 +32,6 @@ main = do -- "data/testInput.xlsx" -- "data/6000.rows.x.26.cols.xlsx" bs <- BS.readFile filename - x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| foldl (\a b -> b : a) [] - print x + x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> b : a) [] + Text.putStrLn $ Text.intercalate "\n" $ format <$> x + pure () diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 843617c6..c6c95b0b 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream @@ -132,9 +134,10 @@ parseSheetLoop = \case file <- use ps_file case file of Sheet name -> do - mingze <- use ps_sheet_name + prevSheetName <- use ps_sheet_name rix <- use ps_cell_row_index - unless (mingze == name) $ + unless (prevSheetName == name) $ do + ps_sheet_name .= name popRow >>= yield . MkSheetItem name rix liftIO $ print (name, evt) @@ -143,25 +146,32 @@ parseSheetLoop = \case case parseRes of Left err -> liftIO $ print err Right mResult -> do - traverse_ (yield . MkSheetItem name rix') mResult + traverse_ (\x -> do + liftIO $ print x + yield $ MkSheetItem name rix' x) mResult await >>= parseSheetLoop _ -> await >>= parseSheetLoop -popRow :: MonadState PipeState m => m CellRow +popRow :: MonadIO m => MonadState PipeState m => m CellRow popRow = do + liftIO $ print "popping row" row <- use ps_row ps_row .= mempty pure row -addCell :: MonadState PipeState m => Text -> m () +addCell :: MonadIO m => MonadState PipeState m => Text -> m () addCell txt = do + liftIO $ print ("adding sell", txt) col <- use ps_cell_col_index + y <- use ps_row ps_row <>= (Map.singleton col $ Cell { _cellStyle = Nothing , _cellValue = Just $ CellText txt -- TODO type , _cellComment = Nothing , _cellFormula = Nothing }) + x <- use ps_row + liftIO $ print ("val of row", y, x) pure () newtype PipeErrors = MkCoordinate CoordinateErrors @@ -190,13 +200,13 @@ parseCoordinates list = do valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText -matchEvent :: MonadError PipeErrors m => MonadState PipeState m => Text -> Event -> m (Maybe CellRow) +matchEvent :: MonadIO m => MonadError PipeErrors m => MonadState PipeState m => Text -> Event -> m (Maybe CellRow) matchEvent currentSheet = \case EventContent (ContentText txt) -> Nothing <$ addCell txt - EventBeginElement Name {nameLocalName = "c"} vals -> Nothing <$ setCoord vals + EventBeginElement (Name{nameLocalName = "c", ..}) vals -> Nothing <$ setCoord vals -- EventEndElement Name {nameLocalName = "v"} -> Nothing <$ (ps_is_in_val .= False) -- EventBeginElement Name {nameLocalName = "c"} _ -> Nothing <$ ps_is_in_cell .= True -- EventEndElement Name {nameLocalName = "c"} -> Nothing <$ ps_is_in_cell .= False EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow - EventEndElement Name {nameLocalName = "row"} -> Just <$> popRow + EventEndElement (Name{nameLocalName = "row", ..}) -> Just <$> popRow _ -> pure Nothing diff --git a/xlsx.cabal b/xlsx.cabal index d939a93b..53fc3624 100644 --- a/xlsx.cabal +++ b/xlsx.cabal @@ -176,4 +176,5 @@ executable streamin , criterion , xlsx , conduit + , text default-language: Haskell2010 \ No newline at end of file From 60ddd8a77bfb33311432522218d2a11f20571354 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 24 Feb 2021 10:47:47 -0400 Subject: [PATCH 11/37] Filter out the formula --- src/Codec/Xlsx/Parser/Stream.hs | 38 ++++++++++++++++----------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index c6c95b0b..f1e72221 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -81,6 +81,7 @@ data PipeState = MkPipeState , _ps_sheet_name :: Text , _ps_cell_row_index :: Int , _ps_cell_col_index :: Int + , _ps_is_in_val :: Bool } makeLenses 'MkPipeState @@ -88,7 +89,7 @@ readXlsx :: MonadIO m => MonadThrow m => PrimMonad m => ConduitT BS.ByteString SheetItem m () readXlsx = (() <$ unZipStream) - .| (C.evalStateLC (MkPipeState InitialNoFile mempty mempty 0 0) $ (await >>= tagFiles) + .| (C.evalStateLC (MkPipeState InitialNoFile mempty mempty 0 0 False) $ (await >>= tagFiles) .| C.filterM (const $ not . has _UnkownFile <$> use ps_file) .| parseBytes def .| parseSheet) @@ -159,20 +160,18 @@ popRow = do ps_row .= mempty pure row -addCell :: MonadIO m => MonadState PipeState m => Text -> m () +addCell :: MonadState PipeState m => Text -> m () addCell txt = do - liftIO $ print ("adding sell", txt) - col <- use ps_cell_col_index - y <- use ps_row - ps_row <>= (Map.singleton col $ Cell - { _cellStyle = Nothing - , _cellValue = Just $ CellText txt -- TODO type - , _cellComment = Nothing - , _cellFormula = Nothing - }) - x <- use ps_row - liftIO $ print ("val of row", y, x) - pure () + inVal <- use ps_is_in_val + when inVal $ do + col <- use ps_cell_col_index + y <- use ps_row + ps_row <>= (Map.singleton col $ Cell + { _cellStyle = Nothing + , _cellValue = Just $ CellText txt -- TODO type + , _cellComment = Nothing + , _cellFormula = Nothing + }) newtype PipeErrors = MkCoordinate CoordinateErrors deriving Show @@ -202,11 +201,12 @@ parseCoordinates list = do matchEvent :: MonadIO m => MonadError PipeErrors m => MonadState PipeState m => Text -> Event -> m (Maybe CellRow) matchEvent currentSheet = \case - EventContent (ContentText txt) -> Nothing <$ addCell txt - EventBeginElement (Name{nameLocalName = "c", ..}) vals -> Nothing <$ setCoord vals - -- EventEndElement Name {nameLocalName = "v"} -> Nothing <$ (ps_is_in_val .= False) + EventContent (ContentText txt) -> Nothing <$ addCell txt + EventBeginElement Name{nameLocalName = "c", ..} vals -> Nothing <$ setCoord vals + EventBeginElement Name {nameLocalName = "v"} _ -> Nothing <$ (ps_is_in_val .= True) + EventEndElement Name {nameLocalName = "v"} -> Nothing <$ (ps_is_in_val .= False) -- EventBeginElement Name {nameLocalName = "c"} _ -> Nothing <$ ps_is_in_cell .= True -- EventEndElement Name {nameLocalName = "c"} -> Nothing <$ ps_is_in_cell .= False - EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow - EventEndElement (Name{nameLocalName = "row", ..}) -> Just <$> popRow + EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow + EventEndElement Name{nameLocalName = "row", ..} -> Just <$> popRow _ -> pure Nothing From a370951c4061f3f07fb841eb60a9d413427409f5 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 24 Feb 2021 14:59:15 -0400 Subject: [PATCH 12/37] Add string table parsing, cleanup warnings --- src/Codec/Xlsx/Parser/Stream.hs | 85 +++++++++++++++++++++++++-------- 1 file changed, 66 insertions(+), 19 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index f1e72221..8f591936 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -9,10 +9,10 @@ module Codec.Xlsx.Parser.Stream ( readXlsx , SheetItem(..) - , SheetItem(..) ) where import qualified Data.Map as Map +import Data.Map (Map) import Data.Bifunctor import Codec.Xlsx.Types.Common import Control.Monad.Except @@ -21,7 +21,6 @@ import Control.Monad.State.Lazy import Data.Conduit(ConduitT) import Conduit(PrimMonad, MonadThrow, yield, await, (.|)) import qualified Conduit as C -import qualified Data.Conduit as C import qualified Data.Conduit.Combinators as C import Codec.Archive.Zip.Conduit.UnZip import Codec.Xlsx.Types.Cell @@ -79,20 +78,34 @@ data PipeState = MkPipeState { _ps_file :: PsFiles , _ps_row :: CellRow , _ps_sheet_name :: Text - , _ps_cell_row_index :: Int - , _ps_cell_col_index :: Int - , _ps_is_in_val :: Bool + , _ps_cell_row_index :: Int + , _ps_cell_col_index :: Int + , _ps_is_in_val :: Bool + , _ps_shared_strings :: Map Int Text + , _ps_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway } makeLenses 'MkPipeState +initialState :: PipeState +initialState = MkPipeState + { _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_shared_ix = 0 + } + readXlsx :: MonadIO m => MonadThrow m => PrimMonad m => ConduitT BS.ByteString SheetItem m () readXlsx = (() <$ unZipStream) - .| (C.evalStateLC (MkPipeState InitialNoFile mempty mempty 0 0 False) $ (await >>= tagFiles) + .| (C.evalStateLC initialState $ (await >>= tagFiles) .| C.filterM (const $ not . has _UnkownFile <$> use ps_file) .| parseBytes def - .| parseSheet) + .| parseFiles) -- | there are various files in the excell file, which is a glorified zip folder -- here we tag them with things we know, and push it into the state monad. @@ -113,28 +126,60 @@ tagFiles = \case await >>= tagFiles Nothing -> pure () -parseSheet :: +parseFiles :: MonadIO m => MonadThrow m => PrimMonad m => MonadState PipeState m => ConduitT Event SheetItem m () -parseSheet = await >>= parseSheetLoop +parseFiles = await >>= parseFileLoop -- we significantly -parseSheetLoop :: +parseFileLoop :: MonadIO m => MonadThrow m => PrimMonad m => MonadState PipeState m => Maybe Event -> ConduitT Event SheetItem m () -parseSheetLoop = \case +parseFileLoop = \case Nothing -> pure () Just evt -> do file <- use ps_file case file of - Sheet name -> do + Sheet name -> parseSheet evt name + SharedStrings -> parseStrings evt + _ -> await >>= parseFileLoop + +parseStrings :: + MonadIO m + => MonadThrow m + => PrimMonad m + => MonadState PipeState m + => Event -> ConduitT Event SheetItem m () +parseStrings evt = do + parseString evt + await >>= parseFileLoop + +parseString :: + MonadIO m + => MonadThrow m + => PrimMonad m + => MonadState PipeState m + => Event -> m () +parseString = \case + EventContent (ContentText txt) -> do + idx <- use ps_shared_ix + ps_shared_strings %= set (at idx) (Just txt) + _ -> pure () + +parseSheet :: + MonadIO m + => MonadThrow m + => PrimMonad m + => MonadState PipeState m + => Event -> Text -> ConduitT Event SheetItem m () +parseSheet evt name = do prevSheetName <- use ps_sheet_name rix <- use ps_cell_row_index unless (prevSheetName == name) $ do @@ -150,12 +195,10 @@ parseSheetLoop = \case traverse_ (\x -> do liftIO $ print x yield $ MkSheetItem name rix' x) mResult - await >>= parseSheetLoop - _ -> await >>= parseSheetLoop + await >>= parseFileLoop -popRow :: MonadIO m => MonadState PipeState m => m CellRow +popRow :: MonadState PipeState m => m CellRow popRow = do - liftIO $ print "popping row" row <- use ps_row ps_row .= mempty pure row @@ -165,7 +208,6 @@ addCell txt = do inVal <- use ps_is_in_val when inVal $ do col <- use ps_cell_col_index - y <- use ps_row ps_row <>= (Map.singleton col $ Cell { _cellStyle = Nothing , _cellValue = Just $ CellText txt -- TODO type @@ -173,6 +215,7 @@ addCell txt = do , _cellFormula = Nothing }) + newtype PipeErrors = MkCoordinate CoordinateErrors deriving Show @@ -192,15 +235,19 @@ setCoord list = do ps_cell_col_index .= (coordinates ^. _2) ps_cell_row_index .= (coordinates ^. _1) +findName :: Text -> [(Name, [Content])] -> Maybe (Name, [Content]) +findName name = find ((name ==) . nameLocalName . fst) + + parseCoordinates :: [(Name, [Content])] -> Either CoordinateErrors (Int, Int) parseCoordinates list = do - nameValPair <- maybe (Left $ CoordinateNotFound list) Right $ find (("r" ==) . nameLocalName . fst) list + 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 matchEvent :: MonadIO m => MonadError PipeErrors m => MonadState PipeState m => Text -> Event -> m (Maybe CellRow) -matchEvent currentSheet = \case +matchEvent _currentSheet = \case EventContent (ContentText txt) -> Nothing <$ addCell txt EventBeginElement Name{nameLocalName = "c", ..} vals -> Nothing <$ setCoord vals EventBeginElement Name {nameLocalName = "v"} _ -> Nothing <$ (ps_is_in_val .= True) From 8690e0af04d0d12f5087823829dd738af7fe9119 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 24 Feb 2021 16:33:57 -0400 Subject: [PATCH 13/37] THis only get's the last string (lol) --- benchmarks/Stream.hs | 2 +- src/Codec/Xlsx/Parser/Stream.hs | 218 +++++++++++++++++++++----------- 2 files changed, 145 insertions(+), 75 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index ef4b9084..9e4a4ea9 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -32,6 +32,6 @@ main = do -- "data/testInput.xlsx" -- "data/6000.rows.x.26.cols.xlsx" bs <- BS.readFile filename - x <- runResourceT $ runConduit $ sourceFile filename .| readXlsx .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> b : a) [] + x <- runResourceT $ runConduit $ readXlsx (sourceFile filename) .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> b : a) [] Text.putStrLn $ Text.intercalate "\n" $ format <$> x pure () diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 8f591936..6bfd6c15 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream @@ -11,26 +13,28 @@ module Codec.Xlsx.Parser.Stream , SheetItem(..) ) where -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Bifunctor -import Codec.Xlsx.Types.Common -import Control.Monad.Except -import Data.Foldable -import Control.Monad.State.Lazy -import Data.Conduit(ConduitT) -import Conduit(PrimMonad, MonadThrow, yield, await, (.|)) -import qualified Conduit as C -import qualified Data.Conduit.Combinators as C -import Codec.Archive.Zip.Conduit.UnZip -import Codec.Xlsx.Types.Cell -import qualified Data.ByteString as BS -import Text.XML.Stream.Parse -import Data.XML.Types -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import qualified Data.Text as Text -import Control.Lens +import Codec.Archive.Zip.Conduit.UnZip +import Codec.Xlsx.Types.Cell +import Codec.Xlsx.Types.Common +import Conduit (MonadThrow, PrimMonad, await, + yield, (.|)) +import qualified Conduit as C +import Control.Lens +import Control.Monad.Except +import Control.Monad.State.Lazy +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 (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.XML.Types +import Text.Read +import Text.XML.Stream.Parse data SheetItem = MkSheetItem { _si_sheet :: Text @@ -74,20 +78,38 @@ decodeFiles = \case Sheet known else UnkownFile unkown -data PipeState = MkPipeState - { _ps_file :: PsFiles - , _ps_row :: CellRow - , _ps_sheet_name :: Text - , _ps_cell_row_index :: Int - , _ps_cell_col_index :: Int - , _ps_is_in_val :: Bool - , _ps_shared_strings :: Map Int Text - , _ps_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway +data TVal = T_S -- string ? + | T_N -- number ? + +data SheetState = MkSheetState + { _ps_file :: PsFiles + , _ps_row :: CellRow + , _ps_sheet_name :: Text + , _ps_cell_row_index :: Int + , _ps_cell_col_index :: Int + , _ps_is_in_val :: Bool + , _ps_shared_strings :: Map Int Text + , _ps_t :: TVal -- the last detected value + } +makeLenses 'MkSheetState + +data SharedStringState = MkSharedStringState + { _ss_file :: PsFiles + , _ss_shared_strings :: Map Int Text + , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway } -makeLenses 'MkPipeState +makeLenses 'MkSharedStringState -initialState :: PipeState -initialState = MkPipeState +class HasPSFiles a where + fileLens :: Lens' a PsFiles + +instance HasPSFiles SheetState where + fileLens = ps_file +instance HasPSFiles SharedStringState where + fileLens = ss_file + +initialSheetState :: SheetState +initialSheetState = MkSheetState { _ps_file = InitialNoFile , _ps_row = mempty , _ps_sheet_name = mempty @@ -95,15 +117,36 @@ initialState = MkPipeState , _ps_cell_col_index = 0 , _ps_is_in_val = False , _ps_shared_strings = mempty - , _ps_shared_ix = 0 + , _ps_t = T_S } -readXlsx :: MonadIO m => MonadThrow m +initialSharedString :: SharedStringState +initialSharedString = MkSharedStringState + { _ss_file = InitialNoFile + , _ss_shared_strings = mempty + , _ss_shared_ix = 0 + } + +parseSharedStrings :: forall m . MonadIO m => MonadThrow m + => PrimMonad m + => forall i. ConduitT i BS.ByteString m () -> ConduitT i SheetItem m SharedStringState +parseSharedStrings input = input .| (() <$ unZipStream) + .| (C.execStateC initialSharedString $ + (await >>= tagFiles) + .| C.filterM (const $ has _SharedStrings <$> use fileLens) + .| parseBytes def + .| C.mapM_ parseString + ) + +readXlsx :: forall m . MonadIO m => MonadThrow m => PrimMonad m - => ConduitT BS.ByteString SheetItem m () -readXlsx = (() <$ unZipStream) - .| (C.evalStateLC initialState $ (await >>= tagFiles) - .| C.filterM (const $ not . has _UnkownFile <$> use ps_file) + => forall i. ConduitT i BS.ByteString m () -> ConduitT i SheetItem m () +readXlsx input = do + ssState <- parseSharedStrings input + let initial = set ps_shared_strings (ssState ^. ss_shared_strings) initialSheetState + input .| (() <$ unZipStream) + .| (C.evalStateLC initial $ (await >>= tagFiles) + .| C.filterM (const $ not . has _UnkownFile <$> use fileLens) .| parseBytes def .| parseFiles) @@ -111,7 +154,8 @@ readXlsx = (() <$ unZipStream) -- here we tag them with things we know, and push it into the state monad. -- we need a state monad to make the excell parsing conduit to function tagFiles :: - MonadState PipeState m + HasPSFiles env + => MonadState env m => MonadIO m => MonadThrow m => PrimMonad m @@ -119,7 +163,7 @@ tagFiles :: tagFiles = \case Just (Left zipEntry) -> do let filePath = either id Text.decodeUtf8 (zipEntryName zipEntry) - ps_file .= decodeFiles filePath + fileLens .= decodeFiles filePath await >>= tagFiles Just (Right fdata) -> do yield fdata @@ -130,7 +174,7 @@ parseFiles :: MonadIO m => MonadThrow m => PrimMonad m - => MonadState PipeState m + => MonadState SheetState m => ConduitT Event SheetItem m () parseFiles = await >>= parseFileLoop @@ -139,7 +183,7 @@ parseFileLoop :: MonadIO m => MonadThrow m => PrimMonad m - => MonadState PipeState m + => MonadState SheetState m => Maybe Event -> ConduitT Event SheetItem m () parseFileLoop = \case @@ -148,36 +192,23 @@ parseFileLoop = \case file <- use ps_file case file of Sheet name -> parseSheet evt name - SharedStrings -> parseStrings evt - _ -> await >>= parseFileLoop + _ -> await >>= parseFileLoop -parseStrings :: - MonadIO m - => MonadThrow m +parseString :: MonadThrow m => PrimMonad m - => MonadState PipeState m - => Event -> ConduitT Event SheetItem m () -parseStrings evt = do - parseString evt - await >>= parseFileLoop - -parseString :: - MonadIO m - => MonadThrow m - => PrimMonad m - => MonadState PipeState m + => MonadState SharedStringState m => Event -> m () parseString = \case EventContent (ContentText txt) -> do - idx <- use ps_shared_ix - ps_shared_strings %= set (at idx) (Just txt) + idx <- use ss_shared_ix + ss_shared_strings %= set (at idx) (Just txt) _ -> pure () parseSheet :: MonadIO m => MonadThrow m => PrimMonad m - => MonadState PipeState m + => MonadState SheetState m => Event -> Text -> ConduitT Event SheetItem m () parseSheet evt name = do prevSheetName <- use ps_sheet_name @@ -197,26 +228,45 @@ parseSheet evt name = do yield $ MkSheetItem name rix' x) mResult await >>= parseFileLoop -popRow :: MonadState PipeState m => m CellRow +popRow :: MonadState SheetState m => m CellRow popRow = do row <- use ps_row ps_row .= mempty pure row -addCell :: MonadState PipeState m => Text -> m () +data AddCellErrors = ReadError String + | SharedStringNotFound Int (Map Int Text) + deriving Show + +parseValue :: Map Int Text -> Text -> TVal -> Either AddCellErrors CellValue +parseValue sstrings txt = \case + T_S -> do + (idx :: Int) <- first ReadError $ readEither $ Text.unpack txt + string <- maybe (Left $ SharedStringNotFound idx sstrings) Right $ sstrings ^? ix idx + Right $ CellText string + T_N -> bimap ReadError CellDouble $ readEither $ Text.unpack txt + +addCell :: MonadError SheetErrors m => MonadState SheetState m => Text -> m () addCell txt = do inVal <- use ps_is_in_val when inVal $ do + type' <- use ps_t + sstrings <- use ps_shared_strings + val <- liftEither $ first MkCell $ parseValue sstrings txt type' + col <- use ps_cell_col_index ps_row <>= (Map.singleton col $ Cell { _cellStyle = Nothing - , _cellValue = Just $ CellText txt -- TODO type + , _cellValue = Just val , _cellComment = Nothing , _cellFormula = Nothing }) -newtype PipeErrors = MkCoordinate CoordinateErrors +data SheetErrors = MkCoordinate CoordinateErrors + | MkType TypeError + | MkCell AddCellErrors + deriving Show data CoordinateErrors = CoordinateNotFound [(Name, [Content])] @@ -225,19 +275,39 @@ data CoordinateErrors = CoordinateNotFound [(Name, [Content])] | DecodeFailure Text [(Name, [Content])] deriving Show +data TypeError = TypeNotFound [(Name, [Content])] + | TypeNoListElement (Name, [Content]) [(Name, [Content])] + | UnkownType Text [(Name, [Content])] + | TypeNoTextContent Content [(Name, [Content])] + deriving Show + contentTextPrims :: Prism' Content Text contentTextPrims = prism' ContentText (\case ContentText x -> Just x _ -> Nothing) -setCoord :: MonadError PipeErrors m => MonadState PipeState m => [(Name, [Content])] -> m () +setCoord :: MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () setCoord list = do coordinates <- liftEither $ first MkCoordinate $ parseCoordinates list ps_cell_col_index .= (coordinates ^. _2) ps_cell_row_index .= (coordinates ^. _1) +setType :: MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () +setType list = do + type' <- liftEither $ first MkType $ parseType list + ps_t .= type' + findName :: Text -> [(Name, [Content])] -> Maybe (Name, [Content]) findName name = find ((name ==) . nameLocalName . fst) +parseType :: [(Name, [Content])] -> Either TypeError TVal +parseType list = do + nameValPair <- maybe (Left (TypeNotFound list)) Right $ findName "t" list + 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 T_N + "s" -> Right T_S + other -> Left $ UnkownType other list parseCoordinates :: [(Name, [Content])] -> Either CoordinateErrors (Int, Int) parseCoordinates list = do @@ -246,10 +316,10 @@ parseCoordinates list = do valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText -matchEvent :: MonadIO m => MonadError PipeErrors m => MonadState PipeState m => Text -> Event -> m (Maybe CellRow) +matchEvent :: MonadIO m => MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) matchEvent _currentSheet = \case EventContent (ContentText txt) -> Nothing <$ addCell txt - EventBeginElement Name{nameLocalName = "c", ..} vals -> Nothing <$ setCoord vals + 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 = "c"} _ -> Nothing <$ ps_is_in_cell .= True From 3efcde57c1847d27ed607f140437a8b62a1f6925 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 4 Mar 2021 15:31:19 -0400 Subject: [PATCH 14/37] Fix shared string bug --- benchmarks/Stream.hs | 9 ++++++--- src/Codec/Xlsx/Parser/Stream.hs | 32 ++++++++++++++++++++++---------- 2 files changed, 28 insertions(+), 13 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index 9e4a4ea9..72914d7d 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -32,6 +32,9 @@ main = do -- "data/testInput.xlsx" -- "data/6000.rows.x.26.cols.xlsx" bs <- BS.readFile filename - x <- runResourceT $ runConduit $ readXlsx (sourceFile filename) .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> b : a) [] - Text.putStrLn $ Text.intercalate "\n" $ format <$> x - pure () + state <- runResourceT $ runConduit $ sourceFile filename .| parseSharedStrings + print state + +-- - x <- runResourceT $ runConduit $ readXlsx (sourceFile filename) .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> b : a) [] +-- - Text.putStrLn $ Text.intercalate "\n" $ format <$> x +-- - pure () diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 6bfd6c15..ed04f0d1 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -11,6 +11,7 @@ module Codec.Xlsx.Parser.Stream ( readXlsx , SheetItem(..) + , parseSharedStrings ) where import Codec.Archive.Zip.Conduit.UnZip @@ -97,7 +98,7 @@ data SharedStringState = MkSharedStringState { _ss_file :: PsFiles , _ss_shared_strings :: Map Int Text , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway - } + } deriving Show makeLenses 'MkSharedStringState class HasPSFiles a where @@ -127,10 +128,10 @@ initialSharedString = MkSharedStringState , _ss_shared_ix = 0 } -parseSharedStrings :: forall m . MonadIO m => MonadThrow m +parseSharedStrings :: forall a m . MonadIO m => MonadThrow m => PrimMonad m - => forall i. ConduitT i BS.ByteString m () -> ConduitT i SheetItem m SharedStringState -parseSharedStrings input = input .| (() <$ unZipStream) + => ConduitT BS.ByteString a m SharedStringState +parseSharedStrings = (() <$ unZipStream) .| (C.execStateC initialSharedString $ (await >>= tagFiles) .| C.filterM (const $ has _SharedStrings <$> use fileLens) @@ -138,17 +139,27 @@ parseSharedStrings input = input .| (() <$ unZipStream) .| C.mapM_ parseString ) -readXlsx :: forall m . MonadIO m => MonadThrow m +readXlsxWithState :: forall m . MonadIO m => MonadThrow m => PrimMonad m - => forall i. ConduitT i BS.ByteString m () -> ConduitT i SheetItem m () -readXlsx input = do - ssState <- parseSharedStrings input - let initial = set ps_shared_strings (ssState ^. ss_shared_strings) initialSheetState - input .| (() <$ unZipStream) + => SharedStringState -> ConduitT BS.ByteString SheetItem m () +readXlsxWithState ssState = + (() <$ unZipStream) .| (C.evalStateLC initial $ (await >>= tagFiles) .| C.filterM (const $ not . has _UnkownFile <$> use fileLens) .| parseBytes def .| parseFiles) + where + initial = set ps_shared_strings (ssState ^. ss_shared_strings) initialSheetState + +-- | first reads the share string table, then provides another conuit to be run again for the remaining data. +-- reading happens twice +readXlsx :: + forall m . MonadIO m => MonadThrow m + => PrimMonad m + => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) +readXlsx input = do + ssState <- C.runConduit $ input .| parseSharedStrings + pure $ input .| readXlsxWithState ssState -- | there are various files in the excell file, which is a glorified zip folder -- here we tag them with things we know, and push it into the state monad. @@ -202,6 +213,7 @@ parseString = \case EventContent (ContentText txt) -> do idx <- use ss_shared_ix ss_shared_strings %= set (at idx) (Just txt) + ss_shared_ix += 1 _ -> pure () parseSheet :: From ad2ac8e41813f2717f96f0f5f9268c23c78a6d21 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 4 Mar 2021 18:11:13 -0400 Subject: [PATCH 15/37] Filter empty rows --- benchmarks/Stream.hs | 11 ++++------- src/Codec/Xlsx/Parser/Stream.hs | 13 +++++++++---- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index 72914d7d..60da8c39 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -31,10 +31,7 @@ main = do "../temp/policy-bordereau-template.xlsx" -- "data/testInput.xlsx" -- "data/6000.rows.x.26.cols.xlsx" - bs <- BS.readFile filename - state <- runResourceT $ runConduit $ sourceFile filename .| parseSharedStrings - print state - --- - x <- runResourceT $ runConduit $ readXlsx (sourceFile filename) .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> b : a) [] --- - Text.putStrLn $ Text.intercalate "\n" $ format <$> x --- - pure () + conduit <- runResourceT $ readXlsx (sourceFile filename) + x <- runResourceT $ runConduit $ conduit .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> a <> [b]) [] + Text.putStrLn $ Text.intercalate "\n" $ format <$> x + pure () diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index ed04f0d1..3ea79b89 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -12,6 +12,7 @@ module Codec.Xlsx.Parser.Stream ( readXlsx , SheetItem(..) , parseSharedStrings + , readXlsxWithState ) where import Codec.Archive.Zip.Conduit.UnZip @@ -227,7 +228,7 @@ parseSheet evt name = do rix <- use ps_cell_row_index unless (prevSheetName == name) $ do ps_sheet_name .= name - popRow >>= yield . MkSheetItem name rix + popRow >>= yieldSheetItem name rix liftIO $ print (name, evt) parseRes <- runExceptT $ matchEvent name evt @@ -235,11 +236,15 @@ parseSheet evt name = do case parseRes of Left err -> liftIO $ print err Right mResult -> do - traverse_ (\x -> do - liftIO $ print x - yield $ MkSheetItem name rix' x) mResult + traverse_ (yieldSheetItem name rix') mResult await >>= parseFileLoop +yieldSheetItem :: MonadThrow m + => PrimMonad m + => Text -> Int -> CellRow -> ConduitT Event SheetItem m () +yieldSheetItem name rix' row = + unless (row == mempty) $ yield $ MkSheetItem name rix' row + popRow :: MonadState SheetState m => m CellRow popRow = do row <- use ps_row From f546cf2f21ab752ac8de2357a1c5809ba815e01d Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 5 Mar 2021 16:20:25 -0400 Subject: [PATCH 16/37] Try allow user to use sideffect to lookup string too much work, let's keep original design --- src/Codec/Xlsx/Parser/Stream.hs | 98 ++++++++++++++++----------------- 1 file changed, 49 insertions(+), 49 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 3ea79b89..f8345d8c 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -31,6 +31,7 @@ import qualified Data.Conduit.Combinators as C import Data.Foldable import Data.Map (Map) import qualified Data.Map as Map +import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -90,15 +91,13 @@ data SheetState = MkSheetState , _ps_cell_row_index :: Int , _ps_cell_col_index :: Int , _ps_is_in_val :: Bool - , _ps_shared_strings :: Map Int Text , _ps_t :: TVal -- the last detected value } makeLenses 'MkSheetState data SharedStringState = MkSharedStringState - { _ss_file :: PsFiles - , _ss_shared_strings :: Map Int Text - , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway + { _ss_file :: PsFiles + , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway } deriving Show makeLenses 'MkSharedStringState @@ -118,49 +117,59 @@ initialSheetState = MkSheetState , _ps_cell_row_index = 0 , _ps_cell_col_index = 0 , _ps_is_in_val = False - , _ps_shared_strings = mempty , _ps_t = T_S } initialSharedString :: SharedStringState initialSharedString = MkSharedStringState { _ss_file = InitialNoFile - , _ss_shared_strings = mempty , _ss_shared_ix = 0 } -parseSharedStrings :: forall a m . MonadIO m => MonadThrow m +parseSharedStrings :: forall m . MonadIO m => MonadThrow m => PrimMonad m - => ConduitT BS.ByteString a m SharedStringState + => ConduitT BS.ByteString (Int, Text) m () parseSharedStrings = (() <$ unZipStream) - .| (C.execStateC initialSharedString $ + .| (C.evalStateLC initialSharedString $ (await >>= tagFiles) .| C.filterM (const $ has _SharedStrings <$> use fileLens) .| parseBytes def - .| C.mapM_ parseString + .| C.concatMapM parseString ) -readXlsxWithState :: forall m . MonadIO m => MonadThrow m +parseString :: MonadThrow m + => PrimMonad m + => MonadState SharedStringState m + => Event -> m (Maybe (Int, Text)) +parseString = \case + EventContent (ContentText txt) -> do + idx <- use ss_shared_ix + ss_shared_ix += 1 + pure $ Just (idx, txt) + _ -> pure Nothing + +-- | Allows the user to decide how to do shared string lookup. +-- for example if the shared string amount is expected to be massive +-- the filesystem could be used (or a database). +readXlsxWith :: forall m . MonadIO m => MonadThrow m => PrimMonad m - => SharedStringState -> ConduitT BS.ByteString SheetItem m () -readXlsxWithState ssState = + => (Int -> m Text) -> ConduitT BS.ByteString SheetItem m () +readXlsxWith stringFunc = (() <$ unZipStream) - .| (C.evalStateLC initial $ (await >>= tagFiles) + .| (C.evalStateLC initialSheetState $ (await >>= tagFiles) .| C.filterM (const $ not . has _UnkownFile <$> use fileLens) .| parseBytes def - .| parseFiles) - where - initial = set ps_shared_strings (ssState ^. ss_shared_strings) initialSheetState + .| parseFiles stringFunc) -- | first reads the share string table, then provides another conuit to be run again for the remaining data. --- reading happens twice +-- reading happens twice. All shared strings will be read into memory. readXlsx :: forall m . MonadIO m => MonadThrow m => PrimMonad m => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) readXlsx input = do - ssState <- C.runConduit $ input .| parseSharedStrings - pure $ input .| readXlsxWithState ssState + ssState <- C.runConduit $ input .| parseSharedStrings .| C.foldMap (uncurry Map.singleton) + pure $ input .| readXlsxWith (\x -> pure $ fromMaybe "" $ ssState ^? at x . _Just) -- | there are various files in the excell file, which is a glorified zip folder -- here we tag them with things we know, and push it into the state monad. @@ -187,8 +196,8 @@ parseFiles :: => MonadThrow m => PrimMonad m => MonadState SheetState m - => ConduitT Event SheetItem m () -parseFiles = await >>= parseFileLoop + => (Int -> m Text) -> ConduitT Event SheetItem m () +parseFiles ssfunC = await >>= parseFileLoop ssfunC -- we significantly parseFileLoop :: @@ -196,34 +205,23 @@ parseFileLoop :: => MonadThrow m => PrimMonad m => MonadState SheetState m - => Maybe Event + => (Int -> m Text) -> Maybe Event -> ConduitT Event SheetItem m () -parseFileLoop = \case +parseFileLoop ssFunc = \case Nothing -> pure () Just evt -> do file <- use ps_file case file of - Sheet name -> parseSheet evt name - _ -> await >>= parseFileLoop - -parseString :: MonadThrow m - => PrimMonad m - => MonadState SharedStringState m - => Event -> m () -parseString = \case - EventContent (ContentText txt) -> do - idx <- use ss_shared_ix - ss_shared_strings %= set (at idx) (Just txt) - ss_shared_ix += 1 - _ -> pure () + Sheet name -> parseSheet ssFunc evt name + _ -> await >>= parseFileLoop ssFunc parseSheet :: MonadIO m => MonadThrow m => PrimMonad m => MonadState SheetState m - => Event -> Text -> ConduitT Event SheetItem m () -parseSheet evt name = do + => (Int -> n Text) -> Event -> Text -> ConduitT Event SheetItem m () +parseSheet ssFunc evt name = do prevSheetName <- use ps_sheet_name rix <- use ps_cell_row_index unless (prevSheetName == name) $ do @@ -231,19 +229,20 @@ parseSheet evt name = do popRow >>= yieldSheetItem name rix liftIO $ print (name, evt) - parseRes <- runExceptT $ matchEvent name evt + parseRes <- runExceptT $ matchEvent ssFunc evt rix' <- use ps_cell_row_index case parseRes of Left err -> liftIO $ print err Right mResult -> do traverse_ (yieldSheetItem name rix') mResult - await >>= parseFileLoop + await >>= parseFileLoop ssFunc yieldSheetItem :: MonadThrow m => PrimMonad m => Text -> Int -> CellRow -> ConduitT Event SheetItem m () yieldSheetItem name rix' row = - unless (row == mempty) $ yield $ MkSheetItem name rix' row + unless (row == mempty) $ -- seems nonsensical to yield rows with no cell contents + yield $ MkSheetItem name rix' row popRow :: MonadState SheetState m => m CellRow popRow = do @@ -263,13 +262,14 @@ parseValue sstrings txt = \case Right $ CellText string T_N -> bimap ReadError CellDouble $ readEither $ Text.unpack txt -addCell :: MonadError SheetErrors m => MonadState SheetState m => Text -> m () -addCell txt = do +addCell :: MonadError SheetErrors m => MonadState SheetState m => (Int -> m Text) -> Text -> m () +addCell ssFunc txt = do inVal <- use ps_is_in_val when inVal $ do type' <- use ps_t - sstrings <- use ps_shared_strings - val <- liftEither $ first MkCell $ parseValue sstrings txt type' + + someStr <- ssFunc 4 + val <- liftEither $ first MkCell $ parseValue (Map.singleton 4 someStr) txt type' col <- use ps_cell_col_index ps_row <>= (Map.singleton col $ Cell @@ -333,9 +333,9 @@ parseCoordinates list = do valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText -matchEvent :: MonadIO m => MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) -matchEvent _currentSheet = \case - EventContent (ContentText txt) -> Nothing <$ addCell txt +matchEvent :: MonadIO m => MonadError SheetErrors m => MonadState SheetState m => (Int -> m Text) -> Event -> m (Maybe CellRow) +matchEvent ssFunc = \case + EventContent (ContentText txt) -> Nothing <$ addCell ssFunc 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) From f311d6949bb3f2af17723106f93868198540443a Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 5 Mar 2021 16:22:20 -0400 Subject: [PATCH 17/37] Revert "Try allow user to use sideffect to lookup string" This reverts commit 13fe5486f90bfc6a9510c9ca05c99e64c03be019. --- src/Codec/Xlsx/Parser/Stream.hs | 98 ++++++++++++++++----------------- 1 file changed, 49 insertions(+), 49 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index f8345d8c..3ea79b89 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -31,7 +31,6 @@ import qualified Data.Conduit.Combinators as C import Data.Foldable import Data.Map (Map) import qualified Data.Map as Map -import Data.Maybe import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -91,13 +90,15 @@ data SheetState = MkSheetState , _ps_cell_row_index :: Int , _ps_cell_col_index :: Int , _ps_is_in_val :: Bool + , _ps_shared_strings :: Map Int Text , _ps_t :: TVal -- the last detected value } makeLenses 'MkSheetState data SharedStringState = MkSharedStringState - { _ss_file :: PsFiles - , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway + { _ss_file :: PsFiles + , _ss_shared_strings :: Map Int Text + , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway } deriving Show makeLenses 'MkSharedStringState @@ -117,59 +118,49 @@ initialSheetState = MkSheetState , _ps_cell_row_index = 0 , _ps_cell_col_index = 0 , _ps_is_in_val = False + , _ps_shared_strings = mempty , _ps_t = T_S } initialSharedString :: SharedStringState initialSharedString = MkSharedStringState { _ss_file = InitialNoFile + , _ss_shared_strings = mempty , _ss_shared_ix = 0 } -parseSharedStrings :: forall m . MonadIO m => MonadThrow m +parseSharedStrings :: forall a m . MonadIO m => MonadThrow m => PrimMonad m - => ConduitT BS.ByteString (Int, Text) m () + => ConduitT BS.ByteString a m SharedStringState parseSharedStrings = (() <$ unZipStream) - .| (C.evalStateLC initialSharedString $ + .| (C.execStateC initialSharedString $ (await >>= tagFiles) .| C.filterM (const $ has _SharedStrings <$> use fileLens) .| parseBytes def - .| C.concatMapM parseString + .| C.mapM_ parseString ) -parseString :: MonadThrow m - => PrimMonad m - => MonadState SharedStringState m - => Event -> m (Maybe (Int, Text)) -parseString = \case - EventContent (ContentText txt) -> do - idx <- use ss_shared_ix - ss_shared_ix += 1 - pure $ Just (idx, txt) - _ -> pure Nothing - --- | Allows the user to decide how to do shared string lookup. --- for example if the shared string amount is expected to be massive --- the filesystem could be used (or a database). -readXlsxWith :: forall m . MonadIO m => MonadThrow m +readXlsxWithState :: forall m . MonadIO m => MonadThrow m => PrimMonad m - => (Int -> m Text) -> ConduitT BS.ByteString SheetItem m () -readXlsxWith stringFunc = + => SharedStringState -> ConduitT BS.ByteString SheetItem m () +readXlsxWithState ssState = (() <$ unZipStream) - .| (C.evalStateLC initialSheetState $ (await >>= tagFiles) + .| (C.evalStateLC initial $ (await >>= tagFiles) .| C.filterM (const $ not . has _UnkownFile <$> use fileLens) .| parseBytes def - .| parseFiles stringFunc) + .| parseFiles) + where + initial = set ps_shared_strings (ssState ^. ss_shared_strings) initialSheetState -- | first reads the share string table, then provides another conuit to be run again for the remaining data. --- reading happens twice. All shared strings will be read into memory. +-- reading happens twice readXlsx :: forall m . MonadIO m => MonadThrow m => PrimMonad m => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) readXlsx input = do - ssState <- C.runConduit $ input .| parseSharedStrings .| C.foldMap (uncurry Map.singleton) - pure $ input .| readXlsxWith (\x -> pure $ fromMaybe "" $ ssState ^? at x . _Just) + ssState <- C.runConduit $ input .| parseSharedStrings + pure $ input .| readXlsxWithState ssState -- | there are various files in the excell file, which is a glorified zip folder -- here we tag them with things we know, and push it into the state monad. @@ -196,8 +187,8 @@ parseFiles :: => MonadThrow m => PrimMonad m => MonadState SheetState m - => (Int -> m Text) -> ConduitT Event SheetItem m () -parseFiles ssfunC = await >>= parseFileLoop ssfunC + => ConduitT Event SheetItem m () +parseFiles = await >>= parseFileLoop -- we significantly parseFileLoop :: @@ -205,23 +196,34 @@ parseFileLoop :: => MonadThrow m => PrimMonad m => MonadState SheetState m - => (Int -> m Text) -> Maybe Event + => Maybe Event -> ConduitT Event SheetItem m () -parseFileLoop ssFunc = \case +parseFileLoop = \case Nothing -> pure () Just evt -> do file <- use ps_file case file of - Sheet name -> parseSheet ssFunc evt name - _ -> await >>= parseFileLoop ssFunc + Sheet name -> parseSheet evt name + _ -> await >>= parseFileLoop + +parseString :: MonadThrow m + => PrimMonad m + => MonadState SharedStringState m + => Event -> m () +parseString = \case + EventContent (ContentText txt) -> do + idx <- use ss_shared_ix + ss_shared_strings %= set (at idx) (Just txt) + ss_shared_ix += 1 + _ -> pure () parseSheet :: MonadIO m => MonadThrow m => PrimMonad m => MonadState SheetState m - => (Int -> n Text) -> Event -> Text -> ConduitT Event SheetItem m () -parseSheet ssFunc evt name = do + => Event -> Text -> ConduitT Event SheetItem m () +parseSheet evt name = do prevSheetName <- use ps_sheet_name rix <- use ps_cell_row_index unless (prevSheetName == name) $ do @@ -229,20 +231,19 @@ parseSheet ssFunc evt name = do popRow >>= yieldSheetItem name rix liftIO $ print (name, evt) - parseRes <- runExceptT $ matchEvent ssFunc evt + parseRes <- runExceptT $ matchEvent name evt rix' <- use ps_cell_row_index case parseRes of Left err -> liftIO $ print err Right mResult -> do traverse_ (yieldSheetItem name rix') mResult - await >>= parseFileLoop ssFunc + await >>= parseFileLoop yieldSheetItem :: MonadThrow m => PrimMonad m => Text -> Int -> CellRow -> ConduitT Event SheetItem m () yieldSheetItem name rix' row = - unless (row == mempty) $ -- seems nonsensical to yield rows with no cell contents - yield $ MkSheetItem name rix' row + unless (row == mempty) $ yield $ MkSheetItem name rix' row popRow :: MonadState SheetState m => m CellRow popRow = do @@ -262,14 +263,13 @@ parseValue sstrings txt = \case Right $ CellText string T_N -> bimap ReadError CellDouble $ readEither $ Text.unpack txt -addCell :: MonadError SheetErrors m => MonadState SheetState m => (Int -> m Text) -> Text -> m () -addCell ssFunc txt = do +addCell :: MonadError SheetErrors m => MonadState SheetState m => Text -> m () +addCell txt = do inVal <- use ps_is_in_val when inVal $ do type' <- use ps_t - - someStr <- ssFunc 4 - val <- liftEither $ first MkCell $ parseValue (Map.singleton 4 someStr) txt type' + sstrings <- use ps_shared_strings + val <- liftEither $ first MkCell $ parseValue sstrings txt type' col <- use ps_cell_col_index ps_row <>= (Map.singleton col $ Cell @@ -333,9 +333,9 @@ parseCoordinates list = do valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText -matchEvent :: MonadIO m => MonadError SheetErrors m => MonadState SheetState m => (Int -> m Text) -> Event -> m (Maybe CellRow) -matchEvent ssFunc = \case - EventContent (ContentText txt) -> Nothing <$ addCell ssFunc txt +matchEvent :: MonadIO m => MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) +matchEvent _currentSheet = \case + EventContent (ContentText txt) -> Nothing <$ addCell 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) From f7b049aa8d5528aa0933e944ed57700589cc2bfa Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 5 Mar 2021 16:27:59 -0400 Subject: [PATCH 18/37] Make a conduit out of shared string instead of use state monad --- src/Codec/Xlsx/Parser/Stream.hs | 45 +++++++++++++++++---------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 3ea79b89..78312f73 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -97,7 +97,6 @@ makeLenses 'MkSheetState data SharedStringState = MkSharedStringState { _ss_file :: PsFiles - , _ss_shared_strings :: Map Int Text , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway } deriving Show makeLenses 'MkSharedStringState @@ -125,41 +124,54 @@ initialSheetState = MkSheetState initialSharedString :: SharedStringState initialSharedString = MkSharedStringState { _ss_file = InitialNoFile - , _ss_shared_strings = mempty , _ss_shared_ix = 0 } -parseSharedStrings :: forall a m . MonadIO m => MonadThrow m +parseSharedStrings :: forall m . MonadIO m => MonadThrow m => PrimMonad m - => ConduitT BS.ByteString a m SharedStringState + => ConduitT BS.ByteString (Int, Text) m () parseSharedStrings = (() <$ unZipStream) - .| (C.execStateC initialSharedString $ + .| (C.evalStateLC initialSharedString $ (await >>= tagFiles) .| C.filterM (const $ has _SharedStrings <$> use fileLens) .| parseBytes def - .| C.mapM_ parseString + .| C.concatMapM parseString ) +parseString :: MonadThrow m + => PrimMonad m + => MonadState SharedStringState m + => Event -> m (Maybe (Int, Text)) +parseString = \case + EventContent (ContentText txt) -> do + idx <- use ss_shared_ix + ss_shared_ix += 1 + pure $ Just (idx, txt) + _ -> pure Nothing + + +-- TODO figure out how to allow user to lookup shared string instead +-- of always reading into memory. readXlsxWithState :: forall m . MonadIO m => MonadThrow m => PrimMonad m - => SharedStringState -> ConduitT BS.ByteString SheetItem m () -readXlsxWithState ssState = + => Map Int Text -> ConduitT BS.ByteString SheetItem m () +readXlsxWithState sstate = (() <$ unZipStream) .| (C.evalStateLC initial $ (await >>= tagFiles) .| C.filterM (const $ not . has _UnkownFile <$> use fileLens) .| parseBytes def .| parseFiles) where - initial = set ps_shared_strings (ssState ^. ss_shared_strings) initialSheetState + initial = set ps_shared_strings sstate initialSheetState -- | first reads the share string table, then provides another conuit to be run again for the remaining data. --- reading happens twice +-- reading happens twice. All shared strings will be read into memory. readXlsx :: forall m . MonadIO m => MonadThrow m => PrimMonad m => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) readXlsx input = do - ssState <- C.runConduit $ input .| parseSharedStrings + ssState <- C.runConduit $ input .| parseSharedStrings .| C.foldMap (uncurry Map.singleton) pure $ input .| readXlsxWithState ssState -- | there are various files in the excell file, which is a glorified zip folder @@ -206,17 +218,6 @@ parseFileLoop = \case Sheet name -> parseSheet evt name _ -> await >>= parseFileLoop -parseString :: MonadThrow m - => PrimMonad m - => MonadState SharedStringState m - => Event -> m () -parseString = \case - EventContent (ContentText txt) -> do - idx <- use ss_shared_ix - ss_shared_strings %= set (at idx) (Just txt) - ss_shared_ix += 1 - _ -> pure () - parseSheet :: MonadIO m => MonadThrow m From 209b2b2c8c5279266b5c5fe4ff4d1c28f93bbd7b Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 8 Mar 2021 11:59:16 -0400 Subject: [PATCH 19/37] Try fix tests after that Cellmap change This made me realize I should undo these changes, it would make the PR easier to accept as well and we don't really need it. --- test/Main.hs | 12 ++++++------ test/PivotTableTests.hs | 3 ++- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index 3ef7f173..a83a45fd 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -78,7 +78,7 @@ 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 "testarchive") @==? toXlsxEither "this is not a valid XLSX file" , CommonTests.tests , CondFmtTests.tests , PivotTableTests.tests @@ -415,9 +415,9 @@ testCustomPropertiesXml = [r| testFormattedResult :: Formatted testFormattedResult = Formatted cm styleSheet merges where - cm = M.fromList [ ((1, 1), cell11) - , ((1, 2), cell12) - , ((2, 5), cell25) ] + cm :: CellMap + cm = M.fromList [ (1, M.fromList [(1, cell11), (2, cell12)]), + (2, M.singleton 5 cell25)] cell11 = Cell { _cellStyle = Just 1 , _cellValue = Just (CellText "text at A1") @@ -475,11 +475,11 @@ testFormatWorkbookResult :: Xlsx testFormatWorkbookResult = def & xlSheets .~ sheets & xlStyles .~ renderStyleSheet style where - testCellMap1 = M.fromList [((1, 1), Cell { _cellStyle = Nothing + testCellMap1 = M.fromList [(1, Map.singleton 1 Cell { _cellStyle = Nothing , _cellValue = Just (CellText "text at A1 Sheet1") , _cellComment = Nothing , _cellFormula = Nothing })] - testCellMap2 = M.fromList [((2, 3), Cell { _cellStyle = Just 1 + testCellMap2 = M.fromList [(2, Map.singleton 3 Cell { _cellStyle = Just 1 , _cellValue = Just (CellDouble 1.23456) , _cellComment = Nothing , _cellFormula = Nothing })] diff --git a/test/PivotTableTests.hs b/test/PivotTableTests.hs index 864b0871..b6bd3f0a 100644 --- a/test/PivotTableTests.hs +++ b/test/PivotTableTests.hs @@ -21,6 +21,7 @@ import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types.Internal (unsafeRefId) import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Writer.Internal.PivotTable +import Codec.Xlsx.Types.Cell import Diff @@ -92,7 +93,7 @@ testPivotTable = countField = PivotFieldName "Count" testPivotSrcCells :: CellMap -testPivotSrcCells = +testPivotSrcCells = toNested $ M.fromList $ concat [ [((row, col), def & cellValue ?~ v) | (col, v) <- zip [1 ..] cells] From 85bc369f95b1ff965d28d8dbaec66678a355b6ea Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 8 Mar 2021 12:05:56 -0400 Subject: [PATCH 20/37] Revert "Try fix tests after that Cellmap change" This reverts commit a5b18d19660ac0a068e75ab03ebe7dd20c3f2d76. --- test/Main.hs | 12 ++++++------ test/PivotTableTests.hs | 3 +-- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index a83a45fd..3ef7f173 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -78,7 +78,7 @@ main = defaultMain $ , testCase "toXlsxEither: properly formatted" $ Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) , testCase "toXlsxEither: invalid format" $ - Left (InvalidZipArchive "testarchive") @==? toXlsxEither "this is not a valid XLSX file" + Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file" , CommonTests.tests , CondFmtTests.tests , PivotTableTests.tests @@ -415,9 +415,9 @@ testCustomPropertiesXml = [r| testFormattedResult :: Formatted testFormattedResult = Formatted cm styleSheet merges where - cm :: CellMap - cm = M.fromList [ (1, M.fromList [(1, cell11), (2, cell12)]), - (2, M.singleton 5 cell25)] + cm = M.fromList [ ((1, 1), cell11) + , ((1, 2), cell12) + , ((2, 5), cell25) ] cell11 = Cell { _cellStyle = Just 1 , _cellValue = Just (CellText "text at A1") @@ -475,11 +475,11 @@ testFormatWorkbookResult :: Xlsx testFormatWorkbookResult = def & xlSheets .~ sheets & xlStyles .~ renderStyleSheet style where - testCellMap1 = M.fromList [(1, Map.singleton 1 Cell { _cellStyle = Nothing + testCellMap1 = M.fromList [((1, 1), Cell { _cellStyle = Nothing , _cellValue = Just (CellText "text at A1 Sheet1") , _cellComment = Nothing , _cellFormula = Nothing })] - testCellMap2 = M.fromList [(2, Map.singleton 3 Cell { _cellStyle = Just 1 + testCellMap2 = M.fromList [((2, 3), Cell { _cellStyle = Just 1 , _cellValue = Just (CellDouble 1.23456) , _cellComment = Nothing , _cellFormula = Nothing })] diff --git a/test/PivotTableTests.hs b/test/PivotTableTests.hs index b6bd3f0a..864b0871 100644 --- a/test/PivotTableTests.hs +++ b/test/PivotTableTests.hs @@ -21,7 +21,6 @@ import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types.Internal (unsafeRefId) import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Writer.Internal.PivotTable -import Codec.Xlsx.Types.Cell import Diff @@ -93,7 +92,7 @@ testPivotTable = countField = PivotFieldName "Count" testPivotSrcCells :: CellMap -testPivotSrcCells = toNested $ +testPivotSrcCells = M.fromList $ concat [ [((row, col), def & cellValue ?~ v) | (col, v) <- zip [1 ..] cells] From aa6a59020b2e1cc6f7e3460f458d8e1f43efd036 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 8 Mar 2021 12:06:40 -0400 Subject: [PATCH 21/37] Revert "Change type alias for CellMap" This reverts commit d17897fd1f2c437b7b3b6e44b673a57caf368899. --- src/Codec/Xlsx/Formatted.hs | 11 +++----- src/Codec/Xlsx/Lens.hs | 13 ++------- src/Codec/Xlsx/Parser.hs | 17 +++++------- src/Codec/Xlsx/Types.hs | 17 ++++++++---- src/Codec/Xlsx/Types/Cell.hs | 27 +------------------ .../Xlsx/Types/Internal/SharedStringTable.hs | 2 +- src/Codec/Xlsx/Writer/Internal/PivotTable.hs | 4 +-- 7 files changed, 27 insertions(+), 64 deletions(-) diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs index 46bf0004..c1b21715 100644 --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -59,7 +59,6 @@ import Prelude hiding (mapM) import Safe (headNote, fromJustNote) import Codec.Xlsx.Types -import Codec.Xlsx.Types.Cell {------------------------------------------------------------------------------- Internal: formatting state @@ -235,13 +234,13 @@ data Formatted = Formatted { -- -- If you don't already have a 'StyleSheet' you want to use as starting point -- then 'minimalStyleSheet' is a good choice. -formatted :: Map (RowIndex, ColIndex) FormattedCell -> StyleSheet -> Formatted +formatted :: Map (Int, Int) FormattedCell -> StyleSheet -> Formatted formatted cs styleSheet = let initSt = stateFromStyleSheet styleSheet (cs', finalSt) = runState (mapM (uncurry formatCell) (M.toList cs)) initSt styleSheet' = updateStyleSheetFromState styleSheet finalSt in Formatted { - formattedCellMap = toNested $ M.fromList (concat cs') + formattedCellMap = M.fromList (concat cs') , formattedStyleSheet = styleSheet' , formattedMerges = reverse (finalSt ^. formattingMerges) } @@ -255,7 +254,7 @@ formatWorkbook nfcss initStyle = extract go cs' <- forM (M.toList fcs) $ \(rc, fc) -> formatCell rc fc merges <- reverse . _formattingMerges <$> get return ( name - , def & wsCells .~ toNested (M.fromList (concat cs')) + , def & wsCells .~ M.fromList (concat cs') & wsMerges .~ merges) extract (sheets, st) = def & xlSheets .~ sheets @@ -264,10 +263,8 @@ formatWorkbook nfcss initStyle = extract go -- | reverse to 'formatted' which allows to get a map of formatted cells -- from an existing worksheet and its workbook's style sheet toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (Int, Int) FormattedCell -toFormattedCells m merges StyleSheet{..} = applyMerges $ - unNested $ fmap toFormattedCell <$> m +toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m where - toFormattedCell :: Cell -> FormattedCell toFormattedCell cell@Cell{..} = FormattedCell { _formattedCell = cell{ _cellStyle = Nothing } -- just to remove confusion diff --git a/src/Codec/Xlsx/Lens.hs b/src/Codec/Xlsx/Lens.hs index 0dd3c03c..67e8bcb0 100644 --- a/src/Codec/Xlsx/Lens.hs +++ b/src/Codec/Xlsx/Lens.hs @@ -16,12 +16,9 @@ module Codec.Xlsx.Lens , cellValueAt , cellValueAtRC , cellValueAtXY - , atRow - , ixRow ) where import Codec.Xlsx.Types -import Codec.Xlsx.Types.Cell #ifdef USE_MICROLENS import Lens.Micro import Lens.Micro.Internal @@ -82,7 +79,7 @@ ixCell = ixCellRC -- | lens to access cell in a worksheet ixCellRC :: (Int, Int) -> Traversal' Worksheet Cell -ixCellRC (y, x) = wsCells . ix y . ix x +ixCellRC i = wsCells . ix i -- | lens to access cell in a worksheet using more traditional -- x+y coordinates @@ -94,15 +91,9 @@ ixCellXY = ixCellRC . swap atCell :: (Int, Int) -> Lens' Worksheet (Maybe Cell) atCell = atCellRC -atRow :: Int -> Lens' Worksheet (Maybe CellRow) -atRow y = wsCells . at y - -ixRow :: Int -> Traversal' Worksheet CellRow -ixRow y = wsCells . ix y - -- | lens to read, write or delete cell in a worksheet atCellRC :: (Int, Int) -> Lens' Worksheet (Maybe Cell) -atCellRC (y,x) = atRow y . non mempty . at x +atCellRC i = wsCells . at i -- | lens to read, write or delete cell in a worksheet -- using more traditional x+y or row+column index diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs index d6cbf9ce..62c1034e 100644 --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -53,7 +53,7 @@ import qualified Xeno.DOM as Xeno import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types -import Codec.Xlsx.Types.Cell +import Codec.Xlsx.Types.Cell (formulaDataFromCursor) import Codec.Xlsx.Types.Common (xlsxTextToCellValue) import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair @@ -216,18 +216,14 @@ extractSheetFast ar sst contentTypes caches wf = do legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< legacyDrRId commentsMap <- fmap join . forM commentTarget $ getComments ar legacyDrPath - let commentCells :: CellMap - commentCells = toNested $ + let commentCells = M.fromList [ (fromSingleCellRefNoting r, def { _cellComment = Just cmnt}) | (r, cmnt) <- maybe [] CommentTable.toList commentsMap ] assignComment withCmnt noCmnt = noCmnt & cellComment .~ (withCmnt ^. cellComment) - mergeCommentRows :: CellRow -> CellRow -> CellRow - mergeCommentRows = M.unionWith assignComment - mergeComments :: CellMap -> CellMap - mergeComments = M.unionWith mergeCommentRows commentCells + mergeComments = M.unionWith assignComment commentCells tables <- forM tableIds $ \rId -> do fp <- lookupRelPath filePath sheetRels rId getTable ar fp @@ -269,7 +265,7 @@ extractSheetFast ar sst contentTypes caches wf = do case mRP of Just rp -> M.insert r rp rowMap Nothing -> rowMap - in (newRowMap, cellMap <> toNested newCells, sharedF <> newSharedF) + in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) parseRow :: Xeno.Node -> Either Text ( Int @@ -426,10 +422,9 @@ extractSheet ar sst contentTypes caches wf = do newRowMap = case mRP of Just rp -> M.insert r rp rowMap Nothing -> rowMap - in (newRowMap, cellMap <> toNested newCells, sharedF <> newSharedF) + in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) - commentCells :: CellMap - commentCells = toNested $ + commentCells = M.fromList [ (fromSingleCellRefNoting r, def {_cellComment = Just cmnt}) | (r, cmnt) <- maybe [] CommentTable.toList commentsMap diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs index 165f9a40..a185de28 100644 --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -66,7 +66,6 @@ import Control.Exception (SomeException, toException) import Lens.Micro.TH #else import Control.Lens.TH -import Control.Lens hiding ((.=)) #endif import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as L @@ -299,12 +298,20 @@ parseStyleSheet (Styles bs) = parseLBS def bs >>= parseDoc -- | converts cells mapped by (row, column) into rows which contain -- row index and cells as pairs of column indices and cell values -toRows :: CellMap -> [(RowIndex, [(ColIndex, Cell)])] -toRows cells = M.toList $ M.toList <$> cells +toRows :: CellMap -> [(Int, [(Int, Cell)])] +toRows cells = + map extractRow $ groupBy ((==) `on` (fst . fst)) $ M.toList cells + where + extractRow row@(((x,_),_):_) = + (x, map (\((_,y),v) -> (y,v)) row) + extractRow _ = error "invalid CellMap row" -- | reverse to 'toRows' -fromRows :: [(RowIndex, [(ColIndex, Cell)])] -> CellMap -fromRows rows = M.fromList $ over (mapped . _2) M.fromList rows +fromRows :: [(Int, [(Int, Cell)])] -> CellMap +fromRows rows = M.fromList $ concatMap mapRow rows + where + mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells + instance ToElement ColumnsProperties where toElement nm ColumnsProperties {..} = leafElement nm attrs diff --git a/src/Codec/Xlsx/Types/Cell.hs b/src/Codec/Xlsx/Types/Cell.hs index 0e9e9534..8279f773 100644 --- a/src/Codec/Xlsx/Types/Cell.hs +++ b/src/Codec/Xlsx/Types/Cell.hs @@ -18,9 +18,6 @@ module Codec.Xlsx.Types.Cell , cellComment , cellFormula , CellMap - , CellRow - , toNested - , unNested ) where import Control.Arrow (first) @@ -115,32 +112,10 @@ instance Default Cell where makeLenses ''Cell - -- | Map containing cell values which are indexed by row and column -- if you need to use more traditional (x,y) indexing please you could -- use corresponding accessors from ''Codec.Xlsx.Lens'' -type CellMap = Map RowIndex CellRow - -type CellRow = Map ColIndex Cell - --- | Map (Int, Int) a was the original representation, this was changed --- to give better support for streaming --- (we can now stream an individual row) --- 'toNested' helps you go from that original representation to the new one. --- 'unNested' helps you go back. --- toNested . unNested === id -toNested :: Map (RowIndex, ColIndex) a -> Map RowIndex (Map ColIndex a) -toNested old = - M.fromListWith (<>) $ - (\((r,c), v) -> (r, M.singleton c v)) <$> M.toList old - --- | reverse of 'toNested' -unNested :: Map RowIndex (Map ColIndex a) -> Map (RowIndex, ColIndex) a -unNested old = M.fromList $ do - (row, dict) <- M.toList old - (\(col, val) -> ((row, col), val) ) <$> M.toList dict - - +type CellMap = Map (Int, Int) Cell {------------------------------------------------------------------------------- Parsing diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs index ff390650..26ea2041 100644 --- a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -95,7 +95,7 @@ sstConstruct = SharedStringTable . V.fromList . uniq . concatMap goSheet where goSheet :: Worksheet -> [XlsxText] - goSheet = mapMaybe (_cellValue >=> sstEntry) . join . Map.elems . fmap Map.elems . _wsCells + goSheet = mapMaybe (_cellValue >=> sstEntry) . Map.elems . _wsCells sstEntry :: CellValue -> Maybe XlsxText sstEntry (CellText text) = Just $ XlsxText text diff --git a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs index aee4fe67..627d8b92 100644 --- a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs @@ -16,7 +16,6 @@ import GHC.Generics (Generic) import Safe (fromJustNote) import Text.XML -import Control.Lens hiding ((.=)) import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common import Codec.Xlsx.Types.Internal @@ -156,8 +155,7 @@ generateCache cm PivotTable {..} = } ((r1, c1), (r2, c2)) = fromJustNote "Invalid src ref of pivot table " $ fromRange _pvtSrcRef - getCellValue :: (Int, Int) -> Maybe CellValue - getCellValue (row, col) = cm ^? at row . _Just . at col . _Just . cellValue . _Just + getCellValue ix = M.lookup ix cm >>= _cellValue itemsByName = M.fromList $ flip mapMaybe [c1 .. c2] $ \c -> do From d2b3abd36f368ba555a56354f0f19f7f0a6975d3 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Mon, 8 Mar 2021 12:09:02 -0400 Subject: [PATCH 22/37] Fix the tests --- src/Codec/Xlsx/Parser/Stream.hs | 3 +++ test/Main.hs | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 78312f73..f4e57faf 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -13,6 +13,7 @@ module Codec.Xlsx.Parser.Stream , SheetItem(..) , parseSharedStrings , readXlsxWithState + , CellRow ) where import Codec.Archive.Zip.Conduit.UnZip @@ -38,6 +39,8 @@ import Data.XML.Types import Text.Read import Text.XML.Stream.Parse +type CellRow = Map Int Cell + data SheetItem = MkSheetItem { _si_sheet :: Text , _si_row_index :: Int diff --git a/test/Main.hs b/test/Main.hs index 3ef7f173..508fae6a 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -78,7 +78,7 @@ 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 From 70390ddfa0855f781a463b4edfcfac69e27c4b4c Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Mar 2021 12:03:14 -0400 Subject: [PATCH 23/37] Remove MonadIO constraint, throw errors with monadthrow also export the various lenses for SheetItem. --- src/Codec/Xlsx/Parser/Stream.hs | 34 +++++++++++++++++---------------- xlsx.cabal | 1 + 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index f4e57faf..eaacb71a 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -6,20 +6,24 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveAnyClass #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream ( readXlsx + , readXlsxWithState , SheetItem(..) , parseSharedStrings - , readXlsxWithState , CellRow + , 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 (MonadThrow, PrimMonad, await, +import Conduit (PrimMonad, await, yield, (.|)) import qualified Conduit as C import Control.Lens @@ -38,6 +42,7 @@ import qualified Data.Text.Encoding as Text import Data.XML.Types import Text.Read import Text.XML.Stream.Parse +import Control.Monad.Catch type CellRow = Map Int Cell @@ -46,6 +51,7 @@ data SheetItem = MkSheetItem , _si_row_index :: Int , _si_cell_row :: CellRow } deriving Show +makeLenses 'MkSheetItem -- http://officeopenxml.com/anatomyofOOXML-xlsx.php data PsFiles = UnkownFile Text @@ -130,7 +136,7 @@ initialSharedString = MkSharedStringState , _ss_shared_ix = 0 } -parseSharedStrings :: forall m . MonadIO m => MonadThrow m +parseSharedStrings :: forall m . MonadThrow m => PrimMonad m => ConduitT BS.ByteString (Int, Text) m () parseSharedStrings = (() <$ unZipStream) @@ -155,7 +161,7 @@ parseString = \case -- TODO figure out how to allow user to lookup shared string instead -- of always reading into memory. -readXlsxWithState :: forall m . MonadIO m => MonadThrow m +readXlsxWithState :: forall m . MonadThrow m => PrimMonad m => Map Int Text -> ConduitT BS.ByteString SheetItem m () readXlsxWithState sstate = @@ -170,7 +176,7 @@ readXlsxWithState sstate = -- | first reads the share string table, then provides another conuit to be run again for the remaining data. -- reading happens twice. All shared strings will be read into memory. readXlsx :: - forall m . MonadIO m => MonadThrow m + forall m . MonadThrow m => PrimMonad m => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) readXlsx input = do @@ -183,7 +189,6 @@ readXlsx input = do tagFiles :: HasPSFiles env => MonadState env m - => MonadIO m => MonadThrow m => PrimMonad m => Maybe (Either ZipEntry BS.ByteString) -> ConduitT (Either ZipEntry BS.ByteString) BS.ByteString m () @@ -198,8 +203,7 @@ tagFiles = \case Nothing -> pure () parseFiles :: - MonadIO m - => MonadThrow m + MonadThrow m => PrimMonad m => MonadState SheetState m => ConduitT Event SheetItem m () @@ -207,8 +211,7 @@ parseFiles = await >>= parseFileLoop -- we significantly parseFileLoop :: - MonadIO m - => MonadThrow m + MonadThrow m => PrimMonad m => MonadState SheetState m => Maybe Event @@ -222,8 +225,7 @@ parseFileLoop = \case _ -> await >>= parseFileLoop parseSheet :: - MonadIO m - => MonadThrow m + MonadThrow m => PrimMonad m => MonadState SheetState m => Event -> Text -> ConduitT Event SheetItem m () @@ -234,11 +236,10 @@ parseSheet evt name = do ps_sheet_name .= name popRow >>= yieldSheetItem name rix - liftIO $ print (name, evt) parseRes <- runExceptT $ matchEvent name evt rix' <- use ps_cell_row_index case parseRes of - Left err -> liftIO $ print err + Left err -> C.throwM err Right mResult -> do traverse_ (yieldSheetItem name rix') mResult await >>= parseFileLoop @@ -288,7 +289,8 @@ data SheetErrors = MkCoordinate CoordinateErrors | MkType TypeError | MkCell AddCellErrors - deriving Show + deriving (Show, Exception) + data CoordinateErrors = CoordinateNotFound [(Name, [Content])] | NoListElement (Name, [Content]) [(Name, [Content])] @@ -337,7 +339,7 @@ parseCoordinates list = do valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText -matchEvent :: MonadIO m => MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) +matchEvent :: MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) matchEvent _currentSheet = \case EventContent (ContentText txt) -> Nothing <$ addCell txt EventBeginElement Name{nameLocalName = "c", ..} vals -> Nothing <$ (setCoord vals >> setType vals) diff --git a/xlsx.cabal b/xlsx.cabal index 53fc3624..adf23492 100644 --- a/xlsx.cabal +++ b/xlsx.cabal @@ -104,6 +104,7 @@ Library , zlib >= 0.5.4.0 , zip-stream >= 0.2.0.1 , xml-types + , exceptions if flag(microlens) Build-depends: microlens >= 0.4 && < 0.5 , microlens-mtl From e75fe0f40f5fda87661a614e1771323166be4f75 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Mar 2021 12:15:13 -0400 Subject: [PATCH 24/37] Remove several redundant constraints --- src/Codec/Xlsx/Parser/Stream.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index eaacb71a..c8a51504 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -148,7 +148,6 @@ parseSharedStrings = (() <$ unZipStream) ) parseString :: MonadThrow m - => PrimMonad m => MonadState SharedStringState m => Event -> m (Maybe (Int, Text)) parseString = \case @@ -190,7 +189,6 @@ tagFiles :: HasPSFiles env => MonadState env m => MonadThrow m - => PrimMonad m => Maybe (Either ZipEntry BS.ByteString) -> ConduitT (Either ZipEntry BS.ByteString) BS.ByteString m () tagFiles = \case Just (Left zipEntry) -> do @@ -204,7 +202,6 @@ tagFiles = \case parseFiles :: MonadThrow m - => PrimMonad m => MonadState SheetState m => ConduitT Event SheetItem m () parseFiles = await >>= parseFileLoop @@ -212,7 +209,6 @@ parseFiles = await >>= parseFileLoop -- we significantly parseFileLoop :: MonadThrow m - => PrimMonad m => MonadState SheetState m => Maybe Event -> ConduitT Event SheetItem m () @@ -226,7 +222,6 @@ parseFileLoop = \case parseSheet :: MonadThrow m - => PrimMonad m => MonadState SheetState m => Event -> Text -> ConduitT Event SheetItem m () parseSheet evt name = do @@ -245,7 +240,6 @@ parseSheet evt name = do await >>= parseFileLoop yieldSheetItem :: MonadThrow m - => PrimMonad m => Text -> Int -> CellRow -> ConduitT Event SheetItem m () yieldSheetItem name rix' row = unless (row == mempty) $ yield $ MkSheetItem name rix' row From f7e6041c9849b9b13926c0ad91b60ed2e72fb4a5 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Mar 2021 12:56:44 -0400 Subject: [PATCH 25/37] Add haskcallstack, but it's not a good idea after reading the docs I think it tracks every loop being called --- src/Codec/Xlsx/Parser/Stream.hs | 42 +++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index c8a51504..4f3e159f 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -6,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream @@ -23,10 +24,10 @@ module Codec.Xlsx.Parser.Stream import Codec.Archive.Zip.Conduit.UnZip import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common -import Conduit (PrimMonad, await, - yield, (.|)) +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.Lazy import Data.Bifunctor @@ -40,9 +41,9 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.XML.Types +import GHC.Stack import Text.Read import Text.XML.Stream.Parse -import Control.Monad.Catch type CellRow = Map Int Cell @@ -105,8 +106,8 @@ data SheetState = MkSheetState makeLenses 'MkSheetState data SharedStringState = MkSharedStringState - { _ss_file :: PsFiles - , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway + { _ss_file :: PsFiles + , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway } deriving Show makeLenses 'MkSharedStringState @@ -160,7 +161,7 @@ parseString = \case -- TODO figure out how to allow user to lookup shared string instead -- of always reading into memory. -readXlsxWithState :: forall m . MonadThrow m +readXlsxWithState :: HasCallStack => forall m . MonadThrow m => PrimMonad m => Map Int Text -> ConduitT BS.ByteString SheetItem m () readXlsxWithState sstate = @@ -175,7 +176,7 @@ readXlsxWithState sstate = -- | first reads the share string table, then provides another conuit to be run again for the remaining data. -- reading happens twice. All shared strings will be read into memory. readXlsx :: - forall m . MonadThrow m + HasCallStack => forall m . MonadThrow m => PrimMonad m => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) readXlsx input = do @@ -201,14 +202,14 @@ tagFiles = \case Nothing -> pure () parseFiles :: - MonadThrow m + HasCallStack => MonadThrow m => MonadState SheetState m => ConduitT Event SheetItem m () parseFiles = await >>= parseFileLoop -- we significantly parseFileLoop :: - MonadThrow m + HasCallStack => MonadThrow m => MonadState SheetState m => Maybe Event -> ConduitT Event SheetItem m () @@ -221,7 +222,7 @@ parseFileLoop = \case _ -> await >>= parseFileLoop parseSheet :: - MonadThrow m + HasCallStack => MonadThrow m => MonadState SheetState m => Event -> Text -> ConduitT Event SheetItem m () parseSheet evt name = do @@ -279,12 +280,17 @@ addCell txt = do }) -data SheetErrors = MkCoordinate CoordinateErrors - | MkType TypeError - | MkCell AddCellErrors - - deriving (Show, Exception) +-- https://maksbotan.github.io/posts/2021-01-20-callstacks.html +data SheetErrors where + MkCoordinate :: HasCallStack => CoordinateErrors -> SheetErrors + MkType :: HasCallStack => TypeError -> SheetErrors + MkCell :: HasCallStack => AddCellErrors -> SheetErrors + deriving Exception +instance Show SheetErrors where + show (MkCoordinate errors) = "(MkCoordinate $ " <> show errors <> "/*" <> prettyCallStack callStack <> " */)" + show (MkType errors) = "(MkType $ " <> show errors <> "/*" <> prettyCallStack callStack <> " */)" + show (MkCell errors) = "(MkCell $ " <> show errors <> "/*" <> prettyCallStack callStack <> " */)" data CoordinateErrors = CoordinateNotFound [(Name, [Content])] | NoListElement (Name, [Content]) [(Name, [Content])] @@ -308,7 +314,7 @@ setCoord list = do ps_cell_col_index .= (coordinates ^. _2) ps_cell_row_index .= (coordinates ^. _1) -setType :: MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () +setType :: HasCallStack => MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () setType list = do type' <- liftEither $ first MkType $ parseType list ps_t .= type' @@ -333,7 +339,7 @@ parseCoordinates list = do valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText -matchEvent :: MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) +matchEvent :: HasCallStack => MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) matchEvent _currentSheet = \case EventContent (ContentText txt) -> Nothing <$ addCell txt EventBeginElement Name{nameLocalName = "c", ..} vals -> Nothing <$ (setCoord vals >> setType vals) From a7d0d371dccff7fde71c5ac119e73331332d93a5 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Mar 2021 13:28:49 -0400 Subject: [PATCH 26/37] Revert "Add haskcallstack, but it's not a good idea after reading the docs" This reverts commit b8adc00b1b1a7a442f08f822c5a3d1e00470a36a. --- src/Codec/Xlsx/Parser/Stream.hs | 42 ++++++++++++++------------------- 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 4f3e159f..c8a51504 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} @@ -7,7 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DeriveAnyClass #-} -- | Read .xlsx as a stream module Codec.Xlsx.Parser.Stream @@ -24,10 +23,10 @@ module Codec.Xlsx.Parser.Stream import Codec.Archive.Zip.Conduit.UnZip import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common -import Conduit (PrimMonad, await, yield, (.|)) +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.Lazy import Data.Bifunctor @@ -41,9 +40,9 @@ import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.XML.Types -import GHC.Stack import Text.Read import Text.XML.Stream.Parse +import Control.Monad.Catch type CellRow = Map Int Cell @@ -106,8 +105,8 @@ data SheetState = MkSheetState makeLenses 'MkSheetState data SharedStringState = MkSharedStringState - { _ss_file :: PsFiles - , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway + { _ss_file :: PsFiles + , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway } deriving Show makeLenses 'MkSharedStringState @@ -161,7 +160,7 @@ parseString = \case -- TODO figure out how to allow user to lookup shared string instead -- of always reading into memory. -readXlsxWithState :: HasCallStack => forall m . MonadThrow m +readXlsxWithState :: forall m . MonadThrow m => PrimMonad m => Map Int Text -> ConduitT BS.ByteString SheetItem m () readXlsxWithState sstate = @@ -176,7 +175,7 @@ readXlsxWithState sstate = -- | first reads the share string table, then provides another conuit to be run again for the remaining data. -- reading happens twice. All shared strings will be read into memory. readXlsx :: - HasCallStack => forall m . MonadThrow m + forall m . MonadThrow m => PrimMonad m => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) readXlsx input = do @@ -202,14 +201,14 @@ tagFiles = \case Nothing -> pure () parseFiles :: - HasCallStack => MonadThrow m + MonadThrow m => MonadState SheetState m => ConduitT Event SheetItem m () parseFiles = await >>= parseFileLoop -- we significantly parseFileLoop :: - HasCallStack => MonadThrow m + MonadThrow m => MonadState SheetState m => Maybe Event -> ConduitT Event SheetItem m () @@ -222,7 +221,7 @@ parseFileLoop = \case _ -> await >>= parseFileLoop parseSheet :: - HasCallStack => MonadThrow m + MonadThrow m => MonadState SheetState m => Event -> Text -> ConduitT Event SheetItem m () parseSheet evt name = do @@ -280,17 +279,12 @@ addCell txt = do }) --- https://maksbotan.github.io/posts/2021-01-20-callstacks.html -data SheetErrors where - MkCoordinate :: HasCallStack => CoordinateErrors -> SheetErrors - MkType :: HasCallStack => TypeError -> SheetErrors - MkCell :: HasCallStack => AddCellErrors -> SheetErrors - deriving Exception +data SheetErrors = MkCoordinate CoordinateErrors + | MkType TypeError + | MkCell AddCellErrors + + deriving (Show, Exception) -instance Show SheetErrors where - show (MkCoordinate errors) = "(MkCoordinate $ " <> show errors <> "/*" <> prettyCallStack callStack <> " */)" - show (MkType errors) = "(MkType $ " <> show errors <> "/*" <> prettyCallStack callStack <> " */)" - show (MkCell errors) = "(MkCell $ " <> show errors <> "/*" <> prettyCallStack callStack <> " */)" data CoordinateErrors = CoordinateNotFound [(Name, [Content])] | NoListElement (Name, [Content]) [(Name, [Content])] @@ -314,7 +308,7 @@ setCoord list = do ps_cell_col_index .= (coordinates ^. _2) ps_cell_row_index .= (coordinates ^. _1) -setType :: HasCallStack => MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () +setType :: MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () setType list = do type' <- liftEither $ first MkType $ parseType list ps_t .= type' @@ -339,7 +333,7 @@ parseCoordinates list = do valText <- maybe (Left $ NoTextContent valContent list) Right $ valContent ^? contentTextPrims maybe (Left $ DecodeFailure valText list) Right $ fromSingleCellRef $ CellRef valText -matchEvent :: HasCallStack => MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) +matchEvent :: MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) matchEvent _currentSheet = \case EventContent (ContentText txt) -> Nothing <$ addCell txt EventBeginElement Name{nameLocalName = "c", ..} vals -> Nothing <$ (setCoord vals >> setType vals) From f48f1efc0decbf0b4aaed79245663d74e5db2538 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Mar 2021 13:37:27 -0400 Subject: [PATCH 27/37] Add bool parse support --- src/Codec/Xlsx/Parser/Stream.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index c8a51504..e6e41877 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -44,6 +44,7 @@ import Text.Read import Text.XML.Stream.Parse import Control.Monad.Catch +-- TODO NonNull type CellRow = Map Int Cell data SheetItem = MkSheetItem @@ -91,6 +92,8 @@ decodeFiles = \case data TVal = T_S -- string ? | T_N -- number ? + | T_B + data SheetState = MkSheetState { _ps_file :: PsFiles @@ -261,6 +264,7 @@ parseValue sstrings txt = \case string <- maybe (Left $ SharedStringNotFound idx sstrings) Right $ sstrings ^? ix idx Right $ CellText string T_N -> bimap ReadError CellDouble $ readEither $ Text.unpack txt + T_B -> bimap ReadError CellBool $ readEither $ Text.unpack txt addCell :: MonadError SheetErrors m => MonadState SheetState m => Text -> m () addCell txt = do @@ -324,6 +328,7 @@ parseType list = do case valText of "n" -> Right T_N "s" -> Right T_S + "b" -> Right T_S other -> Left $ UnkownType other list parseCoordinates :: [(Name, [Content])] -> Either CoordinateErrors (Int, Int) From fdfa1cf654b1a1178ef8f78031c3a95af631761c Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Mar 2021 13:56:21 -0400 Subject: [PATCH 28/37] Add some docs --- src/Codec/Xlsx/Parser/Stream.hs | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index e6e41877..fdb5120d 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -55,14 +55,22 @@ data SheetItem = MkSheetItem makeLenses 'MkSheetItem -- http://officeopenxml.com/anatomyofOOXML-xlsx.php -data PsFiles = UnkownFile Text +data PsFiles = + -- | Files that are encountered in the workbook but not part + -- of this sumtype get this tag. They are then ignored. + UnkownFile Text + -- | files with actual data (rows and cells) | Sheet Text + -- | Initial state, unrelated to excell format | InitialNoFile + -- | stores strings which are replaced by id's in sheet to save space | SharedStrings | Styles + -- | contains the names in the tabs and some internal id | Workbook | ContentTypes | Relationships + -- | contains relations ship between internal id and path | SheetRel Text deriving Show makePrisms ''PsFiles @@ -90,9 +98,9 @@ decodeFiles = \case Sheet known else UnkownFile unkown -data TVal = T_S -- string ? - | T_N -- number ? - | T_B +data TVal = T_S -- ^ string + | T_N -- ^ number + | T_B -- ^ boolean data SheetState = MkSheetState From 59a65f2419970bd2d8ad202f35bc439153f89acb Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 9 Mar 2021 16:05:11 -0400 Subject: [PATCH 29/37] Show the issue with a test --- src/Codec/Xlsx/Parser/Stream.hs | 8 + src/Codec/Xlsx/Types/Common.hs | 16 + test/Main.hs | 519 +----------------------------- test/StreamTests.hs | 56 ++++ test/TestXlsx.hs | 554 ++++++++++++++++++++++++++++++++ xlsx.cabal | 1 + 6 files changed, 638 insertions(+), 516 deletions(-) create mode 100644 test/StreamTests.hs create mode 100644 test/TestXlsx.hs diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index fdb5120d..0245d5d5 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -14,6 +14,7 @@ module Codec.Xlsx.Parser.Stream , readXlsxWithState , SheetItem(..) , parseSharedStrings + , parseStringsIntoMap , CellRow , si_sheet , si_row_index @@ -73,6 +74,7 @@ data PsFiles = -- | contains relations ship between internal id and path | SheetRel Text deriving Show + makePrisms ''PsFiles decodeFiles :: Text -> PsFiles @@ -158,6 +160,11 @@ parseSharedStrings = (() <$ unZipStream) .| C.concatMapM parseString ) +parseStringsIntoMap :: forall m . MonadThrow m + => PrimMonad m + => ConduitT BS.ByteString C.Void m (Map Int Text) +parseStringsIntoMap = parseSharedStrings .| C.foldMap (uncurry Map.singleton) + parseString :: MonadThrow m => MonadState SharedStringState m => Event -> m (Maybe (Int, Text)) @@ -183,6 +190,7 @@ readXlsxWithState sstate = where initial = set ps_shared_strings sstate initialSheetState + -- | first reads the share string table, then provides another conuit to be run again for the remaining data. -- reading happens twice. All shared strings will be read into memory. readXlsx :: diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs index 7cdd5ee4..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 @@ -21,6 +23,14 @@ module Codec.Xlsx.Types.Common , col2int , RowIndex , ColIndex + -- ** prisms + , _XlsxText + , _XlsxRichText + , _CellText + , _CellDouble + , _CellBool + , _CellRich + , _CellError ) where import GHC.Generics (Generic) @@ -42,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 @@ -146,6 +157,7 @@ data XlsxText = XlsxText Text | XlsxRichText [RichTextRun] deriving (Eq, Ord, Show, Generic) + instance NFData XlsxText xlsxTextToCellValue :: XlsxText -> CellValue @@ -172,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 @@ -391,3 +404,6 @@ instance ToAttrVal ErrorType where type RowIndex = Int type ColIndex = Int + +makePrisms ''XlsxText +makePrisms ''CellValue diff --git a/test/Main.hs b/test/Main.hs index 508fae6a..fcfccd27 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -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 @@ -84,521 +86,6 @@ main = defaultMain $ , 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..df397121 --- /dev/null +++ b/test/StreamTests.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TupleSections #-} + +module StreamTests + ( tests + ) where + +import Conduit ( (.|)) +import Codec.Xlsx.Types.Internal.SharedStringTable +import Codec.Xlsx +import Codec.Xlsx.Parser.Stream +import Codec.Xlsx.Types.Common +import qualified Conduit as C +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 Map +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text as T +import Data.Vector (Vector, indexed, toList) +import Diff +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import TestXlsx +import Text.RawString.QQ +import Text.XML + +tests :: TestTree +tests = + testGroup + "Stream tests" + [ testCase "Get's out the shared strings" $ do + let bs = fromXlsx testTime testXlsx + LB.writeFile "data-test.xlsx" bs + + res <- C.runResourceT $ C.runConduit $ C.sourceFile "data-test.xlsx" .| parseStringsIntoMap + let + testSst :: Vector XlsxText + testSst = sstTable $ sstConstruct (testXlsx ^.. 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 + ] 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 adf23492..999c61ec 100644 --- a/xlsx.cabal +++ b/xlsx.cabal @@ -153,6 +153,7 @@ test-suite data-test , vector , xlsx , xml-conduit >= 1.1.0 + , conduit Default-Language: Haskell2010 source-repository head From 4d723571893924688ac93dc4ccf479dc6327d041 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Thu, 11 Mar 2021 15:52:11 -0400 Subject: [PATCH 30/37] Fix tests for shared strings --- src/Codec/Xlsx/Parser/Stream.hs | 7 ++++++- test/StreamTests.hs | 1 - xlsx.cabal | 2 ++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 0245d5d5..789f1aa7 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -120,6 +120,7 @@ makeLenses 'MkSheetState data SharedStringState = MkSharedStringState { _ss_file :: PsFiles , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway + , _ss_string :: Text } deriving Show makeLenses 'MkSharedStringState @@ -147,6 +148,7 @@ initialSharedString :: SharedStringState initialSharedString = MkSharedStringState { _ss_file = InitialNoFile , _ss_shared_ix = 0 + , _ss_string = mempty } parseSharedStrings :: forall m . MonadThrow m @@ -169,10 +171,13 @@ parseString :: MonadThrow m => MonadState SharedStringState m => Event -> m (Maybe (Int, Text)) parseString = \case - EventContent (ContentText txt) -> do + 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 diff --git a/test/StreamTests.hs b/test/StreamTests.hs index df397121..6ad531f5 100644 --- a/test/StreamTests.hs +++ b/test/StreamTests.hs @@ -51,6 +51,5 @@ tests = (x, my) <- toList $ indexed testTexts maybe [] (pure . (x,)) my - testMap @==? res ] diff --git a/xlsx.cabal b/xlsx.cabal index 999c61ec..7a44fafa 100644 --- a/xlsx.cabal +++ b/xlsx.cabal @@ -135,7 +135,9 @@ test-suite data-test , Diff , DrawingTests , PivotTableTests + , StreamTests , Test.SmallCheck.Series.Instances + , TestXlsx Build-Depends: base , bytestring , containers From a79d3361c06661c46e8f08b47fc2d130f6f5b3c7 Mon Sep 17 00:00:00 2001 From: Anton Myasnikov Date: Mon, 19 Apr 2021 21:44:41 +0300 Subject: [PATCH 31/37] Add nix flake template Problem: We want for the project to be as reproducible as possible. Me, as a mac user by now cannot build it due to the fact that haskell tooling is not very stable on this system. More concretely in my case, while I was building it on my global environment I got the following cryptic errors ``` streamin: src/Data/Conduit/Internal/Pipe.hs:(413,5)-(418,38): Non-exhaustive patterns in function go ``` And this was at runtime! I even tried to make a local fork of conduit library and fix the error, but the problem is that it was building on my machine and while I was trying to use it in this project, I got even more cryptic and non-helpful error. ``` streamin: internal error: stg_v_ap_get (GHC version 8.8.4 for x86_64_apple_darwin) Please reporth this as a GHC bug: https://www.haskell.org/ghc/reportabug ``` So my patience went over and I've decided to build it via nix. Solution: Add nix flakes template, cabal.project for cabal env and shell for hls. --- .DS_Store | Bin 0 -> 6148 bytes .gitignore | 7 +++++- cabal.project | 3 +++ default.nix | 3 +++ flake.lock | 61 ++++++++++++++++++++++++++++++++++++++++++++++++++ flake.nix | 42 ++++++++++++++++++++++++++++++++++ shell.nix | 1 + 7 files changed, 116 insertions(+), 1 deletion(-) create mode 100644 .DS_Store create mode 100644 cabal.project create mode 100644 default.nix create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 shell.nix diff --git a/.DS_Store b/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..4367fbc2dfe627b92e886feff01846a965965f75 GIT binary patch literal 6148 zcmeHK!AiqG5Z!I7CWx4WV2^w8)u`@9HW@l%1*_W`h%NXO%IA}0tF~$r~#F7ck7lPxc3sTY^M2>U#ljP1H z#y<4l7NW`V7a72BS78D3SjxQ5-_O4rhDlnlzw=VLva-5nn5JQFnAh$gp17%(juXcl zU1IOlO9#HT&*FGEvpxSj>`%JZ)=?a#UKsU9GC2(T5OQ@9MnODr;&ButavoO=$c4IA zHOpH2?V4z`+IdZ62fOu}Xzn%h+%&d#8iyyn+lR;ODSv)ZtaA7PrEF@P!YdfF4c@z> zXc$K~;G4!z;|PfXVt^P}A_nvkXsj>Mo@uMZ05R}02Jn0kpoq4{LZLi5puy`Sj#m&- zz{a-(qR?n-EEK{B2v@0qDwXRe23P6e7dp Date: Wed, 21 Apr 2021 22:58:14 +0300 Subject: [PATCH 32/37] Add stylish haskell to nix shell and fix shell --- flake.lock | 6 +++--- flake.nix | 3 ++- shell.nix | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/flake.lock b/flake.lock index 08358e3f..1e607441 100644 --- a/flake.lock +++ b/flake.lock @@ -35,11 +35,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1618593293, - "narHash": "sha256-rF2gBXvQ4H1Bz3Fd2eIeAqMGiRPeOUz6lq4Ue/BBzhE=", + "lastModified": 1619033689, + "narHash": "sha256-ABoYZ4ftAum8PTw5i5k/9c1S5Cj0goMFqpuOcdNJdGw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "a8f6369dda06b3e47299f7760b47c6806c03fb95", + "rev": "52b2fec43ba8d39c003627fe5f7fa59195bd40f2", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 84cc33cf..68c7a9bc 100644 --- a/flake.nix +++ b/flake.nix @@ -28,9 +28,10 @@ defaultPackage = self.packages.${system}.${packageName}; - shell = pkgs.mkShell { + devShell = pkgs.mkShell { buildInputs = with pkgs; [ haskell-language-server + stylish-haskell ghcid zlib cabal-install diff --git a/shell.nix b/shell.nix index 007e1095..6d7f42b0 100644 --- a/shell.nix +++ b/shell.nix @@ -1 +1 @@ -(import ./.).shell."${builtins.currentSystem}" \ No newline at end of file +(import ./.).devShell."${builtins.currentSystem}" \ No newline at end of file From 558cd56c5833c8ca7d883ba80e4c24f9bab4a48b Mon Sep 17 00:00:00 2001 From: Anton Myasnikov Date: Wed, 21 Apr 2021 22:59:20 +0300 Subject: [PATCH 33/37] Update streaming parser and add docs For now coundit parser is not able to parse all possible xlsx files, we need to change that and also be able to parse untyped values. We need to optimize parser agressively since using conduits is not fast as loading everything in memory. Also docs need to be added. --- cabal.project | 3 - cabal.project.local | 7 + src/Codec/Xlsx/Parser/Stream.hs | 759 +++++++++++++++++++++----------- xlsx.cabal | 7 +- 4 files changed, 516 insertions(+), 260 deletions(-) delete mode 100644 cabal.project create mode 100644 cabal.project.local diff --git a/cabal.project b/cabal.project deleted file mode 100644 index d7a5f7cc..00000000 --- a/cabal.project +++ /dev/null @@ -1,3 +0,0 @@ -packages: xlsx.cabal -with-compiler: ghc-8.8.4 -optimization: 2 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/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs index 789f1aa7..c77f4658 100644 --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,21 +1,147 @@ +{-# 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 #-} -{-# LANGUAGE DeriveAnyClass #-} --- | Read .xlsx as a stream +-- | +-- 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 - ( readXlsx - , readXlsxWithState - , SheetItem(..) - , parseSharedStrings - , parseStringsIntoMap + ( -- * Parsers + readXlsxC + , readXlsxWithSharedStringMapC + , parseSharedStringsC + , parseSharedStringsIntoMapC + -- * Structs , CellRow + , SheetItem(..) + -- ** `SheetItem` lens , si_sheet , si_row_index , si_cell_row @@ -24,114 +150,120 @@ module Codec.Xlsx.Parser.Stream import Codec.Archive.Zip.Conduit.UnZip import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common -import Conduit (PrimMonad, await, - yield, (.|)) +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.Lazy +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 (Map) -import qualified Data.Map as Map +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 -import Control.Monad.Catch --- TODO NonNull 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 - , _si_row_index :: Int - , _si_cell_row :: CellRow - } deriving Show + { _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 PsFiles = - -- | Files that are encountered in the workbook but not part - -- of this sumtype get this tag. They are then ignored. - UnkownFile Text - -- | files with actual data (rows and cells) - | Sheet Text - -- | Initial state, unrelated to excell format - | InitialNoFile - -- | stores strings which are replaced by id's in sheet to save space - | SharedStrings +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 - -- | contains the names in the tabs and some internal id - | Workbook + | Workbook -- ^ Contains names of the tabs and shared string ids | ContentTypes | Relationships - -- | contains relations ship between internal id and path - | SheetRel Text - deriving Show - -makePrisms ''PsFiles - -decodeFiles :: Text -> PsFiles -decodeFiles = \case - "xl/sharedStrings.xml" -> SharedStrings - "xl/styles.xml" -> Styles - "xl/workbook.xml" -> Workbook - "[Content_Types].xml" -> ContentTypes - "_rels/.rels" -> Relationships - unkown -> let - ws = "xl/worksheets/" - wsL = Text.length ws - in - if Text.take wsL unkown == ws then - let - known = Text.drop wsL unkown - rel = "_rels/" - relL = Text.length rel - in - if Text.take relL known == rel then - SheetRel $ Text.drop relL known - else - Sheet known - else UnkownFile unkown - -data TVal = T_S -- ^ string - | T_N -- ^ number - | T_B -- ^ boolean - - + | 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 :: PsFiles - , _ps_row :: CellRow - , _ps_sheet_name :: Text - , _ps_cell_row_index :: Int - , _ps_cell_col_index :: Int - , _ps_is_in_val :: Bool - , _ps_shared_strings :: Map Int Text - , _ps_t :: TVal -- the last detected value - } + { _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 :: PsFiles - , _ss_shared_ix :: Int -- int is okay, because bigger then int blows up memory anyway - , _ss_string :: Text - } deriving Show + { _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 PsFiles + 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 @@ -141,9 +273,10 @@ initialSheetState = MkSheetState , _ps_cell_col_index = 0 , _ps_is_in_val = False , _ps_shared_strings = mempty - , _ps_t = T_S + , _ps_type = Untyped } +-- | Initial parsing state initialSharedString :: SharedStringState initialSharedString = MkSharedStringState { _ss_file = InitialNoFile @@ -151,222 +284,336 @@ initialSharedString = MkSharedStringState , _ss_string = mempty } -parseSharedStrings :: forall m . MonadThrow m - => PrimMonad m +-- | 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 () -parseSharedStrings = (() <$ unZipStream) - .| (C.evalStateLC initialSharedString $ - (await >>= tagFiles) - .| C.filterM (const $ has _SharedStrings <$> use fileLens) - .| parseBytes def - .| C.concatMapM parseString - ) - -parseStringsIntoMap :: forall m . MonadThrow m - => PrimMonad 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) -parseStringsIntoMap = parseSharedStrings .| C.foldMap (uncurry Map.singleton) - -parseString :: MonadThrow m - => MonadState SharedStringState m +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)) -parseString = \case - EventBeginElement Name {nameLocalName = "t", ..} _ -> Nothing <$ (ss_string .= "") - EventEndElement Name {nameLocalName = "t", ..} -> do - idx <- use ss_shared_ix +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 + !txt <- use ss_string pure $ Just (idx, txt) EventContent (ContentText txt) -> Nothing <$ (ss_string <>= txt) _ -> pure Nothing - --- TODO figure out how to allow user to lookup shared string instead --- of always reading into memory. -readXlsxWithState :: forall m . MonadThrow m - => PrimMonad m - => Map Int Text -> ConduitT BS.ByteString SheetItem m () -readXlsxWithState sstate = - (() <$ unZipStream) - .| (C.evalStateLC initial $ (await >>= tagFiles) - .| C.filterM (const $ not . has _UnkownFile <$> use fileLens) - .| parseBytes def - .| parseFiles) +-- | 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 - --- | first reads the share string table, then provides another conuit to be run again for the remaining data. --- reading happens twice. All shared strings will be read into memory. -readXlsx :: - forall m . MonadThrow m - => PrimMonad m - => ConduitT () BS.ByteString m () -> m (ConduitT () SheetItem m ()) -readXlsx input = do - ssState <- C.runConduit $ input .| parseSharedStrings .| C.foldMap (uncurry Map.singleton) - pure $ input .| readXlsxWithState ssState - --- | there are various files in the excell file, which is a glorified zip folder --- here we tag them with things we know, and push it into the state monad. --- we need a state monad to make the excell parsing conduit to function -tagFiles :: - HasPSFiles env - => MonadState env m - => MonadThrow m - => Maybe (Either ZipEntry BS.ByteString) -> ConduitT (Either ZipEntry BS.ByteString) BS.ByteString m () -tagFiles = \case +-- | 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 .= decodeFiles filePath - await >>= tagFiles + let !filePath = either id Text.decodeUtf8 (zipEntryName zipEntry) + fileLens .= getFileTag filePath + await >>= tagFilesC Just (Right fdata) -> do - yield fdata - await >>= tagFiles + -- strange behaviour indeed, why it does not await already yielded data? + yield fdata + await >>= tagFilesC Nothing -> pure () -parseFiles :: - MonadThrow m - => MonadState SheetState m - => ConduitT Event SheetItem m () -parseFiles = await >>= parseFileLoop - --- we significantly -parseFileLoop :: - MonadThrow m - => MonadState SheetState m - => Maybe Event - -> ConduitT Event SheetItem m () -parseFileLoop = \case - Nothing -> pure () - Just evt -> do - file <- use ps_file - case file of - Sheet name -> parseSheet evt name - _ -> await >>= parseFileLoop - -parseSheet :: - MonadThrow m - => MonadState SheetState m - => Event -> Text -> ConduitT Event SheetItem m () -parseSheet evt name = do - prevSheetName <- use ps_sheet_name - rix <- use ps_cell_row_index - unless (prevSheetName == name) $ do - ps_sheet_name .= name - popRow >>= yieldSheetItem name rix - - parseRes <- runExceptT $ matchEvent name evt - rix' <- use ps_cell_row_index - case parseRes of - Left err -> C.throwM err - Right mResult -> do - traverse_ (yieldSheetItem name rix') mResult - await >>= parseFileLoop - -yieldSheetItem :: MonadThrow m - => Text -> Int -> CellRow -> ConduitT Event SheetItem m () +-- | 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 + unless (row == mempty) $ yield (MkSheetItem name rix' row) -popRow :: MonadState SheetState m => m CellRow +-- | 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 String - | SharedStringNotFound Int (Map Int Text) - deriving Show +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 -parseValue :: Map Int Text -> Text -> TVal -> Either AddCellErrors CellValue +-- | 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 - T_S -> do - (idx :: Int) <- first ReadError $ readEither $ Text.unpack txt + TS -> do + (idx, _) <- ReadError txt `first` Read.decimal @Int txt string <- maybe (Left $ SharedStringNotFound idx sstrings) Right $ sstrings ^? ix idx Right $ CellText string - T_N -> bimap ReadError CellDouble $ readEither $ Text.unpack txt - T_B -> bimap ReadError CellBool $ readEither $ Text.unpack txt - -addCell :: MonadError SheetErrors m => MonadState SheetState m => Text -> m () -addCell txt = do - inVal <- use ps_is_in_val - when inVal $ do - type' <- use ps_t - sstrings <- use ps_shared_strings - val <- liftEither $ first MkCell $ 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 = MkCoordinate CoordinateErrors - | MkType TypeError - | MkCell AddCellErrors - - deriving (Show, Exception) - - -data CoordinateErrors = CoordinateNotFound [(Name, [Content])] - | NoListElement (Name, [Content]) [(Name, [Content])] - | NoTextContent Content [(Name, [Content])] - | DecodeFailure Text [(Name, [Content])] + 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 - -data TypeError = TypeNotFound [(Name, [Content])] - | TypeNoListElement (Name, [Content]) [(Name, [Content])] - | UnkownType Text [(Name, [Content])] - | TypeNoTextContent Content [(Name, [Content])] - deriving Show + deriving anyclass Exception contentTextPrims :: Prism' Content Text contentTextPrims = prism' ContentText (\case ContentText x -> Just x - _ -> Nothing) - -setCoord :: MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () + _ -> Nothing) + +-- | Update state coordinates accordingly to @parseCoordinates@ +setCoord + :: ( MonadError SheetErrors m + , HasSheetState m + ) + => SheetValues -> m () setCoord list = do - coordinates <- liftEither $ first MkCoordinate $ parseCoordinates list + coordinates <- liftEither $ first ParseCoordinateError $ parseCoordinates list ps_cell_col_index .= (coordinates ^. _2) ps_cell_row_index .= (coordinates ^. _1) -setType :: MonadError SheetErrors m => MonadState SheetState m => [(Name, [Content])] -> m () +-- | Parse type from values and update state accordingly +setType + :: ( MonadError SheetErrors m + , HasSheetState m + ) + => SheetValues -> m () setType list = do - type' <- liftEither $ first MkType $ parseType list - ps_t .= type' + type' <- liftEither $ first ParseTypeError $ parseType list + ps_type .= type' -findName :: Text -> [(Name, [Content])] -> Maybe (Name, [Content]) +-- | Find sheet value by its name +findName :: Text -> SheetValues -> Maybe SheetValue findName name = find ((name ==) . nameLocalName . fst) -parseType :: [(Name, [Content])] -> Either TypeError TVal -parseType list = do - nameValPair <- maybe (Left (TypeNotFound list)) Right $ findName "t" list - 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 T_N - "s" -> Right T_S - "b" -> Right T_S - other -> Left $ UnkownType other list - -parseCoordinates :: [(Name, [Content])] -> Either CoordinateErrors (Int, Int) +-- | 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 + 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 -matchEvent :: MonadError SheetErrors m => MonadState SheetState m => Text -> Event -> m (Maybe CellRow) +-- | 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 <$ addCell 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 = "c"} _ -> Nothing <$ ps_is_in_cell .= True - -- EventEndElement Name {nameLocalName = "c"} -> Nothing <$ ps_is_in_cell .= False - EventBeginElement Name {nameLocalName = "row"} _ -> Nothing <$ popRow - EventEndElement Name{nameLocalName = "row", ..} -> Just <$> popRow - _ -> pure Nothing + 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/xlsx.cabal b/xlsx.cabal index 7a44fafa..f9a66377 100644 --- a/xlsx.cabal +++ b/xlsx.cabal @@ -105,6 +105,7 @@ Library , zip-stream >= 0.2.0.1 , xml-types , exceptions + , nothunks if flag(microlens) Build-depends: microlens >= 0.4 && < 0.5 , microlens-mtl @@ -156,6 +157,7 @@ test-suite data-test , xlsx , xml-conduit >= 1.1.0 , conduit + , filepath Default-Language: Haskell2010 source-repository head @@ -172,13 +174,16 @@ benchmark bench , xlsx default-language: Haskell2010 -executable streamin +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 From 93e9107b207e47fa2ba33ccb46a1de8cf3fa616d Mon Sep 17 00:00:00 2001 From: Anton Myasnikov Date: Mon, 17 May 2021 20:33:12 +0300 Subject: [PATCH 34/37] add simple xlsx data --- data/simple.xlsx | Bin 0 -> 9652 bytes 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 data/simple.xlsx diff --git a/data/simple.xlsx b/data/simple.xlsx new file mode 100644 index 0000000000000000000000000000000000000000..bb39f9e4b9a1382dfd88e5a29cc8df0f7bc50218 GIT binary patch literal 9652 zcmeHNWmsIvwr$+qEf5-acMER8-5r9{xC9Hq-CcquxH};@!GZ>d;2IhU9>VL%%)Oam z=DnZq&%M>(snh-SS^GOxXRTek_C6{KFtE4)cmN^*0C)<(wW^H;K>+~iZ~y=f01;YW z!pYIi($URW!`s=?)sV%@!Jgs`EHqs{02*@rf7^fX4D=F;w>9n4BRYX~Z*a_MY;-opGAo7Gt}Z-3$I@giTG%1J&0(IW0N0~d zxXCX`b+7IycM7JO;%XsnGU3{z4AE>JmQVT}LUEQg>C`Yt2YlimMz#%VJvVt#;#Pp4 zVALDz`!vlA%5NUL2HLlWCGoADG})YlNj9@IyKE`=)J_G3T4&#;KktR7=;hRan~-?c zsJUj~;~SREFil+1Fh~;F?Nu(pd0yZB{`mC-Y$Zij1ZJMpbN1_j6AXe>@Hq4NG$k{= zp{^~`@JG$(u%K^HAw9?xpJ|lMjZhpgT9>}R^TN-T=^^|AMnccdJjkVeim2L~Fe4{p z+ug4pTJjNjhPCsm0f%_&1)*DX=e`xTh*T%_;7J}xQo!=V^f?GuZfA6W-4V@XPSh7$ zc-J5TaKH`U7AJslqIsu?P9L4E<;Er$>O3QSeePBrD+&?h!vhRJ=zp*-|1|W9#OKPrY^b4N+3#UPSF;R}k3bSs9vk>*9{UKm$sZ zcBxqJ!}6HDn7z!9k@u$a=!|11Z+Tmw@No?&J$))!i}{H~n-~eFm^2h$I3q}J;JNOq z*>x4vthoBu%Fvo--u#24PgwzTsU`bpqT&3CM^hPiL#}4l3srtY_D?Tvh&9!1_+QkR z<$?q#y^SsGKb%Wub>ZCmF)L*csZnxaUvqqt8Klm?2+(WbIvvUJ?&C%3Egw4h7#v0Z zcJ&`c(hy>#e+>}`7#;w?fXs}SJ*%e^$j;2k$?mtctVnZ3X^9Q@eO`lSxF5M$sa&Qs zu4JaP1aycrLfR0Oqg_H@!e)b1c+^+!OG;l#7Tl3q{LGU5p?g8xd)IsCrM<=RSDxa_`T!Mf2`=rj zSklsuI~7G^L2q^865qvBYl;nLOwS}vc4Tmt4EMOOqh}|cAy;Biwqk^)D|ruKCp1!* z&k#%21v5BzWt_L|PYm0WwmH zp(Vs`u7`cYTOyw;HyQp;0AOSN^;_08k_V!9O7QFw=~37ge~OImB4KT(F-Ps<2ab-+Q}3$4~X07BkJgs?|>B8wpg;m2V5;^4yqw z0;~D;dD>xZru0@$7zh-S$Ss83aJxn7Ql;H`UAeByoQy9Me<@z59M-tK**&jL1G9<(R%)KN6|^Mq z0F_3XsOE2dThgyTycx5jt=j)$GRal!R;;{S7TuGD5BiKoz`%*)x`bvY;Fk5;2YDSnu+0jX@@~DHP5(W-R zR~x_dPK)dwB7?uLBtKppXd^@9GYSI$5CagQAR_sFG5NDp{T}=|K@ige?2_>?6Q-_9GBQo1Hmx2=)uPk_NDt; zK&43!y3b20_J_I&`#RxNK8e{ygqO#~DP7R5u-x{EJpFM+Qe($WpKG|U^CvZh$gQ)3 z)OGBdE3U!D%7sqZujve#(FERJlfe4(cHMF;0^5NZL308v8+tr;pwc5(k_IzuQY|{HY%Q`)8)cHR4g#N0X z^Gm1x%J>6W0q_H*qCc}x#YIgJt;T6<;@N(JX0}O^a*tzd&AR7J-JE;>gXNu_qyV|3 z2R6c5fJokKria&Fq_+)&e_mRgI?GNymuLW&eGftw+GdNG0a~oJd=l2vKqzih_@tuG zCx`>|e`*HBMC%&JXSr^%tA zM#myM$_QUq5uI{mpZF{|R%{Ymzu1hTYjpgBG^CRjC1TjMK*Z;k#B+y_C|Q6DyS3#b z(&Hz3vA9YG+JBWYVRd0VV->x!cI)I4M8&Ap|Cy|i5dO9JbnlGOR%%|4E? z$&9_aH6eWVg8g6l%<+iNQzMRrY`E}W?q$!>Q?L5O#I3~Q89MX#t1_2X*~3iw2?jh^ zG-o}*L3AHw7bH`}I0pP4_~*A*o-x+J>=tw5J*Q!(HVJVk($)U<2`q4{6oIkKWuOa# z_YzJSjBnhP?0d-b9tIH>Zj*8G^#nn*_hitHznL%FbxEVrd0?F5m>)QhcT+~MmMeBw z(e=fiD%~=3sDnQJm&wRVc%0a9n0}bgV8MmEq>_H->>bDYuRv4xxITFXA|sh(Z05+_ z#@g6w+{>4;RtE8}dKvqDeIki=s}mb=$9rcik9sdz-qd%>W7Egrm=`ZOba4_cy<-am9?>MP#IowdXk3i(Eso^xdh zuk3=|RC%yHA^hgEVQf>3+)l2O;?K?N!oK{`#g626fr1+jNKa7VApMlmm}R=osnkz* z>(WgD!rDTAB1Rul%l80IXNRwG?RnD?t^DG`E8m#(MgF!vp8w)KM*Ja*iGAqB%Rf`) z{~|H!-$*?F2Z_Uje7+FJ)Y!sC_HbvK%-KY10#$IUCUKt^iu5c%%>VyUv6}$%y%GWd zFhKEJX69!k>t5r#!;_+`DCB8LS>PYOxoCV zq^iZqk=Q|k15M3;p+;9!oF?uhoIE84gVy;i4vDH^pL~*bY#vy-O_gOYujhdlCG(@R zwDc<1-{;)zbgDDmM$zcJzEY)pTlr9UmQ+pR#OnG?pcj;|&VacZH=q ze-M_#N5sK-m>Ws^f>d%j{v`(de#Fp(mJe2ZL2ES8gR(uqJp4gYvRA9=_>9GBm4v{= zYolN@72lT}Pk~2hDe?in?>dy%*%QRkqUqMO%WA0$YBzi9#KT|jsU4F&T|6_*Wfy$1 z;X8FjhmGxTb3=Wft z#o@hPSJPA}lnqyKN=ehaz+sAGyeXQ>?QB82Hdu26e|5sxu)dY7EbjGOzD7VzC^>4| z7b%qLXY?Wlykj*jZ~Vy*{Mj%fm%XYUN_o$wl3mX^z6mrtfIbp z)|p8ENi`m={76k*QHPRuTQB;ULj({Atwtrc@v$FOc>=MnC5n#!OWzXpG$OWBC^n5r ziv~TKyykVaNYIZGU}O^;M^TEQNrVoG+NGCS-$%u!?~M7gycDdt!oELF_Rqt*gaf|q z-SisQwKg&+I3iH1s~^wC89&_L6Ra9{{Wv)|<=vm5J?-i1`hGK#*7a~Ia8a|djK})^ z<=NSO62aQbi(Tb7vc)A*vh*ipZDAOSHyHhC9oIW=3zC=xR{Pg|*CGpeO);g-##JqSGozLaH-oSZo4Dy}4*w??!_ zOeEMHv&dHfu68-|wKvojVrndR&?2!TO8B~`)VpdWqRGnJCBnDoggG`8Ya+fKV^+Tk zpQe@onNX{-G)S0*kMvklge;zotvXcqzO|bb_Ok$*LhggjKm6VHz=#ct>X911Bs(|R z`zVVo4p2b13{4d)m84H3{rRmqQ;5QjK-dNGvo2)RP4v4bhJ8GV3ZT8I)+j>G1YwW) z7!@JcMa9ISK7ShYr&0-?ujB~);uZuYg(XN;>e!c?k(zq$tteaIwrn$#X~SaK#txlYzt(g8#5p}fRJ%^uoLb<}j#p$2k zB@1NHS?)>()gxVzGuiprcm%G$UEK2}Y{z6Y0^8dq)i&BzTc~l$>rC!+rsZTH^QH@p zC@sfg+yttggyqVI>`2864KGfbeDk6(cSgLtiOM^rbFa9VX(j8{inh#mC~%24Ui1br z5^3@!dwRm))ykPe|2+*)-86W*g=s=lMJp0jcS2QTba7lG>ky-b44p|gok^90v;sY8 zmu+M=2RuBl?aMDxo!ep07N3P$ktXk&{0B#9(0ANm0_a1kuo_ zPxJ{o-Za`GHZuUZ>~3)O2z%$e;9G$+`UG#(TRe#5aviTdO;d>o>cS+G1q_muhT+*0 z(tVTrn2nhOQqZ_2N#8gyY6oJ9=xt_-F_LGwV7dtod2w_DUxcm@s^%(@2d%4DIsYi@ zUn8raS|IJ|B#(*fgb~=~#VXR#VP!;!jR=f-1v(gG56Y^+OW3~g+%Orond^w0;!lnR z3Ph=Ryh*pn?ct878l6;TBqvl}$m}jSWD!a)gSqTfUg0I59d?C(v147*&u}o~mb4!x zxP?}JCNWdTQ0#cG#0;vkV`)Xlp7oaRSf6Ecm&Au_$ux8i(_B9XxDbTQv&P z!FDPYP8@v}cx_av4@UD@shK1dI_U(Wp)bxlsvPnnH-eh=5pAh0{R?&9BBaO*zHKJC z&%dW&G&k9%e`)a^aAn)x^ze^6o6ndTfi;jwPzthxM*DsFb#?Q$w{-oPM$%A#Y+^81 z2=>SjkMZOqw--Z;@?(J%V#v78$ZiS>$bEFNb|zIU{0|+PmM&5*?ufh!>-pxwN*kbe&Q-jQmx84 ziY?*hAyC#<#No41)pn-d`!B&uhOb^HjM6qM6r&j;=IbHAWEKh#W@66n#21~4d<1$s zx)m$mFwUEwzvRRqkQqlZZ?Ga_9~oN*ih( z3UFa9m@?1>KtL=Pd@&Oz!z;9dqq`O2DMrFF{E~<}nQv1QhM3ZwFhz3d11Jv2gd6_* zm5ecPjLewaeyyPLS-WeNhDHiEVuEaz#y34FAihZ=6{Ycz^!8^DI=QBE)M_Lda=!Xh zgjLaYJ>4PV0`>iNyy#tVpUt`m@n^UBMJO(9@)AT!WR$?L;4W~0kcg1~(u0rR{6omQ z%+?oX|Ql`jRgPGV5wRKYh|OYoH4 zwCyp(?W7e=o_Ntj6*lHx!ClLWYth!cx_dF-_lHOf>V`;UrZWi8s!Hp1c`hX$ZtcM1 zU0()xl{JWad)eQ?cA%6nHZi*RpHa6ox4Od28L&b(+$|5TPXv&_y-zc|4dNx7O5i0n zk~YGJTes&+UzOCI*?b~=Zh0by+29lnB!AA7rs(WGageXFhC zN$~tV{gYg{64VEwGy{bAxPMUF#uQ{}q3#BH;b{Gn;RbQfVtd$7rLKT3VMD&MVN%v1 zi8X`~I3J)m-YEdNl_Csbn`zzff$leXUH2BQenqM)wa%j!>#lQw;>fL0ZjH|Tc};8i zIzsOLqapaYL(Xnl7`;qo$JqLWk|nP`lfow+rUy2qDXoa)p6R4*{7rIfIy?{4w1-6K!+VbjUPl6ZK+@qhWH;O!=G*wKD+wp9kvR+KGKiNT$7$Z72mkB$F9m`KY3N!QCt~c;Vg9lzvnbTqG7-X07q4t(Dv$n=z zNluW&BHq87+^Gs2s_JU)Ta8;|TcsHRZ})b`@2*JOK(s5UC;15sv<4u8g~|kVXvcF; zkHC$}g7wW4G*!6Ggw(X#OKc6pk#OFIF#?#|j`Cbiy-HFqe~Nn%7{Bx%=uI|gcpdDn9fCXMBCHCJFruf;=);d| zgaj5$ztg-8bxlTOBxs{Dj+u0Rhrh3Jtg_*=SqSPX@&LEq{v(gcvkarakjE4W;WFl* zd2H(J{9hVFCgzWp9sjEqMt8+cB#VmepM& zc~{dyv;?bCJcy!VyKYJi;A0Ez(df4#%Hmiw)Ni`!BmQ<9R@d=p`?a?m?$Z>2E*rEf zb6jy>quK(wsdK9tk?sq6v?}LJ0VxL(q2;6iazIquluxk~w6d%lXMvF+wgE+}q z-j6d=Q7In#F`fYtFYRmjb`%lSlBV#mNeR~6S`0+#`(t*&u&P%UF`0#e#BX{d6kNac zUH45pHM78=1b}Fsj8`{~XckvD{#ZOSm;Jo_ydDm3 za*}*hQ*`D(a7E{bztjbaqAfek^%5m>4VEjs{`esb)~bE&1vt?-II5y8s9(&+p`9WU zBRL1v5_mjTICG>ocq_TU(5eZoI)W6p>D99gXVR!W`+*}U@*d{xH-!e`2jC^jzx*{6 zG&5vH`sa63{&=kaKK;X+Dk=(pHSpJp`M;5nFXfO~`&0e=G4OE}@fUOg5)MA9DLw}O zwYu^P3IJRn{RICnwU)B@$;A3;<#B52v4O|o^e+QML_ZDu3a%eRABQWypx;P-hdvHo9$Wb9(*Fw&03474 z0DlVv9>f3YasLdjBmWcp5C8iZ{aA{>@N-Xp-u_>NsiFV}VHf~_3i-f7NSaCc+pqrt DV;^}T literal 0 HcmV?d00001 From 7f5c98b8b3e9279c0252fe51e8434cb9fd899b3f Mon Sep 17 00:00:00 2001 From: Anton Myasnikov Date: Mon, 17 May 2021 20:34:53 +0300 Subject: [PATCH 35/37] Update streaming benchmark Make criterion collect info about all three parsers --- benchmarks/Stream.hs | 87 ++++++++++++++++++++++++++++++++------------ 1 file changed, 63 insertions(+), 24 deletions(-) diff --git a/benchmarks/Stream.hs b/benchmarks/Stream.hs index 60da8c39..ec0072f5 100644 --- a/benchmarks/Stream.hs +++ b/benchmarks/Stream.hs @@ -1,37 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} module Main (main) where -import Prelude hiding (foldl) -import Codec.Xlsx -import Criterion.Main -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LB -import Conduit -import Codec.Xlsx.Parser.Stream -import Data.Text(Text) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +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 + 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 + 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) -main :: IO () -main = do - let filename = - "../temp/policy-bordereau-template.xlsx" - -- "data/testInput.xlsx" - -- "data/6000.rows.x.26.cols.xlsx" - conduit <- runResourceT $ readXlsx (sourceFile filename) - x <- runResourceT $ runConduit $ conduit .| C.filter (("sheet1.xml" ==) . _si_sheet) .| C.foldl (\a b -> a <> [b]) [] - Text.putStrLn $ Text.intercalate "\n" $ format <$> 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 + ] From 606488b8362f19858994596e0d5c27a7627a702f Mon Sep 17 00:00:00 2001 From: Anton Myasnikov Date: Mon, 17 May 2021 20:36:06 +0300 Subject: [PATCH 36/37] Add streaming parser tests --- test/Main.hs | 2 +- test/StreamTests.hs | 87 ++++++++++++++++++++++++++------------------- 2 files changed, 52 insertions(+), 37 deletions(-) diff --git a/test/Main.hs b/test/Main.hs index fcfccd27..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 diff --git a/test/StreamTests.hs b/test/StreamTests.hs index 6ad531f5..919b5a2b 100644 --- a/test/StreamTests.hs +++ b/test/StreamTests.hs @@ -1,55 +1,70 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections #-} module StreamTests ( tests ) where -import Conduit ( (.|)) -import Codec.Xlsx.Types.Internal.SharedStringTable -import Codec.Xlsx +import Codec.Xlsx import Codec.Xlsx.Parser.Stream import Codec.Xlsx.Types.Common -import qualified Conduit as C -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 Map -import qualified Data.Map as M -import Data.Maybe (mapMaybe) -import Data.Text (Text) -import qualified Data.Text as Text -import qualified Data.Text as T -import Data.Vector (Vector, indexed, toList) +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 Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) +import System.FilePath.Posix +import Test.Tasty (TestName, + TestTree, + testGroup) +import Test.Tasty.HUnit (testCase) import TestXlsx import Text.RawString.QQ import Text.XML -tests :: TestTree -tests = - testGroup - "Stream tests" - [ testCase "Get's out the shared strings" $ do - let bs = fromXlsx testTime testXlsx - LB.writeFile "data-test.xlsx" bs +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) - res <- C.runResourceT $ C.runConduit $ C.sourceFile "data-test.xlsx" .| parseStringsIntoMap - let - testSst :: Vector XlsxText - testSst = sstTable $ sstConstruct (testXlsx ^.. xlSheets . traversed . _2) + testTexts :: Vector (Maybe Text) + testTexts = preview _XlsxText <$> testSst - 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 :: Map Int Text - testMap = Map.fromList $ do - (x, my) <- toList $ indexed testTexts - maybe [] (pure . (x,)) my + testMap @==? res - 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 ] From 1049345fee71bca87e24c0c655ee06561b7c62e1 Mon Sep 17 00:00:00 2001 From: Mark Florisson Date: Mon, 17 May 2021 20:44:58 +0100 Subject: [PATCH 37/37] Update stack.yaml to include nothunks --- stack-lts-12.yaml | 3 --- stack-lts-14.yaml | 2 ++ stack-lts-16.yaml | 2 ++ stack-lts-17.yaml | 2 ++ stack-nightly.yaml | 2 ++ 5 files changed, 8 insertions(+), 3 deletions(-) delete mode 100644 stack-lts-12.yaml 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