diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs index 9d39fc3..175b2dc 100644 --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -245,6 +245,7 @@ formatted cs styleSheet = , formattedMerges = reverse (finalSt ^. formattingMerges) } +-- | Build an 'Xlsx', render provided cells as per the 'StyleSheet'. formatWorkbook :: [(Text, Map (Int, Int) FormattedCell)] -> StyleSheet -> Xlsx formatWorkbook nfcss initStyle = extract go where diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs index e7bab82..166863a 100644 --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -112,11 +112,12 @@ toXlsxEitherBase parseSheet bs = do (wfs, names, cacheSources, dateBase) <- readWorkbook ar sheets <- forM wfs $ \wf -> do sheet <- parseSheet ar sst contentTypes cacheSources wf - return (wfName wf, sheet) + return . (wfName wf,) . (wsState .~ wfState wf) $ sheet CustomProperties customPropMap <- getCustomProperties ar return $ Xlsx sheets (getStyles ar) names customPropMap dateBase data WorksheetFile = WorksheetFile { wfName :: Text + , wfState :: SheetState , wfPath :: FilePath } deriving (Show, Generic) @@ -204,6 +205,7 @@ extractSheetFast ar sst contentTypes caches wf = do { _wsDrawing = Nothing , _wsPivotTables = [] , _wsTables = [] + , _wsState = wfState wf , .. } , tableIds @@ -500,6 +502,7 @@ extractSheet ar sst contentTypes caches wf = do tables mProtection sharedFormulas + (wfState wf) extractCellValue :: SharedStringTable -> Text -> Cursor -> [CellValue] extractCellValue sst t cur @@ -653,7 +656,7 @@ readWorkbook ar = do sheets <- sequence $ cur $/ element (n_ "sheets") &/ element (n_ "sheet") >=> - liftA2 (worksheetFile wbPath wbRels) <$> attribute "name" <*> + liftA3 (worksheetFile wbPath wbRels) <$> attribute "name" <*> fromAttributeDef "state" def <*> fromAttribute (odr "id") let cacheRefs = cur $/ element (n_ "pivotCaches") &/ element (n_ "pivotCache") >=> @@ -686,9 +689,9 @@ getTable ar fp = do cur <- xmlCursorRequired ar fp headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) -worksheetFile :: FilePath -> Relationships -> Text -> RefId -> Parser WorksheetFile -worksheetFile parentPath wbRels name rId = - WorksheetFile name <$> lookupRelPath parentPath wbRels rId +worksheetFile :: FilePath -> Relationships -> Text -> SheetState -> RefId -> Parser WorksheetFile +worksheetFile parentPath wbRels name visibility rId = + WorksheetFile name visibility <$> lookupRelPath parentPath wbRels rId getRels :: Zip.Archive -> FilePath -> Parser Relationships getRels ar fp = do diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs index 2a7a4a0..c239fee 100644 --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -14,6 +14,7 @@ module Codec.Xlsx.Types ( , ColumnsProperties(..) , PageSetup(..) , Worksheet(..) + , SheetState(..) , CellMap , CellValue(..) , CellFormula(..) @@ -45,6 +46,7 @@ module Codec.Xlsx.Types ( , wsTables , wsProtection , wsSharedFormulas + , wsState -- ** Cells , Cell.cellValue , Cell.cellStyle @@ -227,6 +229,43 @@ instance FromXenoNode ColumnsProperties where cpBestFit <- fromAttrDef "bestFit" False return ColumnsProperties {..} +-- | Sheet visibility state +-- cf. Ecma Office Open XML Part 1: +-- 18.18.68 ST_SheetState (Sheet Visibility Types) +-- * "visible" +-- Indicates the sheet is visible (default) +-- * "hidden" +-- Indicates the workbook window is hidden, but can be shown by the user via the user interface. +-- * "veryHidden" +-- Indicates the sheet is hidden and cannot be shown in the user interface (UI). This state is only available programmatically. +data SheetState = + Visible -- ^ state="visible" + | Hidden -- ^ state="hidden" + | VeryHidden -- ^ state="veryHidden" + deriving (Eq, Show, Generic) + +instance NFData SheetState + +instance Default SheetState where + def = Visible + +instance FromAttrVal SheetState where + fromAttrVal "visible" = readSuccess Visible + fromAttrVal "hidden" = readSuccess Hidden + fromAttrVal "veryHidden" = readSuccess VeryHidden + fromAttrVal t = invalidText "SheetState" t + +instance FromAttrBs SheetState where + fromAttrBs "visible" = return Visible + fromAttrBs "hidden" = return Hidden + fromAttrBs "veryHidden" = return VeryHidden + fromAttrBs t = unexpectedAttrBs "SheetState" t + +instance ToAttrVal SheetState where + toAttrVal Visible = "visible" + toAttrVal Hidden = "hidden" + toAttrVal VeryHidden = "veryHidden" + -- | Xlsx worksheet data Worksheet = Worksheet { _wsColumnsProperties :: [ColumnsProperties] -- ^ column widths @@ -243,6 +282,7 @@ data Worksheet = Worksheet , _wsTables :: [Table] , _wsProtection :: Maybe SheetProtection , _wsSharedFormulas :: Map SharedFormulaIndex SharedFormulaOptions + , _wsState :: SheetState } deriving (Eq, Show, Generic) instance NFData Worksheet @@ -265,6 +305,7 @@ instance Default Worksheet where , _wsTables = [] , _wsProtection = Nothing , _wsSharedFormulas = M.empty + , _wsState = def } -- | Raw worksheet styles, for structured implementation see 'StyleSheet' @@ -375,4 +416,4 @@ instance ToElement ColumnsProperties where , "hidden" .=? justTrue cpHidden , "collapsed" .=? justTrue cpCollapsed , "bestFit" .=? justTrue cpBestFit - ] + ] \ No newline at end of file diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs index a35762b..1375184 100644 --- a/src/Codec/Xlsx/Writer.hs +++ b/src/Codec/Xlsx/Writer.hs @@ -89,7 +89,7 @@ fromXlsx pt xlsx = (customPropsXml (CustomProperties customProps)) ], [ ("custom-properties", "docProps/custom.xml") ]) workbookFiles = bookFiles xlsx - sheetNames = xlsx ^. xlSheets . to (map fst) + sheetNames = xlsx ^. xlSheets & mapped %~ fst singleSheetFiles :: Int -> Cells @@ -489,7 +489,7 @@ bookFiles :: Xlsx -> [FileData] bookFiles xlsx = runST $ do ref <- newSTRef 1 ssRId <- nextRefId ref - let sheets = xlsx ^. xlSheets . to (map snd) + let sheets = xlsx ^. xlSheets & mapped %~ snd shared = sstConstruct sheets sharedStrings = (ssRId, FileData "xl/sharedStrings.xml" (smlCT "sharedStrings") "sharedStrings" $ @@ -514,7 +514,10 @@ bookFiles xlsx = runST $ do (sheetFile, others) <- singleSheetFiles i cells pvTables sheet tblIdRef return ((rId, sheetFile), others) let sheetFiles = map fst allSheetFiles - sheetNameByRId = zip (map fst sheetFiles) (xlsx ^. xlSheets . to (map fst)) + sheetAttrsByRId = + zipWith (\(rId, _) (name, sheet) -> (rId, name, sheet ^. wsState)) + sheetFiles + (xlsx ^. xlSheets) sheetOthers = concatMap snd allSheetFiles cacheRefFDsById <- forM cacheIdFiles $ \(cacheId, fd) -> do refId <- nextRefId ref @@ -522,7 +525,7 @@ bookFiles xlsx = runST $ do let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ] cacheRefs = map snd cacheRefFDsById bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $ - bookXml sheetNameByRId (xlsx ^. xlDefinedNames) cacheRefsById (xlsx ^. xlDateBase) + bookXml sheetAttrsByRId (xlsx ^. xlDefinedNames) cacheRefsById (xlsx ^. xlDateBase) rels = FileData "xl/_rels/workbook.xml.rels" "application/vnd.openxmlformats-package.relationships+xml" "relationships" relsXml @@ -533,12 +536,12 @@ bookFiles xlsx = runST $ do otherFiles = concat [rels:(map snd referenced), pivotOtherFiles, sheetOthers] return $ bookFile:otherFiles -bookXml :: [(RefId, Text)] +bookXml :: [(RefId, Text, SheetState)] -> DefinedNames -> [(CacheId, RefId)] -> DateBase -> L.ByteString -bookXml rIdNames (DefinedNames names) cacheIdRefs dateBase = +bookXml rIdAttrs (DefinedNames names) cacheIdRefs dateBase = renderLBS def {rsNamespaces = nss} $ Document (Prologue [] Nothing []) root [] where nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] @@ -557,8 +560,8 @@ bookXml rIdNames (DefinedNames names) cacheIdRefs dateBase = "sheets" [ leafElement "sheet" - ["name" .= name, "sheetId" .= i, (odr "id") .= rId] - | (i, (rId, name)) <- zip [(1 :: Int) ..] rIdNames + ["name" .= name, "sheetId" .= i, "state" .= state, (odr "id") .= rId] + | (i, (rId, name, state)) <- zip [(1 :: Int) ..] rIdAttrs ] , elementListSimple "definedNames" diff --git a/test/Common.hs b/test/Common.hs index 586aa76..58b804b 100644 --- a/test/Common.hs +++ b/test/Common.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Common ( parseBS , cursorFromElement @@ -7,10 +11,15 @@ import Text.XML import Text.XML.Cursor import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types (SheetState (..)) import Codec.Xlsx.Writer.Internal +import Test.SmallCheck.Series (Serial) + parseBS :: FromCursor a => ByteString -> [a] parseBS = fromCursor . fromDocument . parseLBS_ def cursorFromElement :: Element -> Cursor cursorFromElement = fromNode . NodeElement . addNS mainNamespace Nothing + +instance Monad m => Serial m SheetState diff --git a/test/Main.hs b/test/Main.hs index 99548cc..41ebc22 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} module Main ( main ) where @@ -10,30 +10,22 @@ import Lens.Micro #else import Control.Lens #endif -import Control.Monad.State.Lazy import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LB -import Data.Map (Map) -import Data.Maybe (listToMaybe) import qualified Data.Map as M -import Data.Time.Clock.POSIX (POSIXTime) -import qualified Data.Vector as V +import Data.Maybe (listToMaybe) +import Data.Text (Text) import qualified StreamTests -import Text.RawString.QQ import Text.XML import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.HUnit (testCase) +import Test.Tasty.HUnit (testCase, (@=?)) +import Test.Tasty.SmallCheck (testProperty) -import Test.Tasty.HUnit ((@=?)) import TestXlsx import Codec.Xlsx import Codec.Xlsx.Formatted -import Codec.Xlsx.Types.Internal -import Codec.Xlsx.Types.Internal.CommentTable -import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties -import Codec.Xlsx.Types.Internal.SharedStringTable import AutoFilterTests import Common @@ -89,6 +81,28 @@ main = defaultMain $ $ floatsParsingTests toXlsx , testCase "toXlsxFast: correct floats parsing (typed and untyped cells are floats by default)" $ floatsParsingTests toXlsxFast + , testGroup "Codec: sheet state visibility" + [ testGroup "toXlsxEitherFast" + [ testProperty "pure state == toXlsxEitherFast (fromXlsx (defXlsxWithState state))" $ + \state -> + (Right (Just state) ==) $ + fmap sheetStateOfDefXlsx $ + toXlsxEitherFast . fromXlsx testTime $ + defXlsxWithState state + , testCase "should otherwise infer visible state by default" $ + Right (Just Visible) @=? (fmap sheetStateOfDefXlsx . toXlsxEitherFast) (fromXlsx testTime defXlsx) + ] + , testGroup "toXlsxEither" + [ testProperty "pure state == toXlsxEither (fromXlsx (defXlsxWithState state))" $ + \state -> + (Right (Just state) ==) $ + fmap sheetStateOfDefXlsx $ + toXlsxEither . fromXlsx testTime $ + defXlsxWithState state + , testCase "should otherwise infer visible state by default" $ + Right (Just Visible) @=? (fmap sheetStateOfDefXlsx . toXlsxEither) (fromXlsx testTime defXlsx) + ] + ] , CommonTests.tests , CondFmtTests.tests , PivotTableTests.tests @@ -101,11 +115,25 @@ floatsParsingTests :: (ByteString -> Xlsx) -> IO () floatsParsingTests parser = do bs <- LB.readFile "data/floats.xlsx" let xlsx = parser bs - parsedCells = maybe mempty ((^. wsCells) . snd) $ listToMaybe $ xlsx ^. xlSheets + parsedCells = maybe mempty (_wsCells . snd) $ listToMaybe $ xlsx ^. xlSheets expectedCells = M.fromList [ ((1,1), def & cellValue ?~ CellDouble 12.0) , ((2,1), def & cellValue ?~ CellDouble 13.0) , ((3,1), def & cellValue ?~ CellDouble 14.0 & cellStyle ?~ 1) , ((4,1), def & cellValue ?~ CellDouble 15.0) ] - expectedCells @==? parsedCells \ No newline at end of file + expectedCells @==? parsedCells + +constSheetName :: Text +constSheetName = "sheet1" + +defXlsx :: Xlsx +defXlsx = def & atSheet constSheetName ?~ def + +defXlsxWithState :: SheetState -> Xlsx +defXlsxWithState state = + def & atSheet constSheetName ?~ (wsState .~ state $ def) + +sheetStateOfDefXlsx :: Xlsx -> Maybe SheetState +sheetStateOfDefXlsx xlsx = + xlsx ^. atSheet constSheetName & mapped %~ _wsState diff --git a/test/StreamTests.hs b/test/StreamTests.hs index 55c4ab5..cac23d8 100644 --- a/test/StreamTests.hs +++ b/test/StreamTests.hs @@ -23,45 +23,32 @@ tests = testGroup import Control.Exception import Codec.Xlsx import Codec.Xlsx.Parser.Stream -import Codec.Xlsx.Types.Common -import Codec.Xlsx.Types.Internal.SharedStringTable import Conduit ((.|)) import qualified Conduit as C -import Control.Exception (bracket) import Control.Lens hiding (indexed) import Data.Set.Lens -import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString as BS import Data.Map (Map) import qualified Data.Map as M -import qualified Data.Map as Map import qualified Data.IntMap.Strict as IM -import Data.Maybe (mapMaybe) import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text as Text -import Data.Vector (Vector, indexed, toList) import Diff -import System.Directory (getTemporaryDirectory) -import System.FilePath.Posix -import Test.Tasty (TestName, TestTree, testGroup) +import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase) import TestXlsx -import Text.RawString.QQ -import Text.XML import qualified Codec.Xlsx.Writer.Stream as SW import qualified Codec.Xlsx.Writer.Internal.Stream as SW import Control.Monad.State.Lazy import Test.Tasty.SmallCheck +import Test.SmallCheck.Series.Instances () import qualified Data.Set as Set import Data.Set (Set) import Text.Printf -import Debug.Trace -import Control.DeepSeq import Data.Conduit -import Codec.Xlsx.Formatted +toBs :: Xlsx -> BS.ByteString toBs = LB.toStrict . fromXlsx testTime tests :: TestTree @@ -138,9 +125,9 @@ sharedStringInputTextsIsSameAsValueSetLength someTexts = -- can we do xx simpleWorkbook :: Xlsx -simpleWorkbook = set xlSheets sheets def +simpleWorkbook = def & atSheet "Sheet1" ?~ sheet where - sheets = [("Sheet1" , toWs [((1,1), a1), ((1,2), cellValue ?~ CellText "text at B1 Sheet1" $ def)])] + sheet = toWs [((1,1), a1), ((1,2), cellValue ?~ CellText "text at B1 Sheet1" $ def)] a1 :: Cell a1 = cellValue ?~ CellText "text at A1 Sheet1" $ cellStyle ?~ 1 $ def @@ -148,9 +135,9 @@ a1 = cellValue ?~ CellText "text at A1 Sheet1" $ cellStyle ?~ 1 $ def -- can we do x -- x simpleWorkbookRow :: Xlsx -simpleWorkbookRow = set xlSheets sheets def +simpleWorkbookRow = def & atSheet "Sheet1" ?~ sheet where - sheets = [("Sheet1" , toWs [((1,1), a1), ((2,1), cellValue ?~ CellText "text at A2 Sheet1" $ def)])] + sheet = toWs [((1,1), a1), ((2,1), cellValue ?~ CellText "text at A2 Sheet1" $ def)] tshow :: Show a => a -> Text @@ -164,25 +151,25 @@ toWs x = set wsCells (M.fromList x) def -- . -- . smallWorkbook :: Xlsx -smallWorkbook = set xlSheets sheets def +smallWorkbook = def & atSheet "Sheet1" ?~ sheet where - sheets = [("Sheet1" , toWs $ [1..2] >>= \row -> + 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) ] - )] + bigWorkbook :: Xlsx -bigWorkbook = set xlSheets sheets def +bigWorkbook = def & atSheet "Sheet1" ?~ sheet where - sheets = [("Sheet1" , toWs $ [1..512] >>= \row -> + 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") ] - )] + inlineStringsAreParsed :: IO () inlineStringsAreParsed = do @@ -214,10 +201,7 @@ 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" $ collectItems $ makeIndex 1 - let defCell v = def - { _cellValue = Just v - } - expected = + 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`, diff --git a/test/TestXlsx.hs b/test/TestXlsx.hs index a7cfc38..86aaa04 100644 --- a/test/TestXlsx.hs +++ b/test/TestXlsx.hs @@ -7,26 +7,19 @@ module TestXlsx where #ifdef USE_MICROLENS -import Lens.Micro.Platform +import Lens.Micro.Platform #else import Control.Lens #endif import Control.Monad.State.Lazy import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LB import Data.Map (Map) import qualified Data.Map as M -import Data.Text (Text) 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 @@ -35,11 +28,6 @@ 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 @@ -52,10 +40,12 @@ testXlsx = Xlsx sheets minimalStyles definedNames customProperties DateBase1904 , ("with pivot table", pvSheet) , ("cellrange DV source", foreignDvSourceSheet) -- "foreign" sheet holding validation data , ("cellrange DV test", foreignDvTestSheet) -- applies validation using foreign cell ranges + , ("hidden sheet", def & wsState .~ Hidden & cellValueAt (1,1) ?~ CellText "I'm hidden!") + , ("VERY hidden sheet", def & wsState .~ VeryHidden & cellValueAt (1,1) ?~ CellText "I'm VERY hidden!!") ] sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges sheetViews pageSetup cFormatting validations [] (Just autoFilter) - tables (Just protection) sharedFormulas + tables (Just protection) sharedFormulas def sharedFormulas = M.fromList [ (SharedFormulaIndex 0, SharedFormulaOptions (CellRef "A5:C5") (Formula "A4")) @@ -461,17 +451,15 @@ 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) - ] + cellMap1 = M.fromList [((1, 1), Cell { _cellStyle = Nothing + , _cellValue = Just (CellText "text at A1 Sheet1") + , _cellComment = Nothing + , _cellFormula = Nothing })] + cellMap2 = M.fromList [((2, 3), Cell { _cellStyle = Just 1 + , _cellValue = Just (CellDouble 1.23456) + , _cellComment = Nothing + , _cellFormula = Nothing })] + sheets = [ ("Sheet1", def & wsCells .~ cellMap1) , ("Sheet2", def & wsCells .~ cellMap2) ] style = minimalStyleSheet & styleSheetNumFmts .~ M.fromList [(164, "DD.MM.YYYY")] & styleSheetCellXfs .~ [cellXf1, cellXf2] cellXf1 = def