xlsx 1.1.4 → 1.2.0
raw patch · 42 files changed
+650/−512 lines, 42 files
Files
- CHANGELOG.markdown +9/−0
- src/Codec/Xlsx/Formatted.hs +1/−9
- src/Codec/Xlsx/Lens.hs +1/−8
- src/Codec/Xlsx/LensCompat.hs +40/−0
- src/Codec/Xlsx/Parser.hs +28/−32
- src/Codec/Xlsx/Parser/Internal.hs +11/−4
- src/Codec/Xlsx/Parser/Internal/PivotTable.hs +8/−8
- src/Codec/Xlsx/Parser/Stream.hs +100/−102
- src/Codec/Xlsx/Parser/Stream/Row.hs +23/−0
- src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs +20/−0
- src/Codec/Xlsx/Parser/Stream/SheetIndex.hs +20/−0
- src/Codec/Xlsx/Parser/Stream/SheetInfo.hs +27/−0
- src/Codec/Xlsx/Parser/Stream/SheetItem.hs +26/−0
- src/Codec/Xlsx/Types.hs +1/−29
- src/Codec/Xlsx/Types/AutoFilter.hs +29/−34
- src/Codec/Xlsx/Types/Cell.hs +1/−6
- src/Codec/Xlsx/Types/Common.hs +3/−23
- src/Codec/Xlsx/Types/ConditionalFormatting.hs +10/−15
- src/Codec/Xlsx/Types/DataValidation.hs +9/−11
- src/Codec/Xlsx/Types/Drawing.hs +1/−6
- src/Codec/Xlsx/Types/Drawing/Chart.hs +1/−6
- src/Codec/Xlsx/Types/Drawing/Common.hs +1/−6
- src/Codec/Xlsx/Types/Internal.hs +2/−24
- src/Codec/Xlsx/Types/Internal/CfPair.hs +1/−1
- src/Codec/Xlsx/Types/Internal/CommentTable.hs +3/−3
- src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +1/−1
- src/Codec/Xlsx/Types/PageSetup.hs +1/−6
- src/Codec/Xlsx/Types/PivotTable/Internal.hs +6/−6
- src/Codec/Xlsx/Types/Protection.hs +1/−6
- src/Codec/Xlsx/Types/RefId.hs +25/−0
- src/Codec/Xlsx/Types/RichText.hs +18/−22
- src/Codec/Xlsx/Types/SheetViews.hs +3/−8
- src/Codec/Xlsx/Types/StyleSheet.hs +43/−49
- src/Codec/Xlsx/Types/Table.hs +3/−8
- src/Codec/Xlsx/Writer.hs +1/−6
- src/Codec/Xlsx/Writer/Internal/Stream.hs +1/−6
- src/Codec/Xlsx/Writer/Stream.hs +122/−56
- test/AutoFilterTests.hs +1/−1
- test/CondFmtTests.hs +1/−1
- test/Diff.hs +2/−2
- test/StreamTests.hs +37/−6
- xlsx.cabal +8/−1
CHANGELOG.markdown view
@@ -1,3 +1,12 @@+1.2.0+------------+* expose sheet state in stream parser+ (thanks to Benjamin McRae <benjamin@supercede.com>)+* drop unnecessary `n` namespace from stream writer+ (thanks to Michael Schneider <michael@m1-s.com>)+* add support support for writing multiple sheets with stream writer+ (thanks to Michael Schneider <michael@m1-s.com>)+ 1.1.4 ------------ * fix the problem with leading slashes for comments, drawings and pivot tables
src/Codec/Xlsx/Formatted.hs view
@@ -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
src/Codec/Xlsx/Lens.hs view
@@ -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
+ src/Codec/Xlsx/LensCompat.hs view
@@ -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
src/Codec/Xlsx/Parser.hs view
@@ -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 @@ -- </xsd:complexType> 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
src/Codec/Xlsx/Parser/Internal.hs view
@@ -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 }
src/Codec/Xlsx/Parser/Internal/PivotTable.hs view
@@ -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)
src/Codec/Xlsx/Parser/Stream.hs view
@@ -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.--- <sheet name="Data" sheetId="1" state="hidden" r:id="rId2" /-data SheetInfo = SheetInfo- { sheetInfoName :: Text,- -- | The r:id attribute value.- sheetInfoRelId :: RefId,- -- | The sheetId attribute value- sheetInfoSheetId :: Int- } deriving (Show, Eq)- -- | Information about the workbook contained in xl/workbook.xml -- (currently a subset) data WorkbookInfo = WorkbookInfo@@ -229,10 +196,9 @@ ) -- | Initial parsing state-initialSheetState :: SheetState-initialSheetState = MkSheetState+initialParserState :: ParserState+initialParserState = MkParserState { _ps_row = mempty- , _ps_sheet_index = 0 , _ps_cell_row_index = 0 , _ps_cell_col_index = 0 , _ps_is_in_val = False@@ -300,13 +266,23 @@ readWorkbookInfo = do sel <- Zip.mkEntrySelector "xl/workbook.xml" src <- Zip.getEntrySource sel+ sheetIndexRef <- liftIO $ newIORef 0 sheets <- liftIO $ runExpat [] src $ \evs -> 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
+ src/Codec/Xlsx/Parser/Stream/Row.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Stream/SheetIdentifier.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Stream/SheetIndex.hs view
@@ -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" #-}
+ src/Codec/Xlsx/Parser/Stream/SheetInfo.hs view
@@ -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.+-- <sheet name="Data" sheetId="1" state="hidden" r:id="rId2" /+data SheetInfo = MkSheetInfo+ { sheetInfoName :: Text,+ -- | The r:id attribute value+ sheetInfoRelId :: RefId,+ -- | The sheetId attribute value+ sheetInfoSheetId :: Int,+ -- | The index into the sheets in the workbook+ sheetInfoSheetIndex :: Int,+ -- | The sheet visibility state+ sheetInfoState :: SheetState+ } deriving (Show, Eq)++{-# DEPRECATED sheetInfoRelId, sheetInfoSheetId "this field will be removed in future, see issue #193" #-} ++getSheetIdentifier :: SheetInfo -> SheetIdentifier+getSheetIdentifier sheetInfo = unsafeGetSheetIdentifier (sheetInfoRelId sheetInfo) (sheetInfoSheetId sheetInfo)
+ src/Codec/Xlsx/Parser/Stream/SheetItem.hs view
@@ -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" #-}
src/Codec/Xlsx/Types.hs view
@@ -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
src/Codec/Xlsx/Types/AutoFilter.hs view
@@ -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
src/Codec/Xlsx/Types/Cell.hs view
@@ -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)
src/Codec/Xlsx/Types/Common.hs view
@@ -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
src/Codec/Xlsx/Types/ConditionalFormatting.hs view
@@ -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 " ++
src/Codec/Xlsx/Types/DataValidation.hs view
@@ -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 $
src/Codec/Xlsx/Types/Drawing.hs view
@@ -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
src/Codec/Xlsx/Types/Drawing/Chart.hs view
@@ -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)
src/Codec/Xlsx/Types/Drawing/Common.hs view
@@ -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)
src/Codec/Xlsx/Types/Internal.hs view
@@ -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
src/Codec/Xlsx/Types/Internal/CfPair.hs view
@@ -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
src/Codec/Xlsx/Types/Internal/CommentTable.hs view
@@ -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])
@@ -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)) {-------------------------------------------------------------------------------
src/Codec/Xlsx/Types/PageSetup.hs view
@@ -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
src/Codec/Xlsx/Types/PivotTable/Internal.hs view
@@ -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
src/Codec/Xlsx/Types/Protection.hs view
@@ -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
+ src/Codec/Xlsx/Types/RefId.hs view
@@ -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
src/Codec/Xlsx/Types/RichText.hs view
@@ -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
src/Codec/Xlsx/Types/SheetViews.hs view
@@ -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
src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -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
src/Codec/Xlsx/Types/Table.hs view
@@ -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 {..}
src/Codec/Xlsx/Writer.hs view
@@ -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)
src/Codec/Xlsx/Writer/Internal/Stream.hs view
@@ -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
src/Codec/Xlsx/Writer/Stream.hs view
@@ -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'
test/AutoFilterTests.hs view
@@ -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) ]
test/CondFmtTests.hs view
@@ -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) ]
test/Diff.hs view
@@ -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
test/StreamTests.hs view
@@ -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 ()
xlsx.cabal view
@@ -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