diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,12 @@ +1.2.0 +------------ +* expose sheet state in stream parser + (thanks to Benjamin McRae ) +* drop unnecessary `n` namespace from stream writer + (thanks to Michael Schneider ) +* add support support for writing multiple sheets with stream writer + (thanks to Michael Schneider ) + 1.1.4 ------------ * fix the problem with leading slashes for comments, drawings and pivot tables diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -1,5 +1,4 @@ -- | Higher level interface for creating styled worksheets -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -35,14 +34,7 @@ , condfmtStopIfTrue ) where -#ifdef USE_MICROLENS -import Lens.Micro -import Lens.Micro.Mtl -import Lens.Micro.TH -import Lens.Micro.GHC () -#else -import Control.Lens -#endif +import Codec.Xlsx.LensCompat import Control.Monad (forM, guard) import Control.Monad.State hiding (forM_, mapM) import Data.Default diff --git a/src/Codec/Xlsx/Lens.hs b/src/Codec/Xlsx/Lens.hs --- a/src/Codec/Xlsx/Lens.hs +++ b/src/Codec/Xlsx/Lens.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} @@ -19,13 +18,7 @@ ) where import Codec.Xlsx.Types -#ifdef USE_MICROLENS -import Lens.Micro -import Lens.Micro.Internal -import Lens.Micro.GHC () -#else -import Control.Lens -#endif +import Codec.Xlsx.LensCompat import Data.Function (on) import Data.List (deleteBy) import Data.Text diff --git a/src/Codec/Xlsx/LensCompat.hs b/src/Codec/Xlsx/LensCompat.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/LensCompat.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +module Codec.Xlsx.LensCompat + ( module L + , Prism + , Prism' + , prism + , (<>=) + ) where + +#ifdef USE_MICROLENS + +import Lens.Micro as L +import Lens.Micro.GHC () +import Lens.Micro.Mtl as L +import Lens.Micro.Platform as L +import Data.Profunctor.Choice +import Data.Profunctor (dimap) +import Data.Traversable.WithIndex as L +import Lens.Micro.Internal as L +import Control.Monad.State.Class (MonadState, modify) + +-- Since micro-lens denies the existence of prisms, +-- I copied over the definitions from Control.Lens for the prism +-- function. +type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) +type Prism' s a = Prism s s a a + +prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b +prism bt seta = dimap seta (either pure (fmap bt)) . right' + +(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () +l <>= a = modify (l <>~ a) + +#else + +import Control.Lens as L + +#endif diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} @@ -23,12 +22,8 @@ import Control.Error.Safe (headErr) import Control.Error.Util (note) import Control.Exception (Exception) -#ifdef USE_MICROLENS -import Lens.Micro -#else -import Control.Lens hiding ((<.>), element, views) -#endif -import Control.Monad (join, void) +import Codec.Xlsx.LensCompat hiding ((<.>), element, views) +import Control.Monad (join, void, liftM4) import Control.Monad.Except (catchError, throwError) import Data.Bool (bool) import Data.ByteString (ByteString) @@ -117,6 +112,7 @@ return $ Xlsx sheets (getStyles ar) names customPropMap dateBase data WorksheetFile = WorksheetFile { wfName :: Text + , wfSheetId :: Int , wfState :: SheetState , wfPath :: FilePath } @@ -362,7 +358,7 @@ -- The specification says the file should contain either 0 or 1 @sheetViews@ -- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910) - let sheetViewList = cur $/ element (n_ "sheetViews") &/ element (n_ "sheetView") >=> fromCursor + let sheetViewList = cur $/ element (addSmlNamespace "sheetViews") &/ element (addSmlNamespace "sheetView") >=> fromCursor sheetViews = case sheetViewList of [] -> Nothing views -> Just views @@ -370,18 +366,18 @@ let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" commentTarget :: Maybe FilePath commentTarget = logicalNameToZipItemName . relTarget <$> findRelByType commentsType sheetRels - legacyDrRId = cur $/ element (n_ "legacyDrawing") >=> fromAttribute (odr"id") + legacyDrRId = cur $/ element (addSmlNamespace "legacyDrawing") >=> fromAttribute (odr"id") legacyDrPath = fmap (logicalNameToZipItemName . relTarget) . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget -- Likewise, @pageSetup@ also occurs either 0 or 1 times - let pageSetup = listToMaybe $ cur $/ element (n_ "pageSetup") >=> fromCursor + let pageSetup = listToMaybe $ cur $/ element (addSmlNamespace "pageSetup") >=> fromCursor - cws = cur $/ element (n_ "cols") &/ element (n_ "col") >=> fromCursor + cws = cur $/ element (addSmlNamespace "cols") &/ element (addSmlNamespace "col") >=> fromCursor (rowProps, cells0, sharedFormulas) = - collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow + collect $ cur $/ element (addSmlNamespace "sheetData") &/ element (addSmlNamespace "row") >=> parseRow parseRow :: Cursor -> [( RowIndex @@ -402,7 +398,7 @@ } return ( r , if prop == def then Nothing else Just prop - , c $/ element (n_ "c") >=> parseCell + , c $/ element (addSmlNamespace "c") >=> parseCell ) parseCell :: Cursor @@ -419,7 +415,7 @@ -- t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" d = listToMaybe $ extractCellValue sst t cell - mFormulaData = listToMaybe $ cell $/ element (n_ "f") >=> formulaDataFromCursor + mFormulaData = listToMaybe $ cell $/ element (addSmlNamespace "f") >=> formulaDataFromCursor f = fst <$> mFormulaData shared = snd =<< mFormulaData (r, c) = fromSingleCellRefNoting ref @@ -449,24 +445,24 @@ ] cells = cells0 `M.union` commentCells - mProtection = listToMaybe $ cur $/ element (n_ "sheetProtection") >=> fromCursor + mProtection = listToMaybe $ cur $/ element (addSmlNamespace "sheetProtection") >=> fromCursor - mDrawingId = listToMaybe $ cur $/ element (n_ "drawing") >=> fromAttribute (odr"id") + mDrawingId = listToMaybe $ cur $/ element (addSmlNamespace "drawing") >=> fromAttribute (odr"id") merges = cur $/ parseMerges parseMerges :: Cursor -> [Range] - parseMerges = element (n_ "mergeCells") &/ element (n_ "mergeCell") >=> fromAttribute "ref" + parseMerges = element (addSmlNamespace "mergeCells") &/ element (addSmlNamespace "mergeCell") >=> fromAttribute "ref" - condFormtattings = M.fromList . map unCfPair $ cur $/ element (n_ "conditionalFormatting") >=> fromCursor + condFormtattings = M.fromList . map unCfPair $ cur $/ element (addSmlNamespace "conditionalFormatting") >=> fromCursor validations = M.fromList . map unDvPair $ - cur $/ element (n_ "dataValidations") &/ element (n_ "dataValidation") >=> fromCursor + cur $/ element (addSmlNamespace "dataValidations") &/ element (addSmlNamespace "dataValidation") >=> fromCursor tableIds = - cur $/ element (n_ "tableParts") &/ element (n_ "tablePart") >=> + cur $/ element (addSmlNamespace "tableParts") &/ element (addSmlNamespace "tablePart") >=> fromAttribute (odr "id") - let mAutoFilter = listToMaybe $ cur $/ element (n_ "autoFilter") >=> fromCursor + let mAutoFilter = listToMaybe $ cur $/ element (addSmlNamespace "autoFilter") >=> fromCursor mDrawing <- case mDrawingId of Just dId -> do @@ -512,7 +508,7 @@ Just xlTxt -> return $ xlsxTextToCellValue xlTxt Nothing -> fail "bad shared string index" | t == "inlineStr" = - cur $/ element (n_ "is") >=> fmap xlsxTextToCellValue . fromCursor + cur $/ element (addSmlNamespace "is") >=> fmap xlsxTextToCellValue . fromCursor | t == "str" = CellText <$> vConverted "string" | t == "n" = CellDouble <$> vConverted "double" | t == "b" = CellBool <$> vConverted "boolean" @@ -520,7 +516,7 @@ | otherwise = fail "bad cell value" where vConverted typeStr = do - vContent <- cur $/ element (n_ "v") >=> \c -> + vContent <- cur $/ element (addSmlNamespace "v") >=> \c -> return (T.concat $ c $/ content) case fromAttrVal vContent of Right (val, _) -> return $ val @@ -651,15 +647,15 @@ , listToMaybe $ attribute "localSheetId" c , T.concat $ c $/ content) names = - cur $/ element (n_ "definedNames") &/ element (n_ "definedName") >=> + cur $/ element (addSmlNamespace "definedNames") &/ element (addSmlNamespace "definedName") >=> mkDefinedName sheets <- sequence $ - cur $/ element (n_ "sheets") &/ element (n_ "sheet") >=> - liftA3 (worksheetFile wbPath wbRels) <$> attribute "name" <*> fromAttributeDef "state" def <*> + cur $/ element (addSmlNamespace "sheets") &/ element (addSmlNamespace "sheet") >=> + liftM4 (worksheetFile wbPath wbRels) <$> attribute "name" <*> fromAttribute "sheetId" <*> fromAttributeDef "state" def <*> fromAttribute (odr "id") let cacheRefs = - cur $/ element (n_ "pivotCaches") &/ element (n_ "pivotCache") >=> + cur $/ element (addSmlNamespace "pivotCaches") &/ element (addSmlNamespace "pivotCache") >=> liftA2 (,) <$> fromAttribute "cacheId" <*> fromAttribute (odr "id") caches <- forM cacheRefs $ \(cacheId, rId) -> do @@ -674,14 +670,14 @@ cacheRels <- getRels ar path recsPath <- lookupRelPath path cacheRels recId rCur <- xmlCursorRequired ar recsPath - let recs = rCur $/ element (n_ "r") >=> \cur' -> + let recs = rCur $/ element (addSmlNamespace "r") >=> \cur' -> return $ cur' $/ anyElement >=> recordValueFromNode . node return $ fillCacheFieldsFromRecords fields0 recs Nothing -> return fields0 return $ (cacheId, (sheet, ref, fields)) let dateBase = bool DateBase1900 DateBase1904 . fromMaybe False . listToMaybe $ - cur $/ element (n_ "workbookPr") >=> fromAttribute "date1904" + cur $/ element (addSmlNamespace "workbookPr") >=> fromAttribute "date1904" return (sheets, DefinedNames names, caches, dateBase) getTable :: Zip.Archive -> FilePath -> Parser Table @@ -689,9 +685,9 @@ cur <- xmlCursorRequired ar fp headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) -worksheetFile :: FilePath -> Relationships -> Text -> SheetState -> RefId -> Parser WorksheetFile -worksheetFile parentPath wbRels name visibility rId = - WorksheetFile name visibility <$> lookupRelPath parentPath wbRels rId +worksheetFile :: FilePath -> Relationships -> Text -> Int -> SheetState -> RefId -> Parser WorksheetFile +worksheetFile parentPath wbRels name sheetId visibility rId = + WorksheetFile name sheetId visibility <$> lookupRelPath parentPath wbRels rId getRels :: Zip.Archive -> FilePath -> Parser Relationships getRels ar fp = do diff --git a/src/Codec/Xlsx/Parser/Internal.hs b/src/Codec/Xlsx/Parser/Internal.hs --- a/src/Codec/Xlsx/Parser/Internal.hs +++ b/src/Codec/Xlsx/Parser/Internal.hs @@ -7,6 +7,7 @@ module Codec.Xlsx.Parser.Internal ( ParseException(..) , n_ + , addSmlNamespace , nodeElNameIs , FromCursor(..) , FromAttrVal(..) @@ -38,6 +39,7 @@ import Text.XML import Text.XML.Cursor +import Codec.Xlsx.Writer.Internal import Codec.Xlsx.Parser.Internal.Fast import Codec.Xlsx.Parser.Internal.Util @@ -146,10 +148,15 @@ Right (r, leftover) | T.null leftover -> [r] _ -> [] --- | Add sml namespace to name + +{-# DEPRECATED n_ "Renamed to addSmlNamespace" #-} n_ :: Text -> Name -n_ x = Name +n_ = addSmlNamespace + +-- | Add sml namespace to name +addSmlNamespace :: Text -> Name +addSmlNamespace x = Name { nameLocalName = x - , nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main" - , namePrefix = Just "n" + , nameNamespace = Just mainNamespace + , namePrefix = Nothing } diff --git a/src/Codec/Xlsx/Parser/Internal/PivotTable.hs b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs --- a/src/Codec/Xlsx/Parser/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Parser/Internal/PivotTable.hs @@ -37,19 +37,19 @@ Just (_pvtSrcSheet, _pvtSrcRef, cacheFields) -> do _pvtDataCaption <- attribute "dataCaption" cur _pvtName <- attribute "name" cur - _pvtLocation <- cur $/ element (n_ "location") >=> fromAttribute "ref" + _pvtLocation <- cur $/ element (addSmlNamespace "location") >=> fromAttribute "ref" _pvtRowGrandTotals <- fromAttributeDef "rowGrandTotals" True cur _pvtColumnGrandTotals <- fromAttributeDef "colGrandTotals" True cur _pvtOutline <- fromAttributeDef "outline" False cur _pvtOutlineData <- fromAttributeDef "outlineData" False cur let pvtFieldsWithHidden = - cur $/ element (n_ "pivotFields") &/ element (n_ "pivotField") >=> \c -> do + cur $/ element (addSmlNamespace "pivotFields") &/ element (addSmlNamespace "pivotField") >=> \c -> do -- actually gets overwritten from cache to have consistent field names _pfiName <- maybeAttribute "name" c _pfiSortType <- fromAttributeDef "sortType" FieldSortManual c _pfiOutline <- fromAttributeDef "outline" True c let hidden = - c $/ element (n_ "items") &/ element (n_ "item") >=> + c $/ element (addSmlNamespace "items") &/ element (addSmlNamespace "item") >=> attrValIs "h" True >=> fromAttribute "x" _pfiHiddenItems = [] return (PivotFieldInfo {..}, hidden) @@ -64,13 +64,13 @@ nToFieldName = zip [0 ..] $ map cfName cacheFields fieldNameList fld = maybeToList $ lookup fld nToFieldName _pvtRowFields = - cur $/ element (n_ "rowFields") &/ element (n_ "field") >=> + cur $/ element (addSmlNamespace "rowFields") &/ element (addSmlNamespace "field") >=> fromAttribute "x" >=> fieldPosition _pvtColumnFields = - cur $/ element (n_ "colFields") &/ element (n_ "field") >=> + cur $/ element (addSmlNamespace "colFields") &/ element (addSmlNamespace "field") >=> fromAttribute "x" >=> fieldPosition _pvtDataFields = - cur $/ element (n_ "dataFields") &/ element (n_ "dataField") >=> \c -> do + cur $/ element (addSmlNamespace "dataFields") &/ element (addSmlNamespace "dataField") >=> \c -> do fld <- fromAttribute "fld" c _dfField <- fieldNameList fld -- TOFIX @@ -89,10 +89,10 @@ parse cur = do refId <- maybeAttribute (odr "id") cur (sheet, ref) <- - cur $/ element (n_ "cacheSource") &/ element (n_ "worksheetSource") >=> + cur $/ element (addSmlNamespace "cacheSource") &/ element (addSmlNamespace "worksheetSource") >=> liftA2 (,) <$> attribute "sheet" <*> fromAttribute "ref" let fields = - cur $/ element (n_ "cacheFields") &/ element (n_ "cacheField") >=> + cur $/ element (addSmlNamespace "cacheFields") &/ element (addSmlNamespace "cacheField") >=> fromCursor return (sheet, ref, fields, refId) diff --git a/src/Codec/Xlsx/Parser/Stream.hs b/src/Codec/Xlsx/Parser/Stream.hs --- a/src/Codec/Xlsx/Parser/Stream.hs +++ b/src/Codec/Xlsx/Parser/Stream.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} @@ -15,6 +14,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PatternSynonyms #-} -- | -- Module : Codex.Xlsx.Parser.Stream @@ -45,12 +45,19 @@ , getWorkbookInfo , CellRow , readSheet + , readSheetIdentifier , countRowsInSheet + , countRowsInSheetIdentifier , collectItems + , collectItemsIdentifier -- ** Index , SheetIndex , makeIndex , makeIndexFromName + -- ** Identifier + , SheetIdentifier + , getSheetIdentifier + , makeIdentifierFromName -- ** SheetItem , SheetItem(..) , si_sheet_index @@ -76,15 +83,8 @@ import Conduit (PrimMonad, (.|)) import qualified Conduit as C import qualified Data.Vector as V -#ifdef USE_MICROLENS -import Lens.Micro -import Lens.Micro.GHC () -import Lens.Micro.Mtl -import Lens.Micro.Platform -import Lens.Micro.TH -#else -import Control.Lens -#endif +import Codec.Xlsx.LensCompat + import Codec.Xlsx.Parser.Internal import Control.Monad import Control.Monad.Catch @@ -98,7 +98,6 @@ import qualified Data.DList as DL import Data.Foldable import Data.IORef -import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as M import Data.Text (Text) @@ -109,7 +108,6 @@ import Data.Traversable (for) import Data.XML.Types import GHC.Generics -import Control.DeepSeq import Codec.Xlsx.Parser.Internal.Memoize import qualified Codec.Xlsx.Parser.Stream.HexpatInternal as HexpatInternal @@ -117,32 +115,12 @@ import Control.Monad.Trans.Control import Text.XML.Expat.Internal.IO as Hexpat import Text.XML.Expat.SAX as Hexpat - -#ifdef USE_MICROLENS -(<>=) :: (MonadState s m, Monoid a) => ASetter' s a -> a -> m () -l <>= a = modify (l <>~ a) -#else -#endif - -type CellRow = IntMap Cell - --- | Sheet item --- --- The current sheet at a time, every sheet is constructed of these items. -data SheetItem = MkSheetItem - { _si_sheet_index :: Int -- ^ The sheet number - , _si_row :: ~Row - } deriving stock (Generic, Show) - deriving anyclass NFData - -data Row = MkRow - { _ri_row_index :: RowIndex -- ^ Row number - , _ri_cell_row :: ~CellRow -- ^ Row itself - } deriving stock (Generic, Show) - deriving anyclass NFData - -makeLenses 'MkSheetItem -makeLenses 'MkRow +import Codec.Xlsx.Types +import Codec.Xlsx.Parser.Stream.SheetInfo +import Codec.Xlsx.Parser.Stream.Row +import Codec.Xlsx.Parser.Stream.SheetItem +import Codec.Xlsx.Parser.Stream.SheetIdentifier +import Codec.Xlsx.Parser.Stream.SheetIndex type SharedStringsMap = V.Vector Text @@ -161,9 +139,8 @@ deriving stock (Generic, Show) -- | State for parsing sheets -data SheetState = MkSheetState +data ParserState = MkParserState { _ps_row :: ~CellRow -- ^ Current row - , _ps_sheet_index :: Int -- ^ Current sheet ID (AKA 'sheetInfoSheetId') , _ps_cell_row_index :: RowIndex -- ^ Current row number , _ps_cell_col_index :: ColumnIndex -- ^ Current column number , _ps_cell_style :: Maybe Int @@ -177,7 +154,7 @@ -- ^ For hexpat only, which can throw errors right at the end of the sheet -- rather than ending gracefully. } deriving stock (Generic, Show) -makeLenses 'MkSheetState +makeLenses 'MkParserState -- | State for parsing shared strings data SharedStringsState = MkSharedStringsState @@ -188,19 +165,9 @@ } deriving stock (Generic, Show) makeLenses 'MkSharedStringsState -type HasSheetState = MonadState SheetState +type HasParserState = MonadState ParserState type HasSharedStringsState = MonadState SharedStringsState --- | Represents sheets from the workbook.xml file. E.g. --- forM_ evs $ \case StartElement ("sheet" :: ByteString) attrs -> do nm <- lookupBy "name" attrs sheetId <- lookupBy "sheetId" attrs rId <- lookupBy "r:id" attrs + sheetState <- case lookup "state" attrs of + Nothing -> pure Visible -- default to visible if not found + Just ss -> case ss of + "visible" -> pure Visible + "hidden" -> pure Hidden + "veryHidden" -> pure VeryHidden + _ -> throwM $ InvalidSheetState ss sheetNum <- either (throwM . ParseDecimalError sheetId) pure $ eitherDecimal sheetId - modify' (SheetInfo nm (RefId rId) sheetNum :) + sheetIndex <- liftIO $ atomicModifyIORef' sheetIndexRef $ \i -> (succ i, i) + let info = MkSheetInfo nm (RefId rId) sheetNum sheetIndex sheetState + modify' (info :) _ -> pure () pure $ WorkbookInfo sheets @@ -351,31 +327,20 @@ for (M.lookup rid rels) $ \rel -> do Zip.mkEntrySelector $ "xl/" <> relTarget rel -sheetIdToRelId :: Int -> XlsxM (Maybe RefId) -sheetIdToRelId sheetId = do - WorkbookInfo sheets <- getWorkbookInfo - pure $ sheetInfoRelId <$> find ((== sheetId) . sheetInfoSheetId) sheets - -sheetIdToEntrySelector :: Int -> XlsxM (Maybe Zip.EntrySelector) -sheetIdToEntrySelector sheetId = do - sheetIdToRelId sheetId >>= \case - Nothing -> pure Nothing - Just rid -> relIdToEntrySelector rid - -- If the given sheet number exists, returns Just a conduit source of the stream -- of XML events in a particular sheet. Returns Nothing when the sheet doesn't -- exist. {-# SCC getSheetXmlSource #-} getSheetXmlSource :: (PrimMonad m, MonadThrow m, C.MonadResource m) => - Int -> + SheetIdentifier -> XlsxM (Maybe (ConduitT () ByteString m ())) -getSheetXmlSource sheetId = do +getSheetXmlSource (SheetIdentifier refId _sheetId) = do -- TODO: The Zip library may throw exceptions that aren't exposed from this -- module, so downstream library users would need to add the 'zip' package to -- handle them. Consider re-wrapping zip library exceptions, or just -- re-export them? - mSheetSel <- sheetIdToEntrySelector sheetId + mSheetSel <- relIdToEntrySelector refId sheetExists <- maybe (pure False) (liftZip . Zip.doesEntryExist) mSheetSel case mSheetSel of Just sheetSel @@ -416,14 +381,13 @@ readIORef ref runExpatForSheet :: - SheetState -> + ParserState -> ConduitT () ByteString (C.ResourceT IO) () -> - (SheetItem -> IO ()) -> + (Row -> IO ()) -> XlsxM () runExpatForSheet initState byteSource inner = void $ liftIO $ runExpat initState byteSource handler where - sheetName = _ps_sheet_index initState handler evs = forM_ evs $ \ev -> do parseRes <- runExceptT $ matchHexpatEvent ev case parseRes of @@ -431,60 +395,82 @@ Right (Just cellRow) | not (IntMap.null cellRow) -> do rowNum <- use ps_cell_row_index - liftIO $ inner $ MkSheetItem sheetName $ MkRow rowNum cellRow + liftIO $ inner $ MkRow rowNum cellRow _ -> pure () -- | this will collect the sheetitems in a list. -- useful for cases were memory is of no concern but a sheetitem -- type in a list is needed. +{-# DEPRECATED collectItems "prefer to use collectItemsIdentifier, see issue #193" #-} collectItems :: SheetIndex -> XlsxM [SheetItem] -collectItems sheetId = do +collectItems (MkSheetIndex sheetId) = makeIdentifierFromId sheetId >>= \case + Nothing -> pure [] + Just identifier -> fmap (MkSheetItem sheetId) <$> collectItemsIdentifier identifier + +-- | this will collect the rows in a list. +-- useful for cases were memory is of no concern but a row +-- type in a list is needed. +collectItemsIdentifier :: + SheetIdentifier -> + XlsxM [Row] +collectItemsIdentifier sheetIdentifier = do res <- liftIO $ newIORef [] - void $ readSheet sheetId $ \item -> + void $ readSheetIdentifier sheetIdentifier $ \item -> liftIO (modifyIORef' res (item :)) fmap reverse $ liftIO $ readIORef res --- | datatype representing a sheet index, looking it up by name --- can be done with 'makeIndexFromName', which is the preferred approach. --- although 'makeIndex' is available in case it's already known. -newtype SheetIndex = MkSheetIndex Int - deriving newtype NFData - --- | This does *no* checking if the index exists or not. --- you could have index out of bounds issues because of this. -makeIndex :: Int -> SheetIndex -makeIndex = MkSheetIndex - -- | Look up the index of a case insensitive sheet name +{-# DEPRECATED makeIndexFromName "prefer to use makeIdentifierFromName" #-} makeIndexFromName :: Text -> XlsxM (Maybe SheetIndex) makeIndexFromName sheetName = do + fmap (makeIndex . siSheetId) <$> makeIdentifierFromName sheetName + +-- | Look up the identifier of a case insensitive sheet name +makeIdentifierFromName :: Text -> XlsxM (Maybe SheetIdentifier) +makeIdentifierFromName sheetName = do wi <- getWorkbookInfo -- The Excel UI does not allow a user to create two sheets whose -- names differ only in alphabetic case (at least for ascii...) let sheetNameCI = T.toLower sheetName findRes :: Maybe SheetInfo findRes = find ((== sheetNameCI) . T.toLower . sheetInfoName) $ _wiSheets wi - pure $ makeIndex . sheetInfoSheetId <$> findRes + pure $ getSheetIdentifier <$> findRes +-- | Look up the identifier of a sheet id. Not for exporting since it is somewhat +-- nonsensical if you do not have the sheet id. +makeIdentifierFromId :: Int -> XlsxM (Maybe SheetIdentifier) +makeIdentifierFromId sheetId = do + WorkbookInfo sheets <- getWorkbookInfo + pure $ getSheetIdentifier <$> find ((== sheetId) . sheetInfoSheetId) sheets + +{-# DEPRECATED readSheet "prefer to use readSheetIdentifier" #-} readSheet :: SheetIndex -> -- | Function to consume the sheet's rows (SheetItem -> IO ()) -> -- | Returns False if sheet doesn't exist, or True otherwise XlsxM Bool -readSheet (MkSheetIndex sheetId) inner = do - mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <- - getSheetXmlSource sheetId +readSheet (MkSheetIndex sheetId) inner = makeIdentifierFromId sheetId >>= \case + Nothing -> pure False + Just identifier -> readSheetIdentifier identifier (inner . MkSheetItem sheetId) + +readSheetIdentifier :: + SheetIdentifier -> + -- | Function to consume the sheet's rows + (Row -> IO ()) -> + -- | Returns False if sheet doesn't exist, or True otherwise + XlsxM Bool +readSheetIdentifier identifier inner = do + mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <- getSheetXmlSource identifier let case mSrc of Nothing -> pure False Just sourceSheetXml -> do sharedStrs <- getOrParseSharedStringss - let sheetState0 = initialSheetState + let sheetState0 = initialParserState & ps_shared_strings .~ sharedStrs - & ps_sheet_index .~ sheetId runExpatForSheet sheetState0 sourceSheetXml inner pure True @@ -493,10 +479,21 @@ -- if the sheet does not exist. Does not perform a full parse of the -- XML into 'SheetItem's, so it should be more efficient than counting -- via 'readSheetByIndex'. +{-# DEPRECATED countRowsInSheet "prefer to use countRowsInSheetIdentifier" #-} countRowsInSheet :: SheetIndex -> XlsxM (Maybe Int) -countRowsInSheet (MkSheetIndex sheetId) = do +countRowsInSheet (MkSheetIndex sheetId) = + makeIdentifierFromId sheetId >>= \case + Nothing -> pure Nothing + Just identifier -> countRowsInSheetIdentifier identifier + +-- | Returns number of rows in the given sheet or Nothing +-- if the sheet does not exist. Does not perform a full parse of the +-- XML into 'SheetItem's, so it should be more efficient than counting +-- via 'readSheetByIndex'. +countRowsInSheetIdentifier :: SheetIdentifier -> XlsxM (Maybe Int) +countRowsInSheetIdentifier identifier = do mSrc :: Maybe (ConduitT () ByteString (C.ResourceT IO) ()) <- - getSheetXmlSource sheetId + getSheetXmlSource identifier for mSrc $ \sourceSheetXml -> do liftIO $ runExpat @Int @ByteString @ByteString 0 sourceSheetXml $ \evs -> forM_ evs $ \case @@ -504,7 +501,7 @@ _ -> pure () -- | Return row from the state and empty it -popRow :: HasSheetState m => m CellRow +popRow :: HasParserState m => m CellRow popRow = do row <- use ps_row ps_row .= mempty @@ -546,7 +543,7 @@ {-# SCC addCellToRow #-} addCellToRow :: ( MonadError SheetErrors m - , HasSheetState m + , HasParserState m ) => Text -> m () addCellToRow txt = do @@ -591,13 +588,14 @@ data WorkbookError = LookupError { lookup_attrs :: [(ByteString, Text)], lookup_field :: ByteString } | ParseDecimalError Text String + | InvalidSheetState Text deriving Show deriving anyclass Exception {-# SCC matchHexpatEvent #-} matchHexpatEvent :: ( MonadError SheetErrors m, - HasSheetState m + HasParserState m ) => HexpatEvent -> m (Maybe CellRow) @@ -636,7 +634,7 @@ {-# INLINE finaliseCellValue #-} finaliseCellValue :: - ( MonadError SheetErrors m, HasSheetState m ) => m () + ( MonadError SheetErrors m, HasParserState m ) => m () finaliseCellValue = do txt <- gets _ps_text_buf addCellToRow txt @@ -649,7 +647,7 @@ {-# SCC setCoord #-} setCoord :: ( MonadError SheetErrors m - , HasSheetState m + , HasParserState m ) => SheetValues -> m () setCoord list = do @@ -660,7 +658,7 @@ -- | Parse type from values and update state accordingly setType :: ( MonadError SheetErrors m - , HasSheetState m + , HasParserState m ) => SheetValues -> m () setType list = do @@ -672,7 +670,7 @@ findName name = find ((name ==) . fst) {-# INLINE findName #-} -setStyle :: (MonadError SheetErrors m, HasSheetState m) => SheetValues -> m () +setStyle :: (MonadError SheetErrors m, HasParserState m) => SheetValues -> m () setStyle list = do style <- liftEither $ first ParseStyleErrors $ parseStyle list ps_cell_style .= style diff --git a/src/Codec/Xlsx/Parser/Stream/Row.hs b/src/Codec/Xlsx/Parser/Stream/Row.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/Row.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Codec.Xlsx.Parser.Stream.Row where + +import Codec.Xlsx.LensCompat +import Codec.Xlsx.Types.Cell (Cell) +import Codec.Xlsx.Types.Common ( RowIndex) +import Data.IntMap.Strict (IntMap) +import GHC.Generics (Generic) +import Control.DeepSeq (NFData) + +type CellRow = IntMap Cell + +data Row = MkRow + { _ri_row_index :: !RowIndex -- ^ Row number + , _ri_cell_row :: CellRow -- ^ Row itself + } deriving stock (Generic, Show) + deriving anyclass NFData + +makeLenses 'MkRow diff --git a/src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs b/src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Codec.Xlsx.Parser.Stream.SheetIdentifier + ( SheetIdentifier (SheetIdentifier, siRefId, siSheetId) + , unsafeGetSheetIdentifier + ) where + +import Codec.Xlsx.Types.RefId ( RefId ) + +-- | Opaque identifier for a sheet. +data SheetIdentifier = MkSheetIdentifier RefId Int + deriving (Eq, Ord) + +pattern SheetIdentifier :: RefId -> Int -> SheetIdentifier +pattern SheetIdentifier { siRefId, siSheetId } <- MkSheetIdentifier siRefId siSheetId + +{-# COMPLETE SheetIdentifier #-} + +unsafeGetSheetIdentifier :: RefId -> Int -> SheetIdentifier +unsafeGetSheetIdentifier = MkSheetIdentifier diff --git a/src/Codec/Xlsx/Parser/Stream/SheetIndex.hs b/src/Codec/Xlsx/Parser/Stream/SheetIndex.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetIndex.hs @@ -0,0 +1,20 @@ + +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +module Codec.Xlsx.Parser.Stream.SheetIndex (SheetIndex (..), makeIndex) where + +import Control.DeepSeq + +-- | datatype representing a sheet index, looking it up by name +-- can be done with 'makeIndexFromName', which is the preferred approach. +-- although 'makeIndex' is available in case it's already known. +newtype SheetIndex = MkSheetIndex Int + deriving newtype (NFData, Show) + +-- | This does *no* checking if the index exists or not. +-- you could have index out of bounds issues because of this. +makeIndex :: Int -> SheetIndex +makeIndex = MkSheetIndex + +{-# DEPRECATED SheetIndex, MkSheetIndex, makeIndex "SheetIndex will not be supported in future, see issue #193. Use SheetIdentifier instead" #-} diff --git a/src/Codec/Xlsx/Parser/Stream/SheetInfo.hs b/src/Codec/Xlsx/Parser/Stream/SheetInfo.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetInfo.hs @@ -0,0 +1,27 @@ + +module Codec.Xlsx.Parser.Stream.SheetInfo where + +import Data.Text (Text) +import Codec.Xlsx.Types.RefId (RefId) +import Codec.Xlsx.Parser.Stream.SheetIdentifier + (SheetIdentifier, unsafeGetSheetIdentifier) +import Codec.Xlsx.Types (SheetState) + +-- | Represents sheets from the workbook.xml file. E.g. +-- SheetIdentifier +getSheetIdentifier sheetInfo = unsafeGetSheetIdentifier (sheetInfoRelId sheetInfo) (sheetInfoSheetId sheetInfo) diff --git a/src/Codec/Xlsx/Parser/Stream/SheetItem.hs b/src/Codec/Xlsx/Parser/Stream/SheetItem.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Stream/SheetItem.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +module Codec.Xlsx.Parser.Stream.SheetItem where + +import Codec.Xlsx.Parser.Stream.Row (Row) + +import Codec.Xlsx.LensCompat +import Control.DeepSeq (NFData) +import GHC.Generics (Generic) + + +-- | Sheet item +-- +-- The current sheet at a time, every sheet is constructed of these items. +data SheetItem = MkSheetItem + { _si_sheet_index :: !Int -- ^ The sheet number + , _si_row :: Row + } deriving stock (Generic, Show) + deriving anyclass NFData + +{-# WARNING SheetItem, MkSheetItem "SheetItem will not be supported in future, see issue #193. Use Row directly instead" #-} +makeLenses 'MkSheetItem +{-# DEPRECATED si_sheet_index, si_row "SheetItem will not be supported in future, see issue #193" #-} diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -70,12 +69,7 @@ ) where import Control.Exception (SomeException, toException) -#ifdef USE_MICROLENS -import Lens.Micro.TH -import Data.Profunctor(dimap) -import Data.Profunctor.Choice -#else -#endif +import Codec.Xlsx.LensCompat (lens, Lens', makeLenses, Prism', prism) import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as L import Data.Default @@ -108,12 +102,6 @@ import Codec.Xlsx.Types.Table as X import Codec.Xlsx.Types.Variant as X import Codec.Xlsx.Writer.Internal -#ifdef USE_MICROLENS -import Lens.Micro -#else -import Control.Lens (lens, Lens', makeLenses) -import Control.Lens.TH (makePrisms) -#endif -- | Height of a row in points (1/72in) data RowHeight @@ -124,17 +112,6 @@ deriving (Eq, Ord, Show, Read, Generic) instance NFData RowHeight -#ifdef USE_MICROLENS --- Since micro-lens denies the existence of prisms, --- I pasted the splice that's generated from makePrisms, --- then I copied over the definitions from Control.Lens for the prism --- function as well. -type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) -type Prism' s a = Prism s s a a - -prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b -prism bt seta = dimap seta (either pure (fmap bt)) . right' - _CustomHeight :: Prism' RowHeight Double _CustomHeight = (prism (\ x1_a4xgd -> CustomHeight x1_a4xgd)) @@ -152,11 +129,6 @@ AutomaticHeight y1_a4xgi -> Right y1_a4xgi _ -> Left x_a4xgh) {-# INLINE _AutomaticHeight #-} - -#else -makePrisms ''RowHeight -#endif - -- | Properties of a row. See §18.3.1.73 "row (Row)" for more details data RowProperties = RowProps diff --git a/src/Codec/Xlsx/Types/AutoFilter.hs b/src/Codec/Xlsx/Types/AutoFilter.hs --- a/src/Codec/Xlsx/Types/AutoFilter.hs +++ b/src/Codec/Xlsx/Types/AutoFilter.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -9,11 +8,7 @@ import Control.Arrow (first) import Control.DeepSeq (NFData) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Data.Bool (bool) import Data.ByteString (ByteString) import Data.Default @@ -299,7 +294,7 @@ instance FromCursor AutoFilter where fromCursor cur = do _afRef <- maybeAttribute "ref" cur - let _afFilterColumns = M.fromList $ cur $/ element (n_ "filterColumn") >=> \c -> do + let _afFilterColumns = M.fromList $ cur $/ element (addSmlNamespace "filterColumn") >=> \c -> do colId <- fromAttribute "colId" c fcol <- c $/ anyElement >=> fltColFromNode . node return (colId, fcol) @@ -371,17 +366,17 @@ CustomFilter <$> fromAttrDef "operator" FltrEqual <*> fromAttr "val" fltColFromNode :: Node -> [FilterColumn] -fltColFromNode n | n `nodeElNameIs` (n_ "filters") = do +fltColFromNode n | n `nodeElNameIs` (addSmlNamespace "filters") = do let filterCriteria = cur $/ anyElement >=> fromCursor filterBlank <- fromAttributeDef "blank" DontFilterByBlank cur return $ Filters filterBlank filterCriteria - | n `nodeElNameIs` (n_ "colorFilter") = do + | n `nodeElNameIs` (addSmlNamespace "colorFilter") = do _cfoCellColor <- fromAttributeDef "cellColor" True cur _cfoDxfId <- maybeAttribute "dxfId" cur return $ ColorFilter ColorFilterOptions {..} - | n `nodeElNameIs` (n_ "customFilters") = do + | n `nodeElNameIs` (addSmlNamespace "customFilters") = do isAnd <- fromAttributeDef "and" False cur - let cFilters = cur $/ element (n_ "customFilter") >=> \c -> do + let cFilters = cur $/ element (addSmlNamespace "customFilter") >=> \c -> do op <- fromAttributeDef "operator" FltrEqual c val <- fromAttribute "val" c return $ CustomFilter op val @@ -394,16 +389,16 @@ else return $ CustomFiltersOr f1 f2 _ -> fail "bad custom filter" - | n `nodeElNameIs` (n_ "dynamicFilter") = do + | n `nodeElNameIs` (addSmlNamespace "dynamicFilter") = do _dfoType <- fromAttribute "type" cur _dfoVal <- maybeAttribute "val" cur _dfoMaxVal <- maybeAttribute "maxVal" cur return $ DynamicFilter DynFilterOptions{..} - | n `nodeElNameIs` (n_ "iconFilter") = do + | n `nodeElNameIs` (addSmlNamespace "iconFilter") = do iconId <- maybeAttribute "iconId" cur iconSet <- fromAttribute "iconSet" cur return $ IconFilter iconId iconSet - | n `nodeElNameIs` (n_ "top10") = do + | n `nodeElNameIs` (addSmlNamespace "top10") = do top <- fromAttributeDef "top" True cur let percent = fromAttributeDef "percent" False cur val = fromAttribute "val" cur @@ -462,10 +457,10 @@ -- TODO: follow the spec about the fact that dategroupitem always go after filter filterCriterionFromNode :: Node -> [FilterCriterion] filterCriterionFromNode n - | n `nodeElNameIs` (n_ "filter") = do + | n `nodeElNameIs` (addSmlNamespace "filter") = do v <- fromAttribute "val" cur return $ FilterValue v - | n `nodeElNameIs` (n_ "dateGroupItem") = do + | n `nodeElNameIs` (addSmlNamespace "dateGroupItem") = do g <- fromAttribute "dateTimeGrouping" cur let year = fromAttribute "year" cur month = fromAttribute "month" cur @@ -600,7 +595,7 @@ nm (catMaybes ["ref" .=? _afRef]) [ elementList - (n_ "filterColumn") + (addSmlNamespace "filterColumn") ["colId" .= colId] [fltColToElement fCol] | (colId, fCol) <- M.toList _afFilterColumns @@ -610,50 +605,50 @@ fltColToElement (Filters filterBlank filterCriteria) = let attrs = catMaybes ["blank" .=? justNonDef DontFilterByBlank filterBlank] in elementList - (n_ "filters") attrs $ map filterCriterionToElement filterCriteria -fltColToElement (ColorFilter opts) = toElement (n_ "colorFilter") opts + (addSmlNamespace "filters") attrs $ map filterCriterionToElement filterCriteria +fltColToElement (ColorFilter opts) = toElement (addSmlNamespace "colorFilter") opts fltColToElement (ACustomFilter f) = - elementListSimple (n_ "customFilters") [toElement (n_ "customFilter") f] + elementListSimple (addSmlNamespace "customFilters") [toElement (addSmlNamespace "customFilter") f] fltColToElement (CustomFiltersOr f1 f2) = elementListSimple - (n_ "customFilters") - [toElement (n_ "customFilter") f | f <- [f1, f2]] + (addSmlNamespace "customFilters") + [toElement (addSmlNamespace "customFilter") f | f <- [f1, f2]] fltColToElement (CustomFiltersAnd f1 f2) = elementList - (n_ "customFilters") + (addSmlNamespace "customFilters") ["and" .= True] - [toElement (n_ "customFilter") f | f <- [f1, f2]] -fltColToElement (DynamicFilter opts) = toElement (n_ "dynamicFilter") opts + [toElement (addSmlNamespace "customFilter") f | f <- [f1, f2]] +fltColToElement (DynamicFilter opts) = toElement (addSmlNamespace "dynamicFilter") opts fltColToElement (IconFilter iconId iconSet) = - leafElement (n_ "iconFilter") $ + leafElement (addSmlNamespace "iconFilter") $ ["iconSet" .= iconSet] ++ catMaybes ["iconId" .=? iconId] fltColToElement (BottomNFilter opts) = edgeFilter False opts fltColToElement (TopNFilter opts) = edgeFilter True opts edgeFilter :: Bool -> EdgeFilterOptions -> Element edgeFilter top EdgeFilterOptions {..} = - leafElement (n_ "top10") $ + leafElement (addSmlNamespace "top10") $ ["top" .= top, "percent" .= _efoUsePercents, "val" .= _efoVal] ++ catMaybes ["filterVal" .=? _efoFilterVal] filterCriterionToElement :: FilterCriterion -> Element filterCriterionToElement (FilterValue v) = - leafElement (n_ "filter") ["val" .= v] + leafElement (addSmlNamespace "filter") ["val" .= v] filterCriterionToElement (FilterDateGroup (DateGroupByYear y)) = leafElement - (n_ "dateGroupItem") + (addSmlNamespace "dateGroupItem") ["dateTimeGrouping" .= ("year" :: Text), "year" .= y] filterCriterionToElement (FilterDateGroup (DateGroupByMonth y m)) = leafElement - (n_ "dateGroupItem") + (addSmlNamespace "dateGroupItem") ["dateTimeGrouping" .= ("month" :: Text), "year" .= y, "month" .= m] filterCriterionToElement (FilterDateGroup (DateGroupByDay y m d)) = leafElement - (n_ "dateGroupItem") + (addSmlNamespace "dateGroupItem") ["dateTimeGrouping" .= ("day" :: Text), "year" .= y, "month" .= m, "day" .= d] filterCriterionToElement (FilterDateGroup (DateGroupByHour y m d h)) = leafElement - (n_ "dateGroupItem") + (addSmlNamespace "dateGroupItem") [ "dateTimeGrouping" .= ("hour" :: Text) , "year" .= y , "month" .= m @@ -662,7 +657,7 @@ ] filterCriterionToElement (FilterDateGroup (DateGroupByMinute y m d h mi)) = leafElement - (n_ "dateGroupItem") + (addSmlNamespace "dateGroupItem") [ "dateTimeGrouping" .= ("minute" :: Text) , "year" .= y , "month" .= m @@ -672,7 +667,7 @@ ] filterCriterionToElement (FilterDateGroup (DateGroupBySecond y m d h mi s)) = leafElement - (n_ "dateGroupItem") + (addSmlNamespace "dateGroupItem") [ "dateTimeGrouping" .= ("second" :: Text) , "year" .= y , "month" .= m diff --git a/src/Codec/Xlsx/Types/Cell.hs b/src/Codec/Xlsx/Types/Cell.hs --- a/src/Codec/Xlsx/Types/Cell.hs +++ b/src/Codec/Xlsx/Types/Cell.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -21,11 +20,7 @@ ) where import Control.Arrow (first) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens.TH (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.DeepSeq (NFData) import Data.Default import Data.Map (Map) diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -3,7 +3,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -84,15 +83,7 @@ import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.RichText import Codec.Xlsx.Writer.Internal -#ifdef USE_MICROLENS -import Lens.Micro -import Lens.Micro.Internal -import Lens.Micro.GHC () -import Data.Profunctor.Choice -import Data.Profunctor(dimap) -#else -import Control.Lens(makePrisms) -#endif +import Codec.Xlsx.LensCompat (Prism', prism) newtype RowIndex = RowIndex {unRowIndex :: Int} deriving (Eq, Ord, Show, Read, Generic, Num, Real, Enum, Integral) @@ -548,8 +539,8 @@ instance FromCursor XlsxText where fromCursor cur = do let - ts = cur $/ element (n_ "t") >=> contentOrEmpty - rs = cur $/ element (n_ "r") >=> fromCursor + ts = cur $/ element (addSmlNamespace "t") >=> contentOrEmpty + rs = cur $/ element (addSmlNamespace "r") >=> fromCursor case (ts,rs) of ([t], []) -> return $ XlsxText t @@ -657,18 +648,12 @@ toAttrVal ErrorRef = "#REF!" toAttrVal ErrorValue = "#VALUE!" -#ifdef USE_MICROLENS -- Since micro-lens denies the existence of prisms, -- I pasted the splice that's generated from makePrisms, -- then I copied over the definitions from Control.Lens for the prism -- function as well. -- Essentially this is doing the template haskell by hand. -type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) -type Prism' s a = Prism s s a a -prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b -prism bt seta = dimap seta (either pure (fmap bt)) . right' - _CellText :: Prism' CellValue Text _CellText = (prism (\ x1_a1ZQv -> CellText x1_a1ZQv)) @@ -726,8 +711,3 @@ XlsxRichText y1_a1ZzZ -> Right y1_a1ZzZ _ -> Left x_a1ZzY) {-# INLINE _XlsxRichText #-} - -#else -makePrisms ''XlsxText -makePrisms ''CellValue -#endif diff --git a/src/Codec/Xlsx/Types/ConditionalFormatting.hs b/src/Codec/Xlsx/Types/ConditionalFormatting.hs --- a/src/Codec/Xlsx/Types/ConditionalFormatting.hs +++ b/src/Codec/Xlsx/Types/ConditionalFormatting.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -43,11 +42,7 @@ import Control.Arrow (first, right) import Control.DeepSeq (NFData) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Data.Bool (bool) import Data.ByteString (ByteString) import Data.Default @@ -417,8 +412,8 @@ txt <- fromAttribute "text" cur return $ BeginsWith txt readCondition "colorScale" cur = do - let cfvos = cur $/ element (n_ "colorScale") &/ element (n_ "cfvo") &| node - colors = cur $/ element (n_ "colorScale") &/ element (n_ "color") &| node + let cfvos = cur $/ element (addSmlNamespace "colorScale") &/ element (addSmlNamespace "cfvo") &| node + colors = cur $/ element (addSmlNamespace "colorScale") &/ element (addSmlNamespace "color") &| node case (cfvos, colors) of ([n1, n2], [cn1, cn2]) -> do mincfv <- fromCursor $ fromNode n1 @@ -438,7 +433,7 @@ error "Malformed colorScale condition" readCondition "cellIs" cur = do operator <- fromAttribute "operator" cur - let formulas = cur $/ element (n_ "formula") >=> fromCursor + let formulas = cur $/ element (addSmlNamespace "formula") >=> fromCursor expr <- readOpExpression operator formulas return $ CellIs expr readCondition "containsBlanks" _ = return ContainsBlanks @@ -446,15 +441,15 @@ readCondition "containsText" cur = do txt <- fromAttribute "text" cur return $ ContainsText txt -readCondition "dataBar" cur = fmap DataBar $ cur $/ element (n_ "dataBar") >=> fromCursor +readCondition "dataBar" cur = fmap DataBar $ cur $/ element (addSmlNamespace "dataBar") >=> fromCursor readCondition "duplicateValues" _ = return DuplicateValues readCondition "endsWith" cur = do txt <- fromAttribute "text" cur return $ EndsWith txt readCondition "expression" cur = do - formula <- cur $/ element (n_ "formula") >=> fromCursor + formula <- cur $/ element (addSmlNamespace "formula") >=> fromCursor return $ Expression formula -readCondition "iconSet" cur = fmap IconSet $ cur $/ element (n_ "iconSet") >=> fromCursor +readCondition "iconSet" cur = fmap IconSet $ cur $/ element (addSmlNamespace "iconSet") >=> fromCursor readCondition "notContainsBlanks" _ = return DoesNotContainBlanks readCondition "notContainsErrors" _ = return DoesNotContainErrors readCondition "notContainsText" cur = do @@ -702,7 +697,7 @@ instance FromCursor IconSetOptions where fromCursor cur = do _isoIconSet <- fromAttributeDef "iconSet" defaultIconSet cur - let _isoValues = cur $/ element (n_ "cfvo") >=> fromCursor + let _isoValues = cur $/ element (addSmlNamespace "cfvo") >=> fromCursor _isoReverse <- fromAttributeDef "reverse" False cur _isoShowValue <- fromAttributeDef "showValue" True cur return IconSetOptions {..} @@ -761,12 +756,12 @@ _dboMaxLength <- fromAttributeDef "maxLength" defaultDboMaxLength cur _dboMinLength <- fromAttributeDef "minLength" defaultDboMinLength cur _dboShowValue <- fromAttributeDef "showValue" True cur - let cfvos = cur $/ element (n_ "cfvo") &| node + let cfvos = cur $/ element (addSmlNamespace "cfvo") &| node case cfvos of [nMin, nMax] -> do _dboMinimum <- fromCursor (fromNode nMin) _dboMaximum <- fromCursor (fromNode nMax) - _dboColor <- cur $/ element (n_ "color") >=> fromCursor + _dboColor <- cur $/ element (addSmlNamespace "color") >=> fromCursor return DataBarOptions{..} ns -> do fail $ "expected minimum and maximum cfvo nodes but see instead " ++ diff --git a/src/Codec/Xlsx/Types/DataValidation.hs b/src/Codec/Xlsx/Types/DataValidation.hs --- a/src/Codec/Xlsx/Types/DataValidation.hs +++ b/src/Codec/Xlsx/Types/DataValidation.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -33,11 +32,7 @@ import Control.Applicative ((<|>)) import Control.DeepSeq (NFData) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens.TH (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.Monad ((>=>), guard) import Data.ByteString (ByteString) import Data.Char (isSpace) @@ -106,6 +101,9 @@ , _dvPrompt :: Maybe Text , _dvPromptTitle :: Maybe Text , _dvShowDropDown :: Bool + -- ^ A boolean value indicating whether to display a dropdown combo box for a list type data validation. + -- Note that it has an inverted logic, false shows the dropdown list and true will render the dropdown as + -- plain text instead. , _dvShowErrorMessage :: Bool , _dvShowInputMessage :: Bool , _dvValidationType :: ValidationType @@ -210,7 +208,7 @@ f <- fromCursor cur return $ ValidationTypeCustom f readValidationType _ "list" cur = do - f <- cur $/ element (n_ "formula1") >=> fromCursor + f <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor as <- maybeToList $ readListFormulas f return $ ValidationTypeList as readValidationType op ty cur = do @@ -254,11 +252,11 @@ readOpExpression2 :: Text -> Cursor -> [ValidationExpression] readOpExpression2 op cur | op `elem` ["between", "notBetween"] = do - f1 <- cur $/ element (n_ "formula1") >=> fromCursor - f2 <- cur $/ element (n_ "formula2") >=> fromCursor + f1 <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor + f2 <- cur $/ element (addSmlNamespace "formula2") >=> fromCursor readValExpression op [f1,f2] readOpExpression2 op cur = do - f <- cur $/ element (n_ "formula1") >=> fromCursor + f <- cur $/ element (addSmlNamespace "formula1") >=> fromCursor readValExpression op [f] readValidationTypeOpExp :: Text -> ValidationExpression -> [ValidationType] @@ -335,7 +333,7 @@ ValidationTypeWhole f -> opExp $ viewValidationExpression f ValidationTypeList as -> let renderPlainList l = - let csvFy xs = T.intercalate "," xs + let csvFy = T.intercalate "," reQuote x = '"' `T.cons` x `T.snoc` '"' in reQuote (csvFy l) f = Formula $ diff --git a/src/Codec/Xlsx/Types/Drawing.hs b/src/Codec/Xlsx/Types/Drawing.hs --- a/src/Codec/Xlsx/Types/Drawing.hs +++ b/src/Codec/Xlsx/Types/Drawing.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,11 +12,7 @@ import Control.Arrow (first) import Control.DeepSeq (NFData) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens.TH -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Data.ByteString.Lazy (ByteString) import Data.Default import qualified Data.Map as M diff --git a/src/Codec/Xlsx/Types/Drawing/Chart.hs b/src/Codec/Xlsx/Types/Drawing/Chart.hs --- a/src/Codec/Xlsx/Types/Drawing/Chart.hs +++ b/src/Codec/Xlsx/Types/Drawing/Chart.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -7,11 +6,7 @@ import GHC.Generics (Generic) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens.TH -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes, listToMaybe, maybeToList) diff --git a/src/Codec/Xlsx/Types/Drawing/Common.hs b/src/Codec/Xlsx/Types/Drawing/Common.hs --- a/src/Codec/Xlsx/Types/Drawing/Common.hs +++ b/src/Codec/Xlsx/Types/Drawing/Common.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -8,11 +7,7 @@ import GHC.Generics (Generic) import Control.Arrow (first) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens.TH -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.Monad (join) import Control.Monad.Fail (MonadFail) import Control.DeepSeq (NFData) diff --git a/src/Codec/Xlsx/Types/Internal.hs b/src/Codec/Xlsx/Types/Internal.hs --- a/src/Codec/Xlsx/Types/Internal.hs +++ b/src/Codec/Xlsx/Types/Internal.hs @@ -1,25 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -module Codec.Xlsx.Types.Internal where - -import Control.Arrow -import Data.Monoid ((<>)) -import Data.Text (Text) -import GHC.Generics (Generic) - -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Writer.Internal - -newtype RefId = RefId { unRefId :: Text } deriving (Eq, Ord, Show, Generic) - -instance ToAttrVal RefId where - toAttrVal = toAttrVal . unRefId - -instance FromAttrVal RefId where - fromAttrVal t = first RefId <$> fromAttrVal t - -instance FromAttrBs RefId where - fromAttrBs = fmap RefId . fromAttrBs +module Codec.Xlsx.Types.Internal (module Codec.Xlsx.Types.RefId) where -unsafeRefId :: Int -> RefId -unsafeRefId num = RefId $ "rId" <> txti num +import Codec.Xlsx.Types.RefId diff --git a/src/Codec/Xlsx/Types/Internal/CfPair.hs b/src/Codec/Xlsx/Types/Internal/CfPair.hs --- a/src/Codec/Xlsx/Types/Internal/CfPair.hs +++ b/src/Codec/Xlsx/Types/Internal/CfPair.hs @@ -22,7 +22,7 @@ instance FromCursor CfPair where fromCursor cur = do sqref <- fromAttribute "sqref" cur - let cfRules = cur $/ element (n_ "cfRule") >=> fromCursor + let cfRules = cur $/ element (addSmlNamespace "cfRule") >=> fromCursor return $ CfPair (sqref, cfRules) instance FromXenoNode CfPair where diff --git a/src/Codec/Xlsx/Types/Internal/CommentTable.hs b/src/Codec/Xlsx/Types/Internal/CommentTable.hs --- a/src/Codec/Xlsx/Types/Internal/CommentTable.hs +++ b/src/Codec/Xlsx/Types/Internal/CommentTable.hs @@ -68,15 +68,15 @@ instance FromCursor CommentTable where fromCursor cur = do - let authorNames = cur $/ element (n_ "authors") &/ element (n_ "author") >=> contentOrEmpty + let authorNames = cur $/ element (addSmlNamespace "authors") &/ element (addSmlNamespace "author") >=> contentOrEmpty authors = M.fromList $ zip [0..] authorNames - items = cur $/ element (n_ "commentList") &/ element (n_ "comment") >=> parseComment authors + items = cur $/ element (addSmlNamespace "commentList") &/ element (addSmlNamespace "comment") >=> parseComment authors return . CommentTable $ M.fromList items parseComment :: Map Int Text -> Cursor -> [(CellRef, Comment)] parseComment authors cur = do ref <- fromAttribute "ref" cur - txt <- cur $/ element (n_ "text") >=> fromCursor + txt <- cur $/ element (addSmlNamespace "text") >=> fromCursor authorId <- cur $| attribute "authorId" >=> decimal visible <- (read . Text.unpack :: Text -> Bool) <$> (fromAttribute "visible" cur :: [Text]) diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs --- a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -82,7 +82,7 @@ instance FromCursor SharedStringTable where fromCursor cur = do let - items = cur $/ element (n_ "si") >=> fromCursor + items = cur $/ element (addSmlNamespace "si") >=> fromCursor return (SharedStringTable (V.fromList items)) {------------------------------------------------------------------------------- diff --git a/src/Codec/Xlsx/Types/PageSetup.hs b/src/Codec/Xlsx/Types/PageSetup.hs --- a/src/Codec/Xlsx/Types/PageSetup.hs +++ b/src/Codec/Xlsx/Types/PageSetup.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-} @@ -35,11 +34,7 @@ , pageSetupVerticalDpi ) where -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.DeepSeq (NFData) import Data.Default import qualified Data.Map as Map diff --git a/src/Codec/Xlsx/Types/PivotTable/Internal.hs b/src/Codec/Xlsx/Types/PivotTable/Internal.hs --- a/src/Codec/Xlsx/Types/PivotTable/Internal.hs +++ b/src/Codec/Xlsx/Types/PivotTable/Internal.hs @@ -48,14 +48,14 @@ fromCursor cur = do cfName <- fromAttribute "name" cur let cfItems = - cur $/ element (n_ "sharedItems") &/ anyElement >=> + cur $/ element (addSmlNamespace "sharedItems") &/ anyElement >=> cellValueFromNode . node return CacheField {..} cellValueFromNode :: Node -> [CellValue] cellValueFromNode n - | n `nodeElNameIs` (n_ "s") = CellText <$> attributeV - | n `nodeElNameIs` (n_ "n") = CellDouble <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "s") = CellText <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "n") = CellDouble <$> attributeV | otherwise = fail "no matching shared item" where cur = fromNode n @@ -64,9 +64,9 @@ recordValueFromNode :: Node -> [CacheRecordValue] recordValueFromNode n - | n `nodeElNameIs` (n_ "s") = CacheText <$> attributeV - | n `nodeElNameIs` (n_ "n") = CacheNumber <$> attributeV - | n `nodeElNameIs` (n_ "x") = CacheIndex <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "s") = CacheText <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "n") = CacheNumber <$> attributeV + | n `nodeElNameIs` (addSmlNamespace "x") = CacheIndex <$> attributeV | otherwise = fail "not valid cache record value" where cur = fromNode n diff --git a/src/Codec/Xlsx/Types/Protection.hs b/src/Codec/Xlsx/Types/Protection.hs --- a/src/Codec/Xlsx/Types/Protection.hs +++ b/src/Codec/Xlsx/Types/Protection.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -32,11 +31,7 @@ import GHC.Generics (Generic) import Control.Arrow (first) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.DeepSeq (NFData) import Data.Bits import Data.Char diff --git a/src/Codec/Xlsx/Types/RefId.hs b/src/Codec/Xlsx/Types/RefId.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/RefId.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +module Codec.Xlsx.Types.RefId where + +import Control.Arrow +import Data.Monoid ((<>)) +import Data.Text (Text) +import GHC.Generics (Generic) + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +newtype RefId = RefId { unRefId :: Text } deriving (Eq, Ord, Show, Generic) + +instance ToAttrVal RefId where + toAttrVal = toAttrVal . unRefId + +instance FromAttrVal RefId where + fromAttrVal t = first RefId <$> fromAttrVal t + +instance FromAttrBs RefId where + fromAttrBs = fmap RefId . fromAttrBs + +unsafeRefId :: Int -> RefId +unsafeRefId num = RefId $ "rId" <> txti num diff --git a/src/Codec/Xlsx/Types/RichText.hs b/src/Codec/Xlsx/Types/RichText.hs --- a/src/Codec/Xlsx/Types/RichText.hs +++ b/src/Codec/Xlsx/Types/RichText.hs @@ -32,11 +32,7 @@ import GHC.Generics (Generic) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens hiding (element) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.Monad import Control.DeepSeq (NFData) import Data.Default @@ -263,8 +259,8 @@ -- | See @CT_RElt@, p. 3903 instance FromCursor RichTextRun where fromCursor cur = do - _richTextRunText <- cur $/ element (n_ "t") &/ content - _richTextRunProperties <- maybeFromElement (n_ "rPr") cur + _richTextRunText <- cur $/ element (addSmlNamespace "t") &/ content + _richTextRunProperties <- maybeFromElement (addSmlNamespace "rPr") cur return RichTextRun{..} instance FromXenoNode RichTextRun where @@ -277,21 +273,21 @@ -- | See @CT_RPrElt@, p. 3903 instance FromCursor RunProperties where fromCursor cur = do - _runPropertiesFont <- maybeElementValue (n_ "rFont") cur - _runPropertiesCharset <- maybeElementValue (n_ "charset") cur - _runPropertiesFontFamily <- maybeElementValue (n_ "family") cur - _runPropertiesBold <- maybeBoolElementValue (n_ "b") cur - _runPropertiesItalic <- maybeBoolElementValue (n_ "i") cur - _runPropertiesStrikeThrough <- maybeBoolElementValue (n_ "strike") cur - _runPropertiesOutline <- maybeBoolElementValue (n_ "outline") cur - _runPropertiesShadow <- maybeBoolElementValue (n_ "shadow") cur - _runPropertiesCondense <- maybeBoolElementValue (n_ "condense") cur - _runPropertiesExtend <- maybeBoolElementValue (n_ "extend") cur - _runPropertiesColor <- maybeFromElement (n_ "color") cur - _runPropertiesSize <- maybeElementValue (n_ "sz") cur - _runPropertiesUnderline <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur - _runPropertiesVertAlign <- maybeElementValue (n_ "vertAlign") cur - _runPropertiesScheme <- maybeElementValue (n_ "scheme") cur + _runPropertiesFont <- maybeElementValue (addSmlNamespace "rFont") cur + _runPropertiesCharset <- maybeElementValue (addSmlNamespace "charset") cur + _runPropertiesFontFamily <- maybeElementValue (addSmlNamespace "family") cur + _runPropertiesBold <- maybeBoolElementValue (addSmlNamespace "b") cur + _runPropertiesItalic <- maybeBoolElementValue (addSmlNamespace "i") cur + _runPropertiesStrikeThrough <- maybeBoolElementValue (addSmlNamespace "strike") cur + _runPropertiesOutline <- maybeBoolElementValue (addSmlNamespace "outline") cur + _runPropertiesShadow <- maybeBoolElementValue (addSmlNamespace "shadow") cur + _runPropertiesCondense <- maybeBoolElementValue (addSmlNamespace "condense") cur + _runPropertiesExtend <- maybeBoolElementValue (addSmlNamespace "extend") cur + _runPropertiesColor <- maybeFromElement (addSmlNamespace "color") cur + _runPropertiesSize <- maybeElementValue (addSmlNamespace "sz") cur + _runPropertiesUnderline <- maybeElementValueDef (addSmlNamespace "u") FontUnderlineSingle cur + _runPropertiesVertAlign <- maybeElementValue (addSmlNamespace "vertAlign") cur + _runPropertiesScheme <- maybeElementValue (addSmlNamespace "scheme") cur return RunProperties{..} instance FromXenoNode RunProperties where diff --git a/src/Codec/Xlsx/Types/SheetViews.hs b/src/Codec/Xlsx/Types/SheetViews.hs --- a/src/Codec/Xlsx/Types/SheetViews.hs +++ b/src/Codec/Xlsx/Types/SheetViews.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -49,11 +48,7 @@ import GHC.Generics (Generic) -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes, maybeToList, listToMaybe) @@ -471,8 +466,8 @@ _sheetViewZoomScaleSheetLayoutView <- maybeAttribute "zoomScaleSheetLayoutView" cur _sheetViewZoomScalePageLayoutView <- maybeAttribute "zoomScalePageLayoutView" cur _sheetViewWorkbookViewId <- fromAttribute "workbookViewId" cur - let _sheetViewPane = listToMaybe $ cur $/ element (n_ "pane") >=> fromCursor - _sheetViewSelection = cur $/ element (n_ "selection") >=> fromCursor + let _sheetViewPane = listToMaybe $ cur $/ element (addSmlNamespace "pane") >=> fromCursor + _sheetViewSelection = cur $/ element (addSmlNamespace "selection") >=> fromCursor return SheetView{..} instance FromXenoNode SheetView where diff --git a/src/Codec/Xlsx/Types/StyleSheet.hs b/src/Codec/Xlsx/Types/StyleSheet.hs --- a/src/Codec/Xlsx/Types/StyleSheet.hs +++ b/src/Codec/Xlsx/Types/StyleSheet.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -129,12 +128,7 @@ , firstUserNumFmtId ) where -#ifdef USE_MICROLENS -import Lens.Micro -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens hiding (element, elements, (.=)) -#endif +import Codec.Xlsx.LensCompat (makeLenses, (&), (.~)) import Control.DeepSeq (NFData) import Data.Default import Data.Map.Strict (Map) @@ -1430,15 +1424,15 @@ instance FromCursor StyleSheet where fromCursor cur = do let - _styleSheetFonts = cur $/ element (n_ "fonts") &/ element (n_ "font") >=> fromCursor - _styleSheetFills = cur $/ element (n_ "fills") &/ element (n_ "fill") >=> fromCursor - _styleSheetBorders = cur $/ element (n_ "borders") &/ element (n_ "border") >=> fromCursor + _styleSheetFonts = cur $/ element (addSmlNamespace "fonts") &/ element (addSmlNamespace "font") >=> fromCursor + _styleSheetFills = cur $/ element (addSmlNamespace "fills") &/ element (addSmlNamespace "fill") >=> fromCursor + _styleSheetBorders = cur $/ element (addSmlNamespace "borders") &/ element (addSmlNamespace "border") >=> fromCursor -- TODO: cellStyleXfs - _styleSheetCellXfs = cur $/ element (n_ "cellXfs") &/ element (n_ "xf") >=> fromCursor + _styleSheetCellXfs = cur $/ element (addSmlNamespace "cellXfs") &/ element (addSmlNamespace "xf") >=> fromCursor -- TODO: cellStyles - _styleSheetDxfs = cur $/ element (n_ "dxfs") &/ element (n_ "dxf") >=> fromCursor + _styleSheetDxfs = cur $/ element (addSmlNamespace "dxfs") &/ element (addSmlNamespace "dxf") >=> fromCursor _styleSheetNumFmts = M.fromList . map mkNumFmtPair $ - cur $/ element (n_ "numFmts")&/ element (n_ "numFmt") >=> fromCursor + cur $/ element (addSmlNamespace "numFmts")&/ element (addSmlNamespace "numFmt") >=> fromCursor -- TODO: tableStyles -- TODO: colors -- TODO: extLst @@ -1447,21 +1441,21 @@ -- | See @CT_Font@, p. 4489 instance FromCursor Font where fromCursor cur = do - _fontName <- maybeElementValue (n_ "name") cur - _fontCharset <- maybeElementValue (n_ "charset") cur - _fontFamily <- maybeElementValue (n_ "family") cur - _fontBold <- maybeBoolElementValue (n_ "b") cur - _fontItalic <- maybeBoolElementValue (n_ "i") cur - _fontStrikeThrough<- maybeBoolElementValue (n_ "strike") cur - _fontOutline <- maybeBoolElementValue (n_ "outline") cur - _fontShadow <- maybeBoolElementValue (n_ "shadow") cur - _fontCondense <- maybeBoolElementValue (n_ "condense") cur - _fontExtend <- maybeBoolElementValue (n_ "extend") cur - _fontColor <- maybeFromElement (n_ "color") cur - _fontSize <- maybeElementValue (n_ "sz") cur - _fontUnderline <- maybeElementValueDef (n_ "u") FontUnderlineSingle cur - _fontVertAlign <- maybeElementValue (n_ "vertAlign") cur - _fontScheme <- maybeElementValue (n_ "scheme") cur + _fontName <- maybeElementValue (addSmlNamespace "name") cur + _fontCharset <- maybeElementValue (addSmlNamespace "charset") cur + _fontFamily <- maybeElementValue (addSmlNamespace "family") cur + _fontBold <- maybeBoolElementValue (addSmlNamespace "b") cur + _fontItalic <- maybeBoolElementValue (addSmlNamespace "i") cur + _fontStrikeThrough<- maybeBoolElementValue (addSmlNamespace "strike") cur + _fontOutline <- maybeBoolElementValue (addSmlNamespace "outline") cur + _fontShadow <- maybeBoolElementValue (addSmlNamespace "shadow") cur + _fontCondense <- maybeBoolElementValue (addSmlNamespace "condense") cur + _fontExtend <- maybeBoolElementValue (addSmlNamespace "extend") cur + _fontColor <- maybeFromElement (addSmlNamespace "color") cur + _fontSize <- maybeElementValue (addSmlNamespace "sz") cur + _fontUnderline <- maybeElementValueDef (addSmlNamespace "u") FontUnderlineSingle cur + _fontVertAlign <- maybeElementValue (addSmlNamespace "vertAlign") cur + _fontScheme <- maybeElementValue (addSmlNamespace "scheme") cur return Font{..} -- | See 18.18.94 "ST_FontFamily (Font Family)" (p. 2517) @@ -1545,15 +1539,15 @@ -- | See @CT_Fill@, p. 4484 instance FromCursor Fill where fromCursor cur = do - _fillPattern <- maybeFromElement (n_ "patternFill") cur + _fillPattern <- maybeFromElement (addSmlNamespace "patternFill") cur return Fill{..} -- | See @CT_PatternFill@, p. 4484 instance FromCursor FillPattern where fromCursor cur = do _fillPatternType <- maybeAttribute "patternType" cur - _fillPatternFgColor <- maybeFromElement (n_ "fgColor") cur - _fillPatternBgColor <- maybeFromElement (n_ "bgColor") cur + _fillPatternFgColor <- maybeFromElement (addSmlNamespace "fgColor") cur + _fillPatternBgColor <- maybeFromElement (addSmlNamespace "bgColor") cur return FillPattern{..} instance FromAttrVal PatternType where @@ -1584,21 +1578,21 @@ _borderDiagonalUp <- maybeAttribute "diagonalUp" cur _borderDiagonalDown <- maybeAttribute "diagonalDown" cur _borderOutline <- maybeAttribute "outline" cur - _borderStart <- maybeFromElement (n_ "start") cur - _borderEnd <- maybeFromElement (n_ "end") cur - _borderLeft <- maybeFromElement (n_ "left") cur - _borderRight <- maybeFromElement (n_ "right") cur - _borderTop <- maybeFromElement (n_ "top") cur - _borderBottom <- maybeFromElement (n_ "bottom") cur - _borderDiagonal <- maybeFromElement (n_ "diagonal") cur - _borderVertical <- maybeFromElement (n_ "vertical") cur - _borderHorizontal <- maybeFromElement (n_ "horizontal") cur + _borderStart <- maybeFromElement (addSmlNamespace "start") cur + _borderEnd <- maybeFromElement (addSmlNamespace "end") cur + _borderLeft <- maybeFromElement (addSmlNamespace "left") cur + _borderRight <- maybeFromElement (addSmlNamespace "right") cur + _borderTop <- maybeFromElement (addSmlNamespace "top") cur + _borderBottom <- maybeFromElement (addSmlNamespace "bottom") cur + _borderDiagonal <- maybeFromElement (addSmlNamespace "diagonal") cur + _borderVertical <- maybeFromElement (addSmlNamespace "vertical") cur + _borderHorizontal <- maybeFromElement (addSmlNamespace "horizontal") cur return Border{..} instance FromCursor BorderStyle where fromCursor cur = do _borderStyleLine <- maybeAttribute "style" cur - _borderStyleColor <- maybeFromElement (n_ "color") cur + _borderStyleColor <- maybeFromElement (addSmlNamespace "color") cur return BorderStyle{..} instance FromAttrVal LineStyle where @@ -1621,8 +1615,8 @@ -- | See @CT_Xf@, p. 4486 instance FromCursor CellXf where fromCursor cur = do - _cellXfAlignment <- maybeFromElement (n_ "alignment") cur - _cellXfProtection <- maybeFromElement (n_ "protection") cur + _cellXfAlignment <- maybeFromElement (addSmlNamespace "alignment") cur + _cellXfProtection <- maybeFromElement (addSmlNamespace "protection") cur _cellXfNumFmtId <- maybeAttribute "numFmtId" cur _cellXfFontId <- maybeAttribute "fontId" cur _cellXfFillId <- maybeAttribute "fillId" cur @@ -1641,12 +1635,12 @@ -- | See @CT_Dxf@, p. 3937 instance FromCursor Dxf where fromCursor cur = do - _dxfFont <- maybeFromElement (n_ "font") cur - _dxfNumFmt <- maybeFromElement (n_ "numFmt") cur - _dxfFill <- maybeFromElement (n_ "fill") cur - _dxfAlignment <- maybeFromElement (n_ "alignment") cur - _dxfBorder <- maybeFromElement (n_ "border") cur - _dxfProtection <- maybeFromElement (n_ "protection") cur + _dxfFont <- maybeFromElement (addSmlNamespace "font") cur + _dxfNumFmt <- maybeFromElement (addSmlNamespace "numFmt") cur + _dxfFill <- maybeFromElement (addSmlNamespace "fill") cur + _dxfAlignment <- maybeFromElement (addSmlNamespace "alignment") cur + _dxfBorder <- maybeFromElement (addSmlNamespace "border") cur + _dxfProtection <- maybeFromElement (addSmlNamespace "protection") cur return Dxf{..} -- | See @CT_NumFmt@, p. 3936 diff --git a/src/Codec/Xlsx/Types/Table.hs b/src/Codec/Xlsx/Types/Table.hs --- a/src/Codec/Xlsx/Types/Table.hs +++ b/src/Codec/Xlsx/Types/Table.hs @@ -1,15 +1,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Table where -#ifdef USE_MICROLENS -import Lens.Micro.TH (makeLenses) -#else -import Control.Lens (makeLenses) -#endif +import Codec.Xlsx.LensCompat (makeLenses) import Control.DeepSeq (NFData) import Data.Maybe (catMaybes, maybeToList) import Data.Text (Text) @@ -90,9 +85,9 @@ tblDisplayName <- fromAttribute "displayName" c tblName <- maybeAttribute "name" c tblRef <- fromAttribute "ref" c - tblAutoFilter <- maybeFromElement (n_ "autoFilter") c + tblAutoFilter <- maybeFromElement (addSmlNamespace "autoFilter") c let tblColumns = - c $/ element (n_ "tableColumns") &/ element (n_ "tableColumn") >=> + c $/ element (addSmlNamespace "tableColumns") &/ element (addSmlNamespace "tableColumn") >=> fmap TableColumn . fromAttribute "name" return Table {..} diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs --- a/src/Codec/Xlsx/Writer.hs +++ b/src/Codec/Xlsx/Writer.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -12,11 +11,7 @@ import qualified "zip-archive" Codec.Archive.Zip as Zip import Control.Arrow (second) -#ifdef USE_MICROLENS -import Lens.Micro -#else -import Control.Lens hiding (transform, (.=)) -#endif +import Codec.Xlsx.LensCompat ((^.), mapped, (%~), (&), (?~)) import Control.Monad (forM) import Control.Monad.ST import Control.Monad.State (evalState, get, put) diff --git a/src/Codec/Xlsx/Writer/Internal/Stream.hs b/src/Codec/Xlsx/Writer/Internal/Stream.hs --- a/src/Codec/Xlsx/Writer/Internal/Stream.hs +++ b/src/Codec/Xlsx/Writer/Internal/Stream.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TemplateHaskell #-} @@ -13,11 +12,7 @@ ) where -#ifdef USE_MICROLENS -import Lens.Micro.Platform -#else -import Control.Lens -#endif +import Codec.Xlsx.LensCompat import Control.Monad.State.Strict import Data.Map.Strict (Map) import Data.Maybe diff --git a/src/Codec/Xlsx/Writer/Stream.hs b/src/Codec/Xlsx/Writer/Stream.hs --- a/src/Codec/Xlsx/Writer/Stream.hs +++ b/src/Codec/Xlsx/Writer/Stream.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -13,7 +12,9 @@ -- large Excel files while remaining in constant memory. module Codec.Xlsx.Writer.Stream ( writeXlsx + , writeXlsxMultipleSheets , writeXlsxWithSharedStrings + , writeXlsxWithConfig , SheetWriteSettings(..) , defaultSettings , wsSheetView @@ -21,6 +22,12 @@ , wsColumnProperties , wsRowProperties , wsStyles + , WriteXlsxConfig + , defWriteXlsxConfig + , setWriteSettings + , setSharedStringsMap + , setNamesAndConduits + , setNameInfosAndConduits -- *** Shared strings , sharedStrings , sharedStringsStream @@ -28,26 +35,21 @@ import Codec.Archive.Zip.Conduit.UnZip import Codec.Archive.Zip.Conduit.Zip -import Codec.Xlsx.Parser.Internal (n_) +import Codec.Xlsx.Parser.Internal (addSmlNamespace) import Codec.Xlsx.Parser.Stream import Codec.Xlsx.Types (ColumnsProperties (..), RowProperties (..), Styles (..), _AutomaticHeight, _CustomHeight, - emptyStyles, rowHeightLens) + emptyStyles, rowHeightLens, SheetState (..)) import Codec.Xlsx.Types.Cell import Codec.Xlsx.Types.Common -import Codec.Xlsx.Types.Internal.Relationships (odr, pr) +import Codec.Xlsx.Types.Internal.Relationships (odr, pr, odRelNs) import Codec.Xlsx.Types.SheetViews import Codec.Xlsx.Writer.Internal (nonEmptyElListSimple, toAttrVal, toElement, txtd, txti) import Codec.Xlsx.Writer.Internal.Stream import Conduit (PrimMonad, yield, (.|)) import qualified Conduit as C -#ifdef USE_MICROLENS -import Data.Traversable.WithIndex -import Lens.Micro.Platform -#else -import Control.Lens -#endif +import Codec.Xlsx.LensCompat import Control.Monad import Control.Monad.Catch import Control.Monad.Reader.Class @@ -72,6 +74,7 @@ import qualified Text.XML as TXML import Text.XML.Stream.Render import Text.XML.Unresolved (elementToEvents) +import Data.Bifunctor (Bifunctor(second)) upsertSharedStrings :: MonadState SharedStringState m => Row -> m [(Text,Int)] @@ -132,18 +135,30 @@ -- This first runs 'sharedStrings' and then 'writeXlsxWithSharedStrings'. -- If you want xlsx files this is the most obvious function to use. -- the others are exposed in case you can cache the shared strings for example. --- --- Note that the current implementation concatenates everything into a single sheet. --- In other words there is no support for writing multiple sheets +-- See also 'writeXlsxMultipleSheets'. writeXlsx :: MonadThrow m => PrimMonad m => SheetWriteSettings -- ^ use 'defaultSettings' -> ConduitT () Row m () -- ^ the conduit producing sheetitems -> ConduitT () ByteString m Word64 -- ^ result conduit producing xlsx files writeXlsx settings sheetC = do - sstrings <- sheetC .| sharedStrings - writeXlsxWithSharedStrings settings sstrings sheetC + writeXlsxWithConfig (defWriteXlsxConfig + & setWriteSettings settings + & setNamesAndConduits [("Sheet1", sheetC)]) +-- | Same as 'writeXlsx' but write to multiple sheets. +writeXlsxMultipleSheets :: MonadThrow m + => PrimMonad m + => SheetWriteSettings + -- ^ use 'defaultSettings'. + -- Currently, all sheets will use the same setting. + -> [(Text, ConduitT () Row m ())] + -- ^ the conduits producing sheetitems for each sheet + -> ConduitT () ByteString m Word64 -- ^ result conduit producing xlsx files +writeXlsxMultipleSheets settings sheets = do + writeXlsxWithConfig (defWriteXlsxConfig + & setWriteSettings settings + & setNamesAndConduits sheets) -- TODO maybe should use bimap instead: https://hackage.haskell.org/package/bimap-0.4.0/docs/Data-Bimap.html -- it guarantees uniqueness of both text and int @@ -163,32 +178,78 @@ writeXlsxWithSharedStrings :: MonadThrow m => PrimMonad m => SheetWriteSettings -> Map Text Int -- ^ shared strings table - -> ConduitT () Row m () + -> [(Text, ConduitT () Row m ())] -> ConduitT () ByteString m Word64 -writeXlsxWithSharedStrings settings sharedStrings' items = - combinedFiles settings sharedStrings' items .| zipStream (settings ^. wsZip) +writeXlsxWithSharedStrings settings sharedStrings' sheets = + writeXlsxWithConfig (defWriteXlsxConfig + & setWriteSettings settings + & setSharedStringsMap (Just sharedStrings') + & setNamesAndConduits sheets) --- massive amount of boilerplate needed for excel to function -boilerplate :: forall m . PrimMonad m => SheetWriteSettings -> Map Text Int -> [(ZipEntry, ZipData m)] -boilerplate settings sharedStrings' = - [ (zipEntry "xl/sharedStrings.xml", ZipDataSource $ writeSst sharedStrings' .| eventsToBS) - , (zipEntry "[Content_Types].xml", ZipDataSource $ writeContentTypes .| eventsToBS) - , (zipEntry "xl/workbook.xml", ZipDataSource $ writeWorkbook .| eventsToBS) - , (zipEntry "xl/styles.xml", ZipDataByteString $ coerce $ settings ^. wsStyles) - , (zipEntry "xl/_rels/workbook.xml.rels", ZipDataSource $ writeWorkbookRels .| eventsToBS) - , (zipEntry "_rels/.rels", ZipDataSource $ writeRootRels .| eventsToBS) - ] +-- | Configure how to write to an xlsx. Provides setters but no getters to +-- hide internals for future compatibility +data WriteXlsxConfig m = MkWriteXlsxConfig + { _writeSettings :: SheetWriteSettings + , _sharedStringsMap :: Maybe (Map Text Int) + , _infosAndConduits :: [((Text, SheetState), ConduitT () Row m ())] + } +-- | Create a blank config. Uses the default write setting config, derives shared +-- strings from the conduits and has no conduits or sheet informations within. +defWriteXlsxConfig :: WriteXlsxConfig m +defWriteXlsxConfig = MkWriteXlsxConfig defaultSettings mempty [] + +-- | Overwrite the existing sheet write settings. +setWriteSettings :: SheetWriteSettings -> WriteXlsxConfig m -> WriteXlsxConfig m +setWriteSettings ws (MkWriteXlsxConfig _ ssm iac) = MkWriteXlsxConfig ws ssm iac + +-- | Set the shared strings map. If set to Nothing, derives the shared strings +-- from the conduits. +setSharedStringsMap :: Maybe (Map Text Int) -> WriteXlsxConfig m -> WriteXlsxConfig m +setSharedStringsMap ssm (MkWriteXlsxConfig ws _ iac) = MkWriteXlsxConfig ws ssm iac + +-- | Set the sheet infos and conduits for each sheet. +setNameInfosAndConduits :: [((Text, SheetState), ConduitT () Row m ())] -> WriteXlsxConfig m -> WriteXlsxConfig m +setNameInfosAndConduits iac (MkWriteXlsxConfig ws ssm _) = MkWriteXlsxConfig ws ssm iac + +-- | Set the names and conduits for each sheet. The sheet info is derived from +-- the ordering. +setNamesAndConduits :: [(Text, ConduitT () Row m ())] -> WriteXlsxConfig m -> WriteXlsxConfig m +setNamesAndConduits nacs (MkWriteXlsxConfig ws ssm _) = MkWriteXlsxConfig ws ssm infosAndConduits' + where + infosAndConduits' = nacs <&> \(n, c) -> ((n, Visible), c) + +-- | Write to an XLSX using the 'WriteXlsxConfig' structure. +writeXlsxWithConfig :: MonadThrow m => PrimMonad m + => WriteXlsxConfig m + -> ConduitT () ByteString m Word64 +writeXlsxWithConfig (MkWriteXlsxConfig ws ssm iac) = do + let rowConduits = foldr ((>>) . snd) mempty iac + sstrings <- maybe (rowConduits .| sharedStrings) pure ssm + combinedFiles ws sstrings iac .| zipStream (ws ^. wsZip) + combinedFiles :: PrimMonad m => SheetWriteSettings -> Map Text Int - -> ConduitT () Row m () + -> [((Text, SheetState), ConduitT () Row m ())] -> ConduitT () (ZipEntry, ZipData m) m () -combinedFiles settings sharedStrings' items = +combinedFiles settings sharedStrings' sheets = + let indicesAndSheets = zip [1..] sheets + zippedSheets = map (\(sheetId, (_, rowConduit)) -> + ( zipEntry ("xl/worksheets/sheet" <> Text.pack (show sheetId) <> ".xml") + , ZipDataSource $ rowConduit .| C.runReaderC settings (writeWorkSheet sharedStrings') .| eventsToBS + )) indicesAndSheets + in C.yieldMany $ - boilerplate settings sharedStrings' <> - [(zipEntry "xl/worksheets/sheet1.xml", ZipDataSource $ - items .| C.runReaderC settings (writeWorkSheet sharedStrings') .| eventsToBS )] + [ (zipEntry "xl/sharedStrings.xml", ZipDataSource $ writeSst sharedStrings' .| eventsToBS) + , (zipEntry "[Content_Types].xml", ZipDataSource $ writeContentTypes .| eventsToBS) + , (zipEntry "xl/workbook.xml", ZipDataSource $ writeWorkbook (map (second fst) indicesAndSheets) + .| renderBuilder ( def {rsNamespaces=[("r", odRelNs)]}) + .| C.builderToByteString) + , (zipEntry "xl/styles.xml", ZipDataByteString $ coerce $ settings ^. wsStyles) + , (zipEntry "xl/_rels/workbook.xml.rels", ZipDataSource $ writeWorkbookRels (length sheets) .| eventsToBS) + , (zipEntry "_rels/.rels", ZipDataSource $ writeRootRels .| eventsToBS) + ] <> zippedSheets el :: Monad m => Name -> Monad m => forall i. ConduitT i Event m () -> ConduitT i Event m () el x = tag x mempty @@ -202,7 +263,6 @@ (attr "ContentType" content' <> attr "PartName" part) $ pure () - -- | required by Excel. writeContentTypes :: Monad m => forall i. ConduitT i Event m () writeContentTypes = doc "{http://schemas.openxmlformats.org/package/2006/content-types}Types" $ do @@ -214,14 +274,19 @@ override "application/vnd.openxmlformats-package.relationships+xml" "/_rels/.rels" -- | required by Excel. -writeWorkbook :: Monad m => forall i. ConduitT i Event m () -writeWorkbook = doc (n_ "workbook") $ do - el (n_ "sheets") $ do - tag (n_ "sheet") - (attr "name" "Sheet1" - <> attr "sheetId" "1" <> - attr (odr "id") "rId3") $ - pure () +writeWorkbook :: Monad m => [(Int, (Text, SheetState))] -> forall i. ConduitT i Event m () +writeWorkbook sheetInfos = + let addSheet (sheetId, (sheetName, visibility)) = tag (addSmlNamespace "sheet") + (attr "name" sheetName + <> attr "sheetId" (Text.pack $ show sheetId) + <> attr (odr "id") ("rId" <> (Text.pack $ show (sheetId + 2))) + <> attr "state" (case visibility of + Visible -> "visible" + Hidden -> "hidden" + VeryHidden -> "veryHidden") + ) $ pure () + in doc (addSmlNamespace "workbook") $ + el (addSmlNamespace "sheets") $ mapM_ addSheet sheetInfos doc :: Monad m => Name -> forall i. ConduitT i Event m () -> ConduitT i Event m () doc root docM = do @@ -237,11 +302,12 @@ <> attr "Target" target ) $ pure () -writeWorkbookRels :: Monad m => forall i. ConduitT i Event m () -writeWorkbookRels = doc (pr "Relationships") $ do +writeWorkbookRels :: Monad m => forall i. Int -> ConduitT i Event m () +writeWorkbookRels sheetCount = doc (pr "Relationships") $ do relationship "sharedStrings.xml" 1 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings" - relationship "worksheets/sheet1.xml" 3 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet" relationship "styles.xml" 2 "http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles" + let schema = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet" + mapM_ (\sheetId -> relationship ("worksheets/sheet" <> (Text.pack (show sheetId)) <> ".xml") (sheetId + 2) schema) [1..sheetCount] writeRootRels :: Monad m => forall i. ConduitT i Event m () writeRootRels = doc (pr "Relationships") $ @@ -260,8 +326,8 @@ eventsToBS = writeEvents .| C.builderToByteString writeSst :: Monad m => Map Text Int -> forall i. ConduitT i Event m () -writeSst sharedStrings' = doc (n_ "sst") $ - void $ traverse (el (n_ "si") . el (n_ "t") . content . fst +writeSst sharedStrings' = doc (addSmlNamespace "sst") $ + void $ traverse (el (addSmlNamespace "si") . el (addSmlNamespace "t") . content . fst ) $ sortBy (\(_, i) (_, y :: Int) -> compare i y) $ Map.toList sharedStrings' writeEvents :: PrimMonad m => ConduitT Event Builder m () @@ -271,15 +337,15 @@ sheetViews = do sheetView <- view wsSheetView - unless (null sheetView) $ el (n_ "sheetViews") $ do + unless (null sheetView) $ el (addSmlNamespace "sheetViews") $ do let view' :: [Element] - view' = setNameSpaceRec spreadSheetNS . toXMLElement . toElement (n_ "sheetView") <$> sheetView + view' = setNameSpaceRec spreadSheetNS . toXMLElement . toElement (addSmlNamespace "sheetView") <$> sheetView C.yieldMany $ elementToEvents =<< view' spreadSheetNS :: Text -spreadSheetNS = fold $ nameNamespace $ n_ "" +spreadSheetNS = fold $ nameNamespace $ addSmlNamespace "" setNameSpaceRec :: Text -> Element -> Element setNameSpaceRec space xelm = @@ -294,21 +360,21 @@ columns = do colProps <- view wsColumnProperties let cols :: Maybe TXML.Element - cols = nonEmptyElListSimple (n_ "cols") $ map (toElement (n_ "col")) colProps + cols = nonEmptyElListSimple (addSmlNamespace "cols") $ map (toElement (addSmlNamespace "col")) colProps traverse_ (C.yieldMany . elementToEvents . toXMLElement) cols writeWorkSheet :: MonadReader SheetWriteSettings m => Map Text Int -> ConduitT Row Event m () -writeWorkSheet sharedStrings' = doc (n_ "worksheet") $ do +writeWorkSheet sharedStrings' = doc (addSmlNamespace "worksheet") $ do sheetViews columns - el (n_ "sheetData") $ C.awaitForever (mapRow sharedStrings') + el (addSmlNamespace "sheetData") $ C.awaitForever (mapRow sharedStrings') mapRow :: MonadReader SheetWriteSettings m => Map Text Int -> Row -> ConduitT Row Event m () mapRow sharedStrings' sheetItem = do mRowProp <- preview $ wsRowProperties . ix (unRowIndex rowIx) . rowHeightLens . _Just . failing _CustomHeight _AutomaticHeight let rowAttr :: Attributes rowAttr = ixAttr <> fold (attr "ht" . txtd <$> mRowProp) - tag (n_ "row") rowAttr $ + tag (addSmlNamespace "row") rowAttr $ void $ itraverse (mapCell sharedStrings' rowIx) (sheetItem ^. ri_cell_row) where rowIx = sheetItem ^. ri_row_index @@ -318,9 +384,9 @@ Monad m => Map Text Int -> RowIndex -> Int -> Cell -> ConduitT Row Event m () mapCell sharedStrings' rix cix' cell = when (has (cellValue . _Just) cell || has (cellStyle . _Just) cell) $ - tag (n_ "c") celAttr $ + tag (addSmlNamespace "c") celAttr $ when (has (cellValue . _Just) cell) $ - el (n_ "v") $ + el (addSmlNamespace "v") $ content $ renderCell sharedStrings' cell where cix = ColumnIndex cix' diff --git a/test/AutoFilterTests.hs b/test/AutoFilterTests.hs --- a/test/AutoFilterTests.hs +++ b/test/AutoFilterTests.hs @@ -21,5 +21,5 @@ testGroup "Types.AutFilter tests" [ testProperty "fromCursor . toElement == id" $ \(autoFilter :: AutoFilter) -> - [autoFilter] == fromCursor (cursorFromElement $ toElement (n_ "autoFilter") autoFilter) + [autoFilter] == fromCursor (cursorFromElement $ toElement (addSmlNamespace "autoFilter") autoFilter) ] diff --git a/test/CondFmtTests.hs b/test/CondFmtTests.hs --- a/test/CondFmtTests.hs +++ b/test/CondFmtTests.hs @@ -20,5 +20,5 @@ testGroup "Types.ConditionalFormatting tests" [ testProperty "fromCursor . toElement == id" $ \(cFmt :: CfRule) -> - [cFmt] == fromCursor (cursorFromElement $ toElement (n_ "cfRule") cFmt) + [cFmt] == fromCursor (cursorFromElement $ toElement (addSmlNamespace "cfRule") cFmt) ] diff --git a/test/Diff.hs b/test/Diff.hs --- a/test/Diff.hs +++ b/test/Diff.hs @@ -3,11 +3,11 @@ import Data.Algorithm.Diff (Diff (..), getGroupedDiff) import Data.Algorithm.DiffOutput (ppDiff) import Data.Monoid ((<>)) -import Test.Tasty.HUnit (Assertion, assertBool) +import Test.Tasty.HUnit (Assertion, HasCallStack, assertBool) import Text.Groom (groom) -- | Like '@=?' but producing a diff on failure. -(@==?) :: (Eq a, Show a) => a -> a -> Assertion +(@==?) :: HasCallStack => (Eq a, Show a) => a -> a -> Assertion x @==? y = assertBool ("Expected:\n" <> groom x <> "\nDifference:\n" <> msg) (x == y) where diff --git a/test/StreamTests.hs b/test/StreamTests.hs --- a/test/StreamTests.hs +++ b/test/StreamTests.hs @@ -52,6 +52,8 @@ 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 @@ -77,13 +79,15 @@ 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 sqaure" $ readWrite smallWorkbook + , 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 ], @@ -100,7 +104,7 @@ readWrite :: Xlsx -> IO () readWrite input = do BS.writeFile "testinput.xlsx" (toBs input) - items <- fmap (toListOf (traversed . si_row)) $ runXlsxM "testinput.xlsx" $ collectItems $ makeIndex 1 + 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 -> @@ -108,6 +112,22 @@ 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 = @@ -201,9 +221,20 @@ -- ] -- )] +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" $ collectItems $ makeIndex 1 + items <- runXlsxM "data/inline-strings.xlsx" $ collectItemsIdentifier . fromJust =<< makeIdentifierFromName "Sheet1" let expected = [ IM.fromList [ ( 1, @@ -224,13 +255,13 @@ ) ] ] - expected @==? (items ^.. traversed . si_row . ri_cell_row) + 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" $ collectItems $ makeIndex 1 + 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) ] @@ -240,7 +271,7 @@ , IM.fromList [ (1, def & cellValue ?~ CellDouble 14.0 & cellStyle ?~ 1 ) ] , IM.fromList [ (1, def & cellValue ?~ CellDouble 15.0) ] ] - expected @==? (_ri_cell_row . _si_row <$> items) + expected @==? (_ri_cell_row <$> items) richCellTextIsParsed :: IO () diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 1.1.4 +Version: 1.2.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -70,6 +70,7 @@ , Codec.Xlsx.Types.PivotTable , Codec.Xlsx.Types.PivotTable.Internal , Codec.Xlsx.Types.Protection + , Codec.Xlsx.Types.RefId , Codec.Xlsx.Types.RichText , Codec.Xlsx.Types.SheetViews , Codec.Xlsx.Types.StyleSheet @@ -80,6 +81,9 @@ , Codec.Xlsx.Writer.Internal.PivotTable , Codec.Xlsx.Parser.Stream , Codec.Xlsx.Writer.Stream + , Codec.Xlsx.Parser.Stream.Row + , Codec.Xlsx.Parser.Stream.SheetInfo + , Codec.Xlsx.Parser.Stream.SheetItem , Codec.Xlsx.Writer.Internal.Stream -- The only function it exports is also hidden by the upstream library: https://github.com/the-real-blackh/hexpat/blob/master/Text/XML/Expat/SAX.hs#L227 @@ -87,6 +91,9 @@ -- It be better to expose it in the upstream library instead I think. It was copied here so the parser can use it. Other-modules: Codec.Xlsx.Parser.Stream.HexpatInternal , Codec.Xlsx.Parser.Internal.Memoize + , Codec.Xlsx.Parser.Stream.SheetIdentifier + , Codec.Xlsx.Parser.Stream.SheetIndex + , Codec.Xlsx.LensCompat Build-depends: base >= 4.9.0.0 && < 5.0 , attoparsec