xlsx 0.6.0 → 0.7.0
raw patch · 48 files changed
+3449/−447 lines, 48 filesdep +attoparsecdep +criteriondep +deepseqdep −mtl-compatdep ~basedep ~bytestring
Dependencies added: attoparsec, criterion, deepseq, xeno
Dependencies removed: mtl-compat
Dependency ranges changed: base, bytestring
Files
- CHANGELOG.markdown +14/−0
- benchmarks/Main.hs +21/−0
- src/Codec/Xlsx/Formatted.hs +0/−5
- src/Codec/Xlsx/Lens.hs +0/−5
- src/Codec/Xlsx/Parser.hs +355/−68
- src/Codec/Xlsx/Parser/Internal.hs +28/−45
- src/Codec/Xlsx/Parser/Internal/Fast.hs +330/−0
- src/Codec/Xlsx/Parser/Internal/PivotTable.hs +15/−9
- src/Codec/Xlsx/Parser/Internal/Util.hs +26/−0
- src/Codec/Xlsx/Types.hs +39/−6
- src/Codec/Xlsx/Types/AutoFilter.hs +591/−17
- src/Codec/Xlsx/Types/Cell.hs +99/−30
- src/Codec/Xlsx/Types/Comment.hs +2/−0
- src/Codec/Xlsx/Types/Common.hs +185/−6
- src/Codec/Xlsx/Types/ConditionalFormatting.hs +700/−24
- src/Codec/Xlsx/Types/DataValidation.hs +75/−9
- src/Codec/Xlsx/Types/Drawing.hs +15/−5
- src/Codec/Xlsx/Types/Drawing/Chart.hs +70/−17
- src/Codec/Xlsx/Types/Drawing/Common.hs +22/−5
- src/Codec/Xlsx/Types/Internal.hs +3/−5
- src/Codec/Xlsx/Types/Internal/CfPair.hs +6/−0
- src/Codec/Xlsx/Types/Internal/ContentTypes.hs +0/−5
- src/Codec/Xlsx/Types/Internal/DvPair.hs +6/−0
- src/Codec/Xlsx/Types/Internal/FormulaData.hs +54/−0
- src/Codec/Xlsx/Types/Internal/NumFmtPair.hs +0/−27
- src/Codec/Xlsx/Types/Internal/Relationships.hs +0/−5
- src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +2/−2
- src/Codec/Xlsx/Types/PageSetup.hs +124/−5
- src/Codec/Xlsx/Types/PivotTable.hs +9/−1
- src/Codec/Xlsx/Types/PivotTable/Internal.hs +0/−5
- src/Codec/Xlsx/Types/Protection.hs +27/−0
- src/Codec/Xlsx/Types/RichText.hs +31/−6
- src/Codec/Xlsx/Types/SheetViews.hs +71/−5
- src/Codec/Xlsx/Types/StyleSheet.hs +122/−17
- src/Codec/Xlsx/Types/Table.hs +3/−5
- src/Codec/Xlsx/Types/Variant.hs +3/−0
- src/Codec/Xlsx/Writer.hs +86/−61
- src/Codec/Xlsx/Writer/Internal.hs +5/−2
- src/Codec/Xlsx/Writer/Internal/PivotTable.hs +16/−15
- test/AutoFilterTests.hs +25/−0
- test/Common.hs +5/−0
- test/CommonTests.hs +43/−0
- test/CondFmtTests.hs +24/−0
- test/DrawingTests.hs +2/−2
- test/Main.hs +41/−15
- test/PivotTableTests.hs +4/−4
- test/Test/SmallCheck/Series/Instances.hs +124/−0
- xlsx.cabal +26/−9
CHANGELOG.markdown view
@@ -1,3 +1,17 @@+0.7.0+-----+* fixed serialization of large integer values (thanks Radoslav Dorcik+ <dixiecko@gmail.com>)+* 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 <emax@chalmers.se>)+* 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 <malaquias@gmail.com>)+ 0.6.0 ----- * fixed reading files with optional table name (thanks Aleksey Khudyakov
+ benchmarks/Main.hs view
@@ -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'+ ]+ ]
src/Codec/Xlsx/Formatted.hs view
@@ -1,5 +1,4 @@ -- | Higher level interface for creating styled worksheets-{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}@@ -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
src/Codec/Xlsx/Lens.hs view
@@ -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)
src/Codec/Xlsx/Parser.hs view
@@ -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
src/Codec/Xlsx/Parser/Internal.hs view
@@ -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
+ src/Codec/Xlsx/Parser/Internal/Fast.hs view
@@ -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
src/Codec/Xlsx/Parser/Internal/PivotTable.hs view
@@ -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") >=>
+ src/Codec/Xlsx/Parser/Internal/Util.hs view
@@ -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
src/Codec/Xlsx/Types.hs view
@@ -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 []
src/Codec/Xlsx/Types/AutoFilter.hs view
@@ -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"
src/Codec/Xlsx/Types/Cell.hs view
@@ -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 @\<is\>@ 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+ }
src/Codec/Xlsx/Types/Comment.hs view
@@ -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
src/Codec/Xlsx/Types/Common.hs view
@@ -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!"
src/Codec/Xlsx/Types/ConditionalFormatting.hs view
@@ -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
src/Codec/Xlsx/Types/DataValidation.hs view
@@ -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)-
src/Codec/Xlsx/Types/Drawing.hs view
@@ -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
src/Codec/Xlsx/Types/Drawing/Chart.hs view
@@ -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
src/Codec/Xlsx/Types/Drawing/Common.hs view
@@ -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
src/Codec/Xlsx/Types/Internal.hs view
@@ -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
src/Codec/Xlsx/Types/Internal/CfPair.hs view
@@ -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 ]
src/Codec/Xlsx/Types/Internal/ContentTypes.hs view
@@ -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
src/Codec/Xlsx/Types/Internal/DvPair.hs view
@@ -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}
+ src/Codec/Xlsx/Types/Internal/FormulaData.hs view
@@ -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
− src/Codec/Xlsx/Types/Internal/NumFmtPair.hs
@@ -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 ]
src/Codec/Xlsx/Types/Internal/Relationships.hs view
@@ -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
@@ -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
src/Codec/Xlsx/Types/PageSetup.hs view
@@ -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
src/Codec/Xlsx/Types/PivotTable.hs view
@@ -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
src/Codec/Xlsx/Types/PivotTable/Internal.hs view
@@ -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
src/Codec/Xlsx/Types/Protection.hs view
@@ -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
src/Codec/Xlsx/Types/RichText.hs view
@@ -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{..} {-------------------------------------------------------------------------------
src/Codec/Xlsx/Types/SheetViews.hs view
@@ -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
src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -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
src/Codec/Xlsx/Types/Table.hs view
@@ -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
src/Codec/Xlsx/Types/Variant.hs view
@@ -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
src/Codec/Xlsx/Writer.hs view
@@ -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]
src/Codec/Xlsx/Writer/Internal.hs view
@@ -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
src/Codec/Xlsx/Writer/Internal/PivotTable.hs view
@@ -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
+ test/AutoFilterTests.hs view
@@ -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)+ ]
test/Common.hs view
@@ -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
+ test/CommonTests.hs view
@@ -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
+ test/CondFmtTests.hs view
@@ -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)+ ]
test/DrawingTests.hs view
@@ -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 =
test/Main.hs view
@@ -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
test/PivotTableTests.hs view
@@ -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
+ test/Test/SmallCheck/Series/Instances.hs view
@@ -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
xlsx.cabal view
@@ -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