xlsx 0.2.4 → 0.3.0
raw patch · 17 files changed
+752/−455 lines, 17 files
Files
- CHANGELOG.markdown +9/−0
- src/Codec/Xlsx/Formatted.hs +124/−91
- src/Codec/Xlsx/Lens.hs +50/−7
- src/Codec/Xlsx/Parser.hs +30/−6
- src/Codec/Xlsx/Types.hs +2/−41
- src/Codec/Xlsx/Types/Comment.hs +8/−9
- src/Codec/Xlsx/Types/Common.hs +39/−0
- src/Codec/Xlsx/Types/Internal/CommentTable.hs +46/−1
- src/Codec/Xlsx/Types/Internal/ContentTypes.hs +27/−5
- src/Codec/Xlsx/Types/Internal/NumFmtPair.hs +25/−0
- src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +4/−0
- src/Codec/Xlsx/Types/SheetViews.hs +0/−16
- src/Codec/Xlsx/Types/StyleSheet.hs +198/−148
- src/Codec/Xlsx/Writer.hs +137/−110
- src/Codec/Xlsx/Writer/Internal.hs +5/−0
- test/DataTest.hs +46/−20
- xlsx.cabal +2/−1
CHANGELOG.markdown view
@@ -1,3 +1,12 @@+0.3.0+-----+* implemented number formats+* fixed error of parsing "Default"s in content types (thanks Steve Bigham <steve.bigham@gmail.com> for reporting)+* fixed parsing workbooks with no shared strings (thanks Steve Bigham <steve.bigham@gmail.com> for reporting)+* changed the way sheets are stored to allow abitrary sheet order in a workbook+* separated format information from other cell data in `FormattedCell`+* implemented comment visibility (throught legacy vml drawings)+ 0.2.4 ----- * added basic images support
src/Codec/Xlsx/Formatted.hs view
@@ -11,17 +11,18 @@ , CondFormatted(..) , conditionallyFormatted -- * Lenses+ -- ** Format+ , formatAlignment+ , formatBorder+ , formatFill+ , formatFont+ , formatNumberFormat+ , formatProtection+ , formatPivotButton+ , formatQuotePrefix -- ** FormattedCell- , formattedAlignment- , formattedBorder- , formattedFill- , formattedFont- , formattedNumberFormat- , formattedProtection- , formattedPivotButton- , formattedQuotePrefix- , formattedValue- , formattedFormula+ , formattedCell+ , formattedFormat , formattedColSpan , formattedRowSpan -- ** FormattedCondFmt@@ -34,17 +35,22 @@ import Control.Lens import Control.Monad.State hiding (forM_, mapM) import Data.Default-import Data.Foldable (forM_)+import Data.Foldable (asum, forM_) import Data.Function (on) import Data.List (foldl', groupBy, sortBy, sortBy) import Data.Map (Map) import qualified Data.Map as M import Data.Ord (comparing)+import Data.Text (Text) import Data.Traversable (mapM) import Data.Tuple (swap) import Prelude hiding (mapM) import Safe (headNote) +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+ import Codec.Xlsx.Types {-------------------------------------------------------------------------------@@ -56,6 +62,7 @@ , _formattingCellXfs :: Map CellXf Int , _formattingFills :: Map Fill Int , _formattingFonts :: Map Font Int+ , _formattingNumFmts :: Map Text Int , _formattingMerges :: [Range] -- ^ In reverse order } @@ -63,11 +70,12 @@ stateFromStyleSheet :: StyleSheet -> FormattingState stateFromStyleSheet StyleSheet{..} = FormattingState{- _formattingBorders = fromValueList _styleSheetBorders- , _formattingCellXfs = fromValueList _styleSheetCellXfs- , _formattingFills = fromValueList _styleSheetFills- , _formattingFonts = fromValueList _styleSheetFonts- , _formattingMerges = []+ _formattingBorders = fromValueList _styleSheetBorders+ , _formattingCellXfs = fromValueList _styleSheetCellXfs+ , _formattingFills = fromValueList _styleSheetFills+ , _formattingFonts = fromValueList _styleSheetFonts+ , _formattingNumFmts = M.empty+ , _formattingMerges = [] } fromValueList :: Ord a => [a] -> Map a Int@@ -82,14 +90,22 @@ , _styleSheetCellXfs = toValueList _formattingCellXfs , _styleSheetFills = toValueList _formattingFills , _styleSheetFonts = toValueList _formattingFonts+ , _styleSheetNumFmts = M.fromList . map swap $ M.toList _formattingNumFmts } getId :: Ord a => Lens' FormattingState (Map a Int) -> a -> State FormattingState Int-getId f v = do+getId = getId' 0++getId' :: Ord a+ => Int+ -> Lens' FormattingState (Map a Int)+ -> a+ -> State FormattingState Int+getId' k f v = do aMap <- use f case M.lookup v aMap of Just anId -> return anId- Nothing -> do let anId = M.size aMap+ Nothing -> do let anId = k + M.size aMap f %= M.insert v anId return anId @@ -110,53 +126,61 @@ Cell with formatting -------------------------------------------------------------------------------} --- | Cell with formatting------ See 'formatted' for more details.+-- | Formatting options used to format cells -- -- TODOs: -- -- * Add a number format ('_cellXfApplyNumberFormat', '_cellXfNumFmtId') -- * Add references to the named style sheets ('_cellXfId')-data FormattedCell = FormattedCell {- _formattedAlignment :: Maybe Alignment- , _formattedBorder :: Maybe Border- , _formattedFill :: Maybe Fill- , _formattedFont :: Maybe Font- , _formattedNumberFormat :: Maybe NumberFormat- , _formattedProtection :: Maybe Protection- , _formattedPivotButton :: Maybe Bool- , _formattedQuotePrefix :: Maybe Bool- , _formattedValue :: Maybe CellValue- , _formattedFormula :: Maybe CellFormula- , _formattedColSpan :: Int- , _formattedRowSpan :: Int- }- deriving (Show, Eq)+data Format = Format+ { _formatAlignment :: Maybe Alignment+ , _formatBorder :: Maybe Border+ , _formatFill :: Maybe Fill+ , _formatFont :: Maybe Font+ , _formatNumberFormat :: Maybe NumberFormat+ , _formatProtection :: Maybe Protection+ , _formatPivotButton :: Maybe Bool+ , _formatQuotePrefix :: Maybe Bool+ } deriving (Eq, Show) -makeLenses ''FormattedCell+makeLenses ''Format +-- | Cell with formatting. '_cellStyle' property of '_formattedCell' is ignored+--+-- See 'formatted' for more details.+data FormattedCell = FormattedCell+ { _formattedCell :: Cell+ , _formattedFormat :: Format+ , _formattedColSpan :: Int+ , _formattedRowSpan :: Int+ } deriving (Eq, Show) +makeLenses ''FormattedCell+ {------------------------------------------------------------------------------- Default instances -------------------------------------------------------------------------------} instance Default FormattedCell where- def = FormattedCell {- _formattedAlignment = Nothing- , _formattedBorder = Nothing- , _formattedFill = Nothing- , _formattedFont = Nothing- , _formattedNumberFormat = Nothing- , _formattedProtection = Nothing- , _formattedPivotButton = Nothing- , _formattedQuotePrefix = Nothing- , _formattedValue = Nothing- , _formattedFormula = Nothing- , _formattedColSpan = 1- , _formattedRowSpan = 1- }+ def = FormattedCell+ { _formattedCell = def+ , _formattedFormat = def+ , _formattedColSpan = 1+ , _formattedRowSpan = 1+ } +instance Default Format where+ def = Format+ { _formatAlignment = Nothing+ , _formatBorder = Nothing+ , _formatFill = Nothing+ , _formatFont = Nothing+ , _formatNumberFormat = Nothing+ , _formatProtection = Nothing+ , _formatPivotButton = Nothing+ , _formatQuotePrefix = Nothing+ }+ instance Default FormattedCondFmt where def = FormattedCondFmt ContainsBlanks def topCfPriority Nothing @@ -219,31 +243,35 @@ toFormattedCells :: CellMap -> [Range] -> StyleSheet -> Map (Int, Int) FormattedCell toFormattedCells m merges StyleSheet{..} = applyMerges $ M.map toFormattedCell m where- toFormattedCell Cell{..} =- let mCellXf = _cellStyle >>= \styleId -> M.lookup styleId cellXfs- in FormattedCell- { _formattedAlignment = applied _cellXfApplyAlignment _cellXfAlignment =<< mCellXf- , _formattedBorder = flip M.lookup borders =<<- applied _cellXfApplyBorder _cellXfBorderId =<< mCellXf- , _formattedFill = flip M.lookup fills =<<- applied _cellXfApplyFill _cellXfFillId =<< mCellXf- , _formattedFont = flip M.lookup fonts =<<- applied _cellXfApplyFont _cellXfFontId =<< mCellXf- , _formattedNumberFormat = idToStdNumberFormat =<<- applied _cellXfApplyNumberFormat _cellXfNumFmtId =<< mCellXf- , _formattedProtection = _cellXfProtection =<< mCellXf- , _formattedPivotButton = _cellXfPivotButton =<< mCellXf- , _formattedQuotePrefix = _cellXfQuotePrefix =<< mCellXf- , _formattedValue = _cellValue- , _formattedFormula = _cellFormula- , _formattedColSpan = 1- , _formattedRowSpan = 1 }+ toFormattedCell cell@Cell{..} =+ FormattedCell+ { _formattedCell = cell{ _cellStyle = Nothing } -- just to remove confusion+ , _formattedFormat = maybe def formatFromStyle $ flip M.lookup cellXfs =<< _cellStyle+ , _formattedColSpan = 1+ , _formattedRowSpan = 1 }+ formatFromStyle cellXf =+ Format+ { _formatAlignment = applied _cellXfApplyAlignment _cellXfAlignment cellXf+ , _formatBorder = flip M.lookup borders =<<+ applied _cellXfApplyBorder _cellXfBorderId cellXf+ , _formatFill = flip M.lookup fills =<<+ applied _cellXfApplyFill _cellXfFillId cellXf+ , _formatFont = flip M.lookup fonts =<<+ applied _cellXfApplyFont _cellXfFontId cellXf+ , _formatNumberFormat = lookupNumFmt =<<+ applied _cellXfApplyNumberFormat _cellXfNumFmtId cellXf+ , _formatProtection = _cellXfProtection cellXf+ , _formatPivotButton = _cellXfPivotButton cellXf+ , _formatQuotePrefix = _cellXfQuotePrefix cellXf } idMapped :: [a] -> Map Int a idMapped = M.fromList . zip [0..] cellXfs = idMapped _styleSheetCellXfs borders = idMapped _styleSheetBorders fills = idMapped _styleSheetFills fonts = idMapped _styleSheetFonts+ lookupNumFmt fId = asum+ [ StdNumberFormat <$> idToStdNumberFormat fId+ , UserNumberFormat <$> M.lookup fId _styleSheetNumFmts] applied :: (CellXf -> Maybe Bool) -> (CellXf -> Maybe a) -> CellXf -> Maybe a applied applyProp prop cXf = do apply <- applyProp cXf@@ -290,9 +318,9 @@ mapM go block where go :: ((Int, Int), FormattedCell) -> State FormattingState ((Int, Int), Cell)- go (pos, c) = do+ go (pos, c@ FormattedCell{..}) = do styleId <- cellStyleId c- return (pos, Cell styleId (_formattedValue c) Nothing (_formattedFormula c))+ return (pos, _formattedCell{_cellStyle = styleId}) -- | Cell block corresponding to a single 'FormattedCell' --@@ -321,14 +349,16 @@ cellAt (row', col') = if row' == row && col == col' then cell- else def & formattedBorder .~ Just (borderAt (row', col'))+ else def & formattedFormat . formatBorder ?~ borderAt (row', col') + border = _formatBorder _formattedFormat+ borderAt :: (Int, Int) -> Border borderAt (row', col') = def- & borderTop .~ do guard (row' == topRow) ; _borderTop =<< _formattedBorder- & borderBottom .~ do guard (row' == bottomRow) ; _borderBottom =<< _formattedBorder- & borderLeft .~ do guard (col' == leftCol) ; _borderLeft =<< _formattedBorder- & borderRight .~ do guard (col' == rightCol) ; _borderRight =<< _formattedBorder+ & borderTop .~ do guard (row' == topRow) ; _borderTop =<< border+ & borderBottom .~ do guard (row' == bottomRow) ; _borderBottom =<< border+ & borderLeft .~ do guard (col' == leftCol) ; _borderLeft =<< border+ & borderRight .~ do guard (col' == rightCol) ; _borderRight =<< border topRow, bottomRow, leftCol, rightCol :: Int topRow = row@@ -337,30 +367,33 @@ rightCol = col + _formattedColSpan - 1 cellStyleId :: FormattedCell -> State FormattingState (Maybe Int)-cellStyleId c = mapM (getId formattingCellXfs) =<< cellXf c+cellStyleId c = mapM (getId formattingCellXfs) =<< constructCellXf c -cellXf :: FormattedCell -> State FormattingState (Maybe CellXf)-cellXf FormattedCell{..} = do- mBorderId <- getId formattingBorders `mapM` _formattedBorder- mFillId <- getId formattingFills `mapM` _formattedFill- mFontId <- getId formattingFonts `mapM` _formattedFont- let mNumFmtId = fmap numberFormatId _formattedNumberFormat+constructCellXf :: FormattedCell -> State FormattingState (Maybe CellXf)+constructCellXf FormattedCell{_formattedFormat=Format{..}} = do+ mBorderId <- getId formattingBorders `mapM` _formatBorder+ mFillId <- getId formattingFills `mapM` _formatFill+ mFontId <- getId formattingFonts `mapM` _formatFont+ let getFmtId :: Lens' FormattingState (Map Text Int) -> NumberFormat -> State FormattingState Int+ getFmtId _ (StdNumberFormat fmt) = return (stdNumberFormatId fmt)+ getFmtId l (UserNumberFormat fmt) = getId' firstUserNumFmtId l fmt+ mNumFmtId <- getFmtId formattingNumFmts `mapM` _formatNumberFormat let xf = CellXf {- _cellXfApplyAlignment = apply _formattedAlignment+ _cellXfApplyAlignment = apply _formatAlignment , _cellXfApplyBorder = apply mBorderId , _cellXfApplyFill = apply mFillId , _cellXfApplyFont = apply mFontId- , _cellXfApplyNumberFormat = apply _formattedNumberFormat- , _cellXfApplyProtection = apply _formattedProtection+ , _cellXfApplyNumberFormat = apply _formatNumberFormat+ , _cellXfApplyProtection = apply _formatProtection , _cellXfBorderId = mBorderId , _cellXfFillId = mFillId , _cellXfFontId = mFontId , _cellXfNumFmtId = mNumFmtId- , _cellXfPivotButton = _formattedPivotButton- , _cellXfQuotePrefix = _formattedQuotePrefix+ , _cellXfPivotButton = _formatPivotButton+ , _cellXfQuotePrefix = _formatQuotePrefix , _cellXfId = Nothing -- TODO- , _cellXfAlignment = _formattedAlignment- , _cellXfProtection = _formattedProtection+ , _cellXfAlignment = _formatAlignment+ , _cellXfProtection = _formatProtection } return $ if xf == def then Nothing else Just xf where
src/Codec/Xlsx/Lens.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ -- | lenses to access sheets, cells and values of 'Xlsx'-{-# LANGUAGE RankNTypes #-}+ module Codec.Xlsx.Lens ( ixSheet , atSheet@@ -14,19 +18,58 @@ , cellValueAtXY ) where -import Codec.Xlsx.Types-import Control.Lens-import Data.Text-import Data.Tuple (swap)+import Codec.Xlsx.Types+import Control.Lens+import Data.Function (on)+import Data.List (deleteBy)+import Data.Text+import Data.Tuple (swap) +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++newtype SheetList = SheetList{ unSheetList :: [(Text, Worksheet)] }+ deriving (Eq, Show)++type instance IxValue (SheetList) = Worksheet+type instance Index (SheetList) = Text++instance Ixed SheetList where+ ix k f sl@(SheetList l) = case lookup k l of+ Just v -> f v <&> \v' -> SheetList (upsert k v' l)+ Nothing -> pure sl+ {-# INLINE ix #-}++instance At SheetList where+ at k f (SheetList l) = f mv <&> \r -> case r of+ Nothing -> SheetList $ maybe l (\v -> deleteBy ((==) `on` fst) (k,v) l) mv+ Just v' -> SheetList $ upsert k v' l+ where+ mv = lookup k l+ {-# INLINE at #-}++upsert :: (Eq k) => k -> v -> [(k,v)] -> [(k,v)]+upsert k v [] = [(k,v)]+upsert k v ((k1,v1):r) =+ if k == k1+ then (k,v):r+ else (k1,v1):upsert k v r++sheetList :: Iso' [(Text, Worksheet)] SheetList+sheetList = iso SheetList unSheetList+ -- | lens giving access to a worksheet from 'Xlsx' object -- by its name ixSheet :: Text -> Traversal' Xlsx Worksheet-ixSheet s = xlSheets . ix s+ixSheet s = xlSheets . sheetList . ix s -- | 'Control.Lens.At' variant of 'ixSheet' lens+--+-- /Note:/ if there is no such sheet in this workbook then new sheet will be+-- added as the last one to the sheet list atSheet :: Text -> Lens' Xlsx (Maybe Worksheet)-atSheet s = xlSheets . at s+atSheet s = xlSheets . sheetList . at s -- | lens giving access to a cell in some worksheet -- by its position, by default row+column index is used
src/Codec/Xlsx/Parser.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -13,7 +14,7 @@ import qualified Codec.Archive.Zip as Zip import Control.Applicative-import Control.Arrow (left, (&&&))+import Control.Arrow (left) import Control.Error.Safe (headErr) import Control.Error.Util (note) import Control.Lens hiding (element,@@ -65,7 +66,9 @@ sst <- getSharedStrings ar contentTypes <- getContentTypes ar (wfs, names) <- readWorkbook ar- sheets <- sequence . M.fromList $ map (wfName &&& extractSheet ar sst contentTypes) wfs+ sheets <- forM wfs $ \wf -> do+ sheet <- extractSheet ar sst contentTypes wf+ return (wfName wf, sheet) CustomProperties customPropMap <- getCustomProperties ar return $ Xlsx sheets (getStyles ar) names customPropMap @@ -96,8 +99,10 @@ let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" commentTarget :: Maybe FilePath commentTarget = relTarget <$> findRelByType commentsType sheetRels+ legacyDrRId = cur $/ element (n"legacyDrawing") >=> fromAttribute (odr"id")+ legacyDrPath = fmap relTarget . flip Relationships.lookup sheetRels =<< listToMaybe legacyDrRId - commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar) commentTarget+ commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar legacyDrPath) commentTarget -- Likewise, @pageSetup@ also occurs either 0 or 1 times let pageSetup = listToMaybe $ cur $/ element (n"pageSetup") >=> fromCursor@@ -188,7 +193,8 @@ -- | Get shared string table getSharedStrings :: Zip.Archive -> Parser SharedStringTable-getSharedStrings x = head . fromCursor <$> xmlCursorRequired x "xl/sharedStrings.xml"+getSharedStrings x = maybe sstEmpty (head . fromCursor) <$>+ xmlCursorOptional x "xl/sharedStrings.xml" getContentTypes :: Zip.Archive -> Parser ContentTypes getContentTypes x = head . fromCursor <$> xmlCursorRequired x "[Content_Types].xml"@@ -198,8 +204,26 @@ Nothing -> Styles L.empty Just xml -> Styles xml -getComments :: Zip.Archive -> FilePath -> Parser (Maybe CommentTable)-getComments ar fp = (listToMaybe . fromCursor =<<) <$> xmlCursorOptional ar fp+getComments :: Zip.Archive -> Maybe FilePath -> FilePath -> Parser (Maybe CommentTable)+getComments ar drp fp = do+ mCurComments <- xmlCursorOptional ar fp+ mCurDr <- maybe (return Nothing) (xmlCursorOptional ar) drp+ return (liftA2 hide (hidden <$> mCurDr) . listToMaybe . fromCursor =<< mCurComments)+ where+ hide refs (CommentTable m) = CommentTable $ foldl' hideComment m refs+ hideComment m r = M.adjust (\c->c{_commentVisible = False}) r m+ v nm = Name nm (Just "urn:schemas-microsoft-com:vml") Nothing+ x nm = Name nm (Just "urn:schemas-microsoft-com:office:excel") Nothing+ hidden :: Cursor -> [CellRef]+ hidden cur = cur $/ checkElement visibleShape &/+ element (x"ClientData") >=> shapeCellRef+ visibleShape Element{..} = elementName == (v"shape") &&+ maybe False (any ("visibility:hidden"==) . T.split (==';')) (M.lookup "style" elementAttributes)+ shapeCellRef :: Cursor -> [CellRef]+ shapeCellRef c = do+ r0 <- c $/ element (x"Row") &/ content >=> decimal+ c0 <- c $/ element (x"Column") &/ content >=> decimal+ return $ mkCellRef (r0 + 1, c0 + 1) getCustomProperties :: Zip.Archive -> Parser CustomProperties getCustomProperties ar = maybe CustomProperties.empty (head . fromCursor) <$> xmlCursorOptional ar "docProps/custom.xml"
src/Codec/Xlsx/Types.hs view
@@ -43,10 +43,6 @@ -- * Misc , simpleCellFormula , def- , int2col- , col2int- , mkCellRef- , fromCellRef , mkRange , fromRange , toRows@@ -54,12 +50,10 @@ , module X ) where -import Control.Arrow import Control.Exception (SomeException, toException) import Control.Lens.TH import qualified Data.ByteString.Lazy as L-import Data.Char import Data.Default import Data.Function (on) import Data.List (groupBy)@@ -72,7 +66,6 @@ import Text.XML (Element (..), parseLBS, renderLBS) import Text.XML.Cursor-import Safe (fromJustNote) import Codec.Xlsx.Parser.Internal import Codec.Xlsx.Types.Comment as X@@ -184,7 +177,7 @@ -- | Structured representation of Xlsx file (currently a subset of its contents) data Xlsx = Xlsx- { _xlSheets :: Map Text Worksheet+ { _xlSheets :: [(Text, Worksheet)] , _xlStyles :: Styles , _xlDefinedNames :: DefinedNames , _xlCustomProperties :: Map Text Variant@@ -217,7 +210,7 @@ makeLenses ''Xlsx instance Default Xlsx where- def = Xlsx M.empty emptyStyles def M.empty+ def = Xlsx [] emptyStyles def M.empty instance Default DefinedNames where def = DefinedNames []@@ -248,23 +241,6 @@ [stylesheet] -> Right stylesheet _ -> Left . toException $ ParseException "Could not parse style sheets" --- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\")-int2col :: Int -> Text-int2col = T.pack . reverse . map int2let . base26- where- int2let 0 = 'Z'- int2let x = chr $ (x - 1) + ord 'A'- base26 0 = []- base26 i = let i' = (i `mod` 26)- i'' = if i' == 0 then 26 else i'- in seq i' (i' : base26 ((i - i'') `div` 26))---- | reverse to 'int2col'-col2int :: Text -> Int-col2int = T.foldl' (\i c -> i * 26 + let2int c) 0- where- let2int c = 1 + ord c - ord 'A'- -- | converts cells mapped by (row, column) into rows which contain -- row index and cells as pairs of column indices and cell values toRows :: CellMap -> [(Int, [(Int, Cell)])]@@ -280,21 +256,6 @@ fromRows rows = M.fromList $ concatMap mapRow rows where mapRow (r, cells) = map (\(c, v) -> ((r, c), v)) cells---- | Render position in @(row, col)@ format to an Excel reference.------ > mkCellRef (2, 4) == "D2"-mkCellRef :: (Int, Int) -> CellRef-mkCellRef (row, col) = T.concat [int2col col, T.pack (show row)]---- | reverse to 'mkCellRef'------ /Warning:/ the function isn't total and will throw an error if--- incorrect value will get passed-fromCellRef :: CellRef -> (Int, Int)-fromCellRef t = col2int *** toInt $ T.span (not . isDigit) t- where- toInt = fromJustNote "non-integer row in cell reference" . decimal -- | Render range --
src/Codec/Xlsx/Types/Comment.hs view
@@ -7,15 +7,14 @@ -- | User comment for a cell -- -- TODO: the following child elements:--- * guid--- * shapeId--- * commentPr+-- guid, shapeId, commentPr -- -- Section 18.7.3 "comment (Comment)" (p. 1749)-data Comment = Comment {- -- | cell comment text, maybe formatted+data Comment = Comment+ { _commentText :: XlsxText+ -- ^ cell comment text, maybe formatted -- Section 18.7.7 "text (Comment Text)" (p. 1754)- _commentText :: XlsxText- -- | comment author- , _commentAuthor :: Text }- deriving (Show, Eq)+ , _commentAuthor :: Text+ -- ^ comment author+ , _commentVisible :: Bool+ } deriving (Show, Eq)
src/Codec/Xlsx/Types/Common.hs view
@@ -1,14 +1,22 @@ {-# LANGUAGE OverloadedStrings #-} module Codec.Xlsx.Types.Common ( CellRef+ , mkCellRef+ , fromCellRef , SqRef (..) , XlsxText (..) , Formula (..)+ , int2col+ , col2int ) where +import Control.Arrow+import Data.Char import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T+import Data.Tuple (swap)+import Safe (fromJustNote) import Text.XML import Text.XML.Cursor @@ -16,10 +24,41 @@ import Codec.Xlsx.Types.RichText import Codec.Xlsx.Writer.Internal +-- | convert column number (starting from 1) to its textual form (e.g. 3 -> \"C\")+int2col :: Int -> Text+int2col = T.pack . reverse . map int2let . base26+ where+ int2let 0 = 'Z'+ int2let x = chr $ (x - 1) + ord 'A'+ base26 0 = []+ base26 i = let i' = (i `mod` 26)+ i'' = if i' == 0 then 26 else i'+ in seq i' (i' : base26 ((i - i'') `div` 26)) +-- | reverse to 'int2col'+col2int :: Text -> Int+col2int = T.foldl' (\i c -> i * 26 + let2int c) 0+ where+ let2int c = 1 + ord c - ord 'A'+ -- | Excel cell reference (e.g. @E3@) -- See 18.18.62 @ST_Ref@ (p. 2482) type CellRef = Text++-- | Render position in @(row, col)@ format to an Excel reference.+--+-- > mkCellRef (2, 4) == "D2"+mkCellRef :: (Int, Int) -> CellRef+mkCellRef (row, col) = T.concat [int2col col, T.pack (show row)]++-- | reverse to 'mkCellRef'+--+-- /Warning:/ the function isn't total and will throw an error if+-- incorrect value will get passed+fromCellRef :: CellRef -> (Int, Int)+fromCellRef t = swap $ col2int *** toInt $ T.span (not . isDigit) t+ where+ toInt = fromJustNote "non-integer row in cell reference" . decimal newtype SqRef = SqRef [CellRef] deriving (Eq, Ord, Show)
src/Codec/Xlsx/Types/Internal/CommentTable.hs view
@@ -2,6 +2,9 @@ {-# LANGUAGE RecordWildCards #-} module Codec.Xlsx.Types.Internal.CommentTable where +import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Lazy.Char8 as LBC8 import Data.List.Extra (nubOrd) import Data.Map (Map) import qualified Data.Map as M@@ -66,4 +69,46 @@ txt <- cur $/ element (n"text") >=> fromCursor authorId <- cur $| attribute "authorId" >=> decimal let author = fromJustNote "authorId" $ M.lookup authorId authors- return (ref, Comment txt author)+ return (ref, Comment txt author True)++-- | helper to render comment baloons vml file,+-- currently uses fixed shape+renderShapes :: CommentTable -> ByteString+renderShapes (CommentTable m) = LB.concat+ [ "<xml xmlns:v=\"urn:schemas-microsoft-com:vml\" "+ , "xmlns:o=\"urn:schemas-microsoft-com:office:office\" "+ , "xmlns:x=\"urn:schemas-microsoft-com:office:excel\">"+ , commentShapeType+ , LB.concat commentShapes+ , "</xml>"+ ]+ where+ commentShapeType = LB.concat+ [ "<v:shapetype id=\"baloon\" coordsize=\"21600,21600\" o:spt=\"202\" "+ , "path=\"m,l,21600r21600,l21600,xe\">"+ , "<v:stroke joinstyle=\"miter\"></v:stroke>"+ , "<v:path gradientshapeok=\"t\" o:connecttype=\"rect\"></v:path>"+ , "</v:shapetype>"+ ]+ commentShapes = [ commentShape (fromCellRef ref) (_commentVisible cmnt)+ | (ref, cmnt) <- M.toList m ]+ commentShape (r, c) v = LB.concat+ [ "<v:shape type=\"#baloon\" "+ , "style=\"position:absolute;width:auto" -- ;width:108pt;height:59.25pt"+ , if v then "" else ";visibility:hidden"+ , "\" fillcolor=\"#ffffe1\" o:insetmode=\"auto\">"+ , "<v:fill color2=\"#ffffe1\"></v:fill><v:shadow color=\"black\" obscured=\"t\"></v:shadow>"+ , "<v:path o:connecttype=\"none\"></v:path><v:textbox style=\"mso-direction-alt:auto\">"+ , "<div style=\"text-align:left\"></div></v:textbox>"+ , "<x:ClientData ObjectType=\"Note\">"+ , "<x:MoveWithCells></x:MoveWithCells><x:SizeWithCells></x:SizeWithCells>"+ , "<x:Anchor>4, 15, 0, 7, 6, 31, 5, 1</x:Anchor><x:AutoFill>False</x:AutoFill>"+ , "<x:Row>"+ , LBC8.pack $ show (r - 1)+ , "</x:Row>"+ , "<x:Column>"+ , LBC8.pack $ show (c - 1)+ , "</x:Column>"+ , "</x:ClientData>"+ , "</v:shape>"+ ]
src/Codec/Xlsx/Types/Internal/ContentTypes.hs view
@@ -4,10 +4,12 @@ module Codec.Xlsx.Types.Internal.ContentTypes where import Control.Arrow+import Data.Foldable (asum) import Data.Map (Map) import qualified Data.Map as M import Data.Text (Text) import qualified Data.Text as T+import System.FilePath.Posix (takeExtension) import Text.XML import Text.XML.Cursor @@ -17,25 +19,45 @@ import Codec.Xlsx.Parser.Internal +data CtDefault = CtDefault+ { dfltExtension :: FilePath+ , dfltContentType :: Text+ } deriving (Eq, Show)+ data Override = Override { ovrPartName :: FilePath , ovrContentType :: Text } deriving (Eq, Show) -newtype ContentTypes = ContentTypes- { ctTypes :: Map FilePath Text+data ContentTypes = ContentTypes+ { ctDefaults :: Map FilePath Text+ , ctTypes :: Map FilePath Text } deriving (Eq, Show) lookup :: FilePath -> ContentTypes -> Maybe Text-lookup path = M.lookup path . ctTypes+lookup path ContentTypes{..} =+ asum [ flip M.lookup ctDefaults =<< ext, M.lookup path ctTypes ]+ where+ ext = case takeExtension path of+ '.':e -> Just e+ _ -> Nothing {------------------------------------------------------------------------------- Parsing -------------------------------------------------------------------------------} instance FromCursor ContentTypes where fromCursor cur = do- let items = cur $/ element (ct"Override") >=> fromCursor- return . ContentTypes . M.fromList $ map (ovrPartName &&& ovrContentType) items+ let ds = M.fromList . map (dfltExtension &&& dfltContentType) $+ cur $/ element (ct"Default") >=> fromCursor+ ts = M.fromList . map (ovrPartName &&& ovrContentType) $+ cur $/ element (ct"Override") >=> fromCursor+ return (ContentTypes ds ts)++instance FromCursor CtDefault where+ fromCursor cur = do+ dfltExtension <- T.unpack <$> attribute "Extension" cur+ dfltContentType <- attribute "ContentType" cur+ return CtDefault{..} instance FromCursor Override where fromCursor cur = do
+ src/Codec/Xlsx/Types/Internal/NumFmtPair.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings #-}+module Codec.Xlsx.Types.Internal.NumFmtPair where++import Data.Text (Text)++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)++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 ]
@@ -7,6 +7,7 @@ , sstLookupText , sstLookupRich , sstItem+ , sstEmpty ) where import Control.Monad@@ -47,6 +48,9 @@ sstTable :: Vector XlsxText } deriving (Show, Eq, Ord)++sstEmpty :: SharedStringTable+sstEmpty = SharedStringTable V.empty {------------------------------------------------------------------------------- Rendering
src/Codec/Xlsx/Types/SheetViews.hs view
@@ -10,7 +10,6 @@ , SheetViewType(..) , PaneType(..) , PaneState(..)- , renderSheetViews -- * Lenses -- ** SheetView , sheetViewColorId@@ -357,21 +356,6 @@ {------------------------------------------------------------------------------- Rendering -------------------------------------------------------------------------------}---- | Render sheet views------ The list should be non-empty to be conform to the spec.------ See Section 18.3.1.88 "sheetViews (Sheet Views)" (p. 1704)-renderSheetViews :: [SheetView] -> Node-renderSheetViews views = NodeElement sheetViews- where- sheetViews :: Element- sheetViews = Element {- elementName = "sheetViews"- , elementAttributes = Map.empty- , elementNodes = map (NodeElement . toElement "sheetView") views- } -- | See @CT_SheetView@, p. 3913 instance ToElement SheetView where
src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -1,7 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} -- | Support for writing (but not reading) style sheets module Codec.Xlsx.Types.StyleSheet ( -- * The main two types@@ -17,7 +17,9 @@ , Fill(..) , FillPattern(..) , Font(..)- , NumberFormat(..), numberFormatId, idToStdNumberFormat+ , NumberFormat(..)+ , ImpliedNumberFormat (..)+ , NumFmt , Protection(..) -- * Supporting enumerations , CellHorizontalAlignment(..)@@ -36,6 +38,7 @@ , styleSheetFills , styleSheetCellXfs , styleSheetDxfs+ , styleSheetNumFmts -- ** CellXf , cellXfApplyAlignment , cellXfApplyBorder@@ -114,22 +117,35 @@ -- ** Protection , protectionHidden , protectionLocked+ -- * Helpers+ -- ** Number formats+ , fmtDecimals+ , fmtDecimalsZeroes+ , stdNumberFormatId+ , idToStdNumberFormat+ , firstUserNumFmtId ) where -import Control.Lens hiding ((.=), element)-import Data.Default-import Data.Maybe (catMaybes)-import Data.Text (Text)-import Text.XML-import Text.XML.Cursor-import qualified Data.Map as Map+import Control.Lens hiding (element, elements,+ (.=))+import Data.Default+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as M+import Data.Maybe (catMaybes)+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Text.XML+import Text.XML.Cursor + #if !MIN_VERSION_base(4,8,0)-import Control.Applicative+import Control.Applicative #endif -import Codec.Xlsx.Writer.Internal-import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Parser.Internal+import Codec.Xlsx.Types.Internal.NumFmtPair+import Codec.Xlsx.Writer.Internal {------------------------------------------------------------------------------- The main types@@ -155,7 +171,6 @@ -- * cellStyleXfs -- * colors -- * extLst--- * numFmts -- * tableStyles -- -- NOTE: You will probably want to base your style sheet on 'minimalStyleSheet'.@@ -164,14 +179,15 @@ -- * 'Codec.Xlsx.Types.renderStyleSheet' to translate a 'StyleSheet' to 'Styles' -- * 'Codec.Xlsx.Formatted.formatted' for a higher level interface. -- * 'Codec.Xlsx.Types.parseStyleSheet' to translate a raw 'StyleSheet' into 'Styles'-data StyleSheet = StyleSheet {- -- | This element contains borders formatting information, specifying all+data StyleSheet = StyleSheet+ { _styleSheetBorders :: [Border]+ -- ^ This element contains borders formatting information, specifying all -- border definitions for all cells in the workbook. -- -- Section 18.8.5, "borders (Borders)" (p. 1760)- _styleSheetBorders :: [Border] - -- | Cell formats+ , _styleSheetCellXfs :: [CellXf]+ -- ^ Cell formats -- -- This element contains the master formatting records (xf) which define the -- formatting applied to cells in this workbook. These records are the@@ -179,22 +195,22 @@ -- Sheet Part reference the xf records by zero-based index. -- -- Section 18.8.10, "cellXfs (Cell Formats)" (p. 1764)- , _styleSheetCellXfs :: [CellXf] - -- | This element defines the cell fills portion of the Styles part,+ , _styleSheetFills :: [Fill]+ -- ^ This element defines the cell fills portion of the Styles part, -- consisting of a sequence of fill records. A cell fill consists of a -- background color, foreground color, and pattern to be applied across the -- cell. -- -- Section 18.8.21, "fills (Fills)" (p. 1768)- , _styleSheetFills :: [Fill] - -- | This element contains all font definitions for this workbook.+ , _styleSheetFonts :: [Font]+ -- ^ This element contains all font definitions for this workbook. -- -- Section 18.8.23 "fonts (Fonts)" (p. 1769)- , _styleSheetFonts :: [Font] - -- | Differential formatting+ , _styleSheetDxfs :: [Dxf]+ -- ^ Differential formatting -- -- This element contains the master differential formatting records (dxf's) -- which define formatting for all non-cell formatting in this workbook.@@ -206,10 +222,15 @@ -- present on the object using the dxf record. -- -- Section 18.8.15, "dxfs (Formats)" (p. 1765)- , _styleSheetDxfs :: [Dxf]- }- deriving (Show, Eq, Ord) + , _styleSheetNumFmts :: Map Int NumFmt+ -- ^ Number formats+ --+ -- This element contains custom number formats defined in this style sheet+ --+ -- Section 18.8.31, "numFmts (Number Formats)" (p. 1784)+ } deriving (Eq, Ord, Show)+ -- | Cell formatting -- -- TODO: The @extLst@ field is currently unsupported.@@ -218,19 +239,19 @@ data CellXf = CellXf { -- | A boolean value indicating whether the alignment formatting specified -- for this xf should be applied.- _cellXfApplyAlignment :: Maybe Bool+ _cellXfApplyAlignment :: Maybe Bool -- | A boolean value indicating whether the border formatting specified for -- this xf should be applied.- , _cellXfApplyBorder :: Maybe Bool+ , _cellXfApplyBorder :: Maybe Bool -- | A boolean value indicating whether the fill formatting specified for -- this xf should be applied.- , _cellXfApplyFill :: Maybe Bool+ , _cellXfApplyFill :: Maybe Bool -- | A boolean value indicating whether the font formatting specified for -- this xf should be applied.- , _cellXfApplyFont :: Maybe Bool+ , _cellXfApplyFont :: Maybe Bool -- | A boolean value indicating whether the number formatting specified for -- this xf should be applied.@@ -238,23 +259,23 @@ -- | A boolean value indicating whether the protection formatting specified -- for this xf should be applied.- , _cellXfApplyProtection :: Maybe Bool+ , _cellXfApplyProtection :: Maybe Bool -- | Zero-based index of the border record used by this cell format. -- -- (18.18.2, p. 2437).- , _cellXfBorderId :: Maybe Int+ , _cellXfBorderId :: Maybe Int -- | Zero-based index of the fill record used by this cell format. -- -- (18.18.30, p. 2455)- , _cellXfFillId :: Maybe Int+ , _cellXfFillId :: Maybe Int -- | Zero-based index of the font record used by this cell format. -- -- An integer that represents a zero based index into the `styleSheetFonts` -- collection in the style sheet (18.18.32, p. 2456).- , _cellXfFontId :: Maybe Int+ , _cellXfFontId :: Maybe Int -- | Id of the number format (numFmt) record used by this cell format. --@@ -263,17 +284,16 @@ -- (18.18.47, p. 2468). See also 18.8.31 (p. 1784) for more information on -- number formats. --- -- TODO: The numFmts part of the style sheet is currently not implemented.- , _cellXfNumFmtId :: Maybe Int+ , _cellXfNumFmtId :: Maybe Int -- | A boolean value indicating whether the cell rendering includes a pivot -- table dropdown button.- , _cellXfPivotButton :: Maybe Bool+ , _cellXfPivotButton :: Maybe Bool -- | A boolean value indicating whether the text string in a cell should be -- prefixed by a single quote mark (e.g., 'text). In these cases, the quote -- is not stored in the Shared Strings Part.- , _cellXfQuotePrefix :: Maybe Bool+ , _cellXfQuotePrefix :: Maybe Bool -- | For xf records contained in cellXfs this is the zero-based index of an -- xf record contained in cellStyleXfs corresponding to the cell style@@ -284,17 +304,17 @@ -- Used by xf records and cellStyle records to reference xf records defined -- in the cellStyleXfs collection. (18.18.10, p. 2442) -- TODO: the cellStyleXfs field of a style sheet not currently implemented.- , _cellXfId :: Maybe Int+ , _cellXfId :: Maybe Int -- | Formatting information pertaining to text alignment in cells. There are -- a variety of choices for how text is aligned both horizontally and -- vertically, as well as indentation settings, and so on.- , _cellXfAlignment :: Maybe Alignment+ , _cellXfAlignment :: Maybe Alignment -- | Contains protection properties associated with the cell. Each cell has -- protection properties that can be set. The cell protection properties do -- not take effect unless the sheet has been protected.- , _cellXfProtection :: Maybe Protection+ , _cellXfProtection :: Maybe Protection } deriving (Show, Eq, Ord) @@ -307,12 +327,12 @@ -- See 18.8.1 "alignment (Alignment)" (p. 1754) data Alignment = Alignment { -- | Specifies the type of horizontal alignment in cells.- _alignmentHorizontal :: Maybe CellHorizontalAlignment+ _alignmentHorizontal :: Maybe CellHorizontalAlignment -- | An integer value, where an increment of 1 represents 3 spaces. -- Indicates the number of spaces (of the normal style font) of indentation -- for text in a cell.- , _alignmentIndent :: Maybe Int+ , _alignmentIndent :: Maybe Int -- | A boolean value indicating if the cells justified or distributed -- alignment should be used on the last line of text. (This is typical for@@ -322,28 +342,28 @@ -- | An integer value indicating whether the reading order -- (bidirectionality) of the cell is leftto- right, right-to-left, or -- context dependent.- , _alignmentReadingOrder :: Maybe ReadingOrder+ , _alignmentReadingOrder :: Maybe ReadingOrder -- | An integer value (used only in a dxf element) to indicate the -- additional number of spaces of indentation to adjust for text in a cell.- , _alignmentRelativeIndent :: Maybe Int+ , _alignmentRelativeIndent :: Maybe Int -- | A boolean value indicating if the displayed text in the cell should be -- shrunk to fit the cell width. Not applicable when a cell contains -- multiple lines of text.- , _alignmentShrinkToFit :: Maybe Bool+ , _alignmentShrinkToFit :: Maybe Bool -- | Text rotation in cells. Expressed in degrees. Values range from 0 to -- 180. The first letter of the text is considered the center-point of the -- arc.- , _alignmentTextRotation :: Maybe Int+ , _alignmentTextRotation :: Maybe Int -- | Vertical alignment in cells.- , _alignmentVertical :: Maybe CellVerticalAlignment+ , _alignmentVertical :: Maybe CellVerticalAlignment -- | A boolean value indicating if the text in a cell should be line-wrapped -- within the cell.- , _alignmentWrapText :: Maybe Bool+ , _alignmentWrapText :: Maybe Bool } deriving (Show, Eq, Ord) @@ -360,48 +380,48 @@ -- | A boolean value indicating if the cell's diagonal border includes a -- diagonal line, starting at the bottom left corner of the cell and moving -- up to the top right corner of the cell.- , _borderDiagonalUp :: Maybe Bool+ , _borderDiagonalUp :: Maybe Bool -- | A boolean value indicating if left, right, top, and bottom borders -- should be applied only to outside borders of a cell range.- , _borderOutline :: Maybe Bool+ , _borderOutline :: Maybe Bool -- | Bottom border- , _borderBottom :: Maybe BorderStyle+ , _borderBottom :: Maybe BorderStyle -- | Diagonal- , _borderDiagonal :: Maybe BorderStyle+ , _borderDiagonal :: Maybe BorderStyle -- | Trailing edge border -- -- See also 'borderRight'- , _borderEnd :: Maybe BorderStyle+ , _borderEnd :: Maybe BorderStyle -- | Horizontal inner borders- , _borderHorizontal :: Maybe BorderStyle+ , _borderHorizontal :: Maybe BorderStyle -- | Left border -- -- NOTE: The spec does not formally list a 'left' border element, but the -- examples do mention 'left' and the scheme contains it too. See also 'borderStart'.- , _borderLeft :: Maybe BorderStyle+ , _borderLeft :: Maybe BorderStyle -- | Right border -- -- NOTE: The spec does not formally list a 'right' border element, but the -- examples do mention 'right' and the scheme contains it too. See also 'borderEnd'.- , _borderRight :: Maybe BorderStyle+ , _borderRight :: Maybe BorderStyle -- | Leading edge border -- -- See also 'borderLeft'- , _borderStart :: Maybe BorderStyle+ , _borderStart :: Maybe BorderStyle -- | Top border- , _borderTop :: Maybe BorderStyle+ , _borderTop :: Maybe BorderStyle -- | Vertical inner border- , _borderVertical :: Maybe BorderStyle+ , _borderVertical :: Maybe BorderStyle } deriving (Show, Eq, Ord) @@ -429,12 +449,12 @@ -- This simple type's contents have a length of exactly 8 hexadecimal -- digit(s); see "18.18.86 ST_UnsignedIntHex (Hex Unsigned Integer)" (p. -- 2511).- , _colorARGB :: Maybe Text+ , _colorARGB :: Maybe Text -- | A zero-based index into the <clrScheme> collection (20.1.6.2), -- referencing a particular <sysClr> or <srgbClr> value expressed in the -- Theme part.- , _colorTheme :: Maybe Int+ , _colorTheme :: Maybe Int -- | Specifies the tint value applied to the color. --@@ -443,7 +463,7 @@ -- -- The tint value is stored as a double from -1.0 .. 1.0, where -1.0 means -- 100% darken and 1.0 means 100% lighten. Also, 0.0 means no change.- , _colorTint :: Maybe Double+ , _colorTint :: Maybe Double } deriving (Show, Eq, Ord) @@ -478,7 +498,7 @@ -- Section 18.2.22 "font (Font)" (p. 1769) data Font = Font { -- | Displays characters in bold face font style.- _fontBold :: Maybe Bool+ _fontBold :: Maybe Bool -- | This element defines the font character set of this font. --@@ -499,33 +519,33 @@ -- These are operating-system-dependent values. -- -- Section 18.4.1 "charset (Character Set)" provides some example values.- , _fontCharset :: Maybe Int+ , _fontCharset :: Maybe Int -- | Color- , _fontColor :: Maybe Color+ , _fontColor :: Maybe Color -- | Macintosh compatibility setting. Represents special word/character -- rendering on Macintosh, when this flag is set. The effect is to condense -- the text (squeeze it together). SpreadsheetML applications are not -- required to render according to this flag.- , _fontCondense :: Maybe Bool+ , _fontCondense :: Maybe Bool -- | This element specifies a compatibility setting used for previous -- spreadsheet applications, resulting in special word/character rendering -- on those legacy applications, when this flag is set. The effect extends -- or stretches out the text. SpreadsheetML applications are not required to -- render according to this flag.- , _fontExtend :: Maybe Bool+ , _fontExtend :: Maybe Bool -- | The font family this font belongs to. A font family is a set of fonts -- having common stroke width and serif characteristics. This is system -- level font information. The font name overrides when there are -- conflicting values.- , _fontFamily :: Maybe FontFamily+ , _fontFamily :: Maybe FontFamily -- | Displays characters in italic font style. The italic style is defined -- by the font at a system level and is not specified by ECMA-376.- , _fontItalic :: Maybe Bool+ , _fontItalic :: Maybe Bool -- | This element specifies the face name of this font. --@@ -534,11 +554,11 @@ -- by that font, then another font should be substituted. -- -- The string length for this attribute shall be 0 to 31 characters.- , _fontName :: Maybe Text+ , _fontName :: Maybe Text -- | This element displays only the inner and outer borders of each -- character. This is very similar to Bold in behavior.- , _fontOutline :: Maybe Bool+ , _fontOutline :: Maybe Bool -- | Defines the font scheme, if any, to which this font belongs. When a -- font definition is part of a theme definition, then the font is@@ -547,13 +567,13 @@ -- to use the new major or minor font definition for that theme. Usually -- major fonts are used for styles like headings, and minor fonts are used -- for body and paragraph text.- , _fontScheme :: Maybe FontScheme+ , _fontScheme :: Maybe FontScheme -- | Macintosh compatibility setting. Represents special word/character -- rendering on Macintosh, when this flag is set. The effect is to render a -- shadow behind, beneath and to the right of the text. SpreadsheetML -- applications are not required to render according to this flag.- , _fontShadow :: Maybe Bool+ , _fontShadow :: Maybe Bool -- | This element draws a strikethrough line through the horizontal middle -- of the text.@@ -561,16 +581,16 @@ -- | This element represents the point size (1/72 of an inch) of the Latin -- and East Asian text.- , _fontSize :: Maybe Double+ , _fontSize :: Maybe Double -- | This element represents the underline formatting style.- , _fontUnderline :: Maybe FontUnderline+ , _fontUnderline :: Maybe FontUnderline -- | This element adjusts the vertical position of the text relative to the -- text's default appearance for this run. It is used to get 'superscript' -- or 'subscript' texts, and shall reduce the font size (if a smaller size -- is available) accordingly.- , _fontVertAlign :: Maybe FontVerticalAlignment+ , _fontVertAlign :: Maybe FontVerticalAlignment } deriving (Show, Eq, Ord) @@ -578,19 +598,44 @@ -- -- Section 18.8.14, "dxf (Formatting)" (p. 1765) data Dxf = Dxf- { _dxfFont :: Maybe Font+ { _dxfFont :: Maybe Font -- TODO: numFmt- , _dxfFill :: Maybe Fill- , _dxfAlignment :: Maybe Alignment- , _dxfBorder :: Maybe Border- , _dxfProtection :: Maybe Protection+ , _dxfFill :: Maybe Fill+ , _dxfAlignment :: Maybe Alignment+ , _dxfBorder :: Maybe Border+ , _dxfProtection :: Maybe Protection -- TODO: extList } deriving (Eq, Ord, Show) --- Section 18.2.30 "font (Font)" (p. 1777)--- Note: This only implements the predefined values for 18.2.30 "All Languages",--- not the extended languages or custom ones from 18.2.31-data NumberFormat =+type NumFmt = 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)+data NumberFormat+ = StdNumberFormat ImpliedNumberFormat+ | UserNumberFormat NumFmt+ deriving (Eq, Ord, Show)++-- | 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+fmtDecimals :: Int -> NumberFormat+fmtDecimals k = UserNumberFormat $ "0." <> T.replicate k "#"++-- | Basic number format with predefined number of decimals.+-- Works like 'fmtDecimals' with the only difference that extra zeroes are+-- displayed when number of digits after the point is less than the number+-- of digits specified in the format+fmtDecimalsZeroes :: Int -> NumberFormat+fmtDecimalsZeroes k = UserNumberFormat $ "0." <> T.replicate k "0"++-- | Implied number formats+--+-- /Note:/ This only implements the predefined values for 18.2.30 "All Languages",+-- other built-in format ids (with id < 'firstUserNumFmtId') are stored in 'NfOtherBuiltin'+data ImpliedNumberFormat = NfGeneral -- ^> 0 General | NfZero -- ^> 1 0 | Nf2Decimal -- ^> 2 0.00@@ -619,39 +664,41 @@ | NfMmSs1Decimal -- ^> 47 mmss.0 | NfExponent1Decimal -- ^> 48 ##0.0E+0 | NfTextPlaceHolder -- ^> 49 @+ | NfOtherImplied Int -- ^ other (non local-neutral?) built-in format (id < 164) deriving (Show, Eq, Ord) -numberFormatId :: NumberFormat -> Int-numberFormatId NfGeneral = 0 -- General-numberFormatId NfZero = 1 -- 0-numberFormatId Nf2Decimal = 2 -- 0.00-numberFormatId NfMax3Decimal = 3 -- #,##0-numberFormatId NfThousandSeparator2Decimal = 4 -- #,##0.00-numberFormatId NfPercent = 9 -- 0%-numberFormatId NfPercent2Decimal = 10 -- 0.00%-numberFormatId NfExponent2Decimal = 11 -- 0.00E+00-numberFormatId NfSingleSpacedFraction = 12 -- # ?/?-numberFormatId NfDoubleSpacedFraction = 13 -- # ??/??-numberFormatId NfMmDdYy = 14 -- mm-dd-yy-numberFormatId NfDMmmYy = 15 -- d-mmm-yy-numberFormatId NfDMmm = 16 -- d-mmm-numberFormatId NfMmmYy = 17 -- mmm-yy-numberFormatId NfHMm12Hr = 18 -- h:mm AM/PM-numberFormatId NfHMmSs12Hr = 19 -- h:mm:ss AM/PM-numberFormatId NfHMm = 20 -- h:mm-numberFormatId NfHMmSs = 21 -- h:mm:ss-numberFormatId NfMdyHMm = 22 -- m/d/yy h:mm-numberFormatId NfThousandsNegativeParens = 37 -- #,##0 ;(#,##0)-numberFormatId NfThousandsNegativeRed = 38 -- #,##0 ;[Red](#,##0)-numberFormatId NfThousands2DecimalNegativeParens = 39 -- #,##0.00;(#,##0.00)-numberFormatId NfTousands2DecimalNEgativeRed = 40 -- #,##0.00;[Red](#,##0.00)-numberFormatId NfMmSs = 45 -- mm:ss-numberFormatId NfOptHMmSs = 46 -- [h]:mm:ss-numberFormatId NfMmSs1Decimal = 47 -- mmss.0-numberFormatId NfExponent1Decimal = 48 -- ##0.0E+0-numberFormatId NfTextPlaceHolder = 49 -- @+stdNumberFormatId :: ImpliedNumberFormat -> Int+stdNumberFormatId NfGeneral = 0 -- General+stdNumberFormatId NfZero = 1 -- 0+stdNumberFormatId Nf2Decimal = 2 -- 0.00+stdNumberFormatId NfMax3Decimal = 3 -- #,##0+stdNumberFormatId NfThousandSeparator2Decimal = 4 -- #,##0.00+stdNumberFormatId NfPercent = 9 -- 0%+stdNumberFormatId NfPercent2Decimal = 10 -- 0.00%+stdNumberFormatId NfExponent2Decimal = 11 -- 0.00E+00+stdNumberFormatId NfSingleSpacedFraction = 12 -- # ?/?+stdNumberFormatId NfDoubleSpacedFraction = 13 -- # ??/??+stdNumberFormatId NfMmDdYy = 14 -- mm-dd-yy+stdNumberFormatId NfDMmmYy = 15 -- d-mmm-yy+stdNumberFormatId NfDMmm = 16 -- d-mmm+stdNumberFormatId NfMmmYy = 17 -- mmm-yy+stdNumberFormatId NfHMm12Hr = 18 -- h:mm AM/PM+stdNumberFormatId NfHMmSs12Hr = 19 -- h:mm:ss AM/PM+stdNumberFormatId NfHMm = 20 -- h:mm+stdNumberFormatId NfHMmSs = 21 -- h:mm:ss+stdNumberFormatId NfMdyHMm = 22 -- m/d/yy h:mm+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 NfMmSs = 45 -- mm:ss+stdNumberFormatId NfOptHMmSs = 46 -- [h]:mm:ss+stdNumberFormatId NfMmSs1Decimal = 47 -- mmss.0+stdNumberFormatId NfExponent1Decimal = 48 -- ##0.0E+0+stdNumberFormatId NfTextPlaceHolder = 49 -- @+stdNumberFormatId (NfOtherImplied i) = i -idToStdNumberFormat :: Int -> Maybe NumberFormat+idToStdNumberFormat :: Int -> Maybe ImpliedNumberFormat idToStdNumberFormat 0 = Just NfGeneral -- General idToStdNumberFormat 1 = Just NfZero -- 0 idToStdNumberFormat 2 = Just Nf2Decimal -- 0.00@@ -680,8 +727,11 @@ idToStdNumberFormat 47 = Just NfMmSs1Decimal -- mmss.0 idToStdNumberFormat 48 = Just NfExponent1Decimal -- ##0.0E+0 idToStdNumberFormat 49 = Just NfTextPlaceHolder -- @-idToStdNumberFormat _ = Nothing+idToStdNumberFormat i = if i < firstUserNumFmtId then Just (NfOtherImplied i) else Nothing +firstUserNumFmtId :: Int+firstUserNumFmtId = 164+ -- | Protection properties -- -- Contains protection properties associated with the cell. Each cell has@@ -907,6 +957,7 @@ , _styleSheetFills = [] , _styleSheetCellXfs = [] , _styleSheetDxfs = []+ , _styleSheetNumFmts = M.empty } instance Default CellXf where@@ -1033,23 +1084,21 @@ -- | See @CT_Stylesheet@, p. 4482 instance ToElement StyleSheet where- toElement nm StyleSheet{..} = Element {- elementName = nm- , elementAttributes = Map.empty- , elementNodes = map NodeElement $ [- -- TODO: numFmts- countedElementList "fonts" $ map (toElement "font") _styleSheetFonts- , countedElementList "fills" $ map (toElement "fill") _styleSheetFills- , countedElementList "borders" $ map (toElement "border") _styleSheetBorders- -- TODO: cellStyleXfs- , countedElementList "cellXfs" $ map (toElement "xf") _styleSheetCellXfs- -- TODO: cellStyles- , countedElementList "dxfs" $ map (toElement "dxf") _styleSheetDxfs- -- TODO: tableStyles- -- TODO: colors- -- TODO: extLst- ]- }+ toElement nm StyleSheet{..} = elementListSimple nm elements+ where+ elements = [ countedElementList "numFmts" $ map (toElement "numFmt") numFmts+ , countedElementList "fonts" $ map (toElement "font") _styleSheetFonts+ , countedElementList "fills" $ map (toElement "fill") _styleSheetFills+ , countedElementList "borders" $ map (toElement "border") _styleSheetBorders+ -- TODO: cellStyleXfs+ , countedElementList "cellXfs" $ map (toElement "xf") _styleSheetCellXfs+ -- TODO: cellStyles+ , countedElementList "dxfs" $ map (toElement "dxf") _styleSheetDxfs+ -- TODO: tableStyles+ -- TODO: colors+ -- TODO: extLst+ ]+ numFmts = map NumFmtPair $ M.toList _styleSheetNumFmts -- | See @CT_Xf@, p. 4486 instance ToElement CellXf where@@ -1060,7 +1109,7 @@ , toElement "protection" <$> _cellXfProtection -- TODO: extLst ]- , elementAttributes = Map.fromList . catMaybes $ [+ , elementAttributes = M.fromList . catMaybes $ [ "numFmtId" .=? _cellXfNumFmtId , "fontId" .=? _cellXfFontId , "fillId" .=? _cellXfFillId@@ -1088,7 +1137,7 @@ , toElement "border" <$> _dxfBorder , toElement "protection" <$> _dxfProtection ]- , elementAttributes = Map.empty+ , elementAttributes = M.empty } -- | See @CT_CellAlignment@, p. 4482@@ -1096,7 +1145,7 @@ toElement nm Alignment{..} = Element { elementName = nm , elementNodes = []- , elementAttributes = Map.fromList . catMaybes $ [+ , elementAttributes = M.fromList . catMaybes $ [ "horizontal" .=? _alignmentHorizontal , "vertical" .=? _alignmentVertical , "textRotation" .=? _alignmentTextRotation@@ -1113,7 +1162,7 @@ instance ToElement Border where toElement nm Border{..} = Element { elementName = nm- , elementAttributes = Map.fromList . catMaybes $ [+ , elementAttributes = M.fromList . catMaybes $ [ "diagonalUp" .=? _borderDiagonalUp , "diagonalDown" .=? _borderDiagonalDown , "outline" .=? _borderOutline@@ -1135,7 +1184,7 @@ instance ToElement BorderStyle where toElement nm BorderStyle{..} = Element { elementName = nm- , elementAttributes = Map.fromList . catMaybes $ [+ , elementAttributes = M.fromList . catMaybes $ [ "style" .=? _borderStyleLine ] , elementNodes = map NodeElement . catMaybes $ [@@ -1148,7 +1197,7 @@ toElement nm Color{..} = Element { elementName = nm , elementNodes = []- , elementAttributes = Map.fromList . catMaybes $ [+ , elementAttributes = M.fromList . catMaybes $ [ "auto" .=? _colorAutomatic , "rgb" .=? _colorARGB , "theme" .=? _colorTheme@@ -1160,7 +1209,7 @@ instance ToElement Fill where toElement nm Fill{..} = Element { elementName = nm- , elementAttributes = Map.empty+ , elementAttributes = M.empty , elementNodes = map NodeElement . catMaybes $ [ toElement "patternFill" <$> _fillPattern ]@@ -1170,7 +1219,7 @@ instance ToElement FillPattern where toElement nm FillPattern{..} = Element { elementName = nm- , elementAttributes = Map.fromList . catMaybes $ [+ , elementAttributes = M.fromList . catMaybes $ [ "patternType" .=? _fillPatternType ] , elementNodes = map NodeElement . catMaybes $ [@@ -1183,7 +1232,7 @@ instance ToElement Font where toElement nm Font{..} = Element { elementName = nm- , elementAttributes = Map.empty -- all properties specified as child nodes+ , elementAttributes = M.empty -- all properties specified as child nodes , elementNodes = map NodeElement . catMaybes $ [ elementValue "name" <$> _fontName , elementValue "charset" <$> _fontCharset@@ -1208,7 +1257,7 @@ toElement nm Protection{..} = Element { elementName = nm , elementNodes = []- , elementAttributes = Map.fromList . catMaybes $ [+ , elementAttributes = M.fromList . catMaybes $ [ "locked" .=? _protectionLocked , "hidden" .=? _protectionHidden ]@@ -1310,7 +1359,6 @@ instance FromCursor StyleSheet where fromCursor cur = do let- -- TODO: numFmts _styleSheetFonts = cur $/ element (n"fonts") &/ element (n"font") >=> fromCursor _styleSheetFills = cur $/ element (n"fills") &/ element (n"fill") >=> fromCursor _styleSheetBorders = cur $/ element (n"borders") &/ element (n"border") >=> fromCursor@@ -1318,6 +1366,8 @@ _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 $+ cur $/ element (n"numFmts")&/ element (n"numFmt") >=> fromCursor -- TODO: tableStyles -- TODO: colors -- TODO: extLst
src/Codec/Xlsx/Writer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -13,10 +14,13 @@ import Data.ByteString.Lazy.Char8 () import Data.List (foldl') import Data.Map (Map)+import Data.STRef+import Control.Monad.ST import qualified Data.Map as M import Data.Maybe import Data.Monoid ((<>)) import Data.Text (Text)+import Data.Tuple.Extra (fst3, snd3, thd3) import qualified Data.Text as T import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)@@ -58,10 +62,10 @@ "metadata/core-properties" $ coreXml utcTime "xlsxwriter" , FileData "docProps/app.xml" "application/vnd.openxmlformats-officedocument.extended-properties+xml"- "xtended-properties" $ appXml (xlsx ^. xlSheets)+ "xtended-properties" $ appXml sheetNames , FileData "xl/workbook.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml"- "officeDocument" $ bookXml (xlsx ^. xlSheets) (xlsx ^. xlDefinedNames)+ "officeDocument" $ bookXml sheetNames (xlsx ^. xlDefinedNames) , FileData "xl/styles.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" "styles" $ unStyles (xlsx ^. xlStyles)@@ -90,52 +94,119 @@ [ ("custom-properties", "docProps/custom.xml") ]) bookRelsXml = renderLBS def . toDocument $ bookRels sheetCount sheetFiles = concat $ zipWith3 singleSheetFiles [1..] sheetCells sheets- sheets = xlsx ^. xlSheets . to M.elems+ sheetNames = xlsx ^. xlSheets . to (map fst)+ sheets = xlsx ^. xlSheets . to (map snd) sheetCount = length sheets shared = sstConstruct sheets sheetCells = map (transformSheetData shared) sheets singleSheetFiles :: Int -> Cells -> Worksheet -> [FileData]-singleSheetFiles n cells ws = sheetFile:otherFiles+singleSheetFiles n cells ws = runST $ do+ ref <- newSTRef 1+ mCmntData <- genComments n cells ref+ mDrawingData <- maybe (return Nothing) (fmap Just . genDrawing n ref) (ws ^. wsDrawing)+ let sheetFilePath = "xl/worksheets/sheet" <> show n <> ".xml"+ sheetFile = FileData sheetFilePath+ "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml"+ "worksheet" $+ sheetXml+ nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ]+ sheetXml= renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root []+ root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $+ elementListSimple "worksheet" rootEls+ rootEls = catMaybes $+ [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews+ , nonEmptyElListSimple "cols" . map cwEl $ ws ^. wsColumns+ , Just . elementListSimple "sheetData" $ sheetDataXml cells (ws ^. wsRowPropertiesMap)+ ] +++ map (Just . toElement "conditionalFormatting") cfPairs +++ [ nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges+ , toElement "pageSetup" <$> ws ^. wsPageSetup+ , fst3 <$> mDrawingData+ , fst <$> mCmntData+ ]+ cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings+ cwEl cw = leafElement "col" [ ("min", txti $ cwMin cw)+ , ("max", txti $ cwMax cw)+ , ("width", txtd $ cwWidth cw)+ , ("style", txti $ cwStyle cw)]+ mergeE1 t = leafElement "mergeCell" [("ref", t)]++ sheetRels = if null referencedFiles+ then []+ else [ FileData ("xl/worksheets/_rels/sheet" <> show n <> ".xml.rels")+ "application/vnd.openxmlformats-package.relationships+xml"+ "relationships" sheetRelsXml ]+ sheetRelsXml = renderLBS def . toDocument . Relationships.fromList $+ [ relEntry i fdRelType (fdPath `relFrom` sheetFilePath)+ | (i, FileData{..}) <- referenced ]+ referenced = fromMaybe [] (snd <$> mCmntData) +++ catMaybes [ snd3 <$> mDrawingData ]+ referencedFiles = map snd referenced+ extraFiles = maybe [] thd3 mDrawingData+ otherFiles = sheetRels ++ referencedFiles ++ extraFiles++ return (sheetFile:otherFiles)++sheetDataXml :: Cells -> Map Int RowProperties -> [Element]+sheetDataXml rows rh = map rowEl rows where- sheetFilePath = "xl/worksheets/sheet" <> show n <> ".xml"- sheetFile = FileData sheetFilePath- "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml"- "worksheet" $- sheetXml ws cells drawingRId- drawingRId = if null commentsReferenced then 1 else 2- otherFiles = sheetRels ++ referencedFiles ++ extraFiles- referencedFiles = commentsReferenced ++ drawingReferenced- extraFiles = drawingExtra- commentsReferenced = commentsFiles n cells- sheetRels = if null referencedFiles- then []- else [ FileData ("xl/worksheets/_rels/sheet" <> show n <> ".xml.rels")- "application/vnd.openxmlformats-package.relationships+xml"- "relationships" sheetRelsXml ]- sheetRelsXml = renderLBS def . toDocument . Relationships.fromList $- [ relEntry i fdRelType (fdPath `relFrom` sheetFilePath)- | (i, FileData{..}) <- zip [1..] referencedFiles ]- (drawingReferenced, drawingExtra) = drawingFiles n (ws ^. wsDrawing)+ rowEl (r, cells) = elementList "row"+ (ht ++ s ++ [("r", txti r) ,("hidden", "false"), ("outlineLevel", "0"),+ ("collapsed", "false"), ("customFormat", "true"),+ ("customHeight", txtb hasHeight)])+ $ map (cellEl r) cells+ where+ (ht, hasHeight, s) = case M.lookup r rh of+ Just (RowProps (Just h) (Just st)) -> ([("ht", txtd h)], True,[("s", txti st)])+ Just (RowProps Nothing (Just st)) -> ([], True, [("s", txti st)])+ Just (RowProps (Just h) Nothing ) -> ([("ht", txtd h)], True,[])+ _ -> ([], False,[])+ cellEl r (icol, cell) =+ elementList "c" (cellAttrs (mkCellRef (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)] -commentsFiles :: Int -> Cells -> [FileData]-commentsFiles n cells =- if null comments then [] else [commentsFile]+genComments :: Int -> Cells -> STRef s Int -> ST s (Maybe (Element, [ReferencedFileData]))+genComments n cells ref =+ if null comments+ then do+ return Nothing+ else do+ rId1 <- readSTRef ref+ let rId2 = rId1 + 1+ modifySTRef' ref (+2)+ let el = refElement "legacyDrawing" rId2+ return $ Just (el, [(rId1, commentsFile), (rId2, vmlDrawingFile)]) where comments = concatMap (\(row, rowCells) -> mapMaybe (maybeCellComment row) rowCells) cells maybeCellComment row (col, cell) = do comment <- xlsxComment cell return (mkCellRef (row, col), comment)+ commentTable = CommentTable.fromList comments commentsFile = FileData commentsPath "application/vnd.openxmlformats-officedocument.spreadsheetml.comments+xml" "comments" commentsBS commentsPath = "xl/comments" <> show n <> ".xml"- commentsBS = renderLBS def . toDocument $ CommentTable.fromList comments+ commentsBS = renderLBS def $ toDocument commentTable+ vmlDrawingFile = FileData vmlPath+ "application/vnd.openxmlformats-officedocument.vmlDrawing"+ "vmlDrawing"+ vmlDrawingBS+ vmlPath = "xl/drawings/vmlDrawing" <> show n <> ".vml"+ vmlDrawingBS = CommentTable.renderShapes commentTable -drawingFiles :: Int -> Maybe Drawing -> ([FileData], [FileData])-drawingFiles _ Nothing = ([], [])-drawingFiles n(Just dr) = ([drawingFile], referenced)+genDrawing :: Int -> STRef s Int -> Drawing -> ST s (Element, ReferencedFileData, [FileData])+genDrawing n ref dr = do+ rId <- readSTRef ref+ modifySTRef' ref (+1)+ let el = refElement "drawing" rId+ return (el, (rId, drawingFile), referenced) where drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml" drawingFile = FileData drawingFilePath@@ -169,12 +240,13 @@ [] -> [] _ -> drawingRels:imageFiles - data FileData = FileData { fdPath :: FilePath , fdContentType :: Text , fdRelType :: Text , fdContents :: L.ByteString } +type ReferencedFileData = (Int, FileData)+ type Cells = [(Int, [(Int, XlsxCell)])] coreXml :: UTCTime -> Text -> L.ByteString@@ -195,25 +267,29 @@ , nEl (namespaced "cp" "lastModifiedBy") M.empty [NodeContent creator] ] -appXml :: Map Text Worksheet -> L.ByteString-appXml s = renderLBS def $ Document (Prologue [] Nothing []) root []+appXml :: [Text] -> L.ByteString+appXml sheetNames =+ renderLBS def $ Document (Prologue [] Nothing []) root [] where- nsAttrs = M.fromList [("xmlns:vt", "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")]+ sheetCount = length sheetNames root = Element (extPropNm "Properties") nsAttrs [ extPropEl "TotalTime" [NodeContent "0"] , extPropEl "HeadingPairs" [- vTypeEl "vector" (M.fromList [("size", "2"), ("baseType", "variant")])- [ vTypeEl0 "variant"- [vTypeEl0 "lpstr" [NodeContent "Worksheets"]]- , vTypeEl0 "variant"- [vTypeEl0 "i4" [NodeContent $ txti $ M.size s]]- ]- ]+ vTypeEl "vector" (M.fromList [ ("size", "2")+ , ("baseType", "variant")])+ [ vTypeEl0 "variant"+ [vTypeEl0 "lpstr" [NodeContent "Worksheets"]]+ , vTypeEl0 "variant"+ [vTypeEl0 "i4" [NodeContent $ txti sheetCount]]+ ]+ ] , extPropEl "TitlesOfParts" [- vTypeEl "vector" (M.fromList [("size", txti $ M.size s),("baseType","lpstr")]) $- map (vTypeEl0 "lpstr" . return . NodeContent) $ M.keys s- ]+ vTypeEl "vector" (M.fromList [ ("size", txti sheetCount)+ , ("baseType", "lpstr")]) $+ map (vTypeEl0 "lpstr" . return . NodeContent) sheetNames+ ] ]+ nsAttrs = M.fromList [("xmlns:vt", "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")] extPropNm n = nm "http://schemas.openxmlformats.org/officeDocument/2006/extended-properties" n extPropEl n = nEl (extPropNm n) M.empty vTypeEl0 n = vTypeEl n M.empty@@ -252,55 +328,10 @@ transformValue (CellBool b) = XlsxBool b transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) -sheetXml :: Worksheet -> Cells -> Int -> L.ByteString-sheetXml ws rows nextRId = renderLBS def $ Document (Prologue [] Nothing []) root []- where- cws = ws ^. wsColumns- rh = ws ^. wsRowPropertiesMap- merges = ws ^. wsMerges- sheetViews = ws ^. wsSheetViews- pageSetup = ws ^. wsPageSetup- drawing = ws ^. wsDrawing- cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings- root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $- Element "worksheet" M.empty $ catMaybes $- [ renderSheetViews <$> sheetViews,- nonEmptyNmEl "cols" M.empty $ map cwEl cws,- justNmEl "sheetData" M.empty $ map rowEl rows- ] ++- map (Just . NodeElement . toElement "conditionalFormatting") cfPairs ++- [ nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges,- NodeElement . toElement "pageSetup" <$> pageSetup,- NodeElement . (\_ -> leafElement "drawing" [ odr "id" .= ("rId" <> txti nextRId) ]) <$> drawing- ]- cType = xlsxCellType- cwEl cw = NodeElement $! Element "col" (M.fromList- [("min", txti $ cwMin cw), ("max", txti $ cwMax cw), ("width", txtd $ cwWidth cw), ("style", txti $ cwStyle cw)]) []- rowEl (r, cells) = nEl "row"- (M.fromList (ht ++ s ++ [("r", txti r) ,("hidden", "false"), ("outlineLevel", "0"),- ("collapsed", "false"), ("customFormat", "true"),- ("customHeight", txtb hasHeight)]))- $ map (cellEl r) cells- where- (ht, hasHeight, s) = case M.lookup r rh of- Just (RowProps (Just h) (Just st)) -> ([("ht", txtd h)], True,[("s", txti st)])- Just (RowProps Nothing (Just st)) -> ([], True, [("s", txti st)])- Just (RowProps (Just h) Nothing ) -> ([("ht", txtd h)], True,[])- _ -> ([], False,[])- mergeE1 t = NodeElement $! Element "mergeCell" (M.fromList [("ref",t)]) []- cellEl r (icol, cell) =- nEl "c" (M.fromList (cellAttrs (mkCellRef (r, icol)) cell))- (catMaybes [ (\v -> nEl "v" M.empty [NodeContent v]) . value <$> xlsxCellValue cell- , NodeElement . toElement "f" <$> xlsxCellFormula cell- ])- cellAttrs ref cell = cellStyleAttr cell ++ [("r", ref), ("t", cType cell)]- cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = []- cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)]--bookXml :: Map Text Worksheet -> DefinedNames -> L.ByteString-bookXml wss (DefinedNames names) = renderLBS def $ Document (Prologue [] Nothing []) root []+bookXml :: [Text] -> DefinedNames -> L.ByteString+bookXml sheetNames (DefinedNames names) = renderLBS def $ Document (Prologue [] Nothing []) root [] where- numNames = [(txti i, name) | (i, name) <- zip [(1::Int)..] (M.keys wss)]+ numNames = [(txti i, name) | (i, name) <- zip [(1::Int)..] sheetNames] -- The @bookViews@ element is not required according to the schema, but its -- absence can cause Excel to crash when opening the print preview@@ -308,13 +339,16 @@ -- to define a bookViews with a single empty @workbookView@ element -- (the @bookViews@ must contain at least one @wookbookView@). root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ Element "workbook" M.empty- [nEl "bookViews" M.empty [nEl "workbookView" M.empty []]- ,nEl "sheets" M.empty $- map (\(n, name) -> nEl "sheet"- (M.fromList [("name", name), ("sheetId", n), ("state", "visible"),- (rId, T.concat ["rId", n])]) []) numNames- ,nEl "definedNames" M.empty $ map (\(name, lsId, val) ->- nEl "definedName" (definedName name lsId) [NodeContent val]) names+ [ nEl "bookViews" M.empty [nEl "workbookView" M.empty []]+ , nEl "sheets" M.empty $+ map (\(n, name) -> nEl "sheet"+ (M.fromList [ ("name", name)+ , ("sheetId", n)+ , ("state", "visible")+ , (rId, "rId" <> n)]) [])+ numNames+ , nEl "definedNames" M.empty $ map (\(name, lsId, val) ->+ nEl "definedName" (definedName name lsId) [NodeContent val]) names ] rId = nm "http://schemas.openxmlformats.org/officeDocument/2006/relationships" "id"@@ -365,16 +399,9 @@ , nameNamespace = Just ns , namePrefix = Nothing} --- | Creates an element with the given name, attributes and children,--- if there is at least one child. Otherwise returns `Nothing`.-nonEmptyNmEl :: Name -> Map Name Text -> [Node] -> Maybe Node-nonEmptyNmEl _ _ [] = Nothing-nonEmptyNmEl name attrs nodes = justNmEl name attrs nodes---- | Creates an element with the given name, attributes and children.--- Always returns a node/`Just`.-justNmEl :: Name -> Map Name Text -> [Node] -> Maybe Node-justNmEl name attrs nodes = Just $ nEl name attrs nodes- nEl :: Name -> Map Name Text -> [Node] -> Node nEl name attrs nodes = NodeElement $ Element name attrs nodes++-- | Creates element holding reference to some linked file+refElement :: Name -> Int -> Element+refElement name rId = leafElement name [ odr "id" .= ("rId" <> txti rId) ]
src/Codec/Xlsx/Writer/Internal.hs view
@@ -12,6 +12,7 @@ , countedElementList , elementList , elementListSimple+ , nonEmptyElListSimple , leafElement , emptyElement , elementContent@@ -85,6 +86,10 @@ elementListSimple :: Name -> [Element] -> Element elementListSimple nm els = elementList nm [] els++nonEmptyElListSimple :: Name -> [Element] -> Maybe Element+nonEmptyElListSimple _ [] = Nothing+nonEmptyElListSimple nm els = Just $ elementListSimple nm els leafElement :: Name -> [(Name, Text)] -> Element leafElement nm attrs = elementList nm attrs []
test/DataTest.hs view
@@ -29,6 +29,7 @@ import Codec.Xlsx.Types.Internal.CommentTable import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.SharedStringTable+import Codec.Xlsx.Types.StyleSheet import Codec.Xlsx.Writer.Internal import Diff@@ -43,7 +44,7 @@ , testCase "fromRows . toRows == id" $ testCellMap1 @=? fromRows (toRows testCellMap1) , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $- testStyleSheet @=? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet))+ testStyleSheet @==? fromRight (parseStyleSheet (renderStyleSheet testStyleSheet)) , testCase "correct shared strings parsing" $ [testSharedStringTable] @=? testParsedSharedStringTables , testCase "correct shared strings parsing even when one of the shared strings entry is just <t/>" $@@ -73,7 +74,7 @@ testXlsx :: Xlsx testXlsx = Xlsx sheets minimalStyles definedNames customProperties where- sheets = M.fromList [("List1", sheet1), ("Another sheet", sheet2)]+ sheets = [("List1", sheet1), ("Another sheet", sheet2)] sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges sheetViews pageSetup cFormatting sheet2 = def & wsCells .~ testCellMap2 rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))]@@ -142,8 +143,8 @@ ) ] where- comment1 = Comment (XlsxText "simple comment") "bob"- comment2 = Comment (XlsxRichText [rich1, rich2]) "alice"+ comment1 = Comment (XlsxText "simple comment") "bob" True+ comment2 = Comment (XlsxRichText [rich1, rich2]) "alice" False rich1 = def & richTextRunText.~ "Look ma!" & richTextRunProperties ?~ ( def & runPropertiesBold ?~ True@@ -161,11 +162,19 @@ testStyleSheet :: StyleSheet testStyleSheet = minimalStyleSheet & styleSheetDxfs .~ [dxf1, dxf2]+ & 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)) red = def & colorARGB ?~ "FFFF0000"+ cellXf1 = def+ { _cellXfApplyNumberFormat = Just True+ , _cellXfNumFmtId = Just 2 }+ cellXf2 = def+ { _cellXfApplyNumberFormat = Just True+ , _cellXfNumFmtId = Just 164 } testSharedStringTable :: SharedStringTable testSharedStringTable = SharedStringTable $ V.fromList items@@ -191,8 +200,8 @@ testParsedSharedStringTablesWithEmpty = fromCursor . fromDocument $ parseLBS_ def testStringsWithEmpty testCommentTable = CommentTable $ M.fromList- [ ("D4", Comment (XlsxRichText rich) "Bob")- , ("A2", Comment (XlsxText "Some comment here") "CBR") ]+ [ ("D4", Comment (XlsxRichText rich) "Bob" True)+ , ("A2", Comment (XlsxText "Some comment here") "CBR" True) ] where rich = [ RichTextRun { _richTextRunProperties =@@ -375,21 +384,29 @@ testFormattedResult :: Formatted testFormattedResult = Formatted cm styleSheet merges where- cm = M.fromList [((1, 1), cell11),((1, 2), cell2)]+ cm = M.fromList [ ((1, 1), cell11)+ , ((1, 2), cell12)+ , ((2, 5), cell25) ] cell11 = Cell { _cellStyle = Just 1 , _cellValue = Just (CellText "text at A1") , _cellComment = Nothing , _cellFormula = Nothing }- cell2 = Cell+ cell12 = Cell { _cellStyle = Just 2 , _cellValue = Just (CellDouble 1.23) , _cellComment = Nothing , _cellFormula = Nothing }+ cell25 = Cell+ { _cellStyle = Just 3+ , _cellValue = Just (CellDouble 1.23456)+ , _cellComment = Nothing+ , _cellFormula = Nothing } merges = [] styleSheet =- minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2])+ minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2, cellXf3]) & styleSheetFonts %~ (++ [font1, font2])+ & styleSheetNumFmts .~ numFmts nextFontId = length (minimalStyleSheet ^. styleSheetFonts) cellXf1 = def { _cellXfApplyFont = Just True@@ -398,10 +415,16 @@ { _fontName = Just "Calibri" , _fontBold = Just True } cellXf2 = def- { _cellXfApplyFont = Just True- , _cellXfFontId = Just (nextFontId + 1) }+ { _cellXfApplyFont = Just True+ , _cellXfFontId = Just (nextFontId + 1)+ , _cellXfApplyNumberFormat = Just True+ , _cellXfNumFmtId = Just 164 } font2 = def { _fontItalic = Just True }+ cellXf3 = def+ { _cellXfApplyNumberFormat = Just True+ , _cellXfNumFmtId = Just 2 }+ numFmts = M.fromList [(164, "0.0000")] testRunFormatted :: Formatted testRunFormatted = formatted formattedCellMap minimalStyleSheet@@ -409,10 +432,13 @@ formattedCellMap = flip execState def $ do let font1 = def & fontBold ?~ True & fontName ?~ "Calibri"- at (1, 1) ?= (def & formattedValue ?~ CellText "text at A1"- & formattedFont ?~ font1)- at (1, 2) ?= (def & formattedValue ?~ CellDouble 1.23- & formattedFont . non def . fontItalic ?~ True)+ at (1, 1) ?= (def & formattedCell . cellValue ?~ CellText "text at A1"+ & formattedFormat . formatFont ?~ font1)+ at (1, 2) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23+ & formattedFormat . formatFont . non def . fontItalic ?~ True+ & formattedFormat . formatNumberFormat ?~ fmtDecimalsZeroes 4)+ at (2, 5) ?= (def & formattedCell . cellValue ?~ CellDouble 1.23456+ & formattedFormat . formatNumberFormat ?~ StdNumberFormat Nf2Decimal) testCondFormattedResult :: CondFormatted testCondFormattedResult = CondFormatted styleSheet formattings@@ -445,11 +471,11 @@ testFormattedCells = flip execState def $ do at (1,1) ?= (def & formattedRowSpan .~ 5 & formattedColSpan .~ 5- & formattedBorder . non def . borderTop .- non def . borderStyleLine ?~ LineStyleDashed- & formattedBorder . non def . borderBottom .- non def . borderStyleLine ?~ LineStyleDashed)- at (10,2) ?= (def & formattedFont . non def . fontBold ?~ True)+ & formattedFormat . formatBorder . non def . borderTop .+ non def . borderStyleLine ?~ LineStyleDashed+ & formattedFormat . formatBorder . non def . borderBottom .+ non def . borderStyleLine ?~ LineStyleDashed)+ at (10,2) ?= (def & formattedFormat . formatFont . non def . fontBold ?~ True) testRunCondFormatted :: CondFormatted testRunCondFormatted = conditionallyFormatted condFmts minimalStyleSheet
xlsx.cabal view
@@ -1,6 +1,6 @@ Name: xlsx -Version: 0.2.4+Version: 0.3.0 Synopsis: Simple and incomplete Excel file parser/writer Description:@@ -44,6 +44,7 @@ , Codec.Xlsx.Types.Internal.CommentTable , Codec.Xlsx.Types.Internal.ContentTypes , Codec.Xlsx.Types.Internal.CustomProperties+ , Codec.Xlsx.Types.Internal.NumFmtPair , Codec.Xlsx.Types.Internal.Relationships , Codec.Xlsx.Types.Internal.SharedStringTable , Codec.Xlsx.Types.RichText