Merge pull request #158 from flhorizon/sheetstate-1001master

feat: add support for ST_SheetState (visibility)

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

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

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
-          ]
+          ]

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,15 +514,18 @@ 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
       return (cacheId, (refId, fd))
   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"

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

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
+  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