diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,12 @@ +0.3.0 +----- +* implemented number formats +* fixed error of parsing "Default"s in content types (thanks Steve Bigham for reporting) +* fixed parsing workbooks with no shared strings (thanks Steve Bigham 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 diff --git a/src/Codec/Xlsx/Formatted.hs b/src/Codec/Xlsx/Formatted.hs --- a/src/Codec/Xlsx/Formatted.hs +++ b/src/Codec/Xlsx/Formatted.hs @@ -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 diff --git a/src/Codec/Xlsx/Lens.hs b/src/Codec/Xlsx/Lens.hs --- a/src/Codec/Xlsx/Lens.hs +++ b/src/Codec/Xlsx/Lens.hs @@ -1,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 diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs --- a/src/Codec/Xlsx/Parser.hs +++ b/src/Codec/Xlsx/Parser.hs @@ -1,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" diff --git a/src/Codec/Xlsx/Types.hs b/src/Codec/Xlsx/Types.hs --- a/src/Codec/Xlsx/Types.hs +++ b/src/Codec/Xlsx/Types.hs @@ -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 -- diff --git a/src/Codec/Xlsx/Types/Comment.hs b/src/Codec/Xlsx/Types/Comment.hs --- a/src/Codec/Xlsx/Types/Comment.hs +++ b/src/Codec/Xlsx/Types/Comment.hs @@ -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) diff --git a/src/Codec/Xlsx/Types/Common.hs b/src/Codec/Xlsx/Types/Common.hs --- a/src/Codec/Xlsx/Types/Common.hs +++ b/src/Codec/Xlsx/Types/Common.hs @@ -1,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) diff --git a/src/Codec/Xlsx/Types/Internal/CommentTable.hs b/src/Codec/Xlsx/Types/Internal/CommentTable.hs --- a/src/Codec/Xlsx/Types/Internal/CommentTable.hs +++ b/src/Codec/Xlsx/Types/Internal/CommentTable.hs @@ -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 + [ "" + , commentShapeType + , LB.concat commentShapes + , "" + ] + where + commentShapeType = LB.concat + [ "" + , "" + , "" + , "" + ] + commentShapes = [ commentShape (fromCellRef ref) (_commentVisible cmnt) + | (ref, cmnt) <- M.toList m ] + commentShape (r, c) v = LB.concat + [ "" + , "" + , "" + , "
" + , "" + , "" + , "4, 15, 0, 7, 6, 31, 5, 1False" + , "" + , LBC8.pack $ show (r - 1) + , "" + , "" + , LBC8.pack $ show (c - 1) + , "" + , "" + , "" + ] diff --git a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs --- a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs +++ b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs @@ -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 diff --git a/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs b/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/NumFmtPair.hs @@ -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 ] diff --git a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs --- a/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs +++ b/src/Codec/Xlsx/Types/Internal/SharedStringTable.hs @@ -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 diff --git a/src/Codec/Xlsx/Types/SheetViews.hs b/src/Codec/Xlsx/Types/SheetViews.hs --- a/src/Codec/Xlsx/Types/SheetViews.hs +++ b/src/Codec/Xlsx/Types/SheetViews.hs @@ -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 diff --git a/src/Codec/Xlsx/Types/StyleSheet.hs b/src/Codec/Xlsx/Types/StyleSheet.hs --- a/src/Codec/Xlsx/Types/StyleSheet.hs +++ b/src/Codec/Xlsx/Types/StyleSheet.hs @@ -1,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 collection (20.1.6.2), -- referencing a particular or 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 diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs --- a/src/Codec/Xlsx/Writer.hs +++ b/src/Codec/Xlsx/Writer.hs @@ -1,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) ] diff --git a/src/Codec/Xlsx/Writer/Internal.hs b/src/Codec/Xlsx/Writer/Internal.hs --- a/src/Codec/Xlsx/Writer/Internal.hs +++ b/src/Codec/Xlsx/Writer/Internal.hs @@ -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 [] diff --git a/test/DataTest.hs b/test/DataTest.hs --- a/test/DataTest.hs +++ b/test/DataTest.hs @@ -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 " $ @@ -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 diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -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