xlsx-1.2.0: test/StreamTests.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE CPP #-}
module StreamTests
( tests
) where
#ifdef USE_MICROLENS
import Test.Tasty (TestName, TestTree, testGroup)
tests :: TestTree
tests = testGroup
"I stubbed out the tests module for microlens \
because it doesn't understand setOf. \
Volunteers are welcome to fix this!"
[]
#else
import Control.Exception
import Codec.Archive.Zip as Zip
import Codec.Xlsx
import Codec.Xlsx.Parser.Stream
import Conduit ((.|))
import qualified Conduit as C
import Control.Lens hiding (indexed)
import Control.Monad (void)
import Data.Set.Lens
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString as BS
import Data.Map (Map)
import qualified Data.Conduit.Combinators as C
import qualified Data.Map as M
import qualified Data.IntMap.Strict as IM
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Vector as V
import Diff
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase)
import TestXlsx
import qualified Codec.Xlsx.Writer.Stream as SW
import qualified Codec.Xlsx.Writer.Internal.Stream as SW
import Control.Monad (void)
import Control.Monad.State.Lazy
import Test.Tasty.SmallCheck
import Test.SmallCheck.Series.Instances ()
import qualified Data.Set as Set
import Data.Set (Set)
import Text.Printf
import Data.Conduit
import Control.Arrow ((&&&))
import Data.Maybe (fromJust)
tshow :: Show a => a -> Text
tshow = Text.pack . show
toBs :: Xlsx -> BS.ByteString
toBs = LB.toStrict . fromXlsx testTime
tests :: TestTree
tests =
testGroup "Stream tests"
[
testGroup "Writer/shared strings"
[ testProperty "Input same as the output" sharedStringInputSameAsOutput
, testProperty "Set of input texts is same as map length" sharedStringInputTextsIsSameAsMapLength
, testProperty "Set of input texts is as value set length" sharedStringInputTextsIsSameAsValueSetLength
],
testGroup "Reader/shared strings"
[ testCase "Can parse RichText values" richCellTextIsParsed
],
testGroup "Reader/Writer"
[ testCase "Write as stream, see if memory based implementation can read it" $ readWrite simpleWorkbook
, testCase "Write as stream, see if memory based implementation can read it" $ readWrite simpleWorkbookRow
, testCase "Test a small workbook which has a fullblown square" $ readWrite smallWorkbook
, testCase "Test a big workbook as a full square which caused issues with zipstream \
The buffer of zipstream maybe 1kb, this workbook is big enough \
to be more than that. \
So if this encodes/decodes we know we can handle those sizes. \
In some older version the bytestring got cut off resulting in a corrupt xlsx file"
$ readWrite bigWorkbook
, testCase "Test a workbook containing multiple sheets"
$ readWriteMultipleSheets multipleSheetsWorkbook
-- , testCase "Write as stream, see if memory based implementation can read it" $ readWrite testXlsx
-- TODO forall SheetItem write that can be read
],
testGroup "Reader/inline strings"
[ testCase "Can parse row with inline strings" inlineStringsAreParsed
],
testGroup "Reader/floats parsing"
[ testCase "Can parse untyped values as floats" untypedCellsAreParsedAsFloats
]
]
readWrite :: Xlsx -> IO ()
readWrite input = do
BS.writeFile "testinput.xlsx" (toBs input)
items <- runXlsxM "testinput.xlsx" $ collectItemsIdentifier . fromJust =<< makeIdentifierFromName "Sheet1"
bs <- runConduitRes $ void (SW.writeXlsx SW.defaultSettings $ C.yieldMany items) .| C.foldC
case toXlsxEither $ LB.fromStrict bs of
Right result ->
input @==? result
Left x -> do
throwIO x
readWriteMultipleSheets :: Xlsx -> IO ()
readWriteMultipleSheets input = do
BS.writeFile "testinput.xlsx" $ toBs input
sheetsAndConduits <- runXlsxM "testinput.xlsx" $ do
sheets <- reverse . _wiSheets <$> getWorkbookInfo
let sheetCount = length sheets
let sheetNamesAndStates = map (sheetInfoName &&& sheetInfoState) sheets
sheetConduits <- map C.yieldMany
<$> mapM (collectItemsIdentifier . getSheetIdentifier) sheets
pure $ zip sheetNamesAndStates sheetConduits
bs <- runConduitRes $ void (SW.writeXlsxWithConfig $ SW.defWriteXlsxConfig & SW.setNameInfosAndConduits sheetsAndConduits) .| C.foldC
case toXlsxEither $ LB.fromStrict bs of
Right result -> input @==? result
Left x -> throwIO x
-- test if the input text is also the result (a property we use for convenience)
sharedStringInputSameAsOutput :: Text -> Either String String
sharedStringInputSameAsOutput someText =
if someText == out then Right msg else Left msg
where
out = fst $ evalState (SW.upsertSharedString someText) SW.initialSharedString
msg = printf "'%s' = '%s'" (Text.unpack out) (Text.unpack someText)
-- test if unique strings actually get set in the map as keys
sharedStringInputTextsIsSameAsMapLength :: [Text] -> Bool
sharedStringInputTextsIsSameAsMapLength someTexts =
length result == length unqTexts
where
result :: Map Text Int
result = view SW.string_map $ traverse SW.upsertSharedString someTexts `execState` SW.initialSharedString
unqTexts :: Set Text
unqTexts = Set.fromList someTexts
-- test for every unique string we get a unique number
sharedStringInputTextsIsSameAsValueSetLength :: [Text] -> Bool
sharedStringInputTextsIsSameAsValueSetLength someTexts =
length result == length unqTexts
where
result :: Set Int
result = setOf (SW.string_map . traversed) $ traverse SW.upsertSharedString someTexts `execState` SW.initialSharedString
unqTexts :: Set Text
unqTexts = Set.fromList someTexts
-- can we do xx
simpleWorkbook :: Xlsx
simpleWorkbook = def & atSheet "Sheet1" ?~ sheet
where
sheet = toWs [ ((RowIndex 1, ColumnIndex 1), a1)
, ((RowIndex 1, ColumnIndex 2), cellValue ?~ CellText "text at B1 Sheet1" $ def) ]
a1 :: Cell
a1 = cellValue ?~ CellText "text at A1 Sheet1" $ cellStyle ?~ 1 $ def
-- can we do x
-- x
simpleWorkbookRow :: Xlsx
simpleWorkbookRow = def & atSheet "Sheet1" ?~ sheet
where
sheet = toWs [ ((RowIndex 1, ColumnIndex 1), a1)
, ((RowIndex 2, ColumnIndex 1), cellValue ?~ CellText "text at A2 Sheet1" $ def) ]
toWs :: [((RowIndex, ColumnIndex), Cell)] -> Worksheet
toWs x = set wsCells (M.fromList x) def
-- can we do xxx
-- xxx
-- .
-- .
smallWorkbook :: Xlsx
smallWorkbook = def & atSheet "Sheet1" ?~ sheet
where
sheet = toWs $ [1..2] >>= \row ->
[((row,1), a1)
, ((row,2), def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1"))
, ((row,3), def & cellValue ?~ CellText "text at C1 Sheet1")
, ((row,4), def & cellValue ?~ CellDouble (0.2 + 0.1))
, ((row,5), def & cellValue ?~ CellBool False)
]
-- sheets = [("Sheet1" , toWs $ [1..2] >>= \row ->
-- [ ((RowIndex row, ColumnIndex 1), a1)
-- , ((RowIndex row, ColumnIndex 2),
-- def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1"))
-- , ((RowIndex row, ColumnIndex 3),
-- def & cellValue ?~ CellText "text at C1 Sheet1")
-- , ((RowIndex row, ColumnIndex 4),
-- def & cellValue ?~ CellDouble (0.2 + 0.1))
-- , ((RowIndex row, ColumnIndex 5),
-- def & cellValue ?~ CellBool False)
-- ]
-- )]
bigWorkbook :: Xlsx
bigWorkbook = def & atSheet "Sheet1" ?~ sheet
where
sheet = toWs $ [1..512] >>= \row ->
[((row,1), a1)
,((row,2), def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1"))
,((row,3), def & cellValue ?~ CellText "text at C1 Sheet1")
]
-- sheets = [("Sheet1" , toWs $ [1..512] >>= \row ->
-- [((RowIndex row, ColumnIndex 1), a1)
-- ,((RowIndex row, ColumnIndex 2),
-- def & cellValue ?~ CellText ("text at B"<> tshow row <> " Sheet1"))
-- ,((RowIndex row, ColumnIndex 3),
-- def & cellValue ?~ CellText "text at C1 Sheet1")
-- ]
-- )]
multipleSheetsWorkbook :: Xlsx
multipleSheetsWorkbook = simpleWorkbook
& atSheet "my Sheet 2" ?~ sheet2
& atSheet "my Sheet 3" ?~ sheet3
where
sheet2 = toWs [ ((RowIndex 1, ColumnIndex 1), cellValue ?~ CellText "text at A1 Sheet2" $ def)
, ((RowIndex 1, ColumnIndex 2), cellValue ?~ CellText "text at B1 Sheet2" $ def) ]
sheet3 = toWs [ ((RowIndex 1, ColumnIndex 1), cellValue ?~ CellText "text at A1 Sheet3" $ def)
, ((RowIndex 1, ColumnIndex 2), cellValue ?~ CellText "text at B1 Sheet3" $ def) ]
& wsState .~ Hidden
inlineStringsAreParsed :: IO ()
inlineStringsAreParsed = do
items <- runXlsxM "data/inline-strings.xlsx" $ collectItemsIdentifier . fromJust =<< makeIdentifierFromName "Sheet1"
let expected =
[ IM.fromList
[ ( 1,
Cell
{ _cellStyle = Nothing,
_cellValue = Just (CellText "My Inline String"),
_cellComment = Nothing,
_cellFormula = Nothing
}
),
( 2,
Cell
{ _cellStyle = Nothing,
_cellValue = Just (CellText "two"),
_cellComment = Nothing,
_cellFormula = Nothing
}
)
]
]
expected @==? (items ^.. traversed . ri_cell_row)
untypedCellsAreParsedAsFloats :: IO ()
untypedCellsAreParsedAsFloats = do
-- values in that file are under `General` cell-type and are not marked
-- as numbers explicitly in `t` attribute.
items <- runXlsxM "data/floats.xlsx" $ collectItemsIdentifier . fromJust =<< makeIdentifierFromName "Лист1"
let expected =
[ IM.fromList [ (1, def & cellValue ?~ CellDouble 12.0) ]
, IM.fromList [ (1, def & cellValue ?~ CellDouble 13.0) ]
-- cell below has explicit `Numeric` type, while others are all `General`,
-- but sometimes excel does not add a `t="n"` attr even to numeric cells
-- but it should be default as number in any cases if `t` is missing
, IM.fromList [ (1, def & cellValue ?~ CellDouble 14.0 & cellStyle ?~ 1 ) ]
, IM.fromList [ (1, def & cellValue ?~ CellDouble 15.0) ]
]
expected @==? (_ri_cell_row <$> items)
richCellTextIsParsed :: IO ()
richCellTextIsParsed = do
BS.writeFile "testinput.xlsx" (toBs richWorkbook)
runXlsxM "testinput.xlsx" $ do
sharedStrings <- getOrParseSharedStringss
let result = Set.fromList $ V.toList sharedStrings
liftIO $ expected @==? result
where
expected :: Set.Set Text
expected = Set.fromList
[ textA1
, firstClauseB1 <> secondClauseB1
, firstClauseB2 <> secondClauseB2
]
textA1 = "Text at A1"
firstClauseB1 = "First clause at B1;"
firstClauseB2 = "First clause at B2;"
secondClauseB1 = "Second clause at B1"
secondClauseB2 = "Second clause at B2"
richWorkbook :: Xlsx
richWorkbook = def & atSheet "Sheet1" ?~ toWs
[ ((RowIndex 1, ColumnIndex 1), cellValue ?~ CellText textA1 $ def)
, ((RowIndex 2, ColumnIndex 1), cellValue ?~ cellRich firstClauseB1 secondClauseB1 $ def)
, ((RowIndex 2, ColumnIndex 2), cellValue ?~ cellRich firstClauseB2 secondClauseB2 $ def)
]
cellRich :: Text -> Text -> CellValue
cellRich firstClause secondClause = CellRich
[ RichTextRun
{ _richTextRunProperties = Just RunProperties
{ _runPropertiesBold = Nothing
, _runPropertiesCharset = Just 1
, _runPropertiesColor = Just Color
{ _colorAutomatic = Nothing
, _colorARGB = Nothing
, _colorTheme = Just 1
, _colorTint = Nothing
}
, _runPropertiesCondense = Nothing
, _runPropertiesExtend = Nothing
, _runPropertiesFontFamily = Just FontFamilySwiss
, _runPropertiesItalic = Nothing
, _runPropertiesOutline = Nothing
, _runPropertiesFont = Just "Aptos Narrow"
, _runPropertiesScheme = Nothing
, _runPropertiesShadow = Nothing
, _runPropertiesStrikeThrough = Nothing
, _runPropertiesSize = Just 11.0
, _runPropertiesUnderline = Nothing
, _runPropertiesVertAlign = Nothing
}
, _richTextRunText = firstClause
}
, RichTextRun
{ _richTextRunProperties = Just RunProperties
{ _runPropertiesBold = Just True
, _runPropertiesCharset = Just 1
, _runPropertiesColor = Just Color
{ _colorAutomatic = Nothing
, _colorARGB = Just "FFFF0000"
, _colorTheme = Nothing
, _colorTint = Nothing
}
, _runPropertiesCondense = Nothing
, _runPropertiesExtend = Nothing
, _runPropertiesFontFamily = Just FontFamilySwiss
, _runPropertiesItalic = Nothing
, _runPropertiesOutline = Nothing
, _runPropertiesFont = Just "Arial"
, _runPropertiesScheme = Nothing
, _runPropertiesShadow = Nothing
, _runPropertiesStrikeThrough = Nothing
, _runPropertiesSize = Just 8.0
, _runPropertiesUnderline = Nothing
, _runPropertiesVertAlign = Nothing
}
, _richTextRunText = secondClause
}
]
#endif