diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,17 @@ +0.7.0 +----- +* fixed serialization of large integer values (thanks Radoslav Dorcik + ) +* added fast xlsx parsing using `xeno` library +* dropped support for GHC 7.8.4 and added support for GHC 8.2.2 +* added numer format support in differential formatting records + (thanks Emil Axelsson ) +* added `inlineStr` cell type support +* added shared formulas support +* added error values support +* helper functions for serialization/deserialization of date values + (thanks José Romildo Malaquias ) + 0.6.0 ----- * fixed reading files with optional table name (thanks Aleksey Khudyakov diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Codec.Xlsx +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB + +main :: IO () +main = do + let filename = "data/testInput.xlsx" + -- "data/6000.rows.x.26.cols.xlsx" + bs <- BS.readFile filename + let bs' = LB.fromStrict bs + defaultMain + [ bgroup + "readFile" + [ bench "with xlsx" $ nf toXlsx bs' + , bench "with xlsx fast" $ nf toXlsxFast bs' + ] + ] 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 #-} @@ -48,10 +47,6 @@ import GHC.Generics (Generic) import Prelude hiding (mapM) import Safe (headNote, fromJustNote) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Codec.Xlsx.Types 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 #-} @@ -26,10 +25,6 @@ import Data.Text import Data.Tuple (swap) import GHC.Generics (Generic) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif newtype SheetList = SheetList{ unSheetList :: [(Text, Worksheet)] } deriving (Eq, Show, Generic) 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,45 +1,55 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveGeneric #-} -- | This module provides a function for reading .xlsx files module Codec.Xlsx.Parser ( toXlsx , toXlsxEither + , toXlsxFast + , toXlsxEitherFast , ParseError(..) , Parser ) where - import qualified Codec.Archive.Zip as Zip import Control.Applicative import Control.Arrow (left) import Control.Error.Safe (headErr) import Control.Error.Util (note) -import Control.Lens hiding (element, views, (<.>)) +import Control.Exception (Exception) +import Control.Lens hiding ((<.>), element, views) +import Control.Monad (forM, join, void) import Control.Monad.Except (catchError, throwError) +import Data.Bool (bool) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as LB import Data.ByteString.Lazy.Char8 () import Data.List +import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Read as T import Data.Traversable import GHC.Generics (Generic) import Prelude hiding (sequence) +import Safe import System.FilePath.Posix import Text.XML as X -import Text.XML.Cursor +import Text.XML.Cursor hiding (bool) +import qualified Xeno.DOM as Xeno import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Parser.Internal.PivotTable import Codec.Xlsx.Types +import Codec.Xlsx.Types.Cell (formulaDataFromCursor) +import Codec.Xlsx.Types.Common (xlsxTextToCellValue) import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair import Codec.Xlsx.Types.Internal.CommentTable as CommentTable @@ -47,6 +57,7 @@ import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.DvPair +import Codec.Xlsx.Types.Internal.FormulaData import Codec.Xlsx.Types.Internal.Relationships as Relationships import Codec.Xlsx.Types.Internal.SharedStringTable import Codec.Xlsx.Types.PivotTable.Internal @@ -57,25 +68,45 @@ data ParseError = InvalidZipArchive | MissingFile FilePath - | InvalidFile FilePath + | InvalidFile FilePath Text | InvalidRef FilePath RefId | InconsistentXlsx Text deriving (Eq, Show, Generic) +instance Exception ParseError + type Parser = Either ParseError --- | Reads `Xlsx' from raw data (lazy bytestring), failing with Left on parse error +-- | Reads `Xlsx' from raw data (lazy bytestring) using @xeno@ library +-- using some "cheating" +-- * not doing 100% xml validation +-- * replacing only basic XML enttities +-- * almost not using XML namespaces +toXlsxFast :: L.ByteString -> Xlsx +toXlsxFast = either (error . show) id . toXlsxEitherFast + +-- | Reads `Xlsx' from raw data (lazy bytestring), failing with 'Left' on parse error toXlsxEither :: L.ByteString -> Parser Xlsx -toXlsxEither bs = do +toXlsxEither = toXlsxEitherBase extractSheet + +-- | Fast parsing with 'Left' on parse error, see 'toXlsxFast' +toXlsxEitherFast :: L.ByteString -> Parser Xlsx +toXlsxEitherFast = toXlsxEitherBase extractSheetFast + +toXlsxEitherBase :: + (Zip.Archive -> SharedStringTable -> ContentTypes -> Caches -> WorksheetFile -> Parser Worksheet) + -> L.ByteString + -> Parser Xlsx +toXlsxEitherBase parseSheet bs = do ar <- left (const InvalidZipArchive) $ Zip.toArchiveOrFail bs sst <- getSharedStrings ar contentTypes <- getContentTypes ar - (wfs, names, cacheSources) <- readWorkbook ar + (wfs, names, cacheSources, dateBase) <- readWorkbook ar sheets <- forM wfs $ \wf -> do - sheet <- extractSheet ar sst contentTypes cacheSources wf + sheet <- parseSheet ar sst contentTypes cacheSources wf return (wfName wf, sheet) CustomProperties customPropMap <- getCustomProperties ar - return $ Xlsx sheets (getStyles ar) names customPropMap + return $ Xlsx sheets (getStyles ar) names customPropMap dateBase data WorksheetFile = WorksheetFile { wfName :: Text , wfPath :: FilePath @@ -84,16 +115,229 @@ type Caches = [(CacheId, (Text, CellRef, [CacheField]))] -extractSheet :: Zip.Archive - -> SharedStringTable - -> ContentTypes - -> Caches - -> WorksheetFile - -> Parser Worksheet +extractSheetFast :: Zip.Archive + -> SharedStringTable + -> ContentTypes + -> Caches + -> WorksheetFile + -> Parser Worksheet +extractSheetFast ar sst contentTypes caches wf = do + file <- + note (MissingFile filePath) $ + Zip.fromEntry <$> Zip.findEntryByPath filePath ar + sheetRels <- getRels ar filePath + root <- + left (\ex -> InvalidFile filePath $ T.pack (show ex)) $ + Xeno.parse (LB.toStrict file) + parseWorksheet root sheetRels + where + filePath = wfPath wf + parseWorksheet :: Xeno.Node -> Relationships -> Parser Worksheet + parseWorksheet root sheetRels = do + let prefixes = nsPrefixes root + odrNs = + "http://schemas.openxmlformats.org/officeDocument/2006/relationships" + odrX = addPrefix prefixes odrNs + skip = void . maybeChild + (ws, tableIds, drawingRId, legacyDrRId) <- + liftEither . collectChildren root $ do + skip "sheetPr" + skip "dimension" + _wsSheetViews <- fmap justNonEmpty . maybeParse "sheetViews" $ \n -> + collectChildren n $ fromChildList "sheetView" + skip "sheetFormatPr" + _wsColumnsProperties <- + fmap (fromMaybe []) . maybeParse "cols" $ \n -> + collectChildren n (fromChildList "col") + (_wsRowPropertiesMap, _wsCells, _wsSharedFormulas) <- + requireAndParse "sheetData" $ \n -> do + rows <- collectChildren n $ childList "row" + collectRows <$> forM rows parseRow + skip "sheetCalcPr" + _wsProtection <- maybeFromChild "sheetProtection" + skip "protectedRanges" + skip "scenarios" + _wsAutoFilter <- maybeFromChild "autoFilter" + skip "sortState" + skip "dataConsolidate" + skip "customSheetViews" + _wsMerges <- fmap (fromMaybe []) . maybeParse "mergeCells" $ \n -> do + mCells <- collectChildren n $ childList "mergeCell" + forM mCells $ \mCell -> parseAttributes mCell $ fromAttr "ref" + _wsConditionalFormattings <- + M.fromList . map unCfPair <$> fromChildList "conditionalFormatting" + _wsDataValidations <- + fmap (fromMaybe mempty) . maybeParse "dataValidations" $ \n -> do + M.fromList . map unDvPair <$> + collectChildren n (fromChildList "dataValidation") + skip "hyperlinks" + skip "printOptions" + skip "pageMargins" + _wsPageSetup <- maybeFromChild "pageSetup" + skip "headerFooter" + skip "rowBreaks" + skip "colBreaks" + skip "customProperties" + skip "cellWatches" + skip "ignoredErrors" + skip "smartTags" + drawingRId <- maybeParse "drawing" $ \n -> + parseAttributes n $ fromAttr (odrX "id") + legacyDrRId <- maybeParse "legacyDrawing" $ \n -> + parseAttributes n $ fromAttr (odrX "id") + tableIds <- fmap (fromMaybe []) . maybeParse "tableParts" $ \n -> do + tParts <- collectChildren n $ childList "tablePart" + forM tParts $ \part -> + parseAttributes part $ fromAttr (odrX "id") + + -- all explicitly assigned fields filled below + return ( + Worksheet + { _wsDrawing = Nothing + , _wsPivotTables = [] + , _wsTables = [] + , .. + } + , tableIds + , drawingRId + , legacyDrRId) + + let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" + commentTarget :: Maybe FilePath + commentTarget = relTarget <$> findRelByType commentsType sheetRels + legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< legacyDrRId + commentsMap <- + fmap join . forM commentTarget $ getComments ar legacyDrPath + let commentCells = + M.fromList + [ (fromSingleCellRefNoting r, def { _cellComment = Just cmnt}) + | (r, cmnt) <- maybe [] CommentTable.toList commentsMap + ] + assignComment withCmnt noCmnt = + noCmnt & cellComment .~ (withCmnt ^. cellComment) + mergeComments = M.unionWith assignComment commentCells + tables <- forM tableIds $ \rId -> do + fp <- lookupRelPath filePath sheetRels rId + getTable ar fp + drawing <- forM drawingRId $ \dId -> do + rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels + getDrawing ar contentTypes (relTarget rel) + let ptType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/pivotTable" + pivotTables <- forM (allByType ptType sheetRels) $ \rel -> do + let ptPath = relTarget rel + bs <- note (MissingFile ptPath) $ Zip.fromEntry <$> Zip.findEntryByPath ptPath ar + note (InconsistentXlsx $ "Bad pivot table in " <> T.pack ptPath) $ + parsePivotTable (flip Prelude.lookup caches) bs + + return $ ws & wsTables .~ tables + & wsCells %~ mergeComments + & wsDrawing .~ drawing + & wsPivotTables .~ pivotTables + liftEither :: Either Text a -> Parser a + liftEither = left (\t -> InvalidFile filePath t) + justNonEmpty v@(Just (_:_)) = v + justNonEmpty _ = Nothing + collectRows = foldr collectRow (M.empty, M.empty, M.empty) + collectRow :: + ( Int + , Maybe RowProperties + , [(Int, Int, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))]) + -> ( Map Int RowProperties + , CellMap + , Map SharedFormulaIndex SharedFormulaOptions) + -> ( Map Int RowProperties + , CellMap + , Map SharedFormulaIndex SharedFormulaOptions) + collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) = + let (newCells0, newSharedF0) = + unzip [(((x, y), cd), shared) | (x, y, cd, shared) <- rowCells] + newCells = M.fromAscList newCells0 + newSharedF = M.fromAscList $ catMaybes newSharedF0 + newRowMap = + case mRP of + Just rp -> M.insert r rp rowMap + Nothing -> rowMap + in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) + parseRow :: + Xeno.Node + -> Either Text ( Int + , Maybe RowProperties + , [( Int + , Int + , Cell + , Maybe (SharedFormulaIndex, SharedFormulaOptions))]) + parseRow row = do + (r, s, ht, cstHt, hidden) <- + parseAttributes row $ + ((,,,,) <$> fromAttr "r" <*> maybeAttr "s" <*> maybeAttr "ht" <*> + fromAttrDef "customHeight" False <*> + fromAttrDef "hidden" False) + let props = + RowProps + { rowHeight = + if cstHt + then CustomHeight <$> ht + else AutomaticHeight <$> ht + , rowStyle = s + , rowHidden = hidden + } + cellNodes <- collectChildren row $ childList "c" + cells <- forM cellNodes parseCell + return + ( r + , if props == def + then Nothing + else Just props + , cells) + parseCell :: + Xeno.Node + -> Either Text ( Int + , Int + , Cell + , Maybe (SharedFormulaIndex, SharedFormulaOptions)) + parseCell cell = do + (ref, s, t) <- + parseAttributes cell $ + (,,) <$> fromAttr "r" <*> maybeAttr "s" <*> fromAttrDef "t" "n" + (fNode, vNode, isNode) <- + collectChildren cell $ + (,,) <$> maybeChild "f" <*> maybeChild "v" <*> maybeChild "is" + let vConverted :: (FromAttrBs a) => Either Text (Maybe a) + vConverted = + case contentBs <$> vNode of + Nothing -> return Nothing + Just c -> Just <$> fromAttrBs c + mFormulaData <- mapM fromXenoNode fNode + d <- + case t of + ("s" :: ByteString) -> do + si <- vConverted + case sstItem sst =<< si of + Just xlTxt -> return $ Just (xlsxTextToCellValue xlTxt) + Nothing -> throwError "bad shared string index" + "inlineStr" -> mapM (fmap xlsxTextToCellValue . fromXenoNode) isNode + "str" -> fmap CellText <$> vConverted + "n" -> fmap CellDouble <$> vConverted + "b" -> fmap CellBool <$> vConverted + "e" -> fmap CellError <$> vConverted + unexpected -> + throwError $ "unexpected cell type " <> T.pack (show unexpected) + let (r, c) = fromSingleCellRefNoting ref + f = frmdFormula <$> mFormulaData + shared = frmdShared =<< mFormulaData + return (r, c, Cell s d Nothing f, shared) + +extractSheet :: + Zip.Archive + -> SharedStringTable + -> ContentTypes + -> Caches + -> WorksheetFile + -> Parser Worksheet extractSheet ar sst contentTypes caches wf = do let filePath = wfPath wf file <- note (MissingFile filePath) $ Zip.fromEntry <$> Zip.findEntryByPath filePath ar - cur <- fmap fromDocument . left (\_ -> InvalidFile filePath) $ + cur <- fmap fromDocument . left (\ex -> InvalidFile filePath (T.pack $ show ex)) $ parseLBS def file sheetRels <- getRels ar filePath @@ -117,8 +361,13 @@ cws = cur $/ element (n_ "cols") &/ element (n_ "col") >=> fromCursor - (rowProps, cells0) = collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow - parseRow :: Cursor -> [(Int, Maybe RowProperties, [(Int, Int, Cell)])] + (rowProps, cells0, sharedFormulas) = + collect $ cur $/ element (n_ "sheetData") &/ element (n_ "row") >=> parseRow + parseRow :: + Cursor + -> [( Int + , Maybe RowProperties + , [(Int, Int, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))])] parseRow c = do r <- fromAttribute "r" c let prop = RowProps @@ -136,23 +385,36 @@ , if prop == def then Nothing else Just prop , c $/ element (n_ "c") >=> parseCell ) - parseCell :: Cursor -> [(Int, Int, Cell)] + parseCell :: + Cursor + -> [(Int, Int, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))] parseCell cell = do ref <- fromAttribute "r" cell - let - s = listToMaybe $ cell $| attribute "s" >=> decimal - t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" - d = listToMaybe $ cell $/ element (n_ "v") &/ content >=> extractCellValue sst t - f = listToMaybe $ cell $/ element (n_ "f") >=> fromCursor - (r, c) = fromSingleCellRefNoting ref - comment = commentsMap >>= lookupComment ref - return (r, c, Cell s d comment f) - collect = foldr collectRow (M.empty, M.empty) - collectRow (_, Nothing, rowCells) (rowMap, cellMap) = - (rowMap, foldr collectCell cellMap rowCells) - collectRow (r, Just h, rowCells) (rowMap, cellMap) = - (M.insert r h rowMap, foldr collectCell cellMap rowCells) - collectCell (x, y, cd) = M.insert (x,y) cd + let s = listToMaybe $ cell $| attribute "s" >=> decimal + t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" + d = listToMaybe $ extractCellValue sst t cell + mFormulaData = listToMaybe $ cell $/ element (n_ "f") >=> formulaDataFromCursor + f = fst <$> mFormulaData + shared = snd =<< mFormulaData + (r, c) = fromSingleCellRefNoting ref + comment = commentsMap >>= lookupComment ref + return (r, c, Cell s d comment f, shared) + collect = foldr collectRow (M.empty, M.empty, M.empty) + collectRow :: + ( Int + , Maybe RowProperties + , [(Int, Int, Cell, Maybe (SharedFormulaIndex, SharedFormulaOptions))]) + -> (Map Int RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions) + -> (Map Int RowProperties, CellMap, Map SharedFormulaIndex SharedFormulaOptions) + collectRow (r, mRP, rowCells) (rowMap, cellMap, sharedF) = + let (newCells0, newSharedF0) = + unzip [(((x,y),cd), shared) | (x, y, cd, shared) <- rowCells] + newCells = M.fromList newCells0 + newSharedF = M.fromList $ catMaybes newSharedF0 + newRowMap = case mRP of + Just rp -> M.insert r rp rowMap + Nothing -> rowMap + in (newRowMap, cellMap <> newCells, sharedF <> newSharedF) commentCells = M.fromList @@ -213,24 +475,29 @@ mAutoFilter tables mProtection + sharedFormulas -extractCellValue :: SharedStringTable -> Text -> Text -> [CellValue] -extractCellValue sst "s" v = - case T.decimal v of - Right (d, _) -> - case sstItem sst d of - XlsxText txt -> [CellText txt] - XlsxRichText rich -> [CellRich rich] - _ -> - [] -extractCellValue _ "str" str = [CellText str] -extractCellValue _ "n" v = - case T.rational v of - Right (d, _) -> [CellDouble d] - _ -> [] -extractCellValue _ "b" "1" = [CellBool True] -extractCellValue _ "b" "0" = [CellBool False] -extractCellValue _ _ _ = [] +extractCellValue :: SharedStringTable -> Text -> Cursor -> [CellValue] +extractCellValue sst t cur + | t == "s" = do + si <- vConverted "shared string" + case sstItem sst si of + Just xlTxt -> return $ xlsxTextToCellValue xlTxt + Nothing -> fail "bad shared string index" + | t == "inlineStr" = + cur $/ element (n_ "is") >=> fmap xlsxTextToCellValue . fromCursor + | t == "str" = CellText <$> vConverted "string" + | t == "n" = CellDouble <$> vConverted "double" + | t == "b" = CellBool <$> vConverted "boolean" + | t == "e" = CellError <$> vConverted "error" + | otherwise = fail "bad cell value" + where + vConverted typeStr = do + vContent <- cur $/ element (n_ "v") >=> \c -> + return (T.concat $ c $/ content) + case fromAttrVal vContent of + Right (val, _) -> return $ val + _ -> fail $ "bad " ++ typeStr ++ " cell value" -- | Get xml cursor from the specified file inside the zip archive. xmlCursorOptional :: Zip.Archive -> FilePath -> Parser (Maybe Cursor) @@ -245,16 +512,30 @@ xmlCursorRequired :: Zip.Archive -> FilePath -> Parser Cursor xmlCursorRequired ar fname = do entry <- note (MissingFile fname) $ Zip.findEntryByPath fname ar - cur <- left (\_ -> InvalidFile fname) $ parseLBS def (Zip.fromEntry entry) + cur <- left (\ex -> InvalidFile fname (T.pack $ show ex)) $ parseLBS def (Zip.fromEntry entry) return $ fromDocument cur +fromFileCursorDef :: + FromCursor a => Zip.Archive -> FilePath -> Text -> a -> Parser a +fromFileCursorDef x fp contentsDescr defVal = do + mCur <- xmlCursorOptional x fp + case mCur of + Just cur -> + headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur + Nothing -> return defVal + +fromFileCursor :: FromCursor a => Zip.Archive -> FilePath -> Text -> Parser a +fromFileCursor x fp contentsDescr = do + cur <- xmlCursorRequired x fp + headErr (InvalidFile fp $ "Couldn't parse " <> contentsDescr) $ fromCursor cur + -- | Get shared string table getSharedStrings :: Zip.Archive -> Parser SharedStringTable -getSharedStrings x = maybe sstEmpty (head . fromCursor) <$> - xmlCursorOptional x "xl/sharedStrings.xml" +getSharedStrings x = + fromFileCursorDef x "xl/sharedStrings.xml" "shared strings" sstEmpty getContentTypes :: Zip.Archive -> Parser ContentTypes -getContentTypes x = head . fromCursor <$> xmlCursorRequired x "[Content_Types].xml" +getContentTypes x = fromFileCursor x "[Content_Types].xml" "content types" getStyles :: Zip.Archive -> Styles getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of @@ -283,13 +564,14 @@ return $ singleCellRef (r0 + 1, c0 + 1) getCustomProperties :: Zip.Archive -> Parser CustomProperties -getCustomProperties ar = maybe CustomProperties.empty (head . fromCursor) <$> xmlCursorOptional ar "docProps/custom.xml" +getCustomProperties ar = + fromFileCursorDef ar "docProps/custom.xml" "custom properties" CustomProperties.empty getDrawing :: Zip.Archive -> ContentTypes -> FilePath -> Parser Drawing getDrawing ar contentTypes fp = do cur <- xmlCursorRequired ar fp drawingRels <- getRels ar fp - unresolved <- headErr (InvalidFile fp) (fromCursor cur) + unresolved <- headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels return $ Drawing anchors where @@ -314,19 +596,22 @@ return uAnch {_anchObject = Graphic nv chart tr} lookupFI _ Nothing = return Nothing lookupFI rels (Just rId) = do - path <- lookupRelPath fp rels rId + path <- lookupRelPath fp rels rId -- content types use paths starting with / - contentType <- note (InvalidFile path) $ ContentTypes.lookup ("/" <> path) contentTypes - contents <- Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar) - return . Just $ FileInfo (stripMediaPrefix path) contentType contents + contentType <- + note (InvalidFile path "Missing content type") $ + ContentTypes.lookup ("/" <> path) contentTypes + contents <- + Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar) + return . Just $ FileInfo (stripMediaPrefix path) contentType contents stripMediaPrefix :: FilePath -> FilePath stripMediaPrefix p = fromMaybe p $ stripPrefix "xl/media/" p readChart :: Zip.Archive -> FilePath -> Parser ChartSpace -readChart ar path = head . fromCursor <$> xmlCursorRequired ar path +readChart ar path = fromFileCursor ar path "chart" -- | readWorkbook pulls the names of the sheets and the defined names -readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches) +readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames, Caches, DateBase) readWorkbook ar = do let wbPath = "xl/workbook.xml" cur <- xmlCursorRequired ar wbPath @@ -335,7 +620,7 @@ let mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)] mkDefinedName c = return - ( head $ attribute "name" c + ( headNote "Missing name attribute" $ attribute "name" c , listToMaybe $ attribute "localSheetId" c , T.concat $ c $/ content) names = @@ -358,12 +643,14 @@ note (InconsistentXlsx $ "Bad pivot table cache in " <> T.pack path) $ parseCache bs return (cacheId, sources) - return (sheets, DefinedNames names, caches) + let dateBase = bool DateBase1900 DateBase1904 . fromMaybe False . listToMaybe $ + cur $/ element (n_ "workbookPr") >=> fromAttribute "date1904" + return (sheets, DefinedNames names, caches, dateBase) getTable :: Zip.Archive -> FilePath -> Parser Table getTable ar fp = do cur <- xmlCursorRequired ar fp - headErr (InvalidFile fp) (fromCursor cur) + headErr (InvalidFile fp "Couldn't parse drawing") (fromCursor cur) worksheetFile :: FilePath -> Relationships -> Text -> RefId -> Parser WorksheetFile worksheetFile parentPath wbRels name rId = @@ -374,7 +661,7 @@ let (dir, file) = splitFileName fp relsPath = dir "_rels" file <.> "rels" c <- xmlCursorOptional ar relsPath - return $ maybe Relationships.empty (setTargetsFrom fp . head . fromCursor) c + return $ maybe Relationships.empty (setTargetsFrom fp . headNote "Missing rels" . fromCursor) c lookupRelPath :: FilePath -> Relationships 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 @@ -1,32 +1,32 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Codec.Xlsx.Parser.Internal - ( ParseException(..) - , n_ - , nodeElNameIs - , FromCursor(..) - , FromAttrVal(..) - , fromAttribute - , fromAttributeDef - , maybeAttribute - , fromElementValue - , maybeElementValue - , maybeElementValueDef - , maybeBoolElementValue - , maybeFromElement - , attrValIs - , contentOrEmpty - , readSuccess - , readFailure - , invalidText - , defaultReadFailure - , boolean - , decimal - , rational - ) where + ( ParseException(..) + , n_ + , nodeElNameIs + , FromCursor(..) + , FromAttrVal(..) + , fromAttribute + , fromAttributeDef + , maybeAttribute + , fromElementValue + , maybeElementValue + , maybeElementValueDef + , maybeBoolElementValue + , maybeFromElement + , attrValIs + , contentOrEmpty + , readSuccess + , readFailure + , invalidText + , defaultReadFailure + , module Codec.Xlsx.Parser.Internal.Util + , module Codec.Xlsx.Parser.Internal.Fast + ) where import Control.Exception (Exception) import Data.Maybe @@ -38,9 +38,8 @@ import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif +import Codec.Xlsx.Parser.Internal.Fast +import Codec.Xlsx.Parser.Internal.Util data ParseException = ParseException String deriving (Show, Typeable, Generic) @@ -154,19 +153,3 @@ , nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main" , namePrefix = Just "n" } - -decimal :: (Monad m, Integral a) => Text -> m a -decimal t = case T.signed T.decimal $ t of - Right (d, leftover) | T.null leftover -> return d - _ -> fail $ "invalid decimal" ++ show t - -rational :: Monad m => Text -> m Double -rational t = case T.rational t of - Right (r, leftover) | T.null leftover -> return r - _ -> fail $ "invalid rational: " ++ show t - -boolean :: Monad m => Text -> m Bool -boolean t = case T.strip t of - "true" -> return True - "false" -> return False - _ -> fail $ "invalid boolean: " ++ show t diff --git a/src/Codec/Xlsx/Parser/Internal/Fast.hs b/src/Codec/Xlsx/Parser/Internal/Fast.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Internal/Fast.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +module Codec.Xlsx.Parser.Internal.Fast + ( FromXenoNode(..) + , collectChildren + , maybeChild + , requireChild + , childList + , maybeFromChild + , fromChild + , fromChildList + , maybeParse + , requireAndParse + , childListAny + , maybeElementVal + , toAttrParser + , parseAttributes + , FromAttrBs(..) + , unexpectedAttrBs + , maybeAttrBs + , maybeAttr + , fromAttr + , fromAttrDef + , contentBs + , contentX + , nsPrefixes + , addPrefix + ) where + +import Control.Applicative +import Control.Arrow (second) +import Control.Exception (Exception, throw) +import Control.Monad (ap, forM, join, liftM) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as SU +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Word (Word8) +import Xeno.DOM hiding (parse) + +import Codec.Xlsx.Parser.Internal.Util + +class FromXenoNode a where + fromXenoNode :: Node -> Either Text a + +newtype ChildCollector a = ChildCollector + { runChildCollector :: [Node] -> Either Text ([Node], a) + } + +instance Functor ChildCollector where + fmap f a = ChildCollector $ \ns -> + second f <$> runChildCollector a ns + +instance Applicative ChildCollector where + pure a = ChildCollector $ \ns -> + return (ns, a) + cf <*> ca = ChildCollector $ \ns -> do + (ns', f) <- runChildCollector cf ns + (ns'', a) <- runChildCollector ca ns' + return (ns'', f a) + +instance Alternative ChildCollector where + empty = ChildCollector $ \_ -> Left "ChildCollector.empty" + ChildCollector f <|> ChildCollector g = ChildCollector $ \ns -> + either (const $ g ns) Right (f ns) + +instance Monad ChildCollector where + return = pure + ChildCollector f >>= g = ChildCollector $ \ns -> + either Left (\(!ns', f') -> runChildCollector (g f') ns') (f ns) + +toChildCollector :: Either Text a -> ChildCollector a +toChildCollector unlifted = + case unlifted of + Right a -> return a + Left e -> ChildCollector $ \_ -> Left e + +collectChildren :: Node -> ChildCollector a -> Either Text a +collectChildren n c = snd <$> runChildCollector c (children n) + +maybeChild :: ByteString -> ChildCollector (Maybe Node) +maybeChild nm = + ChildCollector $ \case + (n:ns) + | name n == nm -> pure (ns, Just n) + ns -> pure (ns, Nothing) + +requireChild :: ByteString -> ChildCollector Node +requireChild nm = + ChildCollector $ \case + (n:ns) + | name n == nm -> pure (ns, n) + _ -> + Left $ "required element " <> T.pack (show nm) <> " was not found" + +childList :: ByteString -> ChildCollector [Node] +childList nm = do + mNode <- maybeChild nm + case mNode of + Just n -> (n:) <$> childList nm + Nothing -> return [] + +maybeFromChild :: (FromXenoNode a) => ByteString -> ChildCollector (Maybe a) +maybeFromChild nm = do + mNode <- maybeChild nm + mapM (toChildCollector . fromXenoNode) mNode + +fromChild :: (FromXenoNode a) => ByteString -> ChildCollector a +fromChild nm = do + n <- requireChild nm + case fromXenoNode n of + Right a -> return a + Left e -> ChildCollector $ \_ -> Left e + +fromChildList :: (FromXenoNode a) => ByteString -> ChildCollector [a] +fromChildList nm = do + mA <- maybeFromChild nm + case mA of + Just a -> (a:) <$> fromChildList nm + Nothing -> return [] + +maybeParse :: ByteString -> (Node -> Either Text a) -> ChildCollector (Maybe a) +maybeParse nm parse = maybeChild nm >>= (toChildCollector . mapM parse) + +requireAndParse :: ByteString -> (Node -> Either Text a) -> ChildCollector a +requireAndParse nm parse = requireChild nm >>= (toChildCollector . parse) + +childListAny :: (FromXenoNode a) => Node -> Either Text [a] +childListAny = mapM fromXenoNode . children + +maybeElementVal :: (FromAttrBs a) => ByteString -> ChildCollector (Maybe a) +maybeElementVal nm = do + mN <- maybeChild nm + fmap join . forM mN $ \n -> + toChildCollector . parseAttributes n $ maybeAttr "val" + +-- Stolen from XML Conduit +newtype AttrParser a = AttrParser + { runAttrParser :: [(ByteString, ByteString)] -> Either Text ( [( ByteString + , ByteString)] + , a) + } + +instance Monad AttrParser where + return a = AttrParser $ \as -> Right (as, a) + (AttrParser f) >>= g = + AttrParser $ \as -> + either Left (\(as', f') -> runAttrParser (g f') as') (f as) +instance Applicative AttrParser where + pure = return + (<*>) = ap +instance Functor AttrParser where + fmap = liftM + +attrError :: Text -> AttrParser a +attrError err = AttrParser $ \_ -> Left err + +toAttrParser :: Either Text a -> AttrParser a +toAttrParser unlifted = + case unlifted of + Right a -> return a + Left e -> AttrParser $ \_ -> Left e + +maybeAttrBs :: ByteString -> AttrParser (Maybe ByteString) +maybeAttrBs attrName = AttrParser $ go id + where + go front [] = Right (front [], Nothing) + go front (a@(nm, val):as) = + if nm == attrName + then Right (front as, Just val) + else go (front . (:) a) as + +requireAttrBs :: ByteString -> AttrParser ByteString +requireAttrBs nm = do + mVal <- maybeAttrBs nm + case mVal of + Just val -> return val + Nothing -> attrError $ "attribute " <> T.pack (show nm) <> " is required" + +unexpectedAttrBs :: Text -> ByteString -> Either Text a +unexpectedAttrBs typ val = + Left $ "Unexpected value for " <> typ <> ": " <> T.pack (show val) + +fromAttr :: FromAttrBs a => ByteString -> AttrParser a +fromAttr nm = do + bs <- requireAttrBs nm + toAttrParser $ fromAttrBs bs + +maybeAttr :: FromAttrBs a => ByteString -> AttrParser (Maybe a) +maybeAttr nm = do + mBs <- maybeAttrBs nm + forM mBs (toAttrParser . fromAttrBs) + +fromAttrDef :: FromAttrBs a => ByteString -> a -> AttrParser a +fromAttrDef nm defVal = fromMaybe defVal <$> maybeAttr nm + +parseAttributes :: Node -> AttrParser a -> Either Text a +parseAttributes n attrParser = + case runAttrParser attrParser (attributes n) of + Left e -> Left e + Right (_, a) -> return a + +class FromAttrBs a where + fromAttrBs :: ByteString -> Either Text a + +instance FromAttrBs ByteString where + fromAttrBs = pure + +instance FromAttrBs Bool where + fromAttrBs x | x == "1" || x == "true" = return True + | x == "0" || x == "false" = return False + | otherwise = unexpectedAttrBs "boolean" x + +instance FromAttrBs Int where + -- it appears that parser in text is more optimized than the one in + -- attoparsec at least as of text-1.2.2.2 and attoparsec-0.13.1.0 + fromAttrBs = decimal . T.decodeLatin1 + +instance FromAttrBs Double where + -- as for rationals + fromAttrBs = rational . T.decodeLatin1 + +instance FromAttrBs Text where + fromAttrBs = replaceEntititesBs + +replaceEntititesBs :: ByteString -> Either Text Text +replaceEntititesBs str = + T.decodeUtf8 . BS.concat <$> findAmp 0 + where + findAmp :: Int -> Either Text [ByteString] + findAmp index = + case elemIndexFrom ampersand str index of + Nothing -> if BS.null text then return [] else return [text] + where text = BS.drop index str + Just fromAmp -> + if BS.null text + then checkEntity fromAmp + else (text:) <$> checkEntity fromAmp + where text = substring str index fromAmp + checkEntity index = + case elemIndexFrom semicolon str index of + Just fromSemi | fromSemi >= index + 3 -> do + entity <- checkElementVal (index + 1) (fromSemi - index - 1) + (BS.singleton entity:) <$> findAmp (fromSemi + 1) + _ -> Left "Unending entity" + checkElementVal index len = + if | len == 2 + && s_index this 0 == 108 -- l + && s_index this 1 == 116 -- t + -> return 60 -- '<' + | len == 2 + && s_index this 0 == 103 -- g + && s_index this 1 == 116 -- t + -> return 62 -- '>' + | len == 3 + && s_index this 0 == 97 -- a + && s_index this 1 == 109 -- m + && s_index this 2 == 112 -- p + -> return 38 -- '&' + | len == 4 + && s_index this 0 == 113 -- q + && s_index this 1 == 117 -- u + && s_index this 2 == 111 -- o + && s_index this 3 == 116 -- t + -> return 34 -- '"' + | len == 4 + && s_index this 0 == 97 -- a + && s_index this 1 == 112 -- p + && s_index this 2 == 111 -- o + && s_index this 3 == 115 -- s + -> return 39 -- '\'' + | otherwise -> Left $ "Bad entity " <> T.pack (show $ (substring str (index-1) (index+len+1))) + where + this = BS.drop index str + ampersand = 38 + semicolon = 59 + +data EntityReplaceException = EntityReplaceException deriving Show + +instance Exception EntityReplaceException + +-- | /O(1)/ 'ByteString' index (subscript) operator, starting from 0. +s_index :: ByteString -> Int -> Word8 +s_index ps n + | n < 0 = throw EntityReplaceException + | n >= BS.length ps = throw EntityReplaceException + | otherwise = ps `SU.unsafeIndex` n +{-# INLINE s_index #-} + +-- | Get index of an element starting from offset. +elemIndexFrom :: Word8 -> ByteString -> Int -> Maybe Int +elemIndexFrom c str offset = fmap (+ offset) (BS.elemIndex c (BS.drop offset str)) +-- Without the INLINE below, the whole function is twice as slow and +-- has linear allocation. See git commit with this comment for +-- results. +{-# INLINE elemIndexFrom #-} + +-- | Get a substring of a string. +substring :: ByteString -> Int -> Int -> ByteString +substring s start end = BS.take (end - start) (BS.drop start s) +{-# INLINE substring #-} + +newtype NsPrefixes = NsPrefixes [(ByteString, ByteString)] + +nsPrefixes :: Node -> NsPrefixes +nsPrefixes root = + NsPrefixes . flip mapMaybe (attributes root) $ \(nm, val) -> + (val, ) <$> BS.stripPrefix "xmlns:" nm + +addPrefix :: NsPrefixes -> ByteString -> (ByteString -> ByteString) +addPrefix (NsPrefixes prefixes) ns = + maybe id (\prefix nm -> BS.concat [prefix, ":", nm]) $ Prelude.lookup ns prefixes + +contentBs :: Node -> ByteString +contentBs n = BS.concat . map toBs $ contents n + where + toBs (Element _) = BS.empty + toBs (Text bs) = bs + toBs (CData bs) = bs + +contentX :: Node -> Either Text Text +contentX = replaceEntititesBs . contentBs 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 @@ -7,10 +7,10 @@ ) where import Control.Applicative -import Control.Arrow ((&&&)) import Data.ByteString.Lazy (ByteString) import Data.Maybe (listToMaybe, maybeToList) import Data.Text (Text) +import Safe (atMay) import Text.XML import Text.XML.Cursor @@ -38,20 +38,26 @@ _pvtColumnGrandTotals <- fromAttributeDef "colGrandTotals" True cur _pvtOutline <- fromAttributeDef "outline" False cur _pvtOutlineData <- fromAttributeDef "outlineData" False cur - let name2CacheField = map (cfName &&& id) cacheFields - _pvtFields = + let pvtFieldsWithHidden = cur $/ element (n_ "pivotFields") &/ element (n_ "pivotField") >=> \c -> do - _pfiName <- fromAttribute "name" c + -- 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") >=> attrValIs "h" True >=> fromAttribute "x" - items = maybe [] cfItems $ lookup _pfiName name2CacheField - _pfiHiddenItems = - [item | (n, item) <- zip [(0 :: Int) ..] items, n `elem` hidden] - return PivotFieldInfo {..} - nToFieldName = zip [0 ..] $ map _pfiName _pvtFields + _pfiHiddenItems = [] + return (PivotFieldInfo {..}, hidden) + _pvtFields = flip map (zip [0.. ] pvtFieldsWithHidden) $ + \(i, (PivotFieldInfo {..}, hidden)) -> + let _pfiHiddenItems = + [item | (n, item) <- zip [(0 :: Int) ..] items, n `elem` hidden] + (_pfiName, items) = case atMay cacheFields i of + Just CacheField{..} -> (Just cfName, cfItems) + Nothing -> (Nothing, []) + in PivotFieldInfo {..} + nToFieldName = zip [0 ..] $ map cfName cacheFields fieldNameList fld = maybeToList $ lookup fld nToFieldName _pvtRowFields = cur $/ element (n_ "rowFields") &/ element (n_ "field") >=> diff --git a/src/Codec/Xlsx/Parser/Internal/Util.hs b/src/Codec/Xlsx/Parser/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser/Internal/Util.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +module Codec.Xlsx.Parser.Internal.Util + ( boolean + , decimal + , rational + ) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T + +decimal :: (Monad m, Integral a) => Text -> m a +decimal t = case T.signed T.decimal $ t of + Right (d, leftover) | T.null leftover -> return d + _ -> fail $ "invalid decimal" ++ show t + +rational :: Monad m => Text -> m Double +rational t = case T.signed T.rational t of + Right (r, leftover) | T.null leftover -> return r + _ -> fail $ "invalid rational: " ++ show t + +boolean :: Monad m => Text -> m Bool +boolean t = case T.strip t of + "true" -> return True + "false" -> return False + _ -> fail $ "invalid boolean: " ++ show t 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 @@ -14,6 +14,9 @@ , CellMap , CellValue(..) , CellFormula(..) + , FormulaExpression(..) + , Cell.SharedFormulaIndex(..) + , Cell.SharedFormulaOptions(..) , Cell(..) , RowHeight(..) , RowProperties (..) @@ -23,6 +26,7 @@ , xlStyles , xlDefinedNames , xlCustomProperties + , xlDateBase -- ** Worksheet , wsColumnsProperties , wsRowPropertiesMap @@ -37,6 +41,7 @@ , wsAutoFilter , wsTables , wsProtection + , wsSharedFormulas -- ** Cells , Cell.cellValue , Cell.cellStyle @@ -48,6 +53,7 @@ , parseStyleSheet -- * Misc , simpleCellFormula + , sharedFormulaByIndex , def , toRows , fromRows @@ -56,6 +62,7 @@ import Control.Exception (SomeException, toException) import Control.Lens.TH +import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as L import Data.Default import Data.Function (on) @@ -95,6 +102,7 @@ | AutomaticHeight !Double -- ^ Row height is set automatically by the program deriving (Eq, Ord, Show, Read, Generic) +instance NFData RowHeight -- | Properties of a row. See §18.3.1.73 "row (Row)" for more details data RowProperties = RowProps @@ -105,6 +113,7 @@ , rowHidden :: Bool -- ^ Whether row is visible or not } deriving (Eq, Ord, Show, Read, Generic) +instance NFData RowProperties instance Default RowProperties where def = RowProps { rowHeight = Nothing @@ -139,6 +148,7 @@ -- ^ Flag indicating if the specified column(s) is set to 'best -- fit'. } deriving (Eq, Show, Generic) +instance NFData ColumnsProperties instance FromCursor ColumnsProperties where fromCursor c = do @@ -151,6 +161,17 @@ cpBestFit <- fromAttributeDef "bestFit" False c return ColumnsProperties {..} +instance FromXenoNode ColumnsProperties where + fromXenoNode root = parseAttributes root $ do + cpMin <- fromAttr "min" + cpMax <- fromAttr "max" + cpWidth <- maybeAttr "width" + cpStyle <- maybeAttr "style" + cpHidden <- fromAttrDef "hidden" False + cpCollapsed <- fromAttrDef "collapsed" False + cpBestFit <- fromAttrDef "bestFit" False + return ColumnsProperties {..} + -- | Xlsx worksheet data Worksheet = Worksheet { _wsColumnsProperties :: [ColumnsProperties] -- ^ column widths @@ -166,7 +187,9 @@ , _wsAutoFilter :: Maybe AutoFilter , _wsTables :: [Table] , _wsProtection :: Maybe SheetProtection + , _wsSharedFormulas :: Map SharedFormulaIndex SharedFormulaOptions } deriving (Eq, Show, Generic) +instance NFData Worksheet makeLenses ''Worksheet @@ -186,19 +209,28 @@ , _wsAutoFilter = Nothing , _wsTables = [] , _wsProtection = Nothing + , _wsSharedFormulas = M.empty } newtype Styles = Styles {unStyles :: L.ByteString} deriving (Eq, Show, Generic) +instance NFData Styles -- | Structured representation of Xlsx file (currently a subset of its contents) data Xlsx = Xlsx - { _xlSheets :: [(Text, Worksheet)] - , _xlStyles :: Styles - , _xlDefinedNames :: DefinedNames - , _xlCustomProperties :: Map Text Variant - } deriving (Eq, Show, Generic) + { _xlSheets :: [(Text, Worksheet)] + , _xlStyles :: Styles + , _xlDefinedNames :: DefinedNames + , _xlCustomProperties :: Map Text Variant + , _xlDateBase :: DateBase + -- ^ date base to use when converting serial value (i.e. 'CellDouble d') + -- into date-time. Default value is 'DateBase1900' + -- + -- See also 18.17.4.1 "Date Conversion for Serial Date-Times" (p. 2067) + } deriving (Eq, Show, Generic) +instance NFData Xlsx + -- | Defined names -- -- Each defined name consists of a name, an optional local sheet ID, and a value. @@ -222,11 +254,12 @@ -- NOTE: Right now this is only a minimal implementation of defined names. newtype DefinedNames = DefinedNames [(Text, Maybe Text, Text)] deriving (Eq, Show, Generic) +instance NFData DefinedNames makeLenses ''Xlsx instance Default Xlsx where - def = Xlsx [] emptyStyles def M.empty + def = Xlsx [] emptyStyles def M.empty DateBase1900 instance Default DefinedNames where def = DefinedNames [] 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,22 +1,32 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.AutoFilter where -import GHC.Generics (Generic) - +import Control.Arrow (first) +import Control.DeepSeq (NFData) import Control.Lens (makeLenses) +import Data.Bool (bool) +import Data.ByteString (ByteString) import Data.Default +import Data.Foldable (asum) import Data.Map (Map) -import Data.Maybe (catMaybes) import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) import Text.XML -import Text.XML.Cursor +import Text.XML.Cursor hiding (bool) +import qualified Xeno.DOM as Xeno import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.ConditionalFormatting (IconSetType) import Codec.Xlsx.Writer.Internal -- | The filterColumn collection identifies a particular column in the @@ -25,20 +35,56 @@ -- criteria specified, then there is no corresponding filterColumn -- collection expressed for that column. -- --- Section 18.3.2.7 "filterColumn (AutoFilter Column)" (p. 1717) +-- See 18.3.2.7 "filterColumn (AutoFilter Column)" (p. 1717) data FilterColumn - = Filters { _fltValues :: [Text]} + = Filters FilterByBlank [FilterCriterion] + | ColorFilter ColorFilterOptions | ACustomFilter CustomFilter - | CustomFiltersOr CustomFilter - CustomFilter - | CustomFiltersAnd CustomFilter - CustomFilter + | CustomFiltersOr CustomFilter CustomFilter + | CustomFiltersAnd CustomFilter CustomFilter + | DynamicFilter DynFilterOptions + | IconFilter (Maybe Int) IconSetType + -- ^ Specifies the icon set and particular icon within that set to + -- filter by. Icon is specified using zero-based index of an icon in + -- an icon set. 'Nothing' means "no icon" + | BottomNFilter EdgeFilterOptions + -- ^ Specifies the bottom N (percent or number of items) to filter by + | TopNFilter EdgeFilterOptions + -- ^ Specifies the top N (percent or number of items) to filter by deriving (Eq, Show, Generic) +instance NFData FilterColumn +data FilterByBlank + = FilterByBlank + | DontFilterByBlank + deriving (Eq, Show, Generic) +instance NFData FilterByBlank + +data FilterCriterion + = FilterValue Text + | FilterDateGroup DateGroup + deriving (Eq, Show, Generic) +instance NFData FilterCriterion + +-- | Used to express a group of dates or times which are used in an +-- AutoFilter criteria +-- +-- Section 18.3.2.4 "dateGroupItem (Date Grouping)" (p. 1714) +data DateGroup + = DateGroupByYear Int + | DateGroupByMonth Int Int + | DateGroupByDay Int Int Int + | DateGroupByHour Int Int Int Int + | DateGroupByMinute Int Int Int Int Int + | DateGroupBySecond Int Int Int Int Int Int + deriving (Eq, Show, Generic) +instance NFData DateGroup + data CustomFilter = CustomFilter { cfltOperator :: CustomFilterOperator , cfltValue :: Text } deriving (Eq, Show, Generic) +instance NFData CustomFilter data CustomFilterOperator = FltrEqual @@ -54,18 +100,182 @@ | FltrNotEqual -- ^ Show results which are not equal to criteria. deriving (Eq, Show, Generic) +instance NFData CustomFilterOperator +data EdgeFilterOptions = EdgeFilterOptions + { _efoUsePercents :: Bool + -- ^ Flag indicating whether or not to filter by percent value of + -- the column. A false value filters by number of items. + , _efoVal :: Double + -- ^ Top or bottom value to use as the filter criteria. + -- Example: "Filter by Top 10 Percent" or "Filter by Top 5 Items" + , _efoFilterVal :: Maybe Double + -- ^ The actual cell value in the range which is used to perform the + -- comparison for this filter. + } deriving (Eq, Show, Generic) +instance NFData EdgeFilterOptions + +-- | Specifies the color to filter by and whether to use the cell's +-- fill or font color in the filter criteria. If the cell's font or +-- fill color does not match the color specified in the criteria, the +-- rows corresponding to those cells are hidden from view. +-- +-- See 18.3.2.1 "colorFilter (Color Filter Criteria)" (p. 1712) +data ColorFilterOptions = ColorFilterOptions + { _cfoCellColor :: Bool + -- ^ Flag indicating whether or not to filter by the cell's fill + -- color. 'True' indicates to filter by cell fill. 'False' indicates + -- to filter by the cell's font color. + -- + -- For rich text in cells, if the color specified appears in the + -- cell at all, it shall be included in the filter. + , _cfoDxfId :: Maybe Int + -- ^ Id of differential format record (dxf) in the Styles Part (see + -- '_styleSheetDxfs') which expresses the color value to filter by. + } deriving (Eq, Show, Generic) +instance NFData ColorFilterOptions + +-- | Specifies dynamic filter criteria. These criteria are considered +-- dynamic because they can change, either with the data itself (e.g., +-- "above average") or with the current system date (e.g., show values +-- for "today"). For any cells whose values do not meet the specified +-- criteria, the corresponding rows shall be hidden from view when the +-- filter is applied. +-- +-- '_dfoMaxVal' shall be required for 'DynFilterTday', +-- 'DynFilterYesterday', 'DynFilterTomorrow', 'DynFilterNextWeek', +-- 'DynFilterThisWeek', 'DynFilterLastWeek', 'DynFilterNextMonth', +-- 'DynFilterThisMonth', 'DynFilterLastMonth', 'DynFilterNextQuarter', +-- 'DynFilterThisQuarter', 'DynFilterLastQuarter', +-- 'DynFilterNextYear', 'DynFilterThisYear', 'DynFilterLastYear', and +-- 'DynFilterYearToDate. +-- +-- The above criteria are based on a value range; that is, if today's +-- date is September 22nd, then the range for thisWeek is the values +-- greater than or equal to September 17 and less than September +-- 24. In the thisWeek range, the lower value is expressed +-- '_dfoval'. The higher value is expressed using '_dfoMmaxVal'. +-- +-- These dynamic filters shall not require '_dfoVal or '_dfoMaxVal': +-- 'DynFilterQ1', 'DynFilterQ2', 'DynFilterQ3', 'DynFilterQ4', +-- 'DynFilterM1', 'DynFilterM2', 'DynFilterM3', 'DynFilterM4', +-- 'DynFilterM5', 'DynFilterM6', 'DynFilterM7', 'DynFilterM8', +-- 'DynFilterM9', 'DynFilterM10', 'DynFilterM11' and 'DynFilterM12'. +-- +-- The above criteria shall not specify the range using valIso and +-- maxValIso because Q1 always starts from M1 to M3, and M1 is always +-- January. +-- +-- These types of dynamic filters shall use valIso and shall not use +-- '_dfoMaxVal': 'DynFilterAboveAverage' and 'DynFilterBelowAverage' +-- +-- /Note:/ Specification lists 'valIso' and 'maxIso' to store datetime +-- values but it appears that Excel doesn't use them and stored them +-- as numeric values (as it does for datetimes in cell values) +-- +-- See 18.3.2.5 "dynamicFilter (Dynamic Filter)" (p. 1715) +data DynFilterOptions = DynFilterOptions + { _dfoType :: DynFilterType + , _dfoVal :: Maybe Double + -- ^ A minimum numeric value for dynamic filter. + , _dfoMaxVal :: Maybe Double + -- ^ A maximum value for dynamic filter. + } deriving (Eq, Show, Generic) +instance NFData DynFilterOptions + +-- | Specifies concrete type of dynamic filter used +-- +-- See 18.18.26 "ST_DynamicFilterType (Dynamic Filter)" (p. 2452) +data DynFilterType + = DynFilterAboveAverage + -- ^ Shows values that are above average. + | DynFilterBelowAverage + -- ^ Shows values that are below average. + | DynFilterLastMonth + -- ^ Shows last month's dates. + | DynFilterLastQuarter + -- ^ Shows last calendar quarter's dates. + | DynFilterLastWeek + -- ^ Shows last week's dates, using Sunday as the first weekday. + | DynFilterLastYear + -- ^ Shows last year's dates. + | DynFilterM1 + -- ^ Shows the dates that are in January, regardless of year. + | DynFilterM10 + -- ^ Shows the dates that are in October, regardless of year. + | DynFilterM11 + -- ^ Shows the dates that are in November, regardless of year. + | DynFilterM12 + -- ^ Shows the dates that are in December, regardless of year. + | DynFilterM2 + -- ^ Shows the dates that are in February, regardless of year. + | DynFilterM3 + -- ^ Shows the dates that are in March, regardless of year. + | DynFilterM4 + -- ^ Shows the dates that are in April, regardless of year. + | DynFilterM5 + -- ^ Shows the dates that are in May, regardless of year. + | DynFilterM6 + -- ^ Shows the dates that are in June, regardless of year. + | DynFilterM7 + -- ^ Shows the dates that are in July, regardless of year. + | DynFilterM8 + -- ^ Shows the dates that are in August, regardless of year. + | DynFilterM9 + -- ^ Shows the dates that are in September, regardless of year. + | DynFilterNextMonth + -- ^ Shows next month's dates. + | DynFilterNextQuarter + -- ^ Shows next calendar quarter's dates. + | DynFilterNextWeek + -- ^ Shows next week's dates, using Sunday as the first weekday. + | DynFilterNextYear + -- ^ Shows next year's dates. + | DynFilterNull + -- ^ Common filter type not available. + | DynFilterQ1 + -- ^ Shows the dates that are in the 1st calendar quarter, + -- regardless of year. + | DynFilterQ2 + -- ^ Shows the dates that are in the 2nd calendar quarter, + -- regardless of year. + | DynFilterQ3 + -- ^ Shows the dates that are in the 3rd calendar quarter, + -- regardless of year. + | DynFilterQ4 + -- ^ Shows the dates that are in the 4th calendar quarter, + -- regardless of year. + | DynFilterThisMonth + -- ^ Shows this month's dates. + | DynFilterThisQuarter + -- ^ Shows this calendar quarter's dates. + | DynFilterThisWeek + -- ^ Shows this week's dates, using Sunday as the first weekday. + | DynFilterThisYear + -- ^ Shows this year's dates. + | DynFilterToday + -- ^ Shows today's dates. + | DynFilterTomorrow + -- ^ Shows tomorrow's dates. + | DynFilterYearToDate + -- ^ Shows the dates between the beginning of the year and today, inclusive. + | DynFilterYesterday + -- ^ Shows yesterday's dates. + deriving (Eq, Show, Generic) +instance NFData DynFilterType + -- | AutoFilter temporarily hides rows based on a filter criteria, -- which is applied column by column to a table of datain the -- worksheet. -- -- TODO: sortState, extList -- --- Section 18.3.1.2 "autoFilter (AutoFilter Settings)" (p. 1596) +-- See 18.3.1.2 "autoFilter (AutoFilter Settings)" (p. 1596) data AutoFilter = AutoFilter { _afRef :: Maybe CellRef , _afFilterColumns :: Map Int FilterColumn } deriving (Eq, Show, Generic) +instance NFData AutoFilter makeLenses ''AutoFilter @@ -90,10 +300,80 @@ return (colId, fcol) return AutoFilter {..} +instance FromXenoNode AutoFilter where + fromXenoNode root = do + _afRef <- parseAttributes root $ maybeAttr "ref" + _afFilterColumns <- + fmap M.fromList . collectChildren root $ fromChildList "filterColumn" + return AutoFilter {..} + +instance FromXenoNode (Int, FilterColumn) where + fromXenoNode root = do + colId <- parseAttributes root $ fromAttr "colId" + fCol <- + collectChildren root $ asum [filters, color, custom, dynamic, icon, top10] + return (colId, fCol) + where + filters = + requireAndParse "filters" $ \node -> do + filterBlank <- + parseAttributes node $ fromAttrDef "blank" DontFilterByBlank + filterCriteria <- childListAny node + return $ Filters filterBlank filterCriteria + color = + requireAndParse "colorFilter" $ \node -> + parseAttributes node $ do + _cfoCellColor <- fromAttrDef "cellColor" True + _cfoDxfId <- maybeAttr "dxfId" + return $ ColorFilter ColorFilterOptions {..} + custom = + requireAndParse "customFilters" $ \node -> do + isAnd <- parseAttributes node $ fromAttrDef "and" False + cfilters <- collectChildren node $ fromChildList "customFilter" + case cfilters of + [f] -> return $ ACustomFilter f + [f1, f2] -> + if isAnd + then return $ CustomFiltersAnd f1 f2 + else return $ CustomFiltersOr f1 f2 + _ -> + Left $ + "expected 1 or 2 custom filters but found " <> + T.pack (show $ length cfilters) + dynamic = + requireAndParse "dynamicFilter" . flip parseAttributes $ do + _dfoType <- fromAttr "type" + _dfoVal <- maybeAttr "val" + _dfoMaxVal <- maybeAttr "maxVal" + return $ DynamicFilter DynFilterOptions {..} + icon = + requireAndParse "iconFilter" . flip parseAttributes $ + IconFilter <$> maybeAttr "iconId" <*> fromAttr "iconSet" + top10 = + requireAndParse "top10" . flip parseAttributes $ do + top <- fromAttrDef "top" True + percent <- fromAttrDef "percent" False + val <- fromAttr "val" + filterVal <- maybeAttr "filterVal" + let opts = EdgeFilterOptions percent val filterVal + if top + then return $ TopNFilter opts + else return $ BottomNFilter opts + +instance FromXenoNode CustomFilter where + fromXenoNode root = + parseAttributes root $ + CustomFilter <$> fromAttrDef "operator" FltrEqual <*> fromAttr "val" + fltColFromNode :: Node -> [FilterColumn] fltColFromNode n | n `nodeElNameIs` (n_ "filters") = do - let _fltValues = cur $/ element (n_ "filter") >=> fromAttribute "val" - return Filters{..} + let filterCriteria = cur $/ anyElement >=> fromCursor + filterBlank <- fromAttributeDef "blank" DontFilterByBlank cur + return $ Filters filterBlank filterCriteria + | n `nodeElNameIs` (n_ "colorFilter") = do + _cfoCellColor <- fromAttributeDef "cellColor" True cur + _cfoDxfId <- maybeAttribute "dxfId" cur + return $ ColorFilter ColorFilterOptions {..} | n `nodeElNameIs` (n_ "customFilters") = do isAnd <- fromAttributeDef "and" False cur let cFilters = cur $/ element (n_ "customFilter") >=> \c -> do @@ -109,10 +389,101 @@ else return $ CustomFiltersOr f1 f2 _ -> fail "bad custom filter" + | n `nodeElNameIs` (n_ "dynamicFilter") = do + _dfoType <- fromAttribute "type" cur + _dfoVal <- maybeAttribute "val" cur + _dfoMaxVal <- maybeAttribute "maxVal" cur + return $ DynamicFilter DynFilterOptions{..} + | n `nodeElNameIs` (n_ "iconFilter") = do + iconId <- maybeAttribute "iconId" cur + iconSet <- fromAttribute "iconSet" cur + return $ IconFilter iconId iconSet + | n `nodeElNameIs` (n_ "top10") = do + top <- fromAttributeDef "top" True cur + let percent = fromAttributeDef "percent" False cur + val = fromAttribute "val" cur + filterVal = maybeAttribute "filterVal" cur + if top + then fmap TopNFilter $ + EdgeFilterOptions <$> percent <*> val <*> filterVal + else fmap BottomNFilter $ + EdgeFilterOptions <$> percent <*> val <*> filterVal | otherwise = fail "no matching nodes" where cur = fromNode n +instance FromCursor FilterCriterion where + fromCursor = filterCriterionFromNode . node + +instance FromXenoNode FilterCriterion where + fromXenoNode root = + case Xeno.name root of + "filter" -> parseAttributes root $ do FilterValue <$> fromAttr "val" + "dateGroupItem" -> + parseAttributes root $ do + grouping <- fromAttr "dateTimeGrouping" + group <- case grouping of + ("year" :: ByteString) -> + DateGroupByYear <$> fromAttr "year" + "month" -> + DateGroupByMonth <$> fromAttr "year" + <*> fromAttr "month" + "day" -> + DateGroupByDay <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + "hour" -> + DateGroupByHour <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + <*> fromAttr "hour" + "minute" -> + DateGroupByMinute <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + <*> fromAttr "hour" + <*> fromAttr "minute" + "second" -> + DateGroupBySecond <$> fromAttr "year" + <*> fromAttr "month" + <*> fromAttr "day" + <*> fromAttr "hour" + <*> fromAttr "minute" + <*> fromAttr "second" + _ -> toAttrParser . Left $ "Unexpected date grouping" + return $ FilterDateGroup group + _ -> Left "Bad FilterCriterion" + +-- TODO: follow the spec about the fact that dategroupitem always go after filter +filterCriterionFromNode :: Node -> [FilterCriterion] +filterCriterionFromNode n + | n `nodeElNameIs` (n_ "filter") = do + v <- fromAttribute "val" cur + return $ FilterValue v + | n `nodeElNameIs` (n_ "dateGroupItem") = do + g <- fromAttribute "dateTimeGrouping" cur + let year = fromAttribute "year" cur + month = fromAttribute "month" cur + day = fromAttribute "day" cur + hour = fromAttribute "hour" cur + minute = fromAttribute "minute" cur + second = fromAttribute "second" cur + FilterDateGroup <$> + case g of + "year" -> DateGroupByYear <$> year + "month" -> DateGroupByMonth <$> year <*> month + "day" -> DateGroupByDay <$> year <*> month <*> day + "hour" -> DateGroupByHour <$> year <*> month <*> day <*> hour + "minute" -> + DateGroupByMinute <$> year <*> month <*> day <*> hour <*> minute + "second" -> + DateGroupBySecond <$> year <*> month <*> day <*> hour <*> minute <*> + second + _ -> fail $ "unexpected dateTimeGrouping " ++ show (g :: Text) + | otherwise = fail "no matching nodes" + where + cur = fromNode n + instance FromAttrVal CustomFilterOperator where fromAttrVal "equal" = readSuccess FltrEqual fromAttrVal "greaterThan" = readSuccess FltrGreaterThan @@ -122,6 +493,98 @@ fromAttrVal "notEqual" = readSuccess FltrNotEqual fromAttrVal t = invalidText "CustomFilterOperator" t +instance FromAttrBs CustomFilterOperator where + fromAttrBs "equal" = return FltrEqual + fromAttrBs "greaterThan" = return FltrGreaterThan + fromAttrBs "greaterThanOrEqual" = return FltrGreaterThanOrEqual + fromAttrBs "lessThan" = return FltrLessThan + fromAttrBs "lessThanOrEqual" = return FltrLessThanOrEqual + fromAttrBs "notEqual" = return FltrNotEqual + fromAttrBs x = unexpectedAttrBs "CustomFilterOperator" x + +instance FromAttrVal FilterByBlank where + fromAttrVal = + fmap (first $ bool DontFilterByBlank FilterByBlank) . fromAttrVal + +instance FromAttrBs FilterByBlank where + fromAttrBs = fmap (bool DontFilterByBlank FilterByBlank) . fromAttrBs + +instance FromAttrVal DynFilterType where + fromAttrVal "aboveAverage" = readSuccess DynFilterAboveAverage + fromAttrVal "belowAverage" = readSuccess DynFilterBelowAverage + fromAttrVal "lastMonth" = readSuccess DynFilterLastMonth + fromAttrVal "lastQuarter" = readSuccess DynFilterLastQuarter + fromAttrVal "lastWeek" = readSuccess DynFilterLastWeek + fromAttrVal "lastYear" = readSuccess DynFilterLastYear + fromAttrVal "M1" = readSuccess DynFilterM1 + fromAttrVal "M10" = readSuccess DynFilterM10 + fromAttrVal "M11" = readSuccess DynFilterM11 + fromAttrVal "M12" = readSuccess DynFilterM12 + fromAttrVal "M2" = readSuccess DynFilterM2 + fromAttrVal "M3" = readSuccess DynFilterM3 + fromAttrVal "M4" = readSuccess DynFilterM4 + fromAttrVal "M5" = readSuccess DynFilterM5 + fromAttrVal "M6" = readSuccess DynFilterM6 + fromAttrVal "M7" = readSuccess DynFilterM7 + fromAttrVal "M8" = readSuccess DynFilterM8 + fromAttrVal "M9" = readSuccess DynFilterM9 + fromAttrVal "nextMonth" = readSuccess DynFilterNextMonth + fromAttrVal "nextQuarter" = readSuccess DynFilterNextQuarter + fromAttrVal "nextWeek" = readSuccess DynFilterNextWeek + fromAttrVal "nextYear" = readSuccess DynFilterNextYear + fromAttrVal "null" = readSuccess DynFilterNull + fromAttrVal "Q1" = readSuccess DynFilterQ1 + fromAttrVal "Q2" = readSuccess DynFilterQ2 + fromAttrVal "Q3" = readSuccess DynFilterQ3 + fromAttrVal "Q4" = readSuccess DynFilterQ4 + fromAttrVal "thisMonth" = readSuccess DynFilterThisMonth + fromAttrVal "thisQuarter" = readSuccess DynFilterThisQuarter + fromAttrVal "thisWeek" = readSuccess DynFilterThisWeek + fromAttrVal "thisYear" = readSuccess DynFilterThisYear + fromAttrVal "today" = readSuccess DynFilterToday + fromAttrVal "tomorrow" = readSuccess DynFilterTomorrow + fromAttrVal "yearToDate" = readSuccess DynFilterYearToDate + fromAttrVal "yesterday" = readSuccess DynFilterYesterday + fromAttrVal t = invalidText "DynFilterType" t + +instance FromAttrBs DynFilterType where + fromAttrBs "aboveAverage" = return DynFilterAboveAverage + fromAttrBs "belowAverage" = return DynFilterBelowAverage + fromAttrBs "lastMonth" = return DynFilterLastMonth + fromAttrBs "lastQuarter" = return DynFilterLastQuarter + fromAttrBs "lastWeek" = return DynFilterLastWeek + fromAttrBs "lastYear" = return DynFilterLastYear + fromAttrBs "M1" = return DynFilterM1 + fromAttrBs "M10" = return DynFilterM10 + fromAttrBs "M11" = return DynFilterM11 + fromAttrBs "M12" = return DynFilterM12 + fromAttrBs "M2" = return DynFilterM2 + fromAttrBs "M3" = return DynFilterM3 + fromAttrBs "M4" = return DynFilterM4 + fromAttrBs "M5" = return DynFilterM5 + fromAttrBs "M6" = return DynFilterM6 + fromAttrBs "M7" = return DynFilterM7 + fromAttrBs "M8" = return DynFilterM8 + fromAttrBs "M9" = return DynFilterM9 + fromAttrBs "nextMonth" = return DynFilterNextMonth + fromAttrBs "nextQuarter" = return DynFilterNextQuarter + fromAttrBs "nextWeek" = return DynFilterNextWeek + fromAttrBs "nextYear" = return DynFilterNextYear + fromAttrBs "null" = return DynFilterNull + fromAttrBs "Q1" = return DynFilterQ1 + fromAttrBs "Q2" = return DynFilterQ2 + fromAttrBs "Q3" = return DynFilterQ3 + fromAttrBs "Q4" = return DynFilterQ4 + fromAttrBs "thisMonth" = return DynFilterThisMonth + fromAttrBs "thisQuarter" = return DynFilterThisQuarter + fromAttrBs "thisWeek" = return DynFilterThisWeek + fromAttrBs "thisYear" = return DynFilterThisYear + fromAttrBs "today" = return DynFilterToday + fromAttrBs "tomorrow" = return DynFilterTomorrow + fromAttrBs "yearToDate" = return DynFilterYearToDate + fromAttrBs "yesterday" = return DynFilterYesterday + fromAttrBs x = unexpectedAttrBs "DynFilterType" x + {------------------------------------------------------------------------------- Rendering -------------------------------------------------------------------------------} @@ -139,10 +602,11 @@ ] fltColToElement :: FilterColumn -> Element -fltColToElement Filters {..} = - elementListSimple - (n_ "filters") - [leafElement (n_ "filter") ["val" .= v] | v <- _fltValues] +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 fltColToElement (ACustomFilter f) = elementListSimple (n_ "customFilters") [toElement (n_ "customFilter") f] fltColToElement (CustomFiltersOr f1 f2) = @@ -154,7 +618,65 @@ (n_ "customFilters") ["and" .= True] [toElement (n_ "customFilter") f | f <- [f1, f2]] +fltColToElement (DynamicFilter opts) = toElement (n_ "dynamicFilter") opts +fltColToElement (IconFilter iconId iconSet) = + leafElement (n_ "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") $ + ["top" .= top, "percent" .= _efoUsePercents, "val" .= _efoVal] ++ + catMaybes ["filterVal" .=? _efoFilterVal] + +filterCriterionToElement :: FilterCriterion -> Element +filterCriterionToElement (FilterValue v) = + leafElement (n_ "filter") ["val" .= v] +filterCriterionToElement (FilterDateGroup (DateGroupByYear y)) = + leafElement + (n_ "dateGroupItem") + ["dateTimeGrouping" .= ("year" :: Text), "year" .= y] +filterCriterionToElement (FilterDateGroup (DateGroupByMonth y m)) = + leafElement + (n_ "dateGroupItem") + ["dateTimeGrouping" .= ("month" :: Text), "year" .= y, "month" .= m] +filterCriterionToElement (FilterDateGroup (DateGroupByDay y m d)) = + leafElement + (n_ "dateGroupItem") + ["dateTimeGrouping" .= ("day" :: Text), "year" .= y, "month" .= m, "day" .= d] +filterCriterionToElement (FilterDateGroup (DateGroupByHour y m d h)) = + leafElement + (n_ "dateGroupItem") + [ "dateTimeGrouping" .= ("hour" :: Text) + , "year" .= y + , "month" .= m + , "day" .= d + , "hour" .= h + ] +filterCriterionToElement (FilterDateGroup (DateGroupByMinute y m d h mi)) = + leafElement + (n_ "dateGroupItem") + [ "dateTimeGrouping" .= ("minute" :: Text) + , "year" .= y + , "month" .= m + , "day" .= d + , "hour" .= h + , "minute" .= mi + ] +filterCriterionToElement (FilterDateGroup (DateGroupBySecond y m d h mi s)) = + leafElement + (n_ "dateGroupItem") + [ "dateTimeGrouping" .= ("second" :: Text) + , "year" .= y + , "month" .= m + , "day" .= d + , "hour" .= h + , "minute" .= mi + , "second" .= s + ] + instance ToElement CustomFilter where toElement nm CustomFilter {..} = leafElement nm ["operator" .= cfltOperator, "val" .= cfltValue] @@ -166,3 +688,55 @@ toAttrVal FltrLessThan = "lessThan" toAttrVal FltrLessThanOrEqual = "lessThanOrEqual" toAttrVal FltrNotEqual = "notEqual" + +instance ToAttrVal FilterByBlank where + toAttrVal FilterByBlank = toAttrVal True + toAttrVal DontFilterByBlank = toAttrVal False + +instance ToElement ColorFilterOptions where + toElement nm ColorFilterOptions {..} = + leafElement nm $ + catMaybes ["cellColor" .=? justFalse _cfoCellColor, "dxfId" .=? _cfoDxfId] + +instance ToElement DynFilterOptions where + toElement nm DynFilterOptions {..} = + leafElement nm $ + ["type" .= _dfoType] ++ + catMaybes ["val" .=? _dfoVal, "maxVal" .=? _dfoMaxVal] + +instance ToAttrVal DynFilterType where + toAttrVal DynFilterAboveAverage = "aboveAverage" + toAttrVal DynFilterBelowAverage = "belowAverage" + toAttrVal DynFilterLastMonth = "lastMonth" + toAttrVal DynFilterLastQuarter = "lastQuarter" + toAttrVal DynFilterLastWeek = "lastWeek" + toAttrVal DynFilterLastYear = "lastYear" + toAttrVal DynFilterM1 = "M1" + toAttrVal DynFilterM10 = "M10" + toAttrVal DynFilterM11 = "M11" + toAttrVal DynFilterM12 = "M12" + toAttrVal DynFilterM2 = "M2" + toAttrVal DynFilterM3 = "M3" + toAttrVal DynFilterM4 = "M4" + toAttrVal DynFilterM5 = "M5" + toAttrVal DynFilterM6 = "M6" + toAttrVal DynFilterM7 = "M7" + toAttrVal DynFilterM8 = "M8" + toAttrVal DynFilterM9 = "M9" + toAttrVal DynFilterNextMonth = "nextMonth" + toAttrVal DynFilterNextQuarter = "nextQuarter" + toAttrVal DynFilterNextWeek = "nextWeek" + toAttrVal DynFilterNextYear = "nextYear" + toAttrVal DynFilterNull = "null" + toAttrVal DynFilterQ1 = "Q1" + toAttrVal DynFilterQ2 = "Q2" + toAttrVal DynFilterQ3 = "Q3" + toAttrVal DynFilterQ4 = "Q4" + toAttrVal DynFilterThisMonth = "thisMonth" + toAttrVal DynFilterThisQuarter = "thisQuarter" + toAttrVal DynFilterThisWeek = "thisWeek" + toAttrVal DynFilterThisYear = "thisYear" + toAttrVal DynFilterToday = "today" + toAttrVal DynFilterTomorrow = "tomorrow" + toAttrVal DynFilterYearToDate = "yearToDate" + toAttrVal DynFilterYesterday = "yesterday" 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 @@ -4,7 +4,13 @@ {-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Cell ( CellFormula(..) + , FormulaExpression(..) , simpleCellFormula + , sharedFormulaByIndex + , SharedFormulaIndex(..) + , SharedFormulaOptions(..) + , formulaDataFromCursor + , applySharedFormulaOpts , Cell(..) , cellStyle , cellValue @@ -13,11 +19,14 @@ , CellMap ) where +import Control.Arrow (first) import Control.Lens.TH (makeLenses) +import Control.DeepSeq (NFData) import Data.Default import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, listToMaybe) +import Data.Monoid ((<>)) import Data.Text (Text) import GHC.Generics (Generic) import Text.XML @@ -30,28 +39,59 @@ -- | Formula for the cell. -- --- TODO: array. dataTable and shared formula types support +-- TODO: array, dataTable formula types support -- -- See 18.3.1.40 "f (Formula)" (p. 1636) -data CellFormula - = NormalCellFormula - { _cellfExpression :: Formula - , _cellfAssignsToName :: Bool +data CellFormula = CellFormula + { _cellfExpression :: FormulaExpression + , _cellfAssignsToName :: Bool -- ^ Specifies that this formula assigns a value to a name. - , _cellfCalculate :: Bool + , _cellfCalculate :: Bool -- ^ Indicates that this formula needs to be recalculated -- the next time calculation is performed. -- [/Example/: This is always set on volatile functions, -- like =RAND(), and circular references. /end example/] - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic) +instance NFData CellFormula +-- | formula type with type-specific options +data FormulaExpression + = NormalFormula Formula + | SharedFormula SharedFormulaIndex + deriving (Eq, Show, Generic) +instance NFData FormulaExpression + +defaultFormulaType :: Text +defaultFormulaType = "normal" + +-- | index of shared formula in worksheet's 'wsSharedFormulas' +-- property +newtype SharedFormulaIndex = SharedFormulaIndex Int + deriving (Eq, Ord, Show, Generic) +instance NFData SharedFormulaIndex + +data SharedFormulaOptions = SharedFormulaOptions + { _sfoRef :: CellRef + , _sfoExpression :: Formula + } + deriving (Eq, Show, Generic) +instance NFData SharedFormulaOptions + simpleCellFormula :: Text -> CellFormula -simpleCellFormula expr = NormalCellFormula - { _cellfExpression = Formula expr +simpleCellFormula expr = CellFormula + { _cellfExpression = NormalFormula $ Formula expr , _cellfAssignsToName = False , _cellfCalculate = False } +sharedFormulaByIndex :: SharedFormulaIndex -> CellFormula +sharedFormulaByIndex si = + CellFormula + { _cellfExpression = SharedFormula si + , _cellfAssignsToName = False + , _cellfCalculate = False + } + -- | Currently cell details include cell values, style ids and cell -- formulas (inline strings from @\@ subelements are ignored) data Cell = Cell @@ -60,6 +100,7 @@ , _cellComment :: Maybe Comment , _cellFormula :: Maybe CellFormula } deriving (Eq, Show, Generic) +instance NFData Cell instance Default Cell where def = Cell Nothing Nothing Nothing Nothing @@ -75,31 +116,59 @@ Parsing -------------------------------------------------------------------------------} -instance FromCursor CellFormula where - fromCursor cur = do - t <- fromAttributeDef "t" "normal" cur - typedCellFormula t cur - -typedCellFormula :: Text -> Cursor -> [CellFormula] -typedCellFormula "normal" cur = do - _cellfExpression <- fromCursor cur +formulaDataFromCursor :: + Cursor -> [(CellFormula, Maybe (SharedFormulaIndex, SharedFormulaOptions))] +formulaDataFromCursor cur = do _cellfAssignsToName <- fromAttributeDef "bx" False cur _cellfCalculate <- fromAttributeDef "ca" False cur - return NormalCellFormula {..} -typedCellFormula _ _ = fail "parseable cell formula type was not found" + t <- fromAttributeDef "t" defaultFormulaType cur + (_cellfExpression, shared) <- + case t of + d| d == defaultFormulaType -> do + formula <- fromCursor cur + return (NormalFormula formula, Nothing) + "shared" -> do + let expr = listToMaybe $ fromCursor cur + ref <- maybeAttribute "ref" cur + si <- fromAttribute "si" cur + return (SharedFormula si, (,) <$> pure si <*> + (SharedFormulaOptions <$> ref <*> expr)) + _ -> + fail $ "Unexpected formula type" ++ show t + return (CellFormula {..}, shared) +instance FromAttrVal SharedFormulaIndex where + fromAttrVal = fmap (first SharedFormulaIndex) . fromAttrVal + +instance FromAttrBs SharedFormulaIndex where + fromAttrBs = fmap SharedFormulaIndex . fromAttrBs + {------------------------------------------------------------------------------- Rendering -------------------------------------------------------------------------------} instance ToElement CellFormula where - toElement nm NormalCellFormula {..} = - let formulaEl = toElement nm _cellfExpression - in formulaEl - { elementAttributes = - M.fromList $ - catMaybes - [ "bx" .=? justTrue _cellfAssignsToName - , "ca" .=? justTrue _cellfCalculate - ] - } + toElement nm CellFormula {..} = + formulaEl {elementAttributes = elementAttributes formulaEl <> commonAttrs} + where + commonAttrs = + M.fromList $ + catMaybes + [ "bx" .=? justTrue _cellfAssignsToName + , "ca" .=? justTrue _cellfCalculate + , "t" .=? justNonDef defaultFormulaType fType + ] + (formulaEl, fType) = + case _cellfExpression of + NormalFormula f -> (toElement nm f, defaultFormulaType) + SharedFormula si -> (leafElement nm ["si" .= si], "shared") + +instance ToAttrVal SharedFormulaIndex where + toAttrVal (SharedFormulaIndex si) = toAttrVal si + +applySharedFormulaOpts :: SharedFormulaOptions -> Element -> Element +applySharedFormulaOpts SharedFormulaOptions {..} el = + el + { elementAttributes = elementAttributes el <> M.fromList ["ref" .= _sfoRef] + , elementNodes = NodeContent (unFormula _sfoExpression) : elementNodes el + } diff --git a/src/Codec/Xlsx/Types/Comment.hs b/src/Codec/Xlsx/Types/Comment.hs --- a/src/Codec/Xlsx/Types/Comment.hs +++ b/src/Codec/Xlsx/Types/Comment.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Comment where +import Control.DeepSeq (NFData) import Data.Text (Text) import GHC.Generics (Generic) @@ -20,3 +21,4 @@ -- ^ comment author , _commentVisible :: Bool } deriving (Eq, Show, Generic) +instance NFData Comment 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Common @@ -11,8 +10,13 @@ , fromRange , SqRef(..) , XlsxText(..) + , xlsxTextToCellValue , Formula(..) , CellValue(..) + , ErrorType(..) + , DateBase(..) + , dateFromNumber + , dateToNumber , int2col , col2int ) where @@ -20,20 +24,21 @@ import GHC.Generics (Generic) import Control.Arrow -import Control.Monad (guard) +import Control.DeepSeq (NFData) +import Control.Monad (forM, guard) +import qualified Data.ByteString as BS import Data.Char import Data.Ix (inRange) import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Calendar (Day, addDays, diffDays, fromGregorian) +import Data.Time.Clock (UTCTime(UTCTime), picosecondsToDiffTime) import Safe import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.RichText import Codec.Xlsx.Writer.Internal @@ -61,6 +66,8 @@ { unCellRef :: Text } deriving (Eq, Ord, Show, Generic) +instance NFData CellRef + -- | Render position in @(row, col)@ format to an Excel reference. -- -- > mkCellRef (2, 4) == "D2" @@ -112,6 +119,8 @@ newtype SqRef = SqRef [CellRef] deriving (Eq, Ord, Show, Generic) +instance NFData SqRef + -- | Common type containing either simple string or rich formatted text. -- Used in @si@, @comment@ and @is@ elements -- @@ -134,12 +143,20 @@ | XlsxRichText [RichTextRun] deriving (Eq, Ord, Show, Generic) +instance NFData XlsxText + +xlsxTextToCellValue :: XlsxText -> CellValue +xlsxTextToCellValue (XlsxText txt) = CellText txt +xlsxTextToCellValue (XlsxRichText rich) = CellRich rich + -- | A formula -- -- See 18.18.35 "ST_Formula (Formula)" (p. 2457) newtype Formula = Formula {unFormula :: Text} deriving (Eq, Ord, Show, Generic) +instance NFData Formula + -- | Cell values include text, numbers and booleans, -- standard includes date format also but actually dates -- are represented by numbers with a date format assigned @@ -149,8 +166,109 @@ | CellDouble Double | CellBool Bool | CellRich [RichTextRun] + | CellError ErrorType deriving (Eq, Ord, Show, Generic) +instance NFData CellValue + +-- | The evaluation of an expression can result in an error having one +-- of a number of error values. +-- +-- See Annex L, L.2.16.8 "Error values" (p. 4764) +data ErrorType + = ErrorDiv0 + -- ^ @#DIV/0!@ - Intended to indicate when any number, including + -- zero, is divided by zero. + | ErrorNA + -- ^ @#N/A@ - Intended to indicate when a designated value is not + -- available. For example, some functions, such as @SUMX2MY2@, + -- perform a series of operations on corresponding elements in two + -- arrays. If those arrays do not have the same number of elements, + -- then for some elements in the longer array, there are no + -- corresponding elements in the shorter one; that is, one or more + -- values in the shorter array are not available. This error value + -- can be produced by calling the function @NA@. + | ErrorName + -- ^ @#NAME?@ - Intended to indicate when what looks like a name is + -- used, but no such name has been defined. For example, @XYZ/3@, + -- where @XYZ@ is not a defined name. @Total is & A10@, where + -- neither @Total@ nor @is@ is a defined name. Presumably, @"Total + -- is " & A10@ was intended. @SUM(A1C10)@, where the range @A1:C10@ + -- was intended. + | ErrorNull + -- ^ @#NULL!@ - Intended to indicate when two areas are required to + -- intersect, but do not. For example, In the case of @SUM(B1 C1)@, + -- the space between @B1@ and @C1@ is treated as the binary + -- intersection operator, when a comma was intended. + | ErrorNum + -- ^ @#NUM!@ - Intended to indicate when an argument to a function + -- has a compatible type, but has a value that is outside the domain + -- over which that function is defined. (This is known as a domain + -- error.) For example, Certain calls to @ASIN@, @ATANH@, @FACT@, + -- and @SQRT@ might result in domain errors. Intended to indicate + -- that the result of a function cannot be represented in a value of + -- the specified type, typically due to extreme magnitude. (This is + -- known as a range error.) For example, @FACT(1000)@ might result + -- in a range error. + | ErrorRef + -- ^ @#REF!@ - Intended to indicate when a cell reference is + -- invalid. For example, If a formula contains a reference to a + -- cell, and then the row or column containing that cell is deleted, + -- a @#REF!@ error results. If a worksheet does not support 20,001 + -- columns, @OFFSET(A1,0,20000)@ results in a @#REF!@ error. + | ErrorValue + -- ^ @#VALUE!@ - Intended to indicate when an incompatible type + -- argument is passed to a function, or an incompatible type operand + -- is used with an operator. For example, In the case of a function + -- argument, a number was expected, but text was provided. In the + -- case of @1+"ABC"@, the binary addition operator is not defined for + -- text. + deriving (Eq, Ord, Show, Generic) + +instance NFData ErrorType + +-- | Specifies date base used for conversion of serial values to and +-- from datetime values +-- +-- See Annex L, L.2.16.9.1 "Date Conversion for Serial Values" (p. 4765) +data DateBase + = DateBase1900 + -- ^ 1900 date base system, the lower limit is January 1, -9999 + -- 00:00:00, which has serial value -4346018. The upper-limit is + -- December 31, 9999, 23:59:59, which has serial value + -- 2,958,465.9999884. The base date for this date base system is + -- December 30, 1899, which has a serial value of 0. + | DateBase1904 + -- ^ 1904 backward compatibility date-base system, the lower limit + -- is January 1, 1904, 00:00:00, which has serial value 0. The upper + -- limit is December 31, 9999, 23:59:59, which has serial value + -- 2,957,003.9999884. The base date for this date base system is + -- January 1, 1904, which has a serial value of 0. + deriving (Eq, Show, Generic) +instance NFData DateBase + +baseDate :: DateBase -> Day +baseDate DateBase1900 = fromGregorian 1899 12 30 +baseDate DateBase1904 = fromGregorian 1904 1 1 + +-- | Convertts serial value into datetime according to the specified +-- date base +-- +-- > show (dateFromNumber DateBase1900 42929.75) == "2017-07-13 18:00:00 UTC" +dateFromNumber :: RealFrac t => DateBase -> t -> UTCTime +dateFromNumber b d = UTCTime day diffTime + where + (numberOfDays, fractionOfOneDay) = properFraction d + day = addDays numberOfDays $ baseDate b + diffTime = picosecondsToDiffTime (round (fractionOfOneDay * 24*60*60*1E12)) + +-- | Converts datetime into serial value +dateToNumber :: Fractional a => DateBase -> UTCTime -> a +dateToNumber b (UTCTime day diffTime) = numberOfDays + fractionOfOneDay + where + numberOfDays = fromIntegral (diffDays day $ baseDate b) + fractionOfOneDay = realToFrac diffTime / (24 * 60 * 60) + {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} @@ -169,18 +287,70 @@ _ -> fail "invalid item" +instance FromXenoNode XlsxText where + fromXenoNode root = do + (mCh, rs) <- + collectChildren root $ (,) <$> maybeChild "t" <*> fromChildList "r" + mT <- mapM contentX mCh + case mT of + Just t -> return $ XlsxText t + Nothing -> + case rs of + [] -> Left $ "missing rich text subelements" + _ -> return $ XlsxRichText rs + instance FromAttrVal CellRef where fromAttrVal = fmap (first CellRef) . fromAttrVal +instance FromAttrBs CellRef where + -- we presume that cell references contain only latin letters, + -- numbers and colon + fromAttrBs = pure . CellRef . T.decodeLatin1 + instance FromAttrVal SqRef where fromAttrVal t = do rs <- mapM (fmap fst . fromAttrVal) $ T.split (== ' ') t readSuccess $ SqRef rs +instance FromAttrBs SqRef where + fromAttrBs bs = do + -- split on space + rs <- forM (BS.split 32 bs) fromAttrBs + return $ SqRef rs + -- | See @ST_Formula@, p. 3873 instance FromCursor Formula where fromCursor cur = [Formula . T.concat $ cur $/ content] +instance FromXenoNode Formula where + fromXenoNode = fmap Formula . contentX + +instance FromAttrVal Formula where + fromAttrVal t = readSuccess $ Formula t + +instance FromAttrBs Formula where + fromAttrBs = fmap Formula . fromAttrBs + +instance FromAttrVal ErrorType where + fromAttrVal "#DIV/0!" = readSuccess ErrorDiv0 + fromAttrVal "#N/A" = readSuccess ErrorNA + fromAttrVal "#NAME?" = readSuccess ErrorName + fromAttrVal "#NULL!" = readSuccess ErrorNull + fromAttrVal "#NUM!" = readSuccess ErrorNum + fromAttrVal "#REF!" = readSuccess ErrorRef + fromAttrVal "#VALUE!" = readSuccess ErrorValue + fromAttrVal t = invalidText "ErrorType" t + +instance FromAttrBs ErrorType where + fromAttrBs "#DIV/0!" = return ErrorDiv0 + fromAttrBs "#N/A" = return ErrorNA + fromAttrBs "#NAME?" = return ErrorName + fromAttrBs "#NULL!" = return ErrorNull + fromAttrBs "#NUM!" = return ErrorNum + fromAttrBs "#REF!" = return ErrorRef + fromAttrBs "#VALUE!" = return ErrorValue + fromAttrBs x = unexpectedAttrBs "ErrorType" x + {------------------------------------------------------------------------------- Rendering -------------------------------------------------------------------------------} @@ -206,3 +376,12 @@ -- | See @ST_Formula@, p. 3873 instance ToElement Formula where toElement nm (Formula txt) = elementContent nm txt + +instance ToAttrVal ErrorType where + toAttrVal ErrorDiv0 = "#DIV/0!" + toAttrVal ErrorNA = "#N/A" + toAttrVal ErrorName = "#NAME?" + toAttrVal ErrorNull = "#NULL!" + toAttrVal ErrorNum = "#NUM!" + toAttrVal ErrorRef = "#REF!" + toAttrVal ErrorValue = "#VALUE!" 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,34 +1,65 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types.ConditionalFormatting ( ConditionalFormatting , CfRule(..) + , NStdDev(..) + , Inclusion(..) + , CfValue(..) + , MinCfValue(..) + , MaxCfValue(..) , Condition(..) , OperatorExpression(..) , TimePeriod(..) + , IconSetOptions(..) + , IconSetType(..) + , DataBarOptions(..) + , dataBarWithColor -- * Lenses -- ** CfRule , cfrCondition , cfrDxfId , cfrPriority , cfrStopIfTrue + -- ** IconSetOptions + , isoIconSet + , isoValues + , isoReverse + , isoShowValue + -- ** DataBarOptions + , dboMaxLength + , dboMinLength + , dboShowValue + , dboMinimum + , dboMaximum + , dboColor -- * Misc , topCfPriority ) where +import Control.Arrow (first, right) +import Control.DeepSeq (NFData) import Control.Lens (makeLenses) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.Default import Data.Map (Map) import qualified Data.Map as M import Data.Maybe +import Data.Monoid ((<>)) import Data.Text (Text) +import qualified Data.Text as T import GHC.Generics (Generic) import Text.XML -import Text.XML.Cursor +import Text.XML.Cursor hiding (bool) +import qualified Xeno.DOM as Xeno import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Common +import Codec.Xlsx.Types.StyleSheet (Color) import Codec.Xlsx.Writer.Internal -- | Logical operation used in 'CellIs' condition @@ -49,6 +80,7 @@ | OpNotContains Formula -- ^ 'Does not contain' operator | OpNotEqual Formula -- ^ 'Not equal to' operator deriving (Eq, Ord, Show, Generic) +instance NFData OperatorExpression -- | Used in a "contains dates" conditional formatting rule. -- These are dynamic time periods, which change based on @@ -67,18 +99,55 @@ | PerTomorrow -- ^ Tomorrow's date. | PerYesterday -- ^ Yesterday's date. deriving (Eq, Ord, Show, Generic) +instance NFData TimePeriod +-- | Flag indicating whether the 'aboveAverage' and 'belowAverage' +-- criteria is inclusive of the average itself, or exclusive of that +-- value. +data Inclusion + = Inclusive + | Exclusive + deriving (Eq, Ord, Show, Generic) +instance NFData Inclusion + +-- | The number of standard deviations to include above or below the +-- average in the conditional formatting rule. +newtype NStdDev = + NStdDev Int + deriving (Eq, Ord, Show, Generic) +instance NFData NStdDev + -- | Conditions which could be used for conditional formatting -- -- See 18.18.12 "ST_CfType (Conditional Format Type)" (p. 2443) data Condition + -- | This conditional formatting rule highlights cells that are + -- above (or maybe equal to) the average for all values in the range. + = AboveAverage Inclusion (Maybe NStdDev) -- | This conditional formatting rule highlights cells in the -- range that begin with the given text. Equivalent to -- using the LEFT() sheet function and comparing values. - = BeginsWith Text + | BeginsWith Text + -- | This conditional formatting rule highlights cells that are + -- below the average for all values in the range. + | BelowAverage Inclusion (Maybe NStdDev) + -- | This conditional formatting rule highlights cells whose + -- values fall in the bottom N percent bracket. + | BottomNPercent Int + -- | This conditional formatting rule highlights cells whose + -- values fall in the bottom N bracket. + | BottomNValues Int -- | This conditional formatting rule compares a cell value -- to a formula calculated result, using an operator. | CellIs OperatorExpression + -- | This conditional formatting rule creates a gradated color + -- scale on the cells with specified colors for specified minimum + -- and maximum. + | ColorScale2 MinCfValue Color MaxCfValue Color + -- | This conditional formatting rule creates a gradated color + -- scale on the cells with specified colors for specified minimum, + -- midpoint and maximum. + | ColorScale3 MinCfValue Color CfValue Color MaxCfValue Color -- | This conditional formatting rule highlights cells that -- are completely blank. Equivalent of using LEN(TRIM()). -- This means that if the cell contains only characters @@ -94,6 +163,9 @@ -- sheet function to determine whether the cell contains -- the text. | ContainsText Text + -- | This conditional formatting rule displays a gradated data bar + -- in the range of cells. + | DataBar DataBarOptions -- | This conditional formatting rule highlights cells -- without formula errors. Equivalent to using ISERROR() -- sheet function to determine if there is a formula error. @@ -108,6 +180,9 @@ -- not contain given text. Equivalent to using the -- SEARCH() sheet function. | DoesNotContainText Text + -- | This conditional formatting rule highlights duplicated + -- values. + | DuplicateValues -- | This conditional formatting rule highlights cells ending -- with given text. Equivalent to using the RIGHT() sheet -- function and comparing values. @@ -116,6 +191,9 @@ -- evaluate. When the formula result is true, the cell is -- highlighted. | Expression Formula + -- | This conditional formatting rule applies icons to cells + -- according to their values. + | IconSet IconSetOptions -- | This conditional formatting rule highlights cells -- containing dates in the specified time period. The -- underlying value of the cell is evaluated, therefore the @@ -124,15 +202,149 @@ -- value 38913 the conditional format shall be applied if -- the rule requires a value of 7/14/2006. | InTimePeriod TimePeriod - -- TODO: aboveAverage - -- TODO: colorScale - -- TODO: dataBar - -- TODO: iconSet - -- TODO: timePeriod - -- TODO: top10 - -- TODO: uniqueValues + -- | This conditional formatting rule highlights cells whose + -- values fall in the top N percent bracket. + | TopNPercent Int + -- | This conditional formatting rule highlights cells whose + -- values fall in the top N bracket. + | TopNValues Int + -- | This conditional formatting rule highlights unique values in the range. + | UniqueValues deriving (Eq, Ord, Show, Generic) +instance NFData Condition +-- | Describes the values of the interpolation points in a color +-- scale, data bar or icon set conditional formatting rules. +-- +-- See 18.3.1.11 "cfvo (Conditional Format Value Object)" (p. 1604) +data CfValue + = CfValue Double + | CfPercent Double + | CfPercentile Double + | CfFormula Formula + deriving (Eq, Ord, Show, Generic) +instance NFData CfValue + +data MinCfValue + = CfvMin + | MinCfValue CfValue + deriving (Eq, Ord, Show, Generic) +instance NFData MinCfValue + +data MaxCfValue + = CfvMax + | MaxCfValue CfValue + deriving (Eq, Ord, Show, Generic) +instance NFData MaxCfValue + +-- | internal type for (de)serialization +-- +-- See 18.18.13 "ST_CfvoType (Conditional Format Value Object Type)" (p. 2445) +data CfvType = + CfvtFormula + -- ^ The minimum\/ midpoint \/ maximum value for the gradient is + -- determined by a formula. + | CfvtMax + -- ^ Indicates that the maximum value in the range shall be used as + -- the maximum value for the gradient. + | CfvtMin + -- ^ Indicates that the minimum value in the range shall be used as + -- the minimum value for the gradient. + | CfvtNum + -- ^ Indicates that the minimum \/ midpoint \/ maximum value for the + -- gradient is specified by a constant numeric value. + | CfvtPercent + -- ^ Value indicates a percentage between the minimum and maximum + -- values in the range shall be used as the minimum \/ midpoint \/ + -- maximum value for the gradient. + | CfvtPercentile + -- ^ Value indicates a percentile ranking in the range shall be used + -- as the minimum \/ midpoint \/ maximum value for the gradient. + deriving (Eq, Ord, Show, Generic) +instance NFData CfvType + +-- | Describes an icon set conditional formatting rule. +-- +-- See 18.3.1.49 "iconSet (Icon Set)" (p. 1645) +data IconSetOptions = IconSetOptions + { _isoIconSet :: IconSetType + -- ^ icon set used, default value is 'IconSet3Trafficlights1' + , _isoValues :: [CfValue] + -- ^ values describing per icon ranges + , _isoReverse :: Bool + -- ^ reverses the default order of the icons in the specified icon set + , _isoShowValue :: Bool + -- ^ indicates whether to show the values of the cells on which this + -- icon set is applied. + } deriving (Eq, Ord, Show, Generic) +instance NFData IconSetOptions + +-- | Icon set type for conditional formatting. 'CfValue' fields +-- determine lower range bounds. I.e. @IconSet3Signs (CfPercent 0) +-- (CfPercent 33) (CfPercent 67)@ say that 1st icon will be shown for +-- values ranging from 0 to 33 percents, 2nd for 33 to 67 percent and +-- the 3rd one for values from 67 to 100 percent. +-- +-- 18.18.42 "ST_IconSetType (Icon Set Type)" (p. 2463) +data IconSetType = + IconSet3Arrows -- CfValue CfValue CfValue + | IconSet3ArrowsGray -- CfValue CfValue CfValue + | IconSet3Flags -- CfValue CfValue CfValue + | IconSet3Signs -- CfValue CfValue CfValue + | IconSet3Symbols -- CfValue CfValue CfValue + | IconSet3Symbols2 -- CfValue CfValue CfValue + | IconSet3TrafficLights1 -- CfValue CfValue CfValue + | IconSet3TrafficLights2 -- CfValue CfValue CfValue + -- ^ 3 traffic lights icon set with thick black border. + | IconSet4Arrows -- CfValue CfValue CfValue CfValue + | IconSet4ArrowsGray -- CfValue CfValue CfValue CfValue + | IconSet4Rating -- CfValue CfValue CfValue CfValue + | IconSet4RedToBlack -- CfValue CfValue CfValue CfValue + | IconSet4TrafficLights -- CfValue CfValue CfValue CfValue + | IconSet5Arrows -- CfValue CfValue CfValue CfValue CfValue + | IconSet5ArrowsGray -- CfValue CfValue CfValue CfValue CfValue + | IconSet5Quarters -- CfValue CfValue CfValue CfValue CfValue + | IconSet5Rating -- CfValue CfValue CfValue CfValue CfValue + deriving (Eq, Ord, Show, Generic) +instance NFData IconSetType + +-- | Describes a data bar conditional formatting rule. +-- +-- See 18.3.1.28 "dataBar (Data Bar)" (p. 1621) +data DataBarOptions = DataBarOptions + { _dboMaxLength :: Int + -- ^ The maximum length of the data bar, as a percentage of the cell + -- width. + , _dboMinLength :: Int + -- ^ The minimum length of the data bar, as a percentage of the cell + -- width. + , _dboShowValue :: Bool + -- ^ Indicates whether to show the values of the cells on which this + -- data bar is applied. + , _dboMinimum :: MinCfValue + , _dboMaximum :: MaxCfValue + , _dboColor :: Color + } deriving (Eq, Ord, Show, Generic) +instance NFData DataBarOptions + +defaultDboMaxLength :: Int +defaultDboMaxLength = 90 + +defaultDboMinLength :: Int +defaultDboMinLength = 10 + +dataBarWithColor :: Color -> Condition +dataBarWithColor c = + DataBar + DataBarOptions + { _dboMaxLength = defaultDboMaxLength + , _dboMinLength = defaultDboMinLength + , _dboShowValue = True + , _dboMinimum = CfvMin + , _dboMaximum = CfvMax + , _dboColor = c + } + -- | This collection represents a description of a conditional formatting rule. -- -- See 18.3.1.10 "cfRule (Conditional Formatting Rule)" (p. 1602) @@ -152,8 +364,21 @@ -- evaluates to true. , _cfrStopIfTrue :: Maybe Bool } deriving (Eq, Ord, Show, Generic) +instance NFData CfRule +instance Default IconSetOptions where + def = + IconSetOptions + { _isoIconSet = IconSet3TrafficLights1 + , _isoValues = [CfPercent 0, CfPercent 33.33, CfPercent 66.67] +-- IconSet3TrafficLights1 (CfPercent 0) (CfPercent 33.33) (CfPercent 66.67) + , _isoReverse = False + , _isoShowValue = True + } + makeLenses ''CfRule +makeLenses ''IconSetOptions +makeLenses ''DataBarOptions type ConditionalFormatting = [CfRule] @@ -176,9 +401,36 @@ return CfRule{..} readCondition :: Text -> Cursor -> [Condition] -readCondition "beginsWith" cur = do - txt <- fromAttribute "text" cur - return $ BeginsWith txt +readCondition "aboveAverage" cur = do + above <- fromAttributeDef "aboveAverage" True cur + inclusion <- fromAttributeDef "equalAverage" Exclusive cur + nStdDev <- maybeAttribute "stdDev" cur + if above + then return $ AboveAverage inclusion nStdDev + else return $ BelowAverage inclusion nStdDev +readCondition "beginsWith" cur = do + 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 + case (cfvos, colors) of + ([n1, n2], [cn1, cn2]) -> do + mincfv <- fromCursor $ fromNode n1 + minc <- fromCursor $ fromNode cn1 + maxcfv <- fromCursor $ fromNode n2 + maxc <- fromCursor $ fromNode cn2 + return $ ColorScale2 mincfv minc maxcfv maxc + ([n1, n2, n3], [cn1, cn2, cn3]) -> do + mincfv <- fromCursor $ fromNode n1 + minc <- fromCursor $ fromNode cn1 + midcfv <- fromCursor $ fromNode n2 + midc <- fromCursor $ fromNode cn2 + maxcfv <- fromCursor $ fromNode n3 + maxc <- fromCursor $ fromNode cn3 + return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc + _ -> + error "Malformed colorScale condition" readCondition "cellIs" cur = do operator <- fromAttribute "operator" cur let formulas = cur $/ element (n_ "formula") >=> fromCursor @@ -189,24 +441,37 @@ readCondition "containsText" cur = do txt <- fromAttribute "text" cur return $ ContainsText txt -readCondition "notContainsBlanks" _ = return DoesNotContainBlanks -readCondition "notContainsErrors" _ = return DoesNotContainErrors -readCondition "notContainsText" cur = do - txt <- fromAttribute "text" cur - return $ DoesNotContainText txt +readCondition "dataBar" cur = fmap DataBar $ cur $/ element (n_ "dataBar") >=> fromCursor +readCondition "duplicateValues" _ = return DuplicateValues readCondition "endsWith" cur = do txt <- fromAttribute "text" cur return $ EndsWith txt readCondition "expression" cur = do - formula <- cur $/ element "formula" >=> fromCursor + formula <- cur $/ element (n_ "formula") >=> fromCursor return $ Expression formula +readCondition "iconSet" cur = fmap IconSet $ cur $/ element (n_ "iconSet") >=> fromCursor +readCondition "notContainsBlanks" _ = return DoesNotContainBlanks +readCondition "notContainsErrors" _ = return DoesNotContainErrors +readCondition "notContainsText" cur = do + txt <- fromAttribute "text" cur + return $ DoesNotContainText txt readCondition "timePeriod" cur = do period <- fromAttribute "timePeriod" cur return $ InTimePeriod period -readCondition _ _ = error "Unexpected conditional formatting type" +readCondition "top10" cur = do + bottom <- fromAttributeDef "bottom" False cur + percent <- fromAttributeDef "percent" False cur + rank <- fromAttribute "rank" cur + case (bottom, percent) of + (True, True) -> return $ BottomNPercent rank + (True, False) -> return $ BottomNValues rank + (False, True) -> return $ TopNPercent rank + (False, False) -> return $ TopNValues rank +readCondition "uniqueValues" _ = return UniqueValues +readCondition t _ = error $ "Unexpected conditional formatting type " ++ show t readOpExpression :: Text -> [Formula] -> [OperatorExpression] -readOpExpression "beginsWith" [f ] = [OpBeginsWith f ] +readOpExpression "beginsWith" [f] = [OpBeginsWith f ] readOpExpression "between" [f1, f2] = [OpBetween f1 f2] readOpExpression "containsText" [f] = [OpContainsText f] readOpExpression "endsWith" [f] = [OpEndsWith f] @@ -220,6 +485,92 @@ readOpExpression "notEqual" [f] = [OpNotEqual f] readOpExpression _ _ = [] +instance FromXenoNode CfRule where + fromXenoNode root = parseAttributes root $ do + _cfrDxfId <- maybeAttr "dxfId" + _cfrPriority <- fromAttr "priority" + _cfrStopIfTrue <- maybeAttr "stopIfTrue" + -- spec shows this attribute as optional but it's not clear why could + -- conditional formatting record be needed with no condition type set + cfType <- fromAttr "type" + _cfrCondition <- readConditionX cfType + return CfRule {..} + where + readConditionX ("aboveAverage" :: ByteString) = do + above <- fromAttrDef "aboveAverage" True + inclusion <- fromAttrDef "equalAverage" Exclusive + nStdDev <- maybeAttr "stdDev" + if above + then return $ AboveAverage inclusion nStdDev + else return $ BelowAverage inclusion nStdDev + readConditionX "beginsWith" = BeginsWith <$> fromAttr "text" + readConditionX "colorScale" = toAttrParser $ do + xs <- collectChildren root . maybeParse "colorScale" $ \node -> + collectChildren node $ (,) <$> childList "cfvo" + <*> childList "color" + case xs of + Just ([n1, n2], [cn1, cn2]) -> do + mincfv <- fromXenoNode n1 + minc <- fromXenoNode cn1 + maxcfv <- fromXenoNode n2 + maxc <- fromXenoNode cn2 + return $ ColorScale2 mincfv minc maxcfv maxc + Just ([n1, n2, n3], [cn1, cn2, cn3]) -> do + mincfv <- fromXenoNode n1 + minc <- fromXenoNode cn1 + midcfv <- fromXenoNode n2 + midc <- fromXenoNode cn2 + maxcfv <- fromXenoNode n3 + maxc <- fromXenoNode cn3 + return $ ColorScale3 mincfv minc midcfv midc maxcfv maxc + _ -> + Left "Malformed colorScale condition" + readConditionX "cellIs" = do + operator <- fromAttr "operator" + formulas <- toAttrParser . collectChildren root $ fromChildList "formula" + case (operator, formulas) of + ("beginsWith" :: ByteString, [f]) -> return . CellIs $ OpBeginsWith f + ("between", [f1, f2]) -> return . CellIs $ OpBetween f1 f2 + ("containsText", [f]) -> return . CellIs $ OpContainsText f + ("endsWith", [f]) -> return . CellIs $ OpEndsWith f + ("equal", [f]) -> return . CellIs $ OpEqual f + ("greaterThan", [f]) -> return . CellIs $ OpGreaterThan f + ("greaterThanOrEqual", [f]) -> return . CellIs $ OpGreaterThanOrEqual f + ("lessThan", [f]) -> return . CellIs $ OpLessThan f + ("lessThanOrEqual", [f]) -> return . CellIs $ OpLessThanOrEqual f + ("notBetween", [f1, f2]) -> return . CellIs $ OpNotBetween f1 f2 + ("notContains", [f]) -> return . CellIs $ OpNotContains f + ("notEqual", [f]) -> return . CellIs $ OpNotEqual f + _ -> toAttrParser $ Left "Bad cellIs rule" + readConditionX "containsBlanks" = return ContainsBlanks + readConditionX "containsErrors" = return ContainsErrors + readConditionX "containsText" = ContainsText <$> fromAttr "text" + readConditionX "dataBar" = + fmap DataBar . toAttrParser . collectChildren root $ fromChild "dataBar" + readConditionX "duplicateValues" = return DuplicateValues + readConditionX "endsWith" = EndsWith <$> fromAttr "text" + readConditionX "expression" = + fmap Expression . toAttrParser . collectChildren root $ fromChild "formula" + readConditionX "iconSet" = + fmap IconSet . toAttrParser . collectChildren root $ fromChild "iconSet" + readConditionX "notContainsBlanks" = return DoesNotContainBlanks + readConditionX "notContainsErrors" = return DoesNotContainErrors + readConditionX "notContainsText" = + DoesNotContainText <$> fromAttr "text" + readConditionX "timePeriod" = InTimePeriod <$> fromAttr "timePeriod" + readConditionX "top10" = do + bottom <- fromAttrDef "bottom" False + percent <- fromAttrDef "percent" False + rank <- fromAttr "rank" + case (bottom, percent) of + (True, True) -> return $ BottomNPercent rank + (True, False) -> return $ BottomNValues rank + (False, True) -> return $ TopNPercent rank + (False, False) -> return $ TopNValues rank + readConditionX "uniqueValues" = return UniqueValues + readConditionX x = + toAttrParser . Left $ "Unexpected conditional formatting type " <> T.pack (show x) + instance FromAttrVal TimePeriod where fromAttrVal "last7Days" = readSuccess PerLast7Days fromAttrVal "lastMonth" = readSuccess PerLastMonth @@ -233,7 +584,213 @@ fromAttrVal "yesterday" = readSuccess PerYesterday fromAttrVal t = invalidText "TimePeriod" t +instance FromAttrBs TimePeriod where + fromAttrBs "last7Days" = return PerLast7Days + fromAttrBs "lastMonth" = return PerLastMonth + fromAttrBs "lastWeek" = return PerLastWeek + fromAttrBs "nextMonth" = return PerNextMonth + fromAttrBs "nextWeek" = return PerNextWeek + fromAttrBs "thisMonth" = return PerThisMonth + fromAttrBs "thisWeek" = return PerThisWeek + fromAttrBs "today" = return PerToday + fromAttrBs "tomorrow" = return PerTomorrow + fromAttrBs "yesterday" = return PerYesterday + fromAttrBs x = unexpectedAttrBs "TimePeriod" x +instance FromAttrVal CfvType where + fromAttrVal "num" = readSuccess CfvtNum + fromAttrVal "percent" = readSuccess CfvtPercent + fromAttrVal "max" = readSuccess CfvtMax + fromAttrVal "min" = readSuccess CfvtMin + fromAttrVal "formula" = readSuccess CfvtFormula + fromAttrVal "percentile" = readSuccess CfvtPercentile + fromAttrVal t = invalidText "CfvType" t + +instance FromAttrBs CfvType where + fromAttrBs "num" = return CfvtNum + fromAttrBs "percent" = return CfvtPercent + fromAttrBs "max" = return CfvtMax + fromAttrBs "min" = return CfvtMin + fromAttrBs "formula" = return CfvtFormula + fromAttrBs "percentile" = return CfvtPercentile + fromAttrBs x = unexpectedAttrBs "CfvType" x + +readCfValue :: (CfValue -> a) -> [a] -> [a] -> Cursor -> [a] +readCfValue f minVal maxVal c = do + vType <- fromAttribute "type" c + case vType of + CfvtNum -> do + v <- fromAttribute "val" c + return . f $ CfValue v + CfvtFormula -> do + v <- fromAttribute "val" c + return . f $ CfFormula v + CfvtPercent -> do + v <- fromAttribute "val" c + return . f $ CfPercent v + CfvtPercentile -> do + v <- fromAttribute "val" c + return . f $ CfPercentile v + CfvtMin -> minVal + CfvtMax -> maxVal + +readCfValueX :: + (CfValue -> a) + -> Either Text a + -> Either Text a + -> Xeno.Node + -> Either Text a +readCfValueX f minVal maxVal root = + parseAttributes root $ do + vType <- fromAttr "type" + case vType of + CfvtNum -> do + v <- fromAttr "val" + return . f $ CfValue v + CfvtFormula -> do + v <- fromAttr "val" + return . f $ CfFormula v + CfvtPercent -> do + v <- fromAttr "val" + return . f $ CfPercent v + CfvtPercentile -> do + v <- fromAttr "val" + return . f $ CfPercentile v + CfvtMin -> toAttrParser minVal + CfvtMax -> toAttrParser maxVal + +failMinCfvType :: [a] +failMinCfvType = fail "unexpected 'min' type" + +failMinCfvTypeX :: Either Text a +failMinCfvTypeX = Left "unexpected 'min' type" + +failMaxCfvType :: [a] +failMaxCfvType = fail "unexpected 'max' type" + +failMaxCfvTypeX :: Either Text a +failMaxCfvTypeX = Left "unexpected 'max' type" + +instance FromCursor CfValue where + fromCursor = readCfValue id failMinCfvType failMaxCfvType + +instance FromXenoNode CfValue where + fromXenoNode root = readCfValueX id failMinCfvTypeX failMaxCfvTypeX root + +instance FromCursor MinCfValue where + fromCursor = readCfValue MinCfValue (return CfvMin) failMaxCfvType + +instance FromXenoNode MinCfValue where + fromXenoNode root = + readCfValueX MinCfValue (return CfvMin) failMaxCfvTypeX root + +instance FromCursor MaxCfValue where + fromCursor = readCfValue MaxCfValue failMinCfvType (return CfvMax) + +instance FromXenoNode MaxCfValue where + fromXenoNode root = + readCfValueX MaxCfValue failMinCfvTypeX (return CfvMax) root + +defaultIconSet :: IconSetType +defaultIconSet = IconSet3TrafficLights1 + +instance FromCursor IconSetOptions where + fromCursor cur = do + _isoIconSet <- fromAttributeDef "iconSet" defaultIconSet cur + let _isoValues = cur $/ element (n_ "cfvo") >=> fromCursor + _isoReverse <- fromAttributeDef "reverse" False cur + _isoShowValue <- fromAttributeDef "showValue" True cur + return IconSetOptions {..} + +instance FromXenoNode IconSetOptions where + fromXenoNode root = do + (_isoIconSet, _isoReverse, _isoShowValue) <- + parseAttributes root $ (,,) <$> fromAttrDef "iconSet" defaultIconSet + <*> fromAttrDef "reverse" False + <*> fromAttrDef "showValue" True + _isoValues <- collectChildren root $ fromChildList "cfvo" + return IconSetOptions {..} + +instance FromAttrVal IconSetType where + fromAttrVal "3Arrows" = readSuccess IconSet3Arrows + fromAttrVal "3ArrowsGray" = readSuccess IconSet3ArrowsGray + fromAttrVal "3Flags" = readSuccess IconSet3Flags + fromAttrVal "3Signs" = readSuccess IconSet3Signs + fromAttrVal "3Symbols" = readSuccess IconSet3Symbols + fromAttrVal "3Symbols2" = readSuccess IconSet3Symbols2 + fromAttrVal "3TrafficLights1" = readSuccess IconSet3TrafficLights1 + fromAttrVal "3TrafficLights2" = readSuccess IconSet3TrafficLights2 + fromAttrVal "4Arrows" = readSuccess IconSet4Arrows + fromAttrVal "4ArrowsGray" = readSuccess IconSet4ArrowsGray + fromAttrVal "4Rating" = readSuccess IconSet4Rating + fromAttrVal "4RedToBlack" = readSuccess IconSet4RedToBlack + fromAttrVal "4TrafficLights" = readSuccess IconSet4TrafficLights + fromAttrVal "5Arrows" = readSuccess IconSet5Arrows + fromAttrVal "5ArrowsGray" = readSuccess IconSet5ArrowsGray + fromAttrVal "5Quarters" = readSuccess IconSet5Quarters + fromAttrVal "5Rating" = readSuccess IconSet5Rating + fromAttrVal t = invalidText "IconSetType" t + +instance FromAttrBs IconSetType where + fromAttrBs "3Arrows" = return IconSet3Arrows + fromAttrBs "3ArrowsGray" = return IconSet3ArrowsGray + fromAttrBs "3Flags" = return IconSet3Flags + fromAttrBs "3Signs" = return IconSet3Signs + fromAttrBs "3Symbols" = return IconSet3Symbols + fromAttrBs "3Symbols2" = return IconSet3Symbols2 + fromAttrBs "3TrafficLights1" = return IconSet3TrafficLights1 + fromAttrBs "3TrafficLights2" = return IconSet3TrafficLights2 + fromAttrBs "4Arrows" = return IconSet4Arrows + fromAttrBs "4ArrowsGray" = return IconSet4ArrowsGray + fromAttrBs "4Rating" = return IconSet4Rating + fromAttrBs "4RedToBlack" = return IconSet4RedToBlack + fromAttrBs "4TrafficLights" = return IconSet4TrafficLights + fromAttrBs "5Arrows" = return IconSet5Arrows + fromAttrBs "5ArrowsGray" = return IconSet5ArrowsGray + fromAttrBs "5Quarters" = return IconSet5Quarters + fromAttrBs "5Rating" = return IconSet5Rating + fromAttrBs x = unexpectedAttrBs "IconSetType" x + +instance FromCursor DataBarOptions where + fromCursor cur = do + _dboMaxLength <- fromAttributeDef "maxLength" defaultDboMaxLength cur + _dboMinLength <- fromAttributeDef "minLength" defaultDboMinLength cur + _dboShowValue <- fromAttributeDef "showValue" True cur + let cfvos = cur $/ element (n_ "cfvo") &| node + case cfvos of + [nMin, nMax] -> do + _dboMinimum <- fromCursor (fromNode nMin) + _dboMaximum <- fromCursor (fromNode nMax) + _dboColor <- cur $/ element (n_ "color") >=> fromCursor + return DataBarOptions{..} + ns -> do + fail $ "expected minimum and maximum cfvo nodes but see instead " ++ + show (length ns) ++ " cfvo nodes" + +instance FromXenoNode DataBarOptions where + fromXenoNode root = do + (_dboMaxLength, _dboMinLength, _dboShowValue) <- + parseAttributes root $ (,,) <$> fromAttrDef "maxLength" defaultDboMaxLength + <*> fromAttrDef "minLength" defaultDboMinLength + <*> fromAttrDef "showValue" True + (_dboMinimum, _dboMaximum, _dboColor) <- + collectChildren root $ (,,) <$> fromChild "cfvo" + <*> fromChild "cfvo" + <*> fromChild "color" + return DataBarOptions{..} + +instance FromAttrVal Inclusion where + fromAttrVal = right (first $ bool Exclusive Inclusive) . fromAttrVal + +instance FromAttrBs Inclusion where + fromAttrBs = fmap (bool Exclusive Inclusive) . fromAttrBs + +instance FromAttrVal NStdDev where + fromAttrVal = right (first NStdDev) . fromAttrVal + +instance FromAttrBs NStdDev where + fromAttrBs = fmap NStdDev . fromAttrBs + {------------------------------------------------------------------------------- Rendering -------------------------------------------------------------------------------} @@ -254,18 +811,60 @@ } conditionData :: Condition -> (Text, Map Name Text, [Node]) +conditionData (AboveAverage i sDevs) = + ("aboveAverage", M.fromList $ ["aboveAverage" .= True] ++ + catMaybes [ "equalAverage" .=? justNonDef Exclusive i + , "stdDev" .=? sDevs], []) conditionData (BeginsWith t) = ("beginsWith", M.fromList [ "text" .= t], []) +conditionData (BelowAverage i sDevs) = + ("aboveAverage", M.fromList $ ["aboveAverage" .= False] ++ + catMaybes [ "equalAverage" .=? justNonDef Exclusive i + , "stdDev" .=? sDevs], []) +conditionData (BottomNPercent n) = ("top10", M.fromList [ "bottom" .= True, "rank" .= n, "percent" .= True ], []) +conditionData (BottomNValues n) = ("top10", M.fromList [ "bottom" .= True, "rank" .= n ], []) conditionData (CellIs opExpr) = ("cellIs", M.fromList [ "operator" .= op], formulas) where (op, formulas) = operatorExpressionData opExpr +conditionData (ColorScale2 minv minc maxv maxc) = + ( "colorScale" + , M.empty + , [ NodeElement $ + elementListSimple + "colorScale" + [ toElement "cfvo" minv + , toElement "cfvo" maxv + , toElement "color" minc + , toElement "color" maxc + ] + ]) +conditionData (ColorScale3 minv minc midv midc maxv maxc) = + ( "colorScale" + , M.empty + , [ NodeElement $ + elementListSimple + "colorScale" + [ toElement "cfvo" minv + , toElement "cfvo" midv + , toElement "cfvo" maxv + , toElement "color" minc + , toElement "color" midc + , toElement "color" maxc + ] + ]) conditionData ContainsBlanks = ("containsBlanks", M.empty, []) conditionData ContainsErrors = ("containsErrors", M.empty, []) conditionData (ContainsText t) = ("containsText", M.fromList [ "text" .= t], []) +conditionData (DataBar dbOpts) = ("dataBar", M.empty, [toNode "dataBar" dbOpts]) conditionData DoesNotContainBlanks = ("notContainsBlanks", M.empty, []) conditionData DoesNotContainErrors = ("notContainsErrors", M.empty, []) conditionData (DoesNotContainText t) = ("notContainsText", M.fromList [ "text" .= t], []) +conditionData DuplicateValues = ("duplicateValues", M.empty, []) conditionData (EndsWith t) = ("endsWith", M.fromList [ "text" .= t], []) conditionData (Expression formula) = ("expression", M.empty, [formulaNode formula]) conditionData (InTimePeriod period) = ("timePeriod", M.fromList [ "timePeriod" .= period ], []) +conditionData (IconSet isOptions) = ("iconSet", M.empty, [toNode "iconSet" isOptions]) +conditionData (TopNPercent n) = ("top10", M.fromList [ "rank" .= n, "percent" .= True ], []) +conditionData (TopNValues n) = ("top10", M.fromList [ "rank" .= n ], []) +conditionData UniqueValues = ("uniqueValues", M.empty, []) operatorExpressionData :: OperatorExpression -> (Text, [Node]) operatorExpressionData (OpBeginsWith f) = ("beginsWith", [formulaNode f]) @@ -281,8 +880,79 @@ operatorExpressionData (OpNotContains f) = ("notContains", [formulaNode f]) operatorExpressionData (OpNotEqual f) = ("notEqual", [formulaNode f]) +instance ToElement MinCfValue where + toElement nm CfvMin = leafElement nm ["type" .= CfvtMin] + toElement nm (MinCfValue cfv) = toElement nm cfv + +instance ToElement MaxCfValue where + toElement nm CfvMax = leafElement nm ["type" .= CfvtMax] + toElement nm (MaxCfValue cfv) = toElement nm cfv + +instance ToElement CfValue where + toElement nm (CfValue v) = leafElement nm ["type" .= CfvtNum, "val" .= v] + toElement nm (CfPercent v) = + leafElement nm ["type" .= CfvtPercent, "val" .= v] + toElement nm (CfPercentile v) = + leafElement nm ["type" .= CfvtPercentile, "val" .= v] + toElement nm (CfFormula f) = + leafElement nm ["type" .= CfvtFormula, "val" .= unFormula f] + +instance ToAttrVal CfvType where + toAttrVal CfvtNum = "num" + toAttrVal CfvtPercent = "percent" + toAttrVal CfvtMax = "max" + toAttrVal CfvtMin = "min" + toAttrVal CfvtFormula = "formula" + toAttrVal CfvtPercentile = "percentile" + +instance ToElement IconSetOptions where + toElement nm IconSetOptions {..} = + elementList nm attrs $ map (toElement "cfvo") _isoValues + where + attrs = catMaybes + [ "iconSet" .=? justNonDef defaultIconSet _isoIconSet + , "reverse" .=? justTrue _isoReverse + , "showValue" .=? justFalse _isoShowValue + ] + +instance ToAttrVal IconSetType where + toAttrVal IconSet3Arrows = "3Arrows" + toAttrVal IconSet3ArrowsGray = "3ArrowsGray" + toAttrVal IconSet3Flags = "3Flags" + toAttrVal IconSet3Signs = "3Signs" + toAttrVal IconSet3Symbols = "3Symbols" + toAttrVal IconSet3Symbols2 = "3Symbols2" + toAttrVal IconSet3TrafficLights1 = "3TrafficLights1" + toAttrVal IconSet3TrafficLights2 = "3TrafficLights2" + toAttrVal IconSet4Arrows = "4Arrows" + toAttrVal IconSet4ArrowsGray = "4ArrowsGray" + toAttrVal IconSet4Rating = "4Rating" + toAttrVal IconSet4RedToBlack = "4RedToBlack" + toAttrVal IconSet4TrafficLights = "4TrafficLights" + toAttrVal IconSet5Arrows = "5Arrows" + toAttrVal IconSet5ArrowsGray = "5ArrowsGray" + toAttrVal IconSet5Quarters = "5Quarters" + toAttrVal IconSet5Rating = "5Rating" + +instance ToElement DataBarOptions where + toElement nm DataBarOptions {..} = elementList nm attrs elements + where + attrs = catMaybes + [ "maxLength" .=? justNonDef defaultDboMaxLength _dboMaxLength + , "minLength" .=? justNonDef defaultDboMinLength _dboMinLength + , "showValue" .=? justFalse _dboShowValue + ] + elements = + [ toElement "cfvo" _dboMinimum + , toElement "cfvo" _dboMaximum + , toElement "color" _dboColor + ] + +toNode :: ToElement a => Name -> a -> Node +toNode nm = NodeElement . toElement nm + formulaNode :: Formula -> Node -formulaNode = NodeElement . toElement "formula" +formulaNode = toNode "formula" instance ToAttrVal TimePeriod where toAttrVal PerLast7Days = "last7Days" @@ -295,3 +965,9 @@ toAttrVal PerToday = "today" toAttrVal PerTomorrow = "tomorrow" toAttrVal PerYesterday = "yesterday" + +instance ToAttrVal Inclusion where + toAttrVal = toAttrVal . (== Inclusive) + +instance ToAttrVal NStdDev where + toAttrVal (NStdDev n) = toAttrVal n 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,20 +1,23 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types.DataValidation where +import Control.DeepSeq (NFData) import Control.Lens.TH (makeLenses) import Control.Monad ((>=>)) +import Data.ByteString (ByteString) import Data.Char (isSpace) import Data.Default import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, maybeToList) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) -import Text.XML (Node(..), Element(..)) +import Text.XML (Element(..), Node(..)) import Text.XML.Cursor (Cursor, ($/), element) import Codec.Xlsx.Parser.Internal @@ -32,6 +35,7 @@ | ValNotBetween Formula Formula -- ^ "Not between" operator | ValNotEqual Formula -- ^ "Not equal to" operator deriving (Eq, Show, Generic) +instance NFData ValidationExpression -- See 18.18.21 "ST_DataValidationType (Data Validation Type)" (p. 2440/2450) data ValidationType @@ -44,6 +48,7 @@ | ValidationTypeTime ValidationExpression | ValidationTypeWhole ValidationExpression deriving (Eq, Show, Generic) +instance NFData ValidationType -- See 18.18.18 "ST_DataValidationErrorStyle (Data Validation Error Styles)" (p. 2438/2448) data ErrorStyle @@ -51,6 +56,7 @@ | ErrorStyleStop | ErrorStyleWarning deriving (Eq, Show, Generic) +instance NFData ErrorStyle -- See 18.3.1.32 "dataValidation (Data Validation)" (p. 1614/1624) data DataValidation = DataValidation @@ -65,6 +71,7 @@ , _dvShowInputMessage :: Bool , _dvValidationType :: ValidationType } deriving (Eq, Show, Generic) +instance NFData DataValidation makeLenses ''DataValidation @@ -82,6 +89,12 @@ fromAttrVal "warning" = readSuccess ErrorStyleWarning fromAttrVal t = invalidText "ErrorStyle" t +instance FromAttrBs ErrorStyle where + fromAttrBs "information" = return ErrorStyleInformation + fromAttrBs "stop" = return ErrorStyleStop + fromAttrBs "warning" = return ErrorStyleWarning + fromAttrBs x = unexpectedAttrBs "ErrorStyle" x + instance FromCursor DataValidation where fromCursor cur = do _dvAllowBlank <- fromAttributeDef "allowBlank" False cur @@ -98,6 +111,60 @@ _dvValidationType <- readValidationType mop mtype cur return DataValidation{..} +instance FromXenoNode DataValidation where + fromXenoNode root = do + (op, atype, genDV) <- parseAttributes root $ do + _dvAllowBlank <- fromAttrDef "allowBlank" False + _dvError <- maybeAttr "error" + _dvErrorStyle <- fromAttrDef "errorStyle" ErrorStyleStop + _dvErrorTitle <- maybeAttr "errorTitle" + _dvPrompt <- maybeAttr "prompt" + _dvPromptTitle <- maybeAttr "promptTitle" + _dvShowDropDown <- fromAttrDef "showDropDown" False + _dvShowErrorMessage <- fromAttrDef "showErrorMessage" False + _dvShowInputMessage <- fromAttrDef "showInputMessage" False + op <- fromAttrDef "operator" "between" + typ <- fromAttrDef "type" "none" + return (op, typ, \_dvValidationType -> DataValidation {..}) + valType <- parseValidationType op atype + return $ genDV valType + where + parseValidationType :: ByteString -> ByteString -> Either Text ValidationType + parseValidationType op atype = + case atype of + "none" -> return ValidationTypeNone + "custom" -> + ValidationTypeCustom <$> formula1 + "list" -> do + f <- formula1 + case readListFormulas f of + Nothing -> Left "validation of type \"list\" with empty formula list" + Just fs -> return $ ValidationTypeList fs + "date" -> + ValidationTypeDate <$> readOpExpression op + "decimal" -> + ValidationTypeDecimal <$> readOpExpression op + "textLength" -> + ValidationTypeTextLength <$> readOpExpression op + "time" -> + ValidationTypeTime <$> readOpExpression op + "whole" -> + ValidationTypeWhole <$> readOpExpression op + unexpected -> + Left $ "unexpected type of data validation " <> T.pack (show unexpected) + readOpExpression "between" = uncurry ValBetween <$> formulaPair + readOpExpression "notBetween" = uncurry ValNotBetween <$> formulaPair + readOpExpression "equal" = ValEqual <$> formula1 + readOpExpression "greaterThan" = ValGreaterThan <$> formula1 + readOpExpression "greaterThanOrEqual" = ValGreaterThanOrEqual <$> formula1 + readOpExpression "lessThan" = ValLessThan <$> formula1 + readOpExpression "lessThanOrEqual" = ValLessThanOrEqual <$> formula1 + readOpExpression "notEqual" = ValNotEqual <$> formula1 + readOpExpression op = Left $ "data validation, unexpected operator " <> T.pack (show op) + formula1 = collectChildren root $ fromChild "formula1" + formulaPair = + collectChildren root $ (,) <$> fromChild "formula1" <*> fromChild "formula2" + readValidationType :: Text -> Text -> Cursor -> [ValidationType] readValidationType _ "none" _ = return ValidationTypeNone readValidationType _ "custom" cur = do @@ -105,14 +172,14 @@ return $ ValidationTypeCustom f readValidationType _ "list" cur = do f <- cur $/ element (n_ "formula1") >=> fromCursor - as <- readListFormula f + as <- maybeToList $ readListFormulas f return $ ValidationTypeList as readValidationType op ty cur = do opExp <- readOpExpression2 op cur readValidationTypeOpExp ty opExp -readListFormula :: Formula -> [[Text]] -readListFormula (Formula f) = catMaybes [readQuotedList f] +readListFormulas :: Formula -> Maybe [Text] +readListFormulas (Formula f) = readQuotedList f where readQuotedList t | Just t' <- T.stripPrefix "\"" (T.dropAround isSpace t) @@ -221,4 +288,3 @@ viewValidationExpression (ValLessThanOrEqual f) = ("lessThanOrEqual", f, Nothing) viewValidationExpression (ValNotBetween f1 f2) = ("notBetween", f1, Just f2) viewValidationExpression (ValNotEqual f) = ("notEqual", f, Nothing) - 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 #-} @@ -12,6 +11,7 @@ module Codec.Xlsx.Types.Drawing where import Control.Arrow (first) +import Control.DeepSeq (NFData) import Control.Lens.TH import Data.ByteString.Lazy (ByteString) import Data.Default @@ -23,10 +23,6 @@ import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Drawing.Chart import Codec.Xlsx.Types.Drawing.Common @@ -44,6 +40,7 @@ , _fiContents :: ByteString -- ^ image file contents } deriving (Eq, Show, Generic) +instance NFData FileInfo data Marker = Marker { _mrkCol :: Int @@ -51,6 +48,7 @@ , _mrkRow :: Int , _mrkRowOff :: Coordinate } deriving (Eq, Show, Generic) +instance NFData Marker unqMarker :: (Int, Int) -> (Int, Int) -> Marker unqMarker (col, colOff) (row, rowOff) = @@ -61,6 +59,7 @@ | EditAsOneCell | EditAsAbsolute deriving (Eq, Show, Generic) +instance NFData EditAs data Anchoring = AbsoluteAnchor @@ -77,6 +76,7 @@ , tcaEditAs :: EditAs } deriving (Eq, Show, Generic) +instance NFData Anchoring data DrawingObject p g = Picture { _picMacro :: Maybe Text @@ -91,6 +91,7 @@ , _grTransform :: Transform2D} -- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart deriving (Eq, Show, Generic) +instance (NFData p, NFData g) => NFData (DrawingObject p g) -- | basic function to create picture drawing object -- @@ -150,20 +151,24 @@ -- ^ This attribute indicates whether to print drawing elements -- when printing the sheet. } deriving (Eq, Show, Generic) +instance NFData ClientData data PicNonVisual = PicNonVisual { _pnvDrawingProps :: NonVisualDrawingProperties -- TODO: cNvPicPr } deriving (Eq, Show, Generic) +instance NFData PicNonVisual data GraphNonVisual = GraphNonVisual { _gnvDrawingProps :: NonVisualDrawingProperties -- TODO cNvGraphicFramePr } deriving (Eq, Show, Generic) +instance NFData GraphNonVisual newtype DrawingElementId = DrawingElementId { unDrawingElementId :: Int } deriving (Eq, Show, Generic) +instance NFData DrawingElementId -- see 20.1.2.2.8 "cNvPr (Non-Visual Drawing Properties)" (p. 2731) data NonVisualDrawingProperties = NonVisualDrawingProperties @@ -181,12 +186,14 @@ , _nvdpHidden :: Bool , _nvdpTitle :: Maybe Text } deriving (Eq, Show, Generic) +instance NFData NonVisualDrawingProperties data BlipFillProperties a = BlipFillProperties { _bfpImageInfo :: Maybe a , _bfpFillMode :: Maybe FillMode -- TODO: dpi, rotWithShape, srcRect } deriving (Eq, Show, Generic) +instance NFData a => NFData (BlipFillProperties a) -- see @a_EG_FillModeProperties@ (p. 4319) data FillMode @@ -195,6 +202,7 @@ -- See 20.1.8.56 "stretch (Stretch)" (p. 2879) | FillStretch -- TODO: srcRect deriving (Eq, Show, Generic) +instance NFData FillMode -- See @EG_Anchor@ (p. 4052) data Anchor p g = Anchor @@ -202,6 +210,7 @@ , _anchObject :: DrawingObject p g , _anchClientData :: ClientData } deriving (Eq, Show, Generic) +instance (NFData p, NFData g) => NFData (Anchor p g) -- | simple drawing object anchoring using one cell as a top lelft -- corner and dimensions of that object @@ -222,6 +231,7 @@ data GenericDrawing p g = Drawing { _xdrAnchors :: [Anchor p g] } deriving (Eq, Show, Generic) +instance (NFData p, NFData g) => NFData (GenericDrawing p g) -- See 20.5.2.35 "wsDr (Worksheet Drawing)" (p. 3176) type Drawing = GenericDrawing FileInfo ChartSpace 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 #-} @@ -8,16 +7,13 @@ import GHC.Generics (Generic) import Control.Lens.TH +import Control.DeepSeq (NFData) import Data.Default -import Data.Maybe (catMaybes, maybeToList) +import Data.Maybe (catMaybes, listToMaybe, maybeToList) import Data.Text (Text) import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Common import Codec.Xlsx.Types.Drawing.Common @@ -33,13 +29,15 @@ , _chspPlotVisOnly :: Maybe Bool , _chspDispBlanksAs :: Maybe DispBlanksAs } deriving (Eq, Show, Generic) +instance NFData ChartSpace -- | Chart title -- -- TODO: layout, overlay, spPr, txPr, extLst newtype ChartTitle = - ChartTitle TextBody + ChartTitle (Maybe TextBody) deriving (Eq, Show, Generic) +instance NFData ChartTitle -- | This simple type specifies the possible ways to display blanks. -- @@ -52,12 +50,14 @@ | DispBlanksAsZero -- ^ Specifies that blank values shall be treated as zero. deriving (Eq, Show, Generic) +instance NFData DispBlanksAs -- TODO: legendEntry, layout, overlay, spPr, txPr, extLst data Legend = Legend { _legendPos :: Maybe LegendPos , _legendOverlay :: Maybe Bool } deriving (Eq, Show, Generic) +instance NFData Legend -- See 21.2.3.24 "ST_LegendPos (Legend Position)" (p. 3449) data LegendPos @@ -77,6 +77,7 @@ -- ^ tr (Top Right) Specifies that the legend shall be drawn at -- the top right of the chart. deriving (Eq, Show, Generic) +instance NFData LegendPos -- | Specific Chart -- TODO: @@ -96,7 +97,7 @@ , _archSeries :: [AreaSeries] } | BarChart { _brchDirection :: BarDirection - , _brchGrouping :: Maybe ChartGrouping + , _brchGrouping :: Maybe BarChartGrouping , _brchSeries :: [BarSeries] } | PieChart { _pichSeries :: [PieSeries] @@ -105,8 +106,9 @@ , _scchSeries :: [ScatterSeries] } deriving (Eq, Show, Generic) +instance NFData Chart --- | Possible groupings for a bar chart +-- | Possible groupings for a chart -- -- See 21.2.3.17 "ST_Grouping (Grouping)" (p. 3446) data ChartGrouping @@ -120,7 +122,27 @@ -- ^(Standard) Specifies that the chart series are drawn on the value -- axis. deriving (Eq, Show, Generic) +instance NFData ChartGrouping +-- | Possible groupings for a bar chart +-- +-- See 21.2.3.4 "ST_BarGrouping (Bar Grouping)" (p. 3441) +data BarChartGrouping + = BarClusteredGrouping + -- ^ Specifies that the chart series are drawn next to each other + -- along the category axis. + | BarPercentStackedGrouping + -- ^ (100% Stacked) Specifies that the chart series are drawn next to each + -- other along the value axis and scaled to total 100%. + | BarStackedGrouping + -- ^ (Stacked) Specifies that the chart series are drawn next to each + -- other on the value axis. + | BarStandardGrouping + -- ^(Standard) Specifies that the chart series are drawn on the value + -- axis. + deriving (Eq, Show, Generic) +instance NFData BarChartGrouping + -- | Possible directions for a bar chart -- -- See 21.2.3.3 "ST_BarDir (Bar Direction)" (p. 3441) @@ -128,6 +150,7 @@ = DirectionBar | DirectionColumn deriving (Eq, Show, Generic) +instance NFData BarDirection -- | Possible styles of scatter chart -- @@ -144,6 +167,7 @@ | ScatterSmooth | ScatterSmoothMarker deriving (Eq, Show, Generic) +instance NFData ScatterStyle -- | Single data point options -- @@ -154,6 +178,7 @@ { _dpMarker :: Maybe DataMarker , _dpShapeProperties :: Maybe ShapeProperties } deriving (Eq, Show, Generic) +instance NFData DataPoint -- | Specifies common series options -- TODO: spPr @@ -165,6 +190,7 @@ -- currently only reference formula is supported , _serShapeProperties :: Maybe ShapeProperties } deriving (Eq, Show, Generic) +instance NFData Series -- | A series on a line chart -- @@ -179,6 +205,7 @@ -- ^ currently only reference formula is supported , _lnserSmooth :: Maybe Bool } deriving (Eq, Show, Generic) +instance NFData LineSeries -- | A series on an area chart -- @@ -190,6 +217,7 @@ , _arserDataLblProps :: Maybe DataLblProps , _arserVal :: Maybe Formula } deriving (Eq, Show, Generic) +instance NFData AreaSeries -- | A series on a bar chart -- @@ -202,6 +230,7 @@ , _brserDataLblProps :: Maybe DataLblProps , _brserVal :: Maybe Formula } deriving (Eq, Show, Generic) +instance NFData BarSeries -- | A series on a pie chart -- @@ -216,6 +245,7 @@ , _piserDataLblProps :: Maybe DataLblProps , _piserVal :: Maybe Formula } deriving (Eq, Show, Generic) +instance NFData PieSeries -- | A series on a scatter chart -- @@ -230,6 +260,7 @@ , _scserYVal :: Maybe Formula , _scserSmooth :: Maybe Bool } deriving (Eq, Show, Generic) +instance NFData ScatterSeries -- See @CT_Marker@ (p. 4061) data DataMarker = DataMarker @@ -237,6 +268,7 @@ , _dmrkSize :: Maybe Int -- ^ integer between 2 and 72, specifying a size in points } deriving (Eq, Show, Generic) +instance NFData DataMarker data DataMarkerSymbol = DataMarkerCircle @@ -252,6 +284,7 @@ | DataMarkerX | DataMarkerAuto deriving (Eq, Show, Generic) +instance NFData DataMarkerSymbol -- | Settings for the data labels for an entire series or the -- entire chart @@ -266,6 +299,7 @@ , _dlblShowSerName :: Maybe Bool , _dlblShowPercent :: Maybe Bool } deriving (Eq, Show, Generic) +instance NFData DataLblProps -- | Specifies the possible positions for tick marks. @@ -280,6 +314,7 @@ | TickMarkOut -- ^ (Outside) Specifies the tick marks shall be outside the plot area. deriving (Eq, Show, Generic) +instance NFData TickMark makeLenses ''DataPoint @@ -319,7 +354,8 @@ return AreaChart {..} | n `nodeElNameIs` (c_ "barChart") = do _brchDirection <- fromElementValue (c_ "barDir") cur - _brchGrouping <- maybeElementValue (c_ "grouping") cur + _brchGrouping <- + maybeElementValueDef (c_ "grouping") BarClusteredGrouping cur let _brchSeries = cur $/ element (c_ "ser") >=> fromCursor return BarChart {..} | n `nodeElNameIs` (c_ "pieChart") = do @@ -451,9 +487,18 @@ fromAttrVal "stacked" = readSuccess StackedGrouping fromAttrVal t = invalidText "ChartGrouping" t +instance FromAttrVal BarChartGrouping where + fromAttrVal "clustered" = readSuccess BarClusteredGrouping + fromAttrVal "percentStacked" = readSuccess BarPercentStackedGrouping + fromAttrVal "standard" = readSuccess BarStandardGrouping + fromAttrVal "stacked" = readSuccess BarStackedGrouping + fromAttrVal t = invalidText "BarChartGrouping" t + instance FromCursor ChartTitle where - fromCursor cur = - cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fmap ChartTitle . fromCursor + fromCursor cur = do + let mTitle = listToMaybe $ + cur $/ element (c_ "tx") &/ element (c_ "rich") >=> fromCursor + return $ ChartTitle mTitle instance FromCursor Legend where fromCursor cur = do @@ -539,21 +584,23 @@ _brchSeries [elementValue "barDir" _brchDirection] [] - PieChart {..} -> chartElement "pieChart" [] Nothing _pichSeries [] [] + PieChart {..} -> chartElement "pieChart" [] noGrouping _pichSeries [] [] ScatterChart {..} -> chartElement "scatterChart" xyAxes - Nothing + noGrouping _scchSeries [elementValue "scatterStyle" _scchStyle] [] where + noGrouping :: Maybe ChartGrouping + noGrouping = Nothing chartElement - :: ToElement s + :: (ToElement s, ToAttrVal gr) => Name -> [Element] - -> Maybe ChartGrouping + -> Maybe gr -> [s] -> [Element] -> [Element] @@ -612,6 +659,12 @@ toAttrVal StandardGrouping = "standard" toAttrVal StackedGrouping = "stacked" +instance ToAttrVal BarChartGrouping where + toAttrVal BarClusteredGrouping = "clustered" + toAttrVal BarPercentStackedGrouping = "percentStacked" + toAttrVal BarStandardGrouping = "standard" + toAttrVal BarStackedGrouping = "stacked" + instance ToAttrVal BarDirection where toAttrVal DirectionBar = "bar" toAttrVal DirectionColumn = "col" @@ -740,7 +793,7 @@ toElement nm (ChartTitle body) = elementListSimple nm [txEl, elementValue "overlay" False] where - txEl = elementListSimple "tx" [toElement (c_ "rich") body] + txEl = elementListSimple "tx" $ catMaybes [toElement (c_ "rich") <$> body] instance ToElement Legend where toElement nm Legend{..} = elementListSimple nm elements 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 #-} @@ -10,6 +9,7 @@ import Control.Arrow (first) import Control.Lens.TH import Control.Monad (join) +import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes, listToMaybe) import Data.Monoid ((<>)) @@ -19,10 +19,6 @@ import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Writer.Internal @@ -32,6 +28,7 @@ newtype Angle = Angle Int deriving (Eq, Show, Generic) +instance NFData Angle -- | A string with rich text formatting -- @@ -62,7 +59,9 @@ , _txbdParagraphs :: [TextParagraph] -- ^ Paragraphs of text within the containing text body } deriving (Eq, Show, Generic) +instance NFData TextBody + -- | Text vertical overflow -- See 20.1.10.83 "ST_TextVertOverflowType (Text Vertical Overflow)" (p. 3083) data TextVertOverflow @@ -75,6 +74,7 @@ | TextVertOverflow -- ^ Overflow the text and pay no attention to top and bottom barriers. deriving (Eq, Show, Generic) +instance NFData TextVertOverflow -- | If there is vertical text, determines what kind of vertical text is going to be used. -- @@ -104,6 +104,7 @@ -- ^ Specifies that vertical WordArt should be shown from right to left rather than -- left to right. deriving (Eq, Show, Generic) +instance NFData TextVertical -- | Text wrapping types -- @@ -115,6 +116,7 @@ | TextWrapSquare -- ^ Determines whether we wrap words within the bounding rectangle. deriving (Eq, Show, Generic) +instance NFData TextWrap -- | This type specifies a list of available anchoring types for text. -- @@ -141,12 +143,14 @@ | TextAnchoringTop -- ^ Anchor the text at the top of the bounding rectangle. deriving (Eq, Show, Generic) +instance NFData TextAnchoring -- See 21.1.2.2.6 "p (Text Paragraphs)" (p. 3211) data TextParagraph = TextParagraph { _txpaDefCharProps :: Maybe TextCharacterProperties , _txpaRuns :: [TextRun] } deriving (Eq, Show, Generic) +instance NFData TextParagraph -- | Text character properties -- @@ -162,6 +166,7 @@ , _txchItalic :: Bool , _txchUnderline :: Bool } deriving (Eq, Show, Generic) +instance NFData TextCharacterProperties -- | Text run -- @@ -170,6 +175,7 @@ { _txrCharProps :: Maybe TextCharacterProperties , _txrText :: Text } deriving (Eq, Show, Generic) +instance NFData TextRun -- | This simple type represents a one dimensional position or length -- @@ -181,6 +187,7 @@ Double -- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) deriving (Eq, Show, Generic) +instance NFData Coordinate -- | Units used in "Universal measure" coordinates -- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) @@ -192,12 +199,14 @@ | UnitPc -- "pc" 1 pc = 12 pt (informative) | UnitPi -- "pi" 1 pi = 12 pt (informative) deriving (Eq, Show, Generic) +instance NFData UnitIdentifier -- See @CT_Point2D@ (p. 3989) data Point2D = Point2D { _pt2dX :: Coordinate , _pt2dY :: Coordinate } deriving (Eq, Show, Generic) +instance NFData Point2D unqPoint2D :: Int -> Int -> Point2D unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y) @@ -207,11 +216,13 @@ newtype PositiveCoordinate = PositiveCoordinate Integer deriving (Eq, Ord, Show, Generic) +instance NFData PositiveCoordinate data PositiveSize2D = PositiveSize2D { _ps2dX :: PositiveCoordinate , _ps2dY :: PositiveCoordinate } deriving (Eq, Show, Generic) +instance NFData PositiveSize2D positiveSize2D :: Integer -> Integer -> PositiveSize2D positiveSize2D x y = @@ -239,6 +250,7 @@ -- ^ See 20.1.7.3 "ext (Extents)" (p. 2846) or -- 20.5.2.14 "ext (Shape Extent)" (p. 3165) } deriving (Eq, Show, Generic) +instance NFData Transform2D -- TODO: custGeom data Geometry = @@ -246,6 +258,7 @@ -- TODO: prst, avList -- currently uses "rect" with empty avList deriving (Eq, Show, Generic) +instance NFData Geometry -- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751) data ShapeProperties = ShapeProperties @@ -255,6 +268,7 @@ , _spOutline :: Maybe LineProperties -- TODO: bwMode, a_EG_EffectProperties, scene3d, sp3d, extLst } deriving (Eq, Show, Generic) +instance NFData ShapeProperties -- | Specifies an outline style that can be applied to a number of -- different objects such as shapes and text. @@ -270,6 +284,7 @@ -- value is in EMU, is greater of equal to 0 and maximum value is -- 20116800. } deriving (Eq, Show, Generic) +instance NFData LineProperties -- | Color choice for some drawing element -- @@ -284,6 +299,7 @@ -- -- See 20.1.2.3.32 "srgbClr (RGB Color Model - Hex Variant)" (p. 2773) deriving (Eq, Show, Generic) +instance NFData ColorChoice -- TODO: gradFill, pattFill data FillProperties = @@ -293,6 +309,7 @@ -- ^ Solid fill -- See 20.1.8.54 "solidFill (Solid Fill)" (p. 2879) deriving (Eq, Show, Generic) +instance NFData FillProperties -- | solid fill with color specified by hexadecimal RGB color solidRgb :: Text -> FillProperties 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,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Internal where @@ -6,10 +5,6 @@ import Data.Text (Text) import GHC.Generics (Generic) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Writer.Internal @@ -20,3 +15,6 @@ instance FromAttrVal RefId where fromAttrVal t = first RefId <$> fromAttrVal t + +instance FromAttrBs RefId where + fromAttrBs = fmap RefId . fromAttrBs 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 @@ -25,6 +25,12 @@ let cfRules = cur $/ element (n_ "cfRule") >=> fromCursor return $ CfPair (sqref, cfRules) +instance FromXenoNode CfPair where + fromXenoNode root = do + sqref <- parseAttributes root $ fromAttr "sqref" + cfRules <- collectChildren root $ fromChildList "cfRule" + return $ CfPair (sqref, cfRules) + instance ToElement CfPair where toElement nm (CfPair (sqRef, cfRules)) = elementList nm [ "sqref" .= toAttrVal sqRef ] diff --git a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs --- a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs +++ b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} @@ -14,10 +13,6 @@ import System.FilePath.Posix (takeExtension) import Text.XML import Text.XML.Cursor - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Codec.Xlsx.Parser.Internal diff --git a/src/Codec/Xlsx/Types/Internal/DvPair.hs b/src/Codec/Xlsx/Types/Internal/DvPair.hs --- a/src/Codec/Xlsx/Types/Internal/DvPair.hs +++ b/src/Codec/Xlsx/Types/Internal/DvPair.hs @@ -24,6 +24,12 @@ dv <- fromCursor cur return $ DvPair (sqref, dv) +instance FromXenoNode DvPair where + fromXenoNode root = do + sqref <- parseAttributes root $ fromAttr "sqref" + dv <- fromXenoNode root + return $ DvPair (sqref, dv) + instance ToElement DvPair where toElement nm (DvPair (sqRef,dv)) = e {elementAttributes = M.insert "sqref" (toAttrVal sqRef) $ elementAttributes e} diff --git a/src/Codec/Xlsx/Types/Internal/FormulaData.hs b/src/Codec/Xlsx/Types/Internal/FormulaData.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/FormulaData.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Types.Internal.FormulaData where + +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Cell +import Codec.Xlsx.Types.Common + +data FormulaData = FormulaData + { frmdFormula :: CellFormula + , frmdShared :: Maybe (SharedFormulaIndex, SharedFormulaOptions) + } deriving Generic + +defaultFormulaType :: Text +defaultFormulaType = "normal" + +instance FromXenoNode FormulaData where + fromXenoNode n = do + (bx, ca, t, mSi, mRef) <- + parseAttributes n $ + (,,,,) <$> fromAttrDef "bx" False + <*> fromAttrDef "ca" False + <*> fromAttrDef "t" defaultFormulaType + <*> maybeAttr "si" + <*> maybeAttr "ref" + (expr, shared) <- + case t of + d | d == defaultFormulaType -> do + formula <- contentX n + return (NormalFormula $ Formula formula, Nothing) + "shared" -> do + si <- + maybe + (Left "missing si attribute for shared formula") + return + mSi + formula <- Formula <$> contentX n + return + ( SharedFormula si + , mRef >>= \ref -> return (si, (SharedFormulaOptions ref formula))) + unexpected -> Left $ "Unexpected formula type" <> T.pack (show unexpected) + let f = + CellFormula + { _cellfAssignsToName = bx + , _cellfCalculate = ca + , _cellfExpression = expr + } + return $ FormulaData f shared diff --git a/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs b/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs deleted file mode 100644 --- a/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} -module Codec.Xlsx.Types.Internal.NumFmtPair where - -import Data.Text (Text) -import GHC.Generics (Generic) - -import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Writer.Internal - --- | Internal helper type for parsing "numFmt" recods --- --- See 18.8.30 "numFmt (Number Format)" (p. 1777) -newtype NumFmtPair = NumFmtPair - { unNumFmtPair :: (Int, Text) - } deriving (Eq, Show, Generic) - -instance FromCursor NumFmtPair where - fromCursor cur = do - fId <- fromAttribute "numFmtId" cur - fCode <- fromAttribute "formatCode" cur - return $ NumFmtPair (fId, fCode) - -instance ToElement NumFmtPair where - toElement nm (NumFmtPair (fId, fCode)) = - leafElement nm [ "numFmtId" .= toAttrVal fId - , "formatCode" .= toAttrVal fCode ] diff --git a/src/Codec/Xlsx/Types/Internal/Relationships.hs b/src/Codec/Xlsx/Types/Internal/Relationships.hs --- a/src/Codec/Xlsx/Types/Internal/Relationships.hs +++ b/src/Codec/Xlsx/Types/Internal/Relationships.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} @@ -16,10 +15,6 @@ import Safe import Text.XML import Text.XML.Cursor - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Internal 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 @@ -117,5 +117,5 @@ fromJustNote ("SST entry for " ++ show si ++ " not found") $ searchFromTo (\p -> shared V.! p >= si) 0 (V.length shared - 1) -sstItem :: SharedStringTable -> Int -> XlsxText -sstItem (SharedStringTable shared) = (V.!) shared +sstItem :: SharedStringTable -> Int -> Maybe XlsxText +sstItem (SharedStringTable shared) = (V.!?) shared 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 @@ -5,7 +5,6 @@ module Codec.Xlsx.Types.PageSetup ( -- * Main types PageSetup(..) --- , renderPageSetup -- * Enumerations , CellComments(..) , PrintErrors(..) @@ -36,6 +35,7 @@ ) where import Control.Lens (makeLenses) +import Control.DeepSeq (NFData) import Data.Default import qualified Data.Map as Map import Data.Maybe (catMaybes) @@ -137,6 +137,7 @@ , _pageSetupVerticalDpi :: Maybe Int } deriving (Eq, Ord, Show, Generic) +instance NFData PageSetup {------------------------------------------------------------------------------- Enumerations @@ -158,6 +159,7 @@ -- | Do not print cell comments | CellCommentsNone deriving (Eq, Ord, Show, Generic) +instance NFData CellComments -- | Print errors -- @@ -176,6 +178,7 @@ -- | Display cell errors as @#N/A@ | PrintErrorsNA deriving (Eq, Ord, Show, Generic) +instance NFData PrintErrors -- | Print orientation for this sheet data Orientation = @@ -183,6 +186,7 @@ | OrientationLandscape | OrientationPortrait deriving (Eq, Ord, Show, Generic) +instance NFData Orientation -- | Specifies printed page order data PageOrder = @@ -192,6 +196,7 @@ -- | Order pages horizontally first, then move vertically | PageOrderOverThenDown deriving (Eq, Ord, Show, Generic) +instance NFData PageOrder -- | Paper size data PaperSize = @@ -262,6 +267,7 @@ | EnvelopeItaly -- ^ Italy envelope (110 mm by 230 mm) | EnvelopeMonarch -- ^ Monarch envelope (3.875 in. by 7.5 in.). deriving (Eq, Ord, Show, Generic) +instance NFData PaperSize {------------------------------------------------------------------------------- Default instances @@ -300,10 +306,6 @@ Rendering -------------------------------------------------------------------------------} ----- | Render page setup ---renderPageSetup :: PageSetup -> RawPageSetup ---renderPageSetup = RawPageSetup . NodeElement . toElement "pageSetup" - -- | See @CT_PageSetup@, p. 3922 instance ToElement PageSetup where toElement nm PageSetup{..} = Element { @@ -452,6 +454,30 @@ _pageSetupId <- maybeAttribute "id" cur return PageSetup{..} +instance FromXenoNode PageSetup where + fromXenoNode root = + parseAttributes root $ do + _pageSetupPaperSize <- maybeAttr "paperSize" + _pageSetupPaperHeight <- maybeAttr "paperHeight" + _pageSetupPaperWidth <- maybeAttr "paperWidth" + _pageSetupScale <- maybeAttr "scale" + _pageSetupFirstPageNumber <- maybeAttr "firstPageNumber" + _pageSetupFitToWidth <- maybeAttr "fitToWidth" + _pageSetupFitToHeight <- maybeAttr "fitToHeight" + _pageSetupPageOrder <- maybeAttr "pageOrder" + _pageSetupOrientation <- maybeAttr "orientation" + _pageSetupUsePrinterDefaults <- maybeAttr "usePrinterDefaults" + _pageSetupBlackAndWhite <- maybeAttr "blackAndWhite" + _pageSetupDraft <- maybeAttr "draft" + _pageSetupCellComments <- maybeAttr "cellComments" + _pageSetupUseFirstPageNumber <- maybeAttr "useFirstPageNumber" + _pageSetupErrors <- maybeAttr "errors" + _pageSetupHorizontalDpi <- maybeAttr "horizontalDpi" + _pageSetupVerticalDpi <- maybeAttr "verticalDpi" + _pageSetupCopies <- maybeAttr "copies" + _pageSetupId <- maybeAttr "id" + return PageSetup {..} + -- | See @paperSize@ (attribute of @pageSetup@), p. 1659 instance FromAttrVal PaperSize where fromAttrVal "1" = readSuccess PaperLetter @@ -522,12 +548,86 @@ fromAttrVal "68" = readSuccess PaperA3ExtraTransverse fromAttrVal t = invalidText "PaperSize" t +instance FromAttrBs PaperSize where + fromAttrBs "1" = return PaperLetter + fromAttrBs "2" = return PaperLetterSmall + fromAttrBs "3" = return PaperTabloid + fromAttrBs "4" = return PaperLedger + fromAttrBs "5" = return PaperLegal + fromAttrBs "6" = return PaperStatement + fromAttrBs "7" = return PaperExecutive + fromAttrBs "8" = return PaperA3 + fromAttrBs "9" = return PaperA4 + fromAttrBs "10" = return PaperA4Small + fromAttrBs "11" = return PaperA5 + fromAttrBs "12" = return PaperB4 + fromAttrBs "13" = return PaperB5 + fromAttrBs "14" = return PaperFolio + fromAttrBs "15" = return PaperQuarto + fromAttrBs "16" = return PaperStandard10_14 + fromAttrBs "17" = return PaperStandard11_17 + fromAttrBs "18" = return PaperNote + fromAttrBs "19" = return Envelope9 + fromAttrBs "20" = return Envelope10 + fromAttrBs "21" = return Envelope11 + fromAttrBs "22" = return Envelope12 + fromAttrBs "23" = return Envelope14 + fromAttrBs "24" = return PaperC + fromAttrBs "25" = return PaperD + fromAttrBs "26" = return PaperE + fromAttrBs "27" = return EnvelopeDL + fromAttrBs "28" = return EnvelopeC5 + fromAttrBs "29" = return EnvelopeC3 + fromAttrBs "30" = return EnvelopeC4 + fromAttrBs "31" = return EnvelopeC6 + fromAttrBs "32" = return EnvelopeC65 + fromAttrBs "33" = return EnvelopeB4 + fromAttrBs "34" = return EnvelopeB5 + fromAttrBs "35" = return EnvelopeB6 + fromAttrBs "36" = return EnvelopeItaly + fromAttrBs "37" = return EnvelopeMonarch + fromAttrBs "38" = return Envelope6_3_4 + fromAttrBs "39" = return PaperFanfoldUsStandard + fromAttrBs "40" = return PaperFanfoldGermanStandard + fromAttrBs "41" = return PaperFanfoldGermanLegal + fromAttrBs "42" = return PaperIsoB4 + fromAttrBs "43" = return PaperJapaneseDoublePostcard + fromAttrBs "44" = return PaperStandard9_11 + fromAttrBs "45" = return PaperStandard10_11 + fromAttrBs "46" = return PaperStandard15_11 + fromAttrBs "47" = return EnvelopeInvite + fromAttrBs "50" = return PaperLetterExtra + fromAttrBs "51" = return PaperLegalExtra + fromAttrBs "52" = return PaperTabloidExtra + fromAttrBs "53" = return PaperA4Extra + fromAttrBs "54" = return PaperLetterTransverse + fromAttrBs "55" = return PaperA4Transverse + fromAttrBs "56" = return PaperLetterExtraTransverse + fromAttrBs "57" = return PaperSuperA + fromAttrBs "58" = return PaperSuperB + fromAttrBs "59" = return PaperLetterPlus + fromAttrBs "60" = return PaperA4Plus + fromAttrBs "61" = return PaperA5Transverse + fromAttrBs "62" = return PaperJisB5Transverse + fromAttrBs "63" = return PaperA3Extra + fromAttrBs "64" = return PaperA5Extra + fromAttrBs "65" = return PaperIsoB5Extra + fromAttrBs "66" = return PaperA2 + fromAttrBs "67" = return PaperA3Transverse + fromAttrBs "68" = return PaperA3ExtraTransverse + fromAttrBs x = unexpectedAttrBs "PaperSize" x + -- | See @ST_PageOrder@, p. 3923 instance FromAttrVal PageOrder where fromAttrVal "downThenOver" = readSuccess PageOrderDownThenOver fromAttrVal "overThenDown" = readSuccess PageOrderOverThenDown fromAttrVal t = invalidText "PageOrder" t +instance FromAttrBs PageOrder where + fromAttrBs "downThenOver" = return PageOrderDownThenOver + fromAttrBs "overThenDown" = return PageOrderOverThenDown + fromAttrBs x = unexpectedAttrBs "PageOrder" x + -- | See @ST_CellComments@, p. 3923 instance FromAttrVal CellComments where fromAttrVal "none" = readSuccess CellCommentsNone @@ -535,6 +635,12 @@ fromAttrVal "atEnd" = readSuccess CellCommentsAtEnd fromAttrVal t = invalidText "CellComments" t +instance FromAttrBs CellComments where + fromAttrBs "none" = return CellCommentsNone + fromAttrBs "asDisplayed" = return CellCommentsAsDisplayed + fromAttrBs "atEnd" = return CellCommentsAtEnd + fromAttrBs x = unexpectedAttrBs "CellComments" x + -- | See @ST_PrintError@, p. 3923 instance FromAttrVal PrintErrors where fromAttrVal "displayed" = readSuccess PrintErrorsDisplayed @@ -543,9 +649,22 @@ fromAttrVal "NA" = readSuccess PrintErrorsNA fromAttrVal t = invalidText "PrintErrors" t +instance FromAttrBs PrintErrors where + fromAttrBs "displayed" = return PrintErrorsDisplayed + fromAttrBs "blank" = return PrintErrorsBlank + fromAttrBs "dash" = return PrintErrorsDash + fromAttrBs "NA" = return PrintErrorsNA + fromAttrBs x = unexpectedAttrBs "PrintErrors" x + -- | See @ST_Orientation@, p. 3923 instance FromAttrVal Orientation where fromAttrVal "default" = readSuccess OrientationDefault fromAttrVal "portrait" = readSuccess OrientationPortrait fromAttrVal "landscape" = readSuccess OrientationLandscape fromAttrVal t = invalidText "Orientation" t + +instance FromAttrBs Orientation where + fromAttrBs "default" = return OrientationDefault + fromAttrBs "portrait" = return OrientationPortrait + fromAttrBs "landscape" = return OrientationLandscape + fromAttrBs x = unexpectedAttrBs "Orientation" x diff --git a/src/Codec/Xlsx/Types/PivotTable.hs b/src/Codec/Xlsx/Types/PivotTable.hs --- a/src/Codec/Xlsx/Types/PivotTable.hs +++ b/src/Codec/Xlsx/Types/PivotTable.hs @@ -12,6 +12,7 @@ ) where import Control.Arrow (first) +import Control.DeepSeq (NFData) import Data.Text (Text) import GHC.Generics (Generic) @@ -34,13 +35,15 @@ , _pvtSrcSheet :: Text , _pvtSrcRef :: Range } deriving (Eq, Show, Generic) +instance NFData PivotTable data PivotFieldInfo = PivotFieldInfo - { _pfiName :: PivotFieldName + { _pfiName :: Maybe PivotFieldName , _pfiOutline :: Bool , _pfiSortType :: FieldSortType , _pfiHiddenItems :: [CellValue] } deriving (Eq, Show, Generic) +instance NFData PivotFieldInfo -- | Sort orders that can be applied to fields in a PivotTable -- @@ -50,21 +53,25 @@ | FieldSortDescending | FieldSortManual deriving (Eq, Ord, Show, Generic) +instance NFData FieldSortType newtype PivotFieldName = PivotFieldName Text deriving (Eq, Ord, Show, Generic) +instance NFData PivotFieldName data PositionedField = DataPosition | FieldPosition PivotFieldName deriving (Eq, Ord, Show, Generic) +instance NFData PositionedField data DataField = DataField { _dfField :: PivotFieldName , _dfName :: Text , _dfFunction :: ConsolidateFunction } deriving (Eq, Show, Generic) +instance NFData DataField -- | Data consolidation functions specified by the user and used to -- consolidate ranges of data @@ -102,6 +109,7 @@ -- ^ The variance of a population, where the population is all of -- the data to be summarized. deriving (Eq, Show, Generic) +instance NFData ConsolidateFunction {------------------------------------------------------------------------------- Rendering 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric #-} @@ -13,10 +12,6 @@ import Data.Maybe (catMaybes) import Text.XML import Text.XML.Cursor - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Common 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 @@ -32,6 +32,7 @@ import Control.Arrow (first) import Control.Lens (makeLenses) +import Control.DeepSeq (NFData) import Data.Bits import Data.Char import Data.Maybe (catMaybes) @@ -47,6 +48,7 @@ newtype LegacyPassword = LegacyPassword Text deriving (Eq, Show, Generic) +instance NFData LegacyPassword -- | Creates legacy @XOR@ hashed password. -- @@ -129,6 +131,7 @@ , _sprSort :: Bool -- ^ sorting should not be allowed when the sheet is protected } deriving (Eq, Show, Generic) +instance NFData SheetProtection makeLenses ''SheetProtection @@ -207,9 +210,33 @@ _sprSort <- fromAttributeDef "sort" True cur return SheetProtection {..} +instance FromXenoNode SheetProtection where + fromXenoNode root = + parseAttributes root $ do + _sprLegacyPassword <- maybeAttr "password" + _sprSheet <- fromAttrDef "sheet" False + _sprAutoFilter <- fromAttrDef "autoFilter" True + _sprDeleteColumns <- fromAttrDef "deleteColumns" True + _sprDeleteRows <- fromAttrDef "deleteRows" True + _sprFormatCells <- fromAttrDef "formatCells" True + _sprFormatColumns <- fromAttrDef "formatColumns" True + _sprFormatRows <- fromAttrDef "formatRows" True + _sprInsertColumns <- fromAttrDef "insertColumns" True + _sprInsertHyperlinks <- fromAttrDef "insertHyperlinks" True + _sprInsertRows <- fromAttrDef "insertRows" True + _sprObjects <- fromAttrDef "objects" False + _sprPivotTables <- fromAttrDef "pivotTables" True + _sprScenarios <- fromAttrDef "scenarios" False + _sprSelectLockedCells <- fromAttrDef "selectLockedCells" False + _sprSelectUnlockedCells <- fromAttrDef "selectUnlockedCells" False + _sprSort <- fromAttrDef "sort" True + return SheetProtection {..} + instance FromAttrVal LegacyPassword where fromAttrVal = fmap (first LegacyPassword) . fromAttrVal +instance FromAttrBs LegacyPassword where + fromAttrBs = fmap LegacyPassword . fromAttrBs {------------------------------------------------------------------------------- Rendering 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -34,6 +33,7 @@ import Control.Lens hiding (element) import Control.Monad +import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes) import Data.Text (Text) @@ -45,11 +45,6 @@ import Codec.Xlsx.Types.StyleSheet import Codec.Xlsx.Writer.Internal -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -import Data.Monoid -#endif - -- | Rich Text Run -- -- This element represents a run of rich text. A rich text run is a region of @@ -71,6 +66,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData RichTextRun + -- | Run properties -- -- Section 18.4.7, "rPr (Run Properties)" (p. 1725) @@ -176,6 +173,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData RunProperties + {------------------------------------------------------------------------------- Lenses -------------------------------------------------------------------------------} @@ -262,6 +261,13 @@ _richTextRunProperties <- maybeFromElement (n_ "rPr") cur return RichTextRun{..} +instance FromXenoNode RichTextRun where + fromXenoNode root = do + (prNode, tNode) <- collectChildren root $ (,) <$> maybeChild "rPr" <*> requireChild "t" + _richTextRunProperties <- mapM fromXenoNode prNode + _richTextRunText <- contentX tNode + return RichTextRun {..} + -- | See @CT_RPrElt@, p. 3903 instance FromCursor RunProperties where fromCursor cur = do @@ -280,6 +286,25 @@ _runPropertiesUnderline <- maybeElementValue (n_ "u") cur _runPropertiesVertAlign <- maybeElementValue (n_ "vertAlign") cur _runPropertiesScheme <- maybeElementValue (n_ "scheme") cur + return RunProperties{..} + +instance FromXenoNode RunProperties where + fromXenoNode root = collectChildren root $ do + _runPropertiesFont <- maybeElementVal "rFont" + _runPropertiesCharset <- maybeElementVal "charset" + _runPropertiesFontFamily <- maybeElementVal "family" + _runPropertiesBold <- maybeElementVal "b" + _runPropertiesItalic <- maybeElementVal "i" + _runPropertiesStrikeThrough <- maybeElementVal "strike" + _runPropertiesOutline <- maybeElementVal "outline" + _runPropertiesShadow <- maybeElementVal "shadow" + _runPropertiesCondense <- maybeElementVal "condense" + _runPropertiesExtend <- maybeElementVal "extend" + _runPropertiesColor <- maybeFromChild "color" + _runPropertiesSize <- maybeElementVal "sz" + _runPropertiesUnderline <- maybeElementVal "u" + _runPropertiesVertAlign <- maybeElementVal "vertAlign" + _runPropertiesScheme <- maybeElementVal "scheme" return RunProperties{..} {------------------------------------------------------------------------------- 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 #-} @@ -50,16 +49,13 @@ import GHC.Generics (Generic) import Control.Lens (makeLenses) +import Control.DeepSeq (NFData) import Data.Default import Data.Maybe (catMaybes, maybeToList, listToMaybe) import Text.XML import Text.XML.Cursor import qualified Data.Map as Map -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative () -#endif - import Codec.Xlsx.Types.Common import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Writer.Internal @@ -180,6 +176,7 @@ , _sheetViewSelection :: [Selection] } deriving (Eq, Ord, Show, Generic) +instance NFData SheetView -- | Worksheet view selection. -- @@ -203,6 +200,7 @@ , _selectionSqref :: Maybe SqRef } deriving (Eq, Ord, Show, Generic) +instance NFData Selection -- | Worksheet view pane -- @@ -230,6 +228,7 @@ , _paneYSplit :: Maybe Double } deriving (Eq, Ord, Show, Generic) +instance NFData Pane {------------------------------------------------------------------------------- Enumerations @@ -248,6 +247,7 @@ -- | Page layout view | SheetViewTypePageLayout deriving (Eq, Ord, Show, Generic) +instance NFData SheetViewType -- | Pane type -- @@ -281,6 +281,7 @@ -- specifies the right pane. | PaneTypeTopRight deriving (Eq, Ord, Show, Generic) +instance NFData PaneType -- | State of the sheet's pane. -- @@ -299,6 +300,7 @@ -- adjustable by the user. | PaneStateSplit deriving (Eq, Ord, Show, Generic) +instance NFData PaneState {------------------------------------------------------------------------------- Lenses @@ -468,6 +470,32 @@ _sheetViewSelection = cur $/ element (n_ "selection") >=> fromCursor return SheetView{..} +instance FromXenoNode SheetView where + fromXenoNode root = parseAttributes root $ do + _sheetViewWindowProtection <- maybeAttr "windowProtection" + _sheetViewShowFormulas <- maybeAttr "showFormulas" + _sheetViewShowGridLines <- maybeAttr "showGridLines" + _sheetViewShowRowColHeaders <- maybeAttr "showRowColHeaders" + _sheetViewShowZeros <- maybeAttr "showZeros" + _sheetViewRightToLeft <- maybeAttr "rightToLeft" + _sheetViewTabSelected <- maybeAttr "tabSelected" + _sheetViewShowRuler <- maybeAttr "showRuler" + _sheetViewShowOutlineSymbols <- maybeAttr "showOutlineSymbols" + _sheetViewDefaultGridColor <- maybeAttr "defaultGridColor" + _sheetViewShowWhiteSpace <- maybeAttr "showWhiteSpace" + _sheetViewType <- maybeAttr "view" + _sheetViewTopLeftCell <- maybeAttr "topLeftCell" + _sheetViewColorId <- maybeAttr "colorId" + _sheetViewZoomScale <- maybeAttr "zoomScale" + _sheetViewZoomScaleNormal <- maybeAttr "zoomScaleNormal" + _sheetViewZoomScaleSheetLayoutView <- maybeAttr "zoomScaleSheetLayoutView" + _sheetViewZoomScalePageLayoutView <- maybeAttr "zoomScalePageLayoutView" + _sheetViewWorkbookViewId <- fromAttr "workbookViewId" + (_sheetViewPane, _sheetViewSelection) <- + toAttrParser . collectChildren root $ + (,) <$> maybeFromChild "pane" <*> fromChildList "selection" + return SheetView {..} + -- | See @CT_Pane@, p. 3913 instance FromCursor Pane where fromCursor cur = do @@ -478,6 +506,16 @@ _paneState <- maybeAttribute "state" cur return Pane{..} +instance FromXenoNode Pane where + fromXenoNode root = + parseAttributes root $ do + _paneXSplit <- maybeAttr "xSplit" + _paneYSplit <- maybeAttr "ySplit" + _paneTopLeftCell <- maybeAttr "topLeftCell" + _paneActivePane <- maybeAttr "activePane" + _paneState <- maybeAttr "state" + return Pane {..} + -- | See @CT_Selection@, p. 3914 instance FromCursor Selection where fromCursor cur = do @@ -487,6 +525,15 @@ _selectionSqref <- maybeAttribute "sqref" cur return Selection{..} +instance FromXenoNode Selection where + fromXenoNode root = + parseAttributes root $ do + _selectionPane <- maybeAttr "pane" + _selectionActiveCell <- maybeAttr "activeCell" + _selectionActiveCellId <- maybeAttr "activeCellId" + _selectionSqref <- maybeAttr "sqref" + return Selection {..} + -- | See @ST_SheetViewType@, p. 3913 instance FromAttrVal SheetViewType where fromAttrVal "normal" = readSuccess SheetViewTypeNormal @@ -494,6 +541,12 @@ fromAttrVal "pageLayout" = readSuccess SheetViewTypePageLayout fromAttrVal t = invalidText "SheetViewType" t +instance FromAttrBs SheetViewType where + fromAttrBs "normal" = return SheetViewTypeNormal + fromAttrBs "pageBreakPreview" = return SheetViewTypePageBreakPreview + fromAttrBs "pageLayout" = return SheetViewTypePageLayout + fromAttrBs x = unexpectedAttrBs "SheetViewType" x + -- | See @ST_Pane@, p. 3914 instance FromAttrVal PaneType where fromAttrVal "bottomRight" = readSuccess PaneTypeBottomRight @@ -502,9 +555,22 @@ fromAttrVal "topLeft" = readSuccess PaneTypeTopLeft fromAttrVal t = invalidText "PaneType" t +instance FromAttrBs PaneType where + fromAttrBs "bottomRight" = return PaneTypeBottomRight + fromAttrBs "topRight" = return PaneTypeTopRight + fromAttrBs "bottomLeft" = return PaneTypeBottomLeft + fromAttrBs "topLeft" = return PaneTypeTopLeft + fromAttrBs x = unexpectedAttrBs "PaneType" x + -- | See @ST_PaneState@, p. 3929 instance FromAttrVal PaneState where fromAttrVal "split" = readSuccess PaneStateSplit fromAttrVal "frozen" = readSuccess PaneStateFrozen fromAttrVal "frozenSplit" = readSuccess PaneStateFrozenSplit fromAttrVal t = invalidText "PaneState" t + +instance FromAttrBs PaneState where + fromAttrBs "split" = return PaneStateSplit + fromAttrBs "frozen" = return PaneStateFrozen + fromAttrBs "frozenSplit" = return PaneStateFrozenSplit + fromAttrBs x = unexpectedAttrBs "PaneState" x 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 #-} @@ -19,8 +18,9 @@ , FillPattern(..) , Font(..) , NumberFormat(..) + , NumFmt(..) , ImpliedNumberFormat (..) - , NumFmt + , FormatCode , Protection(..) -- * Supporting enumerations , CellHorizontalAlignment(..) @@ -61,6 +61,7 @@ , dxfBorder , dxfFill , dxfFont + , dxfNumFmt , dxfProtection -- ** Alignment , alignmentHorizontal @@ -128,6 +129,7 @@ ) where import Control.Lens hiding (element, elements, (.=)) +import Control.DeepSeq (NFData) import Data.Default import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -139,12 +141,7 @@ import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Parser.Internal -import Codec.Xlsx.Types.Internal.NumFmtPair import Codec.Xlsx.Writer.Internal {------------------------------------------------------------------------------- @@ -223,7 +220,7 @@ -- -- Section 18.8.15, "dxfs (Formats)" (p. 1765) - , _styleSheetNumFmts :: Map Int NumFmt + , _styleSheetNumFmts :: Map Int FormatCode -- ^ Number formats -- -- This element contains custom number formats defined in this style sheet @@ -231,6 +228,8 @@ -- Section 18.8.31, "numFmts (Number Formats)" (p. 1784) } deriving (Eq, Ord, Show, Generic) +instance NFData StyleSheet + -- | Cell formatting -- -- TODO: The @extLst@ field is currently unsupported. @@ -318,6 +317,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData CellXf + {------------------------------------------------------------------------------- Supporting record types -------------------------------------------------------------------------------} @@ -367,6 +368,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData Alignment + -- | Expresses a single set of cell border formats (left, right, top, bottom, -- diagonal). Color is optional. When missing, 'automatic' is implied. -- @@ -425,6 +428,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData Border + -- | Border style -- See @CT_BorderPr@ (p. 3934) data BorderStyle = BorderStyle { @@ -433,6 +438,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData BorderStyle + -- | One of the colors associated with the data bar or color scale. -- -- The 'indexed' attribute (used for backwards compatibility only) is not @@ -467,6 +474,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData Color + -- | This element specifies fill formatting. -- -- TODO: Gradient fills (18.8.4) are currently unsupported. If we add them, @@ -479,6 +488,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData Fill + -- | This element is used to specify cell fill information for pattern and solid -- color cell fills. For solid cell fills (no pattern), fgColor is used. For -- cell fills with patterns specified, then the cell fill color is specified by @@ -492,6 +503,8 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData FillPattern + -- | This element defines the properties for one of the fonts used in this -- workbook. -- @@ -594,12 +607,17 @@ } deriving (Eq, Ord, Show, Generic) +instance NFData Font + -- | A single dxf record, expressing incremental formatting to be applied. -- -- Section 18.8.14, "dxf (Formatting)" (p. 1765) data Dxf = Dxf { _dxfFont :: Maybe Font - -- TODO: numFmt + -- | It seems to be required that this number format entry is duplicated + -- in '_styleSheetNumFmts' of the style sheet, though the spec says + -- nothing explicitly about it. + , _dxfNumFmt :: Maybe NumFmt , _dxfFill :: Maybe Fill , _dxfAlignment :: Maybe Alignment , _dxfBorder :: Maybe Border @@ -607,17 +625,36 @@ -- TODO: extList } deriving (Eq, Ord, Show, Generic) -type NumFmt = Text +instance NFData Dxf +-- | A number format code. +-- +-- Section 18.8.30, "numFmt (Number Format)" (p. 1777) +type FormatCode = Text + -- | This element specifies number format properties which indicate -- how to format and render the numeric value of a cell. -- --- Section 18.2.30 "numFmt (Number Format)" (p. 1777) +-- Section 18.8.30 "numFmt (Number Format)" (p. 1777) +data NumFmt = NumFmt + { _numFmtId :: Int + , _numFmtCode :: FormatCode + } deriving (Eq, Ord, Show, Generic) + +instance NFData NumFmt + +mkNumFmtPair :: NumFmt -> (Int, FormatCode) +mkNumFmtPair NumFmt{..} = (_numFmtId, _numFmtCode) + +-- | This type gives a high-level version of representation of number format +-- used in 'Codec.Xlsx.Formatted.Format'. data NumberFormat = StdNumberFormat ImpliedNumberFormat - | UserNumberFormat NumFmt + | UserNumberFormat FormatCode deriving (Eq, Ord, Show, Generic) +instance NFData NumberFormat + -- | Basic number format with predefined number of decimals -- as format code of number format in xlsx should be less than 255 characters -- number of decimals shouldn't be more than 253 @@ -658,7 +695,7 @@ | NfThousandsNegativeParens -- ^> 37 #,##0 ;(#,##0) | NfThousandsNegativeRed -- ^> 38 #,##0 ;[Red](#,##0) | NfThousands2DecimalNegativeParens -- ^> 39 #,##0.00;(#,##0.00) - | NfTousands2DecimalNEgativeRed -- ^> 40 #,##0.00;[Red](#,##0.00) + | NfThousands2DecimalNegativeRed -- ^> 40 #,##0.00;[Red](#,##0.00) | NfMmSs -- ^> 45 mm:ss | NfOptHMmSs -- ^> 46 [h]:mm:ss | NfMmSs1Decimal -- ^> 47 mmss.0 @@ -667,6 +704,8 @@ | NfOtherImplied Int -- ^ other (non local-neutral?) built-in format (id < 164) deriving (Eq, Ord, Show, Generic) +instance NFData ImpliedNumberFormat + stdNumberFormatId :: ImpliedNumberFormat -> Int stdNumberFormatId NfGeneral = 0 -- General stdNumberFormatId NfZero = 1 -- 0 @@ -690,7 +729,7 @@ stdNumberFormatId NfThousandsNegativeParens = 37 -- #,##0 ;(#,##0) stdNumberFormatId NfThousandsNegativeRed = 38 -- #,##0 ;[Red](#,##0) stdNumberFormatId NfThousands2DecimalNegativeParens = 39 -- #,##0.00;(#,##0.00) -stdNumberFormatId NfTousands2DecimalNEgativeRed = 40 -- #,##0.00;[Red](#,##0.00) +stdNumberFormatId NfThousands2DecimalNegativeRed = 40 -- #,##0.00;[Red](#,##0.00) stdNumberFormatId NfMmSs = 45 -- mm:ss stdNumberFormatId NfOptHMmSs = 46 -- [h]:mm:ss stdNumberFormatId NfMmSs1Decimal = 47 -- mmss.0 @@ -721,7 +760,7 @@ idToStdNumberFormat 37 = Just NfThousandsNegativeParens -- #,##0 ;(#,##0) idToStdNumberFormat 38 = Just NfThousandsNegativeRed -- #,##0 ;[Red](#,##0) idToStdNumberFormat 39 = Just NfThousands2DecimalNegativeParens -- #,##0.00;(#,##0.00) -idToStdNumberFormat 40 = Just NfTousands2DecimalNEgativeRed -- #,##0.00;[Red](#,##0.00) +idToStdNumberFormat 40 = Just NfThousands2DecimalNegativeRed -- #,##0.00;[Red](#,##0.00) idToStdNumberFormat 45 = Just NfMmSs -- mm:ss idToStdNumberFormat 46 = Just NfOptHMmSs -- [h]:mm:ss idToStdNumberFormat 47 = Just NfMmSs1Decimal -- mmss.0 @@ -744,6 +783,7 @@ , _protectionLocked :: Maybe Bool } deriving (Eq, Ord, Show, Generic) +instance NFData Protection {------------------------------------------------------------------------------- Enumerations @@ -762,6 +802,7 @@ | CellHorizontalAlignmentLeft | CellHorizontalAlignmentRight deriving (Eq, Ord, Show, Generic) +instance NFData CellHorizontalAlignment -- | Vertical alignment in cells -- @@ -773,6 +814,7 @@ | CellVerticalAlignmentJustify | CellVerticalAlignmentTop deriving (Eq, Ord, Show, Generic) +instance NFData CellVerticalAlignment -- | Font family -- @@ -797,6 +839,7 @@ -- | Novelty font | FontFamilyDecorative deriving (Eq, Ord, Show, Generic) +instance NFData FontFamily -- | Font scheme -- @@ -811,6 +854,7 @@ -- | This font is not a theme font. | FontSchemeNone deriving (Eq, Ord, Show, Generic) +instance NFData FontScheme -- | Font underline property -- @@ -822,6 +866,7 @@ | FontUnderlineDoubleAccounting | FontUnderlineNone deriving (Eq, Ord, Show, Generic) +instance NFData FontUnderline -- | Vertical alignment -- @@ -831,6 +876,7 @@ | FontVerticalAlignmentSubscript | FontVerticalAlignmentSuperscript deriving (Eq, Ord, Show, Generic) +instance NFData FontVerticalAlignment data LineStyle = LineStyleDashDot @@ -848,6 +894,7 @@ | LineStyleThick | LineStyleThin deriving (Eq, Ord, Show, Generic) +instance NFData LineStyle -- | Indicates the style of fill pattern being used for a cell format. -- @@ -873,6 +920,7 @@ | PatternTypeNone | PatternTypeSolid deriving (Eq, Ord, Show, Generic) +instance NFData PatternType -- | Reading order -- @@ -882,6 +930,7 @@ | ReadingOrderLeftToRight | ReadingOrderRightToLeft deriving (Eq, Ord, Show, Generic) +instance NFData ReadingOrder {------------------------------------------------------------------------------- Lenses @@ -982,6 +1031,7 @@ instance Default Dxf where def = Dxf { _dxfFont = Nothing + , _dxfNumFmt = Nothing , _dxfFill = Nothing , _dxfAlignment = Nothing , _dxfBorder = Nothing @@ -1098,7 +1148,7 @@ -- TODO: colors -- TODO: extLst ] - numFmts = map NumFmtPair $ M.toList _styleSheetNumFmts + numFmts = map (uncurry NumFmt) $ M.toList _styleSheetNumFmts -- | See @CT_Xf@, p. 4486 instance ToElement CellXf where @@ -1132,6 +1182,7 @@ { elementName = nm , elementNodes = map NodeElement $ catMaybes [ toElement "font" <$> _dxfFont + , toElement "numFmt" <$> _dxfNumFmt , toElement "fill" <$> _dxfFill , toElement "alignment" <$> _dxfAlignment , toElement "border" <$> _dxfBorder @@ -1252,6 +1303,14 @@ ] } +-- | See @CT_NumFmt@, p. 3936 +instance ToElement NumFmt where + toElement nm (NumFmt {..}) = + leafElement nm + [ "numFmtId" .= toAttrVal _numFmtId + , "formatCode" .= toAttrVal _numFmtCode + ] + -- | See @CT_CellProtection@, p. 4484 instance ToElement Protection where toElement nm Protection{..} = Element { @@ -1366,7 +1425,7 @@ _styleSheetCellXfs = cur $/ element (n_ "cellXfs") &/ element (n_ "xf") >=> fromCursor -- TODO: cellStyles _styleSheetDxfs = cur $/ element (n_ "dxfs") &/ element (n_ "dxf") >=> fromCursor - _styleSheetNumFmts = M.fromList . map unNumFmtPair $ + _styleSheetNumFmts = M.fromList . map mkNumFmtPair $ cur $/ element (n_ "numFmts")&/ element (n_ "numFmt") >=> fromCursor -- TODO: tableStyles -- TODO: colors @@ -1403,6 +1462,15 @@ fromAttrVal "5" = readSuccess FontFamilyDecorative fromAttrVal t = invalidText "FontFamily" t +instance FromAttrBs FontFamily where + fromAttrBs "0" = return FontFamilyNotApplicable + fromAttrBs "1" = return FontFamilyRoman + fromAttrBs "2" = return FontFamilySwiss + fromAttrBs "3" = return FontFamilyModern + fromAttrBs "4" = return FontFamilyScript + fromAttrBs "5" = return FontFamilyDecorative + fromAttrBs x = unexpectedAttrBs "FontFamily" x + -- | See @CT_Color@, p. 4484 instance FromCursor Color where fromCursor cur = do @@ -1412,6 +1480,15 @@ _colorTint <- maybeAttribute "tint" cur return Color{..} +instance FromXenoNode Color where + fromXenoNode root = + parseAttributes root $ do + _colorAutomatic <- maybeAttr "auto" + _colorARGB <- maybeAttr "rgb" + _colorTheme <- maybeAttr "theme" + _colorTint <- maybeAttr "tint" + return Color {..} + -- See @ST_UnderlineValues@, p. 3940 instance FromAttrVal FontUnderline where fromAttrVal "single" = readSuccess FontUnderlineSingle @@ -1421,18 +1498,38 @@ fromAttrVal "none" = readSuccess FontUnderlineNone fromAttrVal t = invalidText "FontUnderline" t +instance FromAttrBs FontUnderline where + fromAttrBs "single" = return FontUnderlineSingle + fromAttrBs "double" = return FontUnderlineDouble + fromAttrBs "singleAccounting" = return FontUnderlineSingleAccounting + fromAttrBs "doubleAccounting" = return FontUnderlineDoubleAccounting + fromAttrBs "none" = return FontUnderlineNone + fromAttrBs x = unexpectedAttrBs "FontUnderline" x + instance FromAttrVal FontVerticalAlignment where fromAttrVal "baseline" = readSuccess FontVerticalAlignmentBaseline fromAttrVal "subscript" = readSuccess FontVerticalAlignmentSubscript fromAttrVal "superscript" = readSuccess FontVerticalAlignmentSuperscript fromAttrVal t = invalidText "FontVerticalAlignment" t +instance FromAttrBs FontVerticalAlignment where + fromAttrBs "baseline" = return FontVerticalAlignmentBaseline + fromAttrBs "subscript" = return FontVerticalAlignmentSubscript + fromAttrBs "superscript" = return FontVerticalAlignmentSuperscript + fromAttrBs x = unexpectedAttrBs "FontVerticalAlignment" x + instance FromAttrVal FontScheme where fromAttrVal "major" = readSuccess FontSchemeMajor fromAttrVal "minor" = readSuccess FontSchemeMinor fromAttrVal "none" = readSuccess FontSchemeNone fromAttrVal t = invalidText "FontScheme" t +instance FromAttrBs FontScheme where + fromAttrBs "major" = return FontSchemeMajor + fromAttrBs "minor" = return FontSchemeMinor + fromAttrBs "none" = return FontSchemeNone + fromAttrBs x = unexpectedAttrBs "FontScheme" x + -- | See @CT_Fill@, p. 4484 instance FromCursor Fill where fromCursor cur = do @@ -1533,11 +1630,19 @@ 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 return Dxf{..} + +-- | See @CT_NumFmt@, p. 3936 +instance FromCursor NumFmt where + fromCursor cur = do + _numFmtCode <- fromAttribute "formatCode" cur + _numFmtId <- fromAttribute "numFmtId" cur + return NumFmt{..} -- | See @CT_CellAlignment@, p. 4482 instance FromCursor Alignment where 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,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,16 +5,13 @@ module Codec.Xlsx.Types.Table where import Control.Lens (makeLenses) +import Control.DeepSeq (NFData) import Data.Maybe (catMaybes, maybeToList) import Data.Text (Text) import GHC.Generics (Generic) import Text.XML import Text.XML.Cursor -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.AutoFilter import Codec.Xlsx.Types.Common @@ -62,6 +58,7 @@ -- include at least 1 column , tblAutoFilter :: Maybe AutoFilter } deriving (Eq, Show, Generic) +instance NFData Table -- | Single table column -- @@ -75,6 +72,7 @@ -- UI, and is referenced through functions. This name shall be -- unique per table. } deriving (Eq, Show, Generic) +instance NFData TableColumn makeLenses ''Table diff --git a/src/Codec/Xlsx/Types/Variant.hs b/src/Codec/Xlsx/Types/Variant.hs --- a/src/Codec/Xlsx/Types/Variant.hs +++ b/src/Codec/Xlsx/Types/Variant.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} module Codec.Xlsx.Types.Variant where +import Control.DeepSeq (NFData) import Data.ByteString (ByteString) import Data.ByteString.Base64 as B64 import Data.Text (Text) @@ -25,6 +26,8 @@ -- vt_lpstr, vt_bstr, vt_date, vt_filetime, vt_cy, vt_error, vt_stream, -- vt_ostream, vt_storage, vt_ostorage, vt_vstream, vt_clsid deriving (Eq, Show, Generic) + +instance NFData Variant {------------------------------------------------------------------------------- Parsing 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,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -13,13 +13,13 @@ import Control.Lens hiding (transform, (.=)) import Control.Monad (forM) import Control.Monad.ST +import Control.Monad.State (evalState, get, put) import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () import Data.List (foldl', mapAccumL) import Data.Map (Map) import qualified Data.Map as M import Data.Maybe -import Data.Maybe (maybeToList) import Data.Monoid ((<>)) import Data.STRef import Data.Text (Text) @@ -27,21 +27,14 @@ import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) import Data.Time.Format (formatTime) -#if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) -#else -import System.Locale (defaultTimeLocale) -#endif import Data.Tuple.Extra (fst3, snd3, thd3) import GHC.Generics (Generic) import Safe import Text.XML -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Codec.Xlsx.Types +import Codec.Xlsx.Types.Cell (applySharedFormulaOpts) import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair import qualified Codec.Xlsx.Types.Internal.CommentTable @@ -122,7 +115,8 @@ rootEls = catMaybes $ [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews , nonEmptyElListSimple "cols" . map (toElement "col") $ ws ^. wsColumnsProperties - , Just . elementListSimple "sheetData" $ sheetDataXml cells (ws ^. wsRowPropertiesMap) + , Just . elementListSimple "sheetData" $ + sheetDataXml cells (ws ^. wsRowPropertiesMap) (ws ^. wsSharedFormulas) , toElement "sheetProtection" <$> (ws ^. wsProtection) , toElement "autoFilter" <$> (ws ^. wsAutoFilter) , nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges @@ -165,35 +159,57 @@ unsafeRefId :: Int -> RefId unsafeRefId num = RefId $ "rId" <> txti num -sheetDataXml :: Cells -> Map Int RowProperties -> [Element] -sheetDataXml rows rh = map rowEl rows +sheetDataXml :: + Cells + -> Map Int RowProperties + -> Map SharedFormulaIndex SharedFormulaOptions + -> [Element] +sheetDataXml rows rh sharedFormulas = + evalState (mapM rowEl rows) sharedFormulas where - rowEl (r, cells) = elementList "row" - (ht ++ s ++ - [("r", txti r), ("hidden", txtb hidden), ("outlineLevel", "0"), - ("collapsed", "false"), ("customFormat", "true"), - ("customHeight", txtb hasHeight)]) - $ map (cellEl r) cells - where - mProps = M.lookup r rh - hasHeight = case rowHeight =<< mProps of - Just CustomHeight{} -> True - _ -> False - ht = do Just height <- [rowHeight =<< mProps] - let h = case height of CustomHeight x -> x - AutomaticHeight x -> x - return ("ht", txtd h) - s = do Just st <- [rowStyle =<< mProps] - return ("s", txti st) - hidden = fromMaybe False $ rowHidden <$> mProps - cellEl r (icol, cell) = - elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) - (catMaybes [ elementContent "v" . value <$> xlsxCellValue cell - , toElement "f" <$> xlsxCellFormula cell - ]) - cellAttrs ref cell = cellStyleAttr cell ++ [("r" .= ref), ("t" .= xlsxCellType cell)] - cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] - cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] + rowEl (r, cells) = do + let mProps = M.lookup r rh + hasHeight = case rowHeight =<< mProps of + Just CustomHeight{} -> True + _ -> False + ht = do Just height <- [rowHeight =<< mProps] + let h = case height of CustomHeight x -> x + AutomaticHeight x -> x + return ("ht", txtd h) + s = do Just st <- [rowStyle =<< mProps] + return ("s", txti st) + hidden = fromMaybe False $ rowHidden <$> mProps + attrs = ht ++ + s ++ + [ ("r", txti r) + , ("hidden", txtb hidden) + , ("outlineLevel", "0") + , ("collapsed", "false") + , ("customFormat", "true") + , ("customHeight", txtb hasHeight) + ] + cellEls <- mapM (cellEl r) cells + return $ elementList "row" attrs cellEls + cellEl r (icol, cell) = do + let cellAttrs ref c = + cellStyleAttr c ++ [("r" .= ref), ("t" .= xlsxCellType c)] + cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] + cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] + formula = xlsxCellFormula cell + fEl0 = toElement "f" <$> formula + fEl <- case formula of + Just CellFormula{_cellfExpression=SharedFormula si} -> do + shared <- get + case M.lookup si shared of + Just fOpts -> do + put $ M.delete si shared + return $ applySharedFormulaOpts fOpts <$> fEl0 + Nothing -> + return fEl0 + _ -> + return fEl0 + return $ elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) $ + catMaybes [fEl, elementContent "v" . value <$> xlsxCellValue cell] genComments :: Int -> Cells -> STRef s Int -> ST s (Maybe (Element, [ReferencedFileData])) genComments n cells ref = @@ -413,10 +429,13 @@ vTypeEl0 n = vTypeEl n M.empty vTypeEl = nEl . nm "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" -data XlsxCellData = XlsxSS Int - | XlsxDouble Double - | XlsxBool Bool - deriving (Eq, Show, Generic) +data XlsxCellData + = XlsxSS Int + | XlsxDouble Double + | XlsxBool Bool + | XlsxError ErrorType + deriving (Eq, Show, Generic) + data XlsxCell = XlsxCell { xlsxCellStyle :: Maybe Int , xlsxCellValue :: Maybe XlsxCellData @@ -427,6 +446,7 @@ xlsxCellType :: XlsxCell -> Text xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxSS _)} = "s" xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxBool _)} = "b" +xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxError _)} = "e" xlsxCellType _ = "n" -- default in SpreadsheetML schema, TODO: add other types value :: XlsxCellData -> Text @@ -434,6 +454,7 @@ value (XlsxDouble d) = txtd d value (XlsxBool True) = "1" value (XlsxBool False) = "0" +value (XlsxError eType) = toAttrVal eType transformSheetData :: SharedStringTable -> Worksheet -> Cells transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells) @@ -445,6 +466,7 @@ transformValue (CellDouble dbl) = XlsxDouble dbl transformValue (CellBool b) = XlsxBool b transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) + transformValue (CellError e) = XlsxError e bookFiles :: Xlsx -> [FileData] bookFiles xlsx = runST $ do @@ -483,7 +505,7 @@ let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ] cacheRefs = map snd cacheRefFDsById bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $ - bookXml sheetNameByRId (xlsx ^. xlDefinedNames) cacheRefsById + bookXml sheetNameByRId (xlsx ^. xlDefinedNames) cacheRefsById (xlsx ^. xlDateBase) rels = FileData "xl/_rels/workbook.xml.rels" "application/vnd.openxmlformats-package.relationships+xml" "relationships" relsXml @@ -497,8 +519,9 @@ bookXml :: [(RefId, Text)] -> DefinedNames -> [(CacheId, RefId)] + -> DateBase -> L.ByteString -bookXml rIdNames (DefinedNames names) cacheIdRefs = +bookXml rIdNames (DefinedNames names) cacheIdRefs dateBase = renderLBS def {rsNamespaces = nss} $ Document (Prologue [] Nothing []) root [] where nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] @@ -511,22 +534,24 @@ addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ elementListSimple "workbook" - ([ elementListSimple "bookViews" [emptyElement "workbookView"] - , elementListSimple - "sheets" - [ leafElement - "sheet" - ["name" .= name, "sheetId" .= i, (odr "id") .= rId] - | (i, (rId, name)) <- zip [(1 :: Int) ..] rIdNames - ] - , elementListSimple - "definedNames" - [ elementContent0 "definedName" (definedName name lsId) val - | (name, lsId, val) <- names - ] - ] ++ - maybeToList - (nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs)) + ( [ leafElement "workbookPr" (catMaybes ["date1904" .=? justTrue (dateBase == DateBase1904) ]) + , elementListSimple "bookViews" [emptyElement "workbookView"] + , elementListSimple + "sheets" + [ leafElement + "sheet" + ["name" .= name, "sheetId" .= i, (odr "id") .= rId] + | (i, (rId, name)) <- zip [(1 :: Int) ..] rIdNames + ] + , elementListSimple + "definedNames" + [ elementContent0 "definedName" (definedName name lsId) val + | (name, lsId, val) <- names + ] + ] ++ + maybeToList + (nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs) + ) pivotCacheEl (CacheId cId, refId) = leafElement "pivotCache" ["cacheId" .= cId, (odr "id") .= refId] diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs --- a/src/Codec/Xlsx/Writer/Internal.hs +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -196,8 +196,11 @@ txtd :: Double -> Text -txtd v | v - fromInteger (floor v) == 0 = toStrict . toLazyText $ formatRealFloat Generic (Just 0) v - | otherwise = toStrict . toLazyText $ realFloat v +txtd v + | v - fromInteger v' == 0 = txti v' + | otherwise = toStrict . toLazyText $ realFloat v + where + v' = floor v txtb :: Bool -> Text txtb = T.toLower . T.pack . show diff --git a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs --- a/src/Codec/Xlsx/Writer/Internal/PivotTable.hs +++ b/src/Codec/Xlsx/Writer/Internal/PivotTable.hs @@ -70,40 +70,41 @@ , "firstDataRow" .= (2 :: Int) , "firstDataCol" .= (1 :: Int) ] - name2x = M.fromList $ zip (map _pfiName _pvtFields) [0 ..] + name2x = M.fromList $ zip (mapMaybe _pfiName _pvtFields) [0 ..] mapFieldToX f = fromJustNote "no field" $ M.lookup f name2x pivotFields = elementListSimple "pivotFields" $ map pFieldEl _pvtFields + maybeFieldIn Nothing _ = False + maybeFieldIn (Just name) positions = FieldPosition name `elem` positions pFieldEl PivotFieldInfo { _pfiName = fName , _pfiOutline = outline , _pfiSortType = sortType , _pfiHiddenItems = hidden } - | FieldPosition fName `elem` _pvtRowFields = + | fName `maybeFieldIn` _pvtRowFields = pFieldEl' fName outline ("axisRow" :: Text) hidden sortType - | FieldPosition fName `elem` _pvtColumnFields = + | fName `maybeFieldIn` _pvtColumnFields = pFieldEl' fName outline ("axisCol" :: Text) hidden sortType | otherwise = - leafElement - "pivotField" - [ "name" .= fName - , "dataField" .= True - , "showAll" .= False - , "outline" .= outline - ] + leafElement "pivotField" $ + [ "dataField" .= True + , "showAll" .= False + , "outline" .= outline] ++ + catMaybes ["name" .=? fName] pFieldEl' fName outline axis hidden sortType = elementList "pivotField" - ([ "name" .= fName - , "axis" .= axis + ([ "axis" .= axis , "showAll" .= False , "outline" .= outline ] ++ - catMaybes ["sortType" .=? justNonDef FieldSortManual sortType]) + catMaybes [ "name" .=? fName + , "sortType" .=? justNonDef FieldSortManual sortType]) [ elementListSimple "items" $ items fName hidden ++ [leafElement "item" ["t" .= ("default" :: Text)]] ] - items fName hidden = + items Nothing _ = [] + items (Just fName) hidden = [ itemEl x item hidden | (x, item) <- zip [0 ..] . fromMaybe [] $ M.lookup fName cachedItems ] @@ -138,7 +139,7 @@ , cdFields = cachedFields } where - cachedFields = map (cache . _pfiName) _pvtFields + cachedFields = mapMaybe (fmap cache . _pfiName) _pvtFields cache name = CacheField { cfName = name diff --git a/test/AutoFilterTests.hs b/test/AutoFilterTests.hs new file mode 100644 --- /dev/null +++ b/test/AutoFilterTests.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module AutoFilterTests + ( tests + ) where + +import Test.SmallCheck.Series +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.SmallCheck (testProperty) + +import Codec.Xlsx +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +import Common +import Test.SmallCheck.Series.Instances () + +tests :: TestTree +tests = + testGroup + "Types.AutFilter tests" + [ testProperty "fromCursor . toElement == id" $ \(autoFilter :: AutoFilter) -> + [autoFilter] == fromCursor (cursorFromElement $ toElement (n_ "autoFilter") autoFilter) + ] diff --git a/test/Common.hs b/test/Common.hs --- a/test/Common.hs +++ b/test/Common.hs @@ -1,11 +1,16 @@ module Common ( parseBS + , cursorFromElement ) where import Data.ByteString.Lazy (ByteString) import Text.XML import Text.XML.Cursor import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal parseBS :: FromCursor a => ByteString -> [a] parseBS = fromCursor . fromDocument . parseLBS_ def + +cursorFromElement :: Element -> Cursor +cursorFromElement = fromNode . NodeElement . addNS mainNamespace Nothing diff --git a/test/CommonTests.hs b/test/CommonTests.hs new file mode 100644 --- /dev/null +++ b/test/CommonTests.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module CommonTests + ( tests + ) where + +import Data.Fixed (Pico, Fixed(..), E12) +import Test.Tasty.SmallCheck (testProperty) +import Test.SmallCheck.Series + (Positive(..), Serial(..), newtypeCons, cons0, (\/)) +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.HUnit (testCase, (@?=)) + +import Codec.Xlsx.Types.Common + +tests :: TestTree +tests = + testGroup + "Types.Common tests" + [ testProperty "col2int . int2col == id" $ + \(Positive i) -> i == col2int (int2col i) + , testCase "date conversions" $ do + dateFromNumber DateBase1900 (- 2338.0) @?= read "1893-08-05 00:00:00 UTC" + dateFromNumber DateBase1900 2.0 @?= read "1900-01-01 00:00:00 UTC" + dateFromNumber DateBase1900 3687.0 @?= read "1910-02-03 00:00:00 UTC" + dateFromNumber DateBase1900 38749.0 @?= read "2006-02-01 00:00:00 UTC" + dateFromNumber DateBase1900 2958465.0 @?= read "9999-12-31 00:00:00 UTC" + dateFromNumber DateBase1904 (-3800.0) @?= read "1893-08-05 00:00:00 UTC" + dateFromNumber DateBase1904 0.0 @?= read "1904-01-01 00:00:00 UTC" + dateFromNumber DateBase1904 2225.0 @?= read "1910-02-03 00:00:00 UTC" + dateFromNumber DateBase1904 37287.0 @?= read "2006-02-01 00:00:00 UTC" + dateFromNumber DateBase1904 2957003.0 @?= read "9999-12-31 00:00:00 UTC" + , testProperty "dateToNumber . dateFromNumber == id" $ + \b (n :: Pico) -> n == dateToNumber b (dateFromNumber b $ n) + ] + +instance Monad m => Serial m (Fixed E12) where + series = newtypeCons MkFixed + +instance Monad m => Serial m DateBase where + series = cons0 DateBase1900 \/ cons0 DateBase1904 diff --git a/test/CondFmtTests.hs b/test/CondFmtTests.hs new file mode 100644 --- /dev/null +++ b/test/CondFmtTests.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module CondFmtTests + ( tests + ) where + +import Test.Tasty (testGroup, TestTree) +import Test.Tasty.SmallCheck (testProperty) + +import Codec.Xlsx +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + +import Common +import Test.SmallCheck.Series.Instances () + +tests :: TestTree +tests = + testGroup + "Types.ConditionalFormatting tests" + [ testProperty "fromCursor . toElement == id" $ \(cFmt :: CfRule) -> + [cFmt] == fromCursor (cursorFromElement $ toElement (n_ "cfRule") cFmt) + ] diff --git a/test/DrawingTests.hs b/test/DrawingTests.hs --- a/test/DrawingTests.hs +++ b/test/DrawingTests.hs @@ -228,7 +228,7 @@ oneChartChartSpace :: Chart -> ChartSpace oneChartChartSpace chart = ChartSpace - { _chspTitle = Just $ ChartTitle titleBody + { _chspTitle = Just $ ChartTitle (Just titleBody) , _chspCharts = [chart] , _chspLegend = Nothing , _chspPlotVisOnly = Just True @@ -327,7 +327,7 @@ oneChartChartSpace BarChart { _brchDirection = DirectionColumn - , _brchGrouping = Just StandardGrouping + , _brchGrouping = Just BarStandardGrouping , _brchSeries = [ BarSeries { _brserShared = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-} -module Main (main) where +module Main + ( main + ) where import Control.Lens import Control.Monad.State.Lazy @@ -16,9 +18,7 @@ import Test.Tasty (defaultMain, testGroup) import Test.Tasty.HUnit (testCase) -import Test.Tasty.SmallCheck (testProperty) -import Test.SmallCheck.Series (Positive(..)) import Test.Tasty.HUnit ((@=?)) import Codec.Xlsx @@ -29,7 +29,10 @@ as CustomProperties import Codec.Xlsx.Types.Internal.SharedStringTable +import AutoFilterTests import Common +import CommonTests +import CondFmtTests import Diff import PivotTableTests import DrawingTests @@ -37,12 +40,14 @@ main :: IO () main = defaultMain $ testGroup "Tests" - [ testProperty "col2int . int2col == id" $ - \(Positive i) -> i == col2int (int2col i) - , testCase "write . read == id" $ do + [ testCase "write . read == id" $ do let bs = fromXlsx testTime testXlsx LB.writeFile "data-test.xlsx" bs testXlsx @==? toXlsx (fromXlsx testTime testXlsx) + , testCase "write . fast-read == id" $ do + let bs = fromXlsx testTime testXlsx + LB.writeFile "data-test.xlsx" bs + testXlsx @==? toXlsxFast (fromXlsx testTime testXlsx) , testCase "fromRows . toRows == id" $ testCellMap1 @=? fromRows (toRows testCellMap1) , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $ @@ -67,20 +72,30 @@ Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) , testCase "toXlsxEither: invalid format" $ Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file" + , CommonTests.tests + , CondFmtTests.tests , PivotTableTests.tests , DrawingTests.tests + , AutoFilterTests.tests ] testXlsx :: Xlsx -testXlsx = Xlsx sheets minimalStyles definedNames customProperties +testXlsx = Xlsx sheets minimalStyles definedNames customProperties DateBase1904 where sheets = [("List1", sheet1), ("Another sheet", sheet2), ("with pivot table", pvSheet)] sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges - sheetViews pageSetup cFormatting validations [] (Just autoFilter) tables (Just protection) + sheetViews pageSetup cFormatting validations [] (Just autoFilter) + tables (Just protection) sharedFormulas + sharedFormulas = + M.fromList + [ (SharedFormulaIndex 0, SharedFormulaOptions (CellRef "A5:C5") (Formula "A4")) + , (SharedFormulaIndex 1, SharedFormulaOptions (CellRef "B6:C6") (Formula "B3+12")) + ] autoFilter = def & afRef ?~ CellRef "A1:E10" & afFilterColumns .~ fCols - fCols = M.fromList [ (1, Filters ["a","b","ZZZ"]) + fCols = M.fromList [ (1, Filters DontFilterByBlank + [FilterValue "a", FilterValue "b",FilterValue "ZZZ"]) , (2, CustomFiltersAnd (CustomFilter FltrGreaterThanOrEqual "0") (CustomFilter FltrLessThan "42"))] tables = @@ -159,22 +174,32 @@ rules2 = [ cfRule ContainsErrors 3 ] testCellMap1 :: CellMap -testCellMap1 = M.fromList [ ((1, 2), cd1_2), ((1, 5), cd1_5) - , ((3, 1), cd3_1), ((3, 2), cd3_2), ((3, 7), cd3_7) +testCellMap1 = M.fromList [ ((1, 2), cd1_2), ((1, 5), cd1_5), ((1, 10), cd1_10) + , ((3, 1), cd3_1), ((3, 2), cd3_2), ((3, 3), cd3_3), ((3, 7), cd3_7) , ((4, 1), cd4_1), ((4, 2), cd4_2), ((4, 3), cd4_3) + , ((5, 1), cd5_1), ((5, 2), cd5_2), ((5, 3), cd5_3) + , ((6, 2), cd6_2), ((6, 3), cd6_3) ] where cd v = def {_cellValue=Just v} - cd1_2 = cd (CellText "just a text") + cd1_2 = cd (CellText "just a text, fließen, русский <> и & \"in quotes\"") cd1_5 = cd (CellDouble 42.4567) + cd1_10 = cd (CellText "") cd3_1 = cd (CellText "another text") cd3_2 = def -- shouldn't it be skipped? + cd3_3 = def & cellValue ?~ CellError ErrorDiv0 + & cellFormula ?~ simpleCellFormula "1/0" cd3_7 = cd (CellBool True) cd4_1 = cd (CellDouble 1) - cd4_2 = cd (CellDouble 2) + cd4_2 = cd (CellDouble 123456789012345) cd4_3 = (cd (CellDouble (1+2))) { _cellFormula = - Just $ simpleCellFormula "A4+B4" + Just $ simpleCellFormula "A4+B4<>11" } + cd5_1 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 0) + cd5_2 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 0) + cd5_3 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 0) + cd6_2 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 1) + cd6_3 = def & cellFormula ?~ sharedFormulaByIndex (SharedFormulaIndex 1) testCellMap2 :: CellMap testCellMap2 = M.fromList [ ((1, 2), def & cellValue ?~ CellText "something here") @@ -210,13 +235,14 @@ fromRight (Left x) = error $ "Right _ was expected but Left " ++ show x ++ " found" testStyleSheet :: StyleSheet -testStyleSheet = minimalStyleSheet & styleSheetDxfs .~ [dxf1, dxf2] +testStyleSheet = minimalStyleSheet & styleSheetDxfs .~ [dxf1, dxf2, dxf3] & styleSheetNumFmts .~ M.fromList [(164, "0.000")] & styleSheetCellXfs %~ (++ [cellXf1, cellXf2]) where dxf1 = def & dxfFont ?~ (def & fontBold ?~ True & fontSize ?~ 12) dxf2 = def & dxfFill ?~ (def & fillPattern ?~ (def & fillPatternBgColor ?~ red)) + dxf3 = def & dxfNumFmt ?~ NumFmt 164 "0.000" red = def & colorARGB ?~ "FFFF0000" cellXf1 = def { _cellXfApplyNumberFormat = Just True diff --git a/test/PivotTableTests.hs b/test/PivotTableTests.hs --- a/test/PivotTableTests.hs +++ b/test/PivotTableTests.hs @@ -67,10 +67,10 @@ } ] , _pvtFields = - [ PivotFieldInfo colorField False FieldSortAscending [CellText "green"] - , PivotFieldInfo yearField True FieldSortManual [] - , PivotFieldInfo priceField False FieldSortManual [] - , PivotFieldInfo countField False FieldSortManual [] + [ PivotFieldInfo (Just $ colorField) False FieldSortAscending [CellText "green"] + , PivotFieldInfo (Just $ yearField) True FieldSortManual [] + , PivotFieldInfo (Just $ priceField) False FieldSortManual [] + , PivotFieldInfo (Just $ countField) False FieldSortManual [] ] , _pvtRowGrandTotals = True , _pvtColumnGrandTotals = False diff --git a/test/Test/SmallCheck/Series/Instances.hs b/test/Test/SmallCheck/Series/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Test/SmallCheck/Series/Instances.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.SmallCheck.Series.Instances + ( + ) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text (Text) +import qualified Data.Text as T +import Test.SmallCheck.Series + +import Codec.Xlsx + +cons6 :: + ( Serial m a6 + , Serial m a5 + , Serial m a4 + , Serial m a3 + , Serial m a2 + , Serial m a1 + ) + => (a6 -> a5 -> a4 -> a3 -> a2 -> a1 -> a) + -> Test.SmallCheck.Series.Series m a +cons6 f = decDepth $ + f <$> series + <~> series + <~> series + <~> series + <~> series + <~> series + +instance Monad m => Serial m Text where + series = T.pack <$> series + +instance (Serial m k, Serial m v) => Serial m (Map k v) where + series = Map.singleton <$> series <~> series + +{------------------------------------------------------------------------------- + Conditional formatting +-------------------------------------------------------------------------------} + +instance Monad m => Serial m CfRule + +instance Monad m => Serial m Condition where + series = localDepth (const 2) $ cons2 AboveAverage + \/ cons1 BeginsWith + \/ cons2 BelowAverage + \/ cons1 BottomNPercent + \/ cons1 BottomNValues + \/ cons1 CellIs + \/ cons4 ColorScale2 + \/ cons6 ColorScale3 + \/ cons0 ContainsBlanks + \/ cons0 ContainsErrors + \/ cons1 ContainsText + \/ cons1 DataBar + \/ cons0 DoesNotContainErrors + \/ cons0 DoesNotContainBlanks + \/ cons1 DoesNotContainText + \/ cons0 DuplicateValues + \/ cons1 EndsWith + \/ cons1 Expression + \/ cons1 IconSet + \/ cons1 InTimePeriod + \/ cons1 TopNPercent + \/ cons1 TopNValues + \/ cons0 UniqueValues + +instance Monad m => Serial m NStdDev + +instance Monad m => Serial m Inclusion + +instance Monad m => Serial m OperatorExpression + +instance Monad m => Serial m DataBarOptions + +instance Monad m => Serial m MaxCfValue + +instance Monad m => Serial m MinCfValue + +instance Monad m => Serial m Color + +-- TODO: proper formula generator (?) +instance Monad m => Serial m Formula + +instance Monad m => Serial m IconSetOptions + +instance Monad m => Serial m IconSetType + +instance Monad m => Serial m CfValue + +instance Monad m => Serial m TimePeriod + +{------------------------------------------------------------------------------- + Autofilter +-------------------------------------------------------------------------------} + +instance Monad m => Serial m AutoFilter where + series = localDepth (const 4) $ cons2 AutoFilter + +instance Monad m => Serial m CellRef + +instance Monad m => Serial m FilterColumn + +instance Monad m => Serial m EdgeFilterOptions + +instance Monad m => Serial m CustomFilter + +instance Monad m => Serial m CustomFilterOperator + +instance Monad m => Serial m FilterCriterion + +instance Monad m => Serial m DateGroup + +instance Monad m => Serial m FilterByBlank + +instance Monad m => Serial m ColorFilterOptions + +instance Monad m => Serial m DynFilterOptions + +instance Monad m => Serial m DynFilterType diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.6.0 +Version: 0.7.0 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -26,7 +26,7 @@ Category: Codec Build-type: Simple -Tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 +Tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 Cabal-version: >=1.10 @@ -39,6 +39,8 @@ , Codec.Xlsx.Lens , Codec.Xlsx.Parser , Codec.Xlsx.Parser.Internal + , Codec.Xlsx.Parser.Internal.Fast + , Codec.Xlsx.Parser.Internal.Util , Codec.Xlsx.Parser.Internal.PivotTable , Codec.Xlsx.Types.AutoFilter , Codec.Xlsx.Types.Cell @@ -55,7 +57,7 @@ , Codec.Xlsx.Types.Internal.ContentTypes , Codec.Xlsx.Types.Internal.CustomProperties , Codec.Xlsx.Types.Internal.DvPair - , Codec.Xlsx.Types.Internal.NumFmtPair + , Codec.Xlsx.Types.Internal.FormulaData , Codec.Xlsx.Types.Internal.Relationships , Codec.Xlsx.Types.Internal.SharedStringTable , Codec.Xlsx.Types.PageSetup @@ -72,17 +74,19 @@ , Codec.Xlsx.Writer.Internal.PivotTable Build-depends: base == 4.* + , attoparsec + , base64-bytestring , binary-search - , bytestring >= 0.10.0.2 + , bytestring >= 0.10.8.0 , conduit >= 1.0.0 , containers >= 0.5.0.0 , data-default + , deepseq >= 1.4 , errors , extra , filepath , lens >= 3.8 && < 5 , mtl >= 2.1 - , mtl-compat , network-uri , old-locale >= 1.0.0.5 , safe >= 0.3 @@ -90,13 +94,12 @@ , time >= 1.4.0.1 , transformers >= 0.3.0.0 , vector >= 0.10 + , xeno >= 0.3.2 , xml-conduit >= 1.1.0 , zip-archive >= 0.2 , zlib >= 0.5.4.0 - , base64-bytestring Default-Language: Haskell2010 - Other-Extensions: CPP - DeriveDataTypeable + Other-Extensions: DeriveDataTypeable FlexibleInstances NoMonomorphismRestriction OverloadedStrings @@ -109,10 +112,14 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test/ - other-modules: Common + other-modules: AutoFilterTests + , Common + , CommonTests + , CondFmtTests , Diff , DrawingTests , PivotTableTests + , Test.SmallCheck.Series.Instances Build-Depends: base , bytestring , containers @@ -135,3 +142,13 @@ source-repository head type: git location: git://github.com/qrilka/xlsx.git + +benchmark bench + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Main.hs + build-depends: base + , bytestring + , criterion + , xlsx + default-language: Haskell2010