diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,9 @@ +0.2.4 +----- +* added basic images support +* added "normal" cell formula support +* added basic xlsx parsing error reporting (thanks to Brad Ediger ) + 0.2.3 ----- * added conditional formatting 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 @@ -1,12 +1,13 @@ -- | Higher level interface for creating styled worksheets {-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} module Codec.Xlsx.Formatted ( FormattedCell(..) , Formatted(..) , formatted + , toFormattedCells , CondFormatted(..) , conditionallyFormatted -- * Lenses @@ -20,6 +21,7 @@ , formattedPivotButton , formattedQuotePrefix , formattedValue + , formattedFormula , formattedColSpan , formattedRowSpan -- ** FormattedCondFmt @@ -29,32 +31,32 @@ , condfmtStopIfTrue ) where -import Prelude hiding (mapM) -import Control.Lens -import Control.Monad.State hiding (mapM, forM_) -import Data.Default -import Data.Foldable (forM_) -import Data.Function (on) -import Data.List (sortBy, groupBy, sortBy) -import Data.Map (Map) -import Data.Ord (comparing) -import Data.Traversable (mapM) -import Data.Tuple (swap) -import qualified Data.Map as M -import Safe (headNote) +import Control.Lens +import Control.Monad.State hiding (forM_, mapM) +import Data.Default +import Data.Foldable (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.Traversable (mapM) +import Data.Tuple (swap) +import Prelude hiding (mapM) +import Safe (headNote) -import Codec.Xlsx.Types +import Codec.Xlsx.Types {------------------------------------------------------------------------------- Internal: formatting state -------------------------------------------------------------------------------} data FormattingState = FormattingState { - _formattingBorders :: Map Border Int - , _formattingCellXfs :: Map CellXf Int - , _formattingFills :: Map Fill Int - , _formattingFonts :: Map Font Int - , _formattingMerges :: [Range] -- ^ In reverse order + _formattingBorders :: Map Border Int + , _formattingCellXfs :: Map CellXf Int + , _formattingFills :: Map Fill Int + , _formattingFonts :: Map Font Int + , _formattingMerges :: [Range] -- ^ In reverse order } makeLenses ''FormattingState @@ -83,13 +85,13 @@ } getId :: Ord a => Lens' FormattingState (Map a Int) -> a -> State FormattingState Int -getId f a = do +getId f v = do aMap <- use f - case M.lookup a aMap of - Just aId -> return aId - Nothing -> do let aId = M.size aMap - f %= M.insert a aId - return aId + case M.lookup v aMap of + Just anId -> return anId + Nothing -> do let anId = M.size aMap + f %= M.insert v anId + return anId {------------------------------------------------------------------------------- Unwrapped cell conditional formatting @@ -126,6 +128,7 @@ , _formattedPivotButton :: Maybe Bool , _formattedQuotePrefix :: Maybe Bool , _formattedValue :: Maybe CellValue + , _formattedFormula :: Maybe CellFormula , _formattedColSpan :: Int , _formattedRowSpan :: Int } @@ -149,6 +152,7 @@ , _formattedPivotButton = Nothing , _formattedQuotePrefix = Nothing , _formattedValue = Nothing + , _formattedFormula = Nothing , _formattedColSpan = 1 , _formattedRowSpan = 1 } @@ -165,13 +169,13 @@ -- See 'formatted' data Formatted = Formatted { -- | The final 'CellMap'; see '_wsCells' - formattedCellMap :: CellMap + formattedCellMap :: CellMap -- | The final stylesheet; see '_xlStyles' (and 'renderStyleSheet') , formattedStyleSheet :: StyleSheet -- | The final list of cell merges; see '_wsMerges' - , formattedMerges :: [Range] + , formattedMerges :: [Range] } deriving (Eq, Show) -- | Higher level API for creating formatted documents @@ -210,9 +214,51 @@ , formattedMerges = reverse (finalSt ^. formattingMerges) } +-- | reverse to 'formatted' which allows to get a map of formatted cells +-- from an existing worksheet and its workbook's style sheet +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 } + idMapped :: [a] -> Map Int a + idMapped = M.fromList . zip [0..] + cellXfs = idMapped _styleSheetCellXfs + borders = idMapped _styleSheetBorders + fills = idMapped _styleSheetFills + fonts = idMapped _styleSheetFonts + applied :: (CellXf -> Maybe Bool) -> (CellXf -> Maybe a) -> CellXf -> Maybe a + applied applyProp prop cXf = do + apply <- applyProp cXf + if apply then prop cXf else fail "not applied" + applyMerges cells = foldl' onlyTopLeft cells merges + onlyTopLeft cells range = flip execState cells $ do + let ((r1, c1), (r2, c2)) = fromRange range + nonTopLeft = tail [(r, c) | r<-[r1..r2], c<-[c1..c2]] + forM_ nonTopLeft (modify . M.delete) + at (r1, c1) . non def . formattedRowSpan .= (r2 - r1 +1) + at (r1, c1) . non def . formattedColSpan .= (c2 - c1 +1) + data CondFormatted = CondFormatted { -- | The resulting stylesheet - condformattedStyleSheet :: StyleSheet + condformattedStyleSheet :: StyleSheet -- | The final map of conditional formatting rules applied to ranges , condformattedFormattings :: Map SqRef ConditionalFormatting } deriving (Eq, Show) @@ -246,7 +292,7 @@ go :: ((Int, Int), FormattedCell) -> State FormattingState ((Int, Int), Cell) go (pos, c) = do styleId <- cellStyleId c - return (pos, Cell styleId (_formattedValue c) Nothing) + return (pos, Cell styleId (_formattedValue c) Nothing (_formattedFormula c)) -- | Cell block corresponding to a single 'FormattedCell' -- 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,26 +1,37 @@ {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} + -- | This module provides a function for reading .xlsx files module Codec.Xlsx.Parser ( toXlsx + , toXlsxEither + , ParseError (..) + , Parser ) where import qualified Codec.Archive.Zip as Zip import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad.IO.Class () +import Control.Arrow (left, (&&&)) +import Control.Error.Safe (headErr) +import Control.Error.Util (note) +import Control.Lens hiding (element, + views, (<.>)) +import Control.Monad.Except (catchError, + throwError) import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () import Data.List import qualified Data.Map as M import Data.Maybe +import Data.Monoid import Data.Ord import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Read as T +import Data.Traversable import Prelude hiding (sequence) -import Safe import System.FilePath.Posix import Text.XML as X import Text.XML.Cursor @@ -30,22 +41,34 @@ import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair import Codec.Xlsx.Types.Internal.CommentTable +import Codec.Xlsx.Types.Internal.ContentTypes as ContentTypes import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.Relationships as Relationships import Codec.Xlsx.Types.Internal.SharedStringTable - -- | Reads `Xlsx' from raw data (lazy bytestring) toXlsx :: L.ByteString -> Xlsx -toXlsx bs = Xlsx sheets styles names customPropMap - where - ar = Zip.toArchive bs - sst = getSharedStrings ar - styles = getStyles ar - (wfs, names) = readWorkbook ar - sheets = M.fromList $ map (wfName &&& extractSheet ar sst) wfs - CustomProperties customPropMap = getCustomProperties ar +toXlsx = either (error . show) id . toXlsxEither +data ParseError = InvalidZipArchive + | MissingFile FilePath + | InvalidFile FilePath + | InvalidRef FilePath RefId + deriving (Show, Eq) + +type Parser = Either ParseError + +-- | Reads `Xlsx' from raw data (lazy bytestring), failing with Left on parse error +toXlsxEither :: L.ByteString -> Parser Xlsx +toXlsxEither bs = do + ar <- left (const InvalidZipArchive) $ Zip.toArchiveOrFail bs + sst <- getSharedStrings ar + contentTypes <- getContentTypes ar + (wfs, names) <- readWorkbook ar + sheets <- sequence . M.fromList $ map (wfName &&& extractSheet ar sst contentTypes) wfs + CustomProperties customPropMap <- getCustomProperties ar + return $ Xlsx sheets (getStyles ar) names customPropMap + data WorksheetFile = WorksheetFile { wfName :: Text , wfPath :: FilePath } @@ -53,69 +76,82 @@ extractSheet :: Zip.Archive -> SharedStringTable + -> ContentTypes -> WorksheetFile - -> Worksheet -extractSheet ar sst wf = Worksheet cws rowProps cells merges sheetViews pageSetup condFormtattings - where - file = fromJust $ Zip.fromEntry <$> Zip.findEntryByPath (wfPath wf) ar - cur = case parseLBS def file of - Left _ -> error "could not read file" - Right d -> fromDocument d + -> Parser Worksheet +extractSheet ar sst contentTypes wf = do + let filePath = wfPath wf + file <- note (MissingFile filePath) $ Zip.fromEntry <$> Zip.findEntryByPath filePath ar + cur <- fmap fromDocument . left (\_ -> InvalidFile filePath) $ + parseLBS def file + sheetRels <- getRels ar filePath - -- The specification says the file should contain either 0 or 1 @sheetViews@ - -- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910) - sheetViewList = cur $/ element (n"sheetViews") &/ element (n"sheetView") >=> fromCursor - sheetViews = case sheetViewList of - [] -> Nothing - views -> Just views + -- The specification says the file should contain either 0 or 1 @sheetViews@ + -- (4th edition, section 18.3.1.88, p. 1704 and definition CT_Worksheet, p. 3910) + let sheetViewList = cur $/ element (n"sheetViews") &/ element (n"sheetView") >=> fromCursor + sheetViews = case sheetViewList of + [] -> Nothing + views -> Just views - commentsMap = getComments ar . relTarget =<< findRelByType commentsType sheetRels - commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" + let commentsType = "http://schemas.openxmlformats.org/officeDocument/2006/relationships/comments" + commentTarget :: Maybe FilePath + commentTarget = relTarget <$> findRelByType commentsType sheetRels - sheetRels = getRels ar (wfPath wf) + commentsMap :: Maybe CommentTable <- maybe (Right Nothing) (getComments ar) commentTarget - -- Likewise, @pageSetup@ also occurs either 0 or 1 times - pageSetup = listToMaybe $ cur $/ element (n"pageSetup") >=> fromCursor + -- Likewise, @pageSetup@ also occurs either 0 or 1 times + let pageSetup = listToMaybe $ cur $/ element (n"pageSetup") >=> fromCursor - cws = cur $/ element (n"cols") &/ element (n"col") >=> fromCursor + cws = cur $/ element (n"cols") &/ element (n"col") >=> fromCursor - (rowProps, cells) = collect $ cur $/ element (n"sheetData") &/ element (n"row") >=> parseRow - parseRow c = do - r <- c $| attribute "r" >=> decimal - let ht = if attribute "customHeight" c == ["true"] - then listToMaybe $ c $| attribute "ht" >=> rational - else Nothing - let s = if attribute "s" c /= [] - then listToMaybe $ c $| attribute "s" >=> decimal - else Nothing - let rp = if isNothing s && isNothing ht - then Nothing - else Just (RowProps ht s) - return (r, rp, c $/ element (n"c") >=> parseCell) - parseCell :: Cursor -> [(Int, Int, Cell)] - parseCell cell = do - ref <- cell $| attribute "r" - let - s = listToMaybe $ cell $| attribute "s" >=> decimal - t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" - d = listToMaybe $ cell $/ element (n"v") &/ content >=> extractCellValue sst t - (c, r) = T.span (>'9') ref - comment = commentsMap >>= lookupComment ref - return (int r, col2int c, Cell s d comment) - collect = foldr collectRow (M.empty, M.empty) - collectRow (_, Nothing, rowCells) (rowMap, cellMap) = - (rowMap, foldr collectCell cellMap rowCells) - collectRow (r, Just h, rowCells) (rowMap, cellMap) = - (M.insert r h rowMap, foldr collectCell cellMap rowCells) - collectCell (x, y, cd) = M.insert (x,y) cd + (rowProps, cells) = collect $ cur $/ element (n"sheetData") &/ element (n"row") >=> parseRow + parseRow :: Cursor -> [(Int, Maybe RowProperties, [(Int, Int, Cell)])] + parseRow c = do + r <- c $| attribute "r" >=> decimal + let ht = if attribute "customHeight" c == ["true"] + then listToMaybe $ c $| attribute "ht" >=> rational + else Nothing + let s = listToMaybe $ decimal =<< attribute "s" c :: Maybe Int + let rp = if isNothing s && isNothing ht + then Nothing + else Just (RowProps ht s) + return (r, rp, c $/ element (n"c") >=> parseCell) + parseCell :: Cursor -> [(Int, Int, Cell)] + parseCell cell = do + ref <- cell $| attribute "r" + let + s = listToMaybe $ cell $| attribute "s" >=> decimal + t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" + d = listToMaybe $ cell $/ element (n"v") &/ content >=> extractCellValue sst t + f = listToMaybe $ cell $/ element (n"f") >=> fromCursor + (c, r) = T.span (>'9') ref + comment = commentsMap >>= lookupComment ref + return (int r, col2int c, Cell s d comment f) + collect = foldr collectRow (M.empty, M.empty) + collectRow (_, Nothing, rowCells) (rowMap, cellMap) = + (rowMap, foldr collectCell cellMap rowCells) + collectRow (r, Just h, rowCells) (rowMap, cellMap) = + (M.insert r h rowMap, foldr collectCell cellMap rowCells) + collectCell (x, y, cd) = M.insert (x,y) cd - merges = cur $/ parseMerges - parseMerges :: Cursor -> [Text] - parseMerges = element (n"mergeCells") &/ element (n"mergeCell") >=> parseMerge - parseMerge c = c $| attribute "ref" + mDrawingId = listToMaybe $ cur $/ element (n"drawing") >=> fromAttribute (odr"id") - condFormtattings = M.fromList . map unCfPair $ cur $/ element (n"conditionalFormatting") >=> fromCursor + merges = cur $/ parseMerges + parseMerges :: Cursor -> [Text] + parseMerges = element (n"mergeCells") &/ element (n"mergeCell") >=> parseMerge + parseMerge c = c $| attribute "ref" + condFormtattings = M.fromList . map unCfPair $ cur $/ element (n"conditionalFormatting") >=> fromCursor + + mDrawing <- case mDrawingId of + Just dId -> do + rel <- note (InvalidRef filePath dId) $ Relationships.lookup dId sheetRels + Just <$> getDrawing ar contentTypes (relTarget rel) + Nothing -> + return Nothing + + return $ Worksheet cws rowProps cells mDrawing merges sheetViews pageSetup condFormtattings + extractCellValue :: SharedStringTable -> Text -> Text -> [CellValue] extractCellValue sst "s" v = case T.decimal v of @@ -129,75 +165,101 @@ extractCellValue _ "n" v = case T.rational v of Right (d, _) -> [CellDouble d] - _ -> [] + _ -> [] extractCellValue _ "b" "1" = [CellBool True] extractCellValue _ "b" "0" = [CellBool False] extractCellValue _ _ _ = [] -- | Get xml cursor from the specified file inside the zip archive. -xmlCursor :: Zip.Archive -> FilePath -> Maybe Cursor -xmlCursor ar fname = parse <$> Zip.findEntryByPath fname ar +xmlCursorOptional :: Zip.Archive -> FilePath -> Parser (Maybe Cursor) +xmlCursorOptional ar fname = + (Just <$> xmlCursorRequired ar fname) `catchError` missingToNothing where - parse entry = case parseLBS def (Zip.fromEntry entry) of - Left _ -> error "could not read file" - Right d -> fromDocument d + missingToNothing :: ParseError -> Either ParseError (Maybe a) + missingToNothing (MissingFile _) = return Nothing + missingToNothing other = throwError other +-- | Get xml cursor from the given file, failing with MissingFile if not found. +xmlCursorRequired :: Zip.Archive -> FilePath -> Parser Cursor +xmlCursorRequired ar fname = do + entry <- note (MissingFile fname) $ Zip.findEntryByPath fname ar + cur <- left (\_ -> InvalidFile fname) $ parseLBS def (Zip.fromEntry entry) + return $ fromDocument cur + -- | Get shared string table -getSharedStrings :: Zip.Archive -> SharedStringTable -getSharedStrings x = case xmlCursor x "xl/sharedStrings.xml" of - Nothing -> - error "invalid shared strings" - Just c -> - let [sst] = fromCursor c in sst +getSharedStrings :: Zip.Archive -> Parser SharedStringTable +getSharedStrings x = head . fromCursor <$> xmlCursorRequired x "xl/sharedStrings.xml" +getContentTypes :: Zip.Archive -> Parser ContentTypes +getContentTypes x = head . fromCursor <$> xmlCursorRequired x "[Content_Types].xml" + getStyles :: Zip.Archive -> Styles getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of Nothing -> Styles L.empty Just xml -> Styles xml -getComments :: Zip.Archive -> FilePath -> Maybe CommentTable -getComments ar fp = listToMaybe =<< fromCursor <$> xmlCursor ar fp +getComments :: Zip.Archive -> FilePath -> Parser (Maybe CommentTable) +getComments ar fp = (listToMaybe . fromCursor =<<) <$> xmlCursorOptional ar fp -getCustomProperties :: Zip.Archive -> CustomProperties -getCustomProperties ar = case fromCursor <$> xmlCursor ar "docProps/custom.xml" of - Just [cp] -> cp - _ -> CustomProperties.empty +getCustomProperties :: Zip.Archive -> Parser CustomProperties +getCustomProperties ar = maybe CustomProperties.empty (head . fromCursor) <$> xmlCursorOptional ar "docProps/custom.xml" --- | readWorkbook pulls the names of the sheets and the defined names -readWorkbook :: Zip.Archive -> ([WorksheetFile], DefinedNames) -readWorkbook ar = case xmlCursor ar wbPath of - Nothing -> - error "invalid workbook" - Just c -> - let - sheets = c $/ element (n"sheets") &/ element (n"sheet") >=> - liftA2 (worksheetFile wbRels) <$> attribute "name" <*> (attribute (odr"id") &| RefId) - wbRels = getRels ar wbPath - names = c $/ element (n"definedNames") &/ element (n"definedName") >=> mkDefinedName - in (sheets, DefinedNames names) +getDrawing :: Zip.Archive -> ContentTypes -> FilePath -> Parser Drawing +getDrawing ar contentTypes fp = do + cur <- xmlCursorRequired ar fp + drawingRels <- getRels ar fp + unresolved <- headErr (InvalidFile fp) (fromCursor cur) + anchors <- forM (unresolved ^. xdrAnchors) $ resolveFileInfo drawingRels + return $ Drawing anchors where - wbPath = "xl/workbook.xml" - -- Specification says the 'name' is required. - mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)] - mkDefinedName c = return ( head $ attribute "name" c - , listToMaybe $ attribute "localSheetId" c - , T.concat $ c $/ content - ) + resolveFileInfo :: Relationships -> Anchor RefId -> Parser (Anchor FileInfo) + resolveFileInfo rels uAnch = case uAnch ^. anchObject of + pic@Picture{} -> do + let mRefId = pic ^. picBlipFill . bfpImageInfo + mFI <- lookupFI rels mRefId + return uAnch{ _anchObject = pic & picBlipFill . bfpImageInfo .~ mFI } + lookupFI _ Nothing = return Nothing + lookupFI rels (Just rId) = do + path <- relTarget <$> note (InvalidRef fp rId) (Relationships.lookup rId rels) + -- content types use paths starting with / + contentType <- note (InvalidFile path) $ ContentTypes.lookup ("/" <> path) contentTypes + contents <- Zip.fromEntry <$> note (MissingFile path) (Zip.findEntryByPath path ar) + return . Just $ FileInfo (stripMediaPrefix path) contentType contents + stripMediaPrefix :: FilePath -> FilePath + stripMediaPrefix p = fromMaybe p $ stripPrefix "xl/media/" p -worksheetFile :: Relationships -> Text -> RefId -> WorksheetFile -worksheetFile wbRels name rId = WorksheetFile name path +-- | readWorkbook pulls the names of the sheets and the defined names +readWorkbook :: Zip.Archive -> Parser ([WorksheetFile], DefinedNames) +readWorkbook ar = do + let wbPath = "xl/workbook.xml" + cur <- xmlCursorRequired ar wbPath + wbRels <- getRels ar wbPath + let -- Specification says the 'name' is required. + mkDefinedName :: Cursor -> [(Text, Maybe Text, Text)] + mkDefinedName c = return ( head $ attribute "name" c + , listToMaybe $ attribute "localSheetId" c + , T.concat $ c $/ content + ) + + names = cur $/ element (n"definedNames") &/ element (n"definedName") >=> mkDefinedName + sheets <- sequence $ + cur $/ element (n"sheets") &/ element (n"sheet") >=> + liftA2 (worksheetFile wbPath wbRels) <$> attribute "name" <*> (attribute (odr"id") &| RefId) + return (sheets, DefinedNames names) + + +worksheetFile :: FilePath -> Relationships -> Text -> RefId -> Parser WorksheetFile +worksheetFile parentPath wbRels name rId = WorksheetFile name <$> path where - path = relTarget . fromJustNote "sheet path" $ Relationships.lookup rId wbRels + path :: Parser FilePath + path = relTarget <$> note (InvalidRef parentPath rId) (Relationships.lookup rId wbRels) -getRels :: Zip.Archive -> FilePath -> Relationships -getRels ar fp = +getRels :: Zip.Archive -> FilePath -> Parser Relationships +getRels ar fp = do let (dir, file) = splitFileName fp relsPath = dir "_rels" file <.> "rels" - in case xmlCursor ar relsPath of - Nothing -> - Relationships.empty - Just c -> - let [rels] = fromCursor c in setTargetsFrom fp rels + c <- xmlCursorOptional ar relsPath + return $ maybe Relationships.empty (setTargetsFrom fp . head . fromCursor) c int :: Text -> Int int = either error fst . T.decimal diff --git a/src/Codec/Xlsx/Parser/Internal.hs b/src/Codec/Xlsx/Parser/Internal.hs --- a/src/Codec/Xlsx/Parser/Internal.hs +++ b/src/Codec/Xlsx/Parser/Internal.hs @@ -7,6 +7,7 @@ , FromCursor(..) , FromAttrVal(..) , fromAttribute + , fromAttributeDef , maybeAttribute , maybeElementValue , maybeElementValueDef @@ -51,6 +52,9 @@ instance FromAttrVal Int where fromAttrVal = T.decimal +instance FromAttrVal Integer where + fromAttrVal = T.decimal + instance FromAttrVal Double where fromAttrVal = T.rational @@ -64,6 +68,13 @@ fromAttribute name cursor = attribute name cursor >>= runReader fromAttrVal +-- | parsing optional attributes with defaults +fromAttributeDef :: FromAttrVal a => Name -> a -> Cursor -> [a] +fromAttributeDef name defVal cursor = + case attribute name cursor of + [attr] -> runReader fromAttrVal attr + _ -> [defVal] + -- | parsing optional attributes maybeAttribute :: FromAttrVal a => Name -> Cursor -> [Maybe a] maybeAttribute name cursor = @@ -106,7 +117,7 @@ runReader :: T.Reader a -> Text -> [a] runReader reader t = case reader t of - Right (r, _) -> [r] + Right (r, leftover) | T.null leftover -> [r] _ -> [] -- | Add sml namespace to name @@ -117,14 +128,14 @@ , namePrefix = Nothing } -decimal :: Monad m => Text -> m Int +decimal :: (Monad m, Integral a) => Text -> m a decimal t = case T.decimal t of - Right (d, _) -> return d + Right (d, leftover) | T.null leftover -> return d _ -> fail $ "invalid decimal" ++ show t rational :: Monad m => Text -> m Double rational t = case T.rational t of - Right (r, _) -> return r + Right (r, leftover) | T.null leftover -> return r _ -> fail $ "invalid rational: " ++ show t boolean :: Monad m => Text -> m Bool 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 @@ -1,7 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Codec.Xlsx.Types ( -- * The main types Xlsx(..) @@ -12,6 +12,7 @@ , Worksheet(..) , CellMap , CellValue(..) + , CellFormula(..) , Cell(..) , RowProperties (..) , Range @@ -25,6 +26,7 @@ , wsColumns , wsRowPropertiesMap , wsCells + , wsDrawing , wsMerges , wsSheetViews , wsPageSetup @@ -33,44 +35,55 @@ , cellValue , cellStyle , cellComment + , cellFormula -- * Style helpers , emptyStyles , renderStyleSheet , parseStyleSheet -- * Misc + , simpleCellFormula , def , int2col , col2int , mkCellRef + , fromCellRef , mkRange + , fromRange , toRows , fromRows , module X ) where -import Control.Exception (SomeException, toException) +import Control.Arrow +import Control.Exception (SomeException, + toException) import Control.Lens.TH -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy as L import Data.Char import Data.Default -import Data.Function (on) -import Data.List (groupBy) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Text (Text) -import qualified Data.Text as T -import Text.XML (renderLBS, parseLBS) +import Data.Function (on) +import Data.List (groupBy) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +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 -import Codec.Xlsx.Types.Common as X +import Codec.Xlsx.Types.Comment as X +import Codec.Xlsx.Types.Common as X import Codec.Xlsx.Types.ConditionalFormatting as X -import Codec.Xlsx.Types.PageSetup as X -import Codec.Xlsx.Types.RichText as X -import Codec.Xlsx.Types.SheetViews as X -import Codec.Xlsx.Types.StyleSheet as X -import Codec.Xlsx.Types.Variant as X +import Codec.Xlsx.Types.Drawing as X +import Codec.Xlsx.Types.PageSetup as X +import Codec.Xlsx.Types.RichText as X +import Codec.Xlsx.Types.SheetViews as X +import Codec.Xlsx.Types.StyleSheet as X +import Codec.Xlsx.Types.Variant as X import Codec.Xlsx.Writer.Internal -- | Cell values include text, numbers and booleans, @@ -83,19 +96,44 @@ | CellRich [RichTextRun] deriving (Eq, Show) +-- | Formula for the cell. +-- +-- TODO: array. dataTable and shared formula types support +-- +-- See 18.3.1.40 "f (Formula)" (p. 1636) +data CellFormula + = NormalCellFormula + { _cellfExpression :: Formula + , _cellfAssignsToName :: Bool + -- ^ Specifies that this formula assigns a value to a name. + , _cellfCalculate :: Bool + -- ^ Indicates that this formula needs to be recalculated + -- the next time calculation is performed. + -- [/Example/: This is always set on volatile functions, + -- like =RAND(), and circular references. /end example/] + } deriving (Eq, Show) + +simpleCellFormula :: Text -> CellFormula +simpleCellFormula expr = NormalCellFormula + { _cellfExpression = Formula expr + , _cellfAssignsToName = False + , _cellfCalculate = False + } + -- | Currently cell details include only cell values and style ids -- (e.g. formulas from @\@ and inline strings from @\@ -- subelements are ignored) data Cell = Cell { _cellStyle :: Maybe Int , _cellValue :: Maybe CellValue - , _cellComment :: Maybe Comment + , _cellComment :: Maybe Comment + , _cellFormula :: Maybe CellFormula } deriving (Eq, Show) makeLenses ''Cell instance Default Cell where - def = Cell Nothing Nothing Nothing + def = Cell Nothing Nothing Nothing Nothing -- | Map containing cell values which are indexed by row and column -- if you need to use more traditional (x,y) indexing please you could @@ -107,8 +145,8 @@ -- | Column range (from cwMin to cwMax) width data ColumnsWidth = ColumnsWidth - { cwMin :: Int - , cwMax :: Int + { cwMin :: Int + , cwMax :: Int , cwWidth :: Double , cwStyle :: Int } deriving (Eq, Show) @@ -129,6 +167,7 @@ { _wsColumns :: [ColumnsWidth] -- ^ column widths , _wsRowPropertiesMap :: Map Int RowProperties -- ^ custom row properties (height, style) map , _wsCells :: CellMap -- ^ data mapped by (row, column) pairs + , _wsDrawing :: Maybe Drawing -- ^ SpreadsheetML Drawing , _wsMerges :: [Range] -- ^ list of cell merges , _wsSheetViews :: Maybe [SheetView] , _wsPageSetup :: Maybe PageSetup @@ -138,7 +177,7 @@ makeLenses ''Worksheet instance Default Worksheet where - def = Worksheet [] M.empty M.empty [] Nothing Nothing M.empty + def = Worksheet [] M.empty M.empty Nothing [] Nothing Nothing M.empty newtype Styles = Styles {unStyles :: L.ByteString} deriving (Eq, Show) @@ -248,8 +287,56 @@ 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 -- -- > mkRange (2, 4) (6, 8) == "D2:H6" mkRange :: (Int, Int) -> (Int, Int) -> Range mkRange fr to = T.concat [mkCellRef fr, T.pack ":", mkCellRef to] + +-- | reverse to 'mkRange' +-- +-- /Warning:/ the function isn't total and will throw an error if +-- incorrect value will get passed +fromRange :: Range -> ((Int, Int), (Int, Int)) +fromRange t = case T.split (==':') t of + [from, to] -> (fromCellRef from, fromCellRef to) + _ -> error $ "invalid range " <> show t + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor CellFormula where + fromCursor cur = do + t <- fromAttributeDef "t" "normal" cur + typedCellFormula t cur + +typedCellFormula :: Text -> Cursor -> [CellFormula] +typedCellFormula "normal" cur = do + _cellfExpression <- fromCursor cur + _cellfAssignsToName <- fromAttributeDef "bx" False cur + _cellfCalculate <- fromAttributeDef "ca" False cur + return NormalCellFormula{..} +typedCellFormula _ _ = fail "parseable cell formula type was not found" + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToElement CellFormula where + toElement nm NormalCellFormula{..} = + let formulaEl = toElement nm _cellfExpression + in formulaEl + { elementAttributes = + M.fromList $ catMaybes [ "bx" .=? justTrue _cellfAssignsToName + , "ca" .=? justTrue _cellfCalculate ] + } 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 @@ -46,7 +46,6 @@ | XlsxRichText [RichTextRun] deriving (Show, Eq, Ord) - -- | A formula -- -- See 18.18.35 "ST_Formula (Formula)" (p. 2457) diff --git a/src/Codec/Xlsx/Types/Drawing.hs b/src/Codec/Xlsx/Types/Drawing.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Drawing.hs @@ -0,0 +1,595 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Codec.Xlsx.Types.Drawing where + +import Control.Arrow (first) +import Control.Lens.TH +import Data.ByteString.Lazy (ByteString) +import Data.Default +import qualified Data.Map as M +import Data.Maybe (catMaybes, + listToMaybe) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import Text.XML +import Text.XML.Cursor + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Codec.Xlsx.Parser.Internal hiding (n) +import Codec.Xlsx.Types.Internal +import Codec.Xlsx.Types.Internal.Relationships +import Codec.Xlsx.Writer.Internal + +-- | information about image file as a par of a drawing +data FileInfo = FileInfo + { _fiFilename :: FilePath + -- ^ image filename, images are assumed to be stored under path "xl/media/" + , _fiContentType :: Text + -- ^ image content type, ECMA-376 advises to use "image/png" or "image/jpeg" + -- if interoperability is wanted + , _fiContents :: ByteString + -- ^ image file contents + } deriving (Eq, Show) + +-- | This simple type represents a one dimensional position or length +-- +-- See 20.1.10.16 "ST_Coordinate (Coordinate)" (p. 2921) +data Coordinate + = UnqCoordinate Int + -- ^ see 20.1.10.19 "ST_CoordinateUnqualified (Coordinate)" (p. 2922) + | UniversalMeasure UnitIdentifier Double + -- ^ see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) + deriving (Eq, Show) + +-- | Units used in "Universal measure" coordinates +-- see 22.9.2.15 "ST_UniversalMeasure (Universal Measurement)" (p. 3793) +data UnitIdentifier + = UnitCm -- "cm" As defined in ISO 31. + | UnitMm -- "mm" As defined in ISO 31. + | UnitIn -- "in" 1 in = 2.54 cm (informative) + | UnitPt -- "pt" 1 pt = 1/72 in (informative) + | UnitPc -- "pc" 1 pc = 12 pt (informative) + | UnitPi -- "pi" 1 pi = 12 pt (informative) + deriving (Eq, Show) + +-- See @CT_Point2D@ (p. 3989) +data Point2D = Point2D + { _pt2dX :: Coordinate + , _pt2dY :: Coordinate + } deriving (Eq, Show) + +unqPoint2D :: Int -> Int -> Point2D +unqPoint2D x y = Point2D (UnqCoordinate x) (UnqCoordinate y) + +-- | Positive position or length in EMUs, maximu allowed value is 27273042316900. +-- see 20.1.10.41 "ST_PositiveCoordinate (Positive Coordinate)" (p. 2942) +newtype PositiveCoordinate = PositiveCoordinate Integer + deriving (Eq, Ord, Show) + +-- | This simple type represents an angle in 60,000ths of a degree. +-- Positive angles are clockwise (i.e., towards the positive y axis); negative +-- angles are counter-clockwise (i.e., towards the negative y axis). +newtype Angle = Angle Int + deriving (Eq, Show) + +data PositiveSize2D = PositiveSize2D + { _ps2dX :: PositiveCoordinate + , _ps2dY :: PositiveCoordinate + } deriving (Eq, Show) + +data Marker = Marker + { _mrkCol :: Int + , _mrkColOff :: Coordinate + , _mrkRow :: Int + , _mrkRowOff :: Coordinate + } deriving (Eq, Show) + +unqMarker :: (Int, Int) -> (Int, Int) -> Marker +unqMarker (col, colOff) (row, rowOff) = + Marker col (UnqCoordinate colOff) row (UnqCoordinate rowOff) + +data EditAs + = EditAsTwoCell + | EditAsOneCell + | EditAsAbsolute + deriving (Eq,Show) + +data Anchoring + = AbsoluteAnchor + { absaPos :: Point2D + , absaExt :: PositiveSize2D + } + | OneCellAnchor + { onecaFrom :: Marker + , onecaExt :: PositiveSize2D + } + | TwoCellAnchor + { tcaFrom :: Marker + , tcaTo :: Marker + , tcaEditAs :: EditAs + } + deriving (Eq, Show) + +data DrawingObject a + = Picture + { _picMacro :: Maybe Text + , _picPublished :: Bool + , _picNonVisual :: PicNonVisual + , _picBlipFill :: BlipFillProperties a + , _picShapeProperties :: ShapeProperties + -- TODO: style + } + -- TODO: sp, grpSp, graphicFrame, cxnSp, contentPart + deriving (Eq, Show) + +-- | This element is used to set certain properties related to a drawing +-- element on the client spreadsheet application. +-- +-- see 20.5.2.3 "clientData (Client Data)" (p. 3156) +data ClientData = ClientData + { _cldLcksWithSheet :: Bool + -- ^ This attribute indicates whether to disable selection on + -- drawing elements when the sheet is protected. + , _cldPrintsWithSheet :: Bool + -- ^ This attribute indicates whether to print drawing elements + -- when printing the sheet. + } deriving (Eq, Show) + +data PicNonVisual = PicNonVisual + { _pnvDrawingProps :: PicDrawingNonVisual + -- TODO: cNvPicPr + } + deriving (Eq, Show) + +-- see 20.1.2.2.8 "cNvPr (Non-Visual Drawing Properties)" (p. 2731) +data PicDrawingNonVisual = PicDrawingNonVisual + { _pdnvId :: Int + -- ^ Specifies a unique identifier for the current + -- DrawingML object within the current + -- + -- TODO: make ids internal and consistent by construction + , _pdnvName :: Text + -- ^ Specifies the name of the object. + -- Typically, this is used to store the original file + -- name of a picture object. + , _pdnvDescription :: Maybe Text + -- ^ Alternative Text for Object + , _pdnvHidden :: Bool + , _pdnvTitle :: Maybe Text + } deriving (Eq, Show) + +data BlipFillProperties a = BlipFillProperties + { _bfpImageInfo :: Maybe a + , _bfpFillMode :: Maybe FillMode + -- TODO: dpi, rotWithShape, srcRect + } deriving (Eq, Show) + +-- see @a_EG_FillModeProperties@ (p. 4319) +data FillMode + -- See 20.1.8.58 "tile (Tile)" (p. 2880) + = FillTile -- TODO: tx, ty, sx, sy, flip, algn + -- See 20.1.8.56 "stretch (Stretch)" (p. 2879) + | FillStretch -- TODO: srcRect + deriving (Eq, Show) + +-- See 20.1.2.2.35 "spPr (Shape Properties)" (p. 2751) +data ShapeProperties = ShapeProperties + { _spXfrm :: Maybe Transform2D + , _spGeometry :: Maybe Geometry + , _spOutline :: Maybe LineProperties + -- TODO: bwMode, a_EG_FillProperties, a_EG_EffectProperties, scene3d, sp3d, extLst + } deriving (Eq, Show) + +-- See 20.1.7.6 "xfrm (2D Transform for Individual Objects)" (p. 2849) +data Transform2D = Transform2D + { _trRot :: Angle + -- ^ Specifies the rotation of the Graphic Frame. + , _trFlipH :: Bool + -- ^ Specifies a horizontal flip. When true, this attribute defines + -- that the shape is flipped horizontally about the center of its bounding box. + , _trFlipV :: Bool + -- ^ Specifies a vertical flip. When true, this attribute defines + -- that the shape is flipped vetically about the center of its bounding box. + , _trOffset :: Maybe Point2D + -- ^ See 20.1.7.4 "off (Offset)" (p. 2847) + , _trExtents :: Maybe PositiveSize2D + -- ^ See 20.1.7.3 "ext (Extents)" (p. 2846) or + -- 20.5.2.14 "ext (Shape Extent)" (p. 3165) + } + deriving (Eq, Show) + +data Geometry + -- TODO: custGeom + = PresetGeometry + -- TODO: prst, avList + -- currently uses "rect" with empty avList + deriving (Eq, Show) + +-- See 20.1.2.2.24 "ln (Outline)" (p. 2744) +data LineProperties = LineProperties + { _lnFill :: Maybe LineFill + -- TODO: w, cap, cmpd, algn, a_EG_LineDashProperties, + -- a_EG_LineJoinProperties, headEnd, tailEnd, extLst + } + deriving (Eq, Show) + +data LineFill + -- See 20.1.8.44 "noFill (No Fill)" (p. 2872) + = LineNoFill + -- TODO: solidFill, gradFill, pattFill + deriving (Eq, Show) + +-- See @EG_Anchor@ (p. 4052) +data Anchor a = Anchor + { _anchAnchoring :: Anchoring + , _anchObject :: DrawingObject a + , _anchClientData :: ClientData + } deriving (Eq, Show) + +data GenericDrawing a = Drawing + { _xdrAnchors :: [Anchor a] + } deriving (Eq, Show) + +-- See 20.5.2.35 "wsDr (Worksheet Drawing)" (p. 3176) +type Drawing = GenericDrawing FileInfo + +type UnresolvedDrawing = GenericDrawing RefId + +makeLenses ''Anchor +makeLenses ''DrawingObject +makeLenses ''BlipFillProperties +makeLenses ''GenericDrawing + +{------------------------------------------------------------------------------- + Default instances +-------------------------------------------------------------------------------} + +instance Default ClientData where + def = ClientData True True + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +instance FromCursor UnresolvedDrawing where + fromCursor cur = [Drawing $ cur $/ anyElement >=> fromCursor] + +instance FromCursor (Anchor RefId) where + fromCursor cur = do + _anchAnchoring <- fromCursor cur + _anchObject <- cur $/ anyElement >=> fromCursor + _anchClientData <- cur $/ element (xdr"clientData") >=> fromCursor + return Anchor{..} + +instance FromCursor Anchoring where + fromCursor = anchoringFromNode . node + +anchoringFromNode :: Node -> [Anchoring] +anchoringFromNode n | n `nodeElNameIs` xdr "twoCellAnchor" = do + tcaEditAs <- fromAttributeDef "editAs" EditAsTwoCell cur + tcaFrom <- cur $/ element (xdr"from") >=> fromCursor + tcaTo <- cur $/ element (xdr"to") >=> fromCursor + return TwoCellAnchor{..} + | n `nodeElNameIs` xdr "oneCellAnchor" = do + onecaFrom <- cur $/ element (xdr"from") >=> fromCursor + onecaExt <- cur $/ element (xdr"ext") >=> fromCursor + return OneCellAnchor{..} + | n `nodeElNameIs` xdr "absolueAnchor" = do + absaPos <- cur $/ element (xdr"pos") >=> fromCursor + absaExt <- cur $/ element (xdr"ext") >=> fromCursor + return AbsoluteAnchor{..} + | otherwise = fail "no matching anchoring node" + where + cur = fromNode n + +nodeElNameIs :: Node -> Name -> Bool +nodeElNameIs (NodeElement el) name = elementName el == name +nodeElNameIs _ _ = False + +instance FromCursor Marker where + fromCursor cur = do + _mrkCol <- cur $/ element (xdr"col") &/ content >=> decimal + _mrkColOff <- cur $/ element (xdr"colOff") &/ content >=> coordinate + _mrkRow <- cur $/ element (xdr"row") &/ content >=> decimal + _mrkRowOff <- cur $/ element (xdr"rowOff") &/ content >=> coordinate + return Marker{..} + +instance FromCursor (DrawingObject RefId) where + fromCursor = drawingObjectFromNode . node + +drawingObjectFromNode :: Node -> [DrawingObject RefId] +drawingObjectFromNode n | n `nodeElNameIs` xdr "pic" = do + _picMacro <- maybeAttribute "macro" cur + _picPublished <- fromAttributeDef "fPublished" False cur + _picNonVisual <- cur $/ element (xdr"nvPicPr") >=> fromCursor + _picBlipFill <- cur $/ element (xdr"blipFill") >=> fromCursor + _picShapeProperties <- cur $/ element (xdr"spPr") >=> fromCursor + return Picture{..} + | otherwise = fail "no matching drawing object node" + where + cur = fromNode n + +instance FromCursor PicNonVisual where + fromCursor cur = do + _pnvDrawingProps <- cur $/ element (xdr"cNvPr") >=> fromCursor + return PicNonVisual{..} + +instance FromCursor PicDrawingNonVisual where + fromCursor cur = do + _pdnvId <- fromAttribute "id" cur + _pdnvName <- fromAttribute "name" cur + _pdnvDescription <- maybeAttribute "descr" cur + _pdnvHidden <- fromAttributeDef "hidden" False cur + _pdnvTitle <- maybeAttribute "title" cur + return PicDrawingNonVisual{..} + +instance FromCursor (BlipFillProperties RefId) where + fromCursor cur = do + let _bfpImageInfo = listToMaybe $ cur $/ element (a"blip") >=> + fmap RefId . attribute (odr"embed") + _bfpFillMode = listToMaybe $ cur $/ anyElement >=> fromCursor + return BlipFillProperties{..} + +instance FromCursor ShapeProperties where + fromCursor cur = do + _spXfrm <- maybeFromElement (a"xfrm") cur + let _spGeometry = listToMaybe $ cur $/ anyElement >=> fromCursor + _spOutline <- maybeFromElement (a"ln") cur + return ShapeProperties{..} + +instance FromCursor FillMode where + fromCursor = fillModeFromNode . node + +fillModeFromNode :: Node -> [FillMode] +fillModeFromNode n | n `nodeElNameIs` a "stretch" = return FillStretch + | n `nodeElNameIs` a "stretch" = return FillTile + | otherwise = fail "no matching fill mode node" + +instance FromCursor Transform2D where + fromCursor cur = do + _trRot <- fromAttributeDef "rot" (Angle 0) cur + _trFlipH <- fromAttributeDef "flipH" False cur + _trFlipV <- fromAttributeDef "flipV" False cur + _trOffset <- maybeFromElement (a"off") cur + _trExtents <- maybeFromElement (a"ext") cur + return Transform2D{..} + +instance FromCursor Geometry where + fromCursor = geometryFromNode . node + +geometryFromNode :: Node -> [Geometry] +geometryFromNode n | n `nodeElNameIs` a "prstGeom" = + return PresetGeometry + | otherwise = fail "no matching geometry node" + +instance FromCursor LineProperties where + fromCursor cur = do + let _lnFill = listToMaybe $ cur $/ anyElement >=> fromCursor + return LineProperties{..} + +instance FromCursor ClientData where + fromCursor cur = do + _cldLcksWithSheet <- fromAttributeDef "fLocksWithSheet" True cur + _cldPrintsWithSheet <- fromAttributeDef "fPrintsWithSheet" True cur + return ClientData{..} + +instance FromCursor Point2D where + fromCursor cur = do + x <- coordinate =<< fromAttribute "x" cur + y <- coordinate =<< fromAttribute "y" cur + return $ Point2D x y + +instance FromCursor PositiveSize2D where + fromCursor cur = do + cx <- PositiveCoordinate <$> fromAttribute "cx" cur + cy <- PositiveCoordinate <$> fromAttribute "cy" cur + return $ PositiveSize2D cx cy + +-- see 20.1.10.3 "ST_Angle (Angle)" (p. 2912) +instance FromAttrVal Angle where + fromAttrVal t = first Angle <$> fromAttrVal t + +-- see 20.5.3.2 "ST_EditAs (Resizing Behaviors)" (p. 3177) +instance FromAttrVal EditAs where + fromAttrVal "absolute" = readSuccess EditAsAbsolute + fromAttrVal "oneCell" = readSuccess EditAsOneCell + fromAttrVal "twoCell" = readSuccess EditAsTwoCell + fromAttrVal t = invalidText "EditAs" t + +instance FromCursor LineFill where + fromCursor = lineFillFromNode . node + +lineFillFromNode :: Node -> [LineFill] +lineFillFromNode n | n `nodeElNameIs` a "noFill" = return LineNoFill + | otherwise = fail "no matching line fill node" + +coordinate :: Monad m => Text -> m Coordinate +coordinate t = case T.decimal t of + Right (d, leftover) | leftover == T.empty -> + return $ UnqCoordinate d + _ -> + case T.rational t of + Right (r, "cm") -> return $ UniversalMeasure UnitCm r + Right (r, "mm") -> return $ UniversalMeasure UnitMm r + Right (r, "in") -> return $ UniversalMeasure UnitIn r + Right (r, "pt") -> return $ UniversalMeasure UnitPt r + Right (r, "pc") -> return $ UniversalMeasure UnitPc r + Right (r, "pi") -> return $ UniversalMeasure UnitPi r + _ -> fail $ "invalid coordinate: " ++ show t + +{------------------------------------------------------------------------------- + Rendering +-------------------------------------------------------------------------------} + +instance ToDocument UnresolvedDrawing where + toDocument = documentFromNsElement "Drawing generated by xlsx" xlDrawingNs + . toElement "wsDr" + +instance ToElement UnresolvedDrawing where + toElement nm (Drawing anchors) = Element + { elementName = nm + , elementAttributes = M.empty + , elementNodes = map NodeElement $ + map anchorToElement anchors + } + +anchorToElement :: Anchor RefId -> Element +anchorToElement Anchor{..} = el + { elementNodes = elementNodes el ++ + map NodeElement [ drawingObjEl, cdEl ] } + where + el = anchoringToElement _anchAnchoring + drawingObjEl = drawingObjToElement _anchObject + cdEl = toElement "clientData" _anchClientData + +anchoringToElement :: Anchoring -> Element +anchoringToElement anchoring = elementList nm attrs elements + where + (nm, attrs, elements) = case anchoring of + AbsoluteAnchor{..} -> + ("absoluteAnchor", [], + [ toElement "pos" absaPos, toElement "ext" absaExt ]) + OneCellAnchor{..} -> + ("oneCellAnchor", [], + [ toElement "from" onecaFrom, toElement "ext" onecaExt ]) + TwoCellAnchor{..} -> + ("twoCellAnchor", [ "editAs" .= tcaEditAs ], + [ toElement "from" tcaFrom, toElement "to" tcaTo ]) + +instance ToElement Marker where + toElement nm Marker{..} = elementListSimple nm elements + where + elements = [ elementContent "col" (toAttrVal _mrkCol) + , elementContent "colOff" (toAttrVal _mrkColOff) + , elementContent "row" (toAttrVal _mrkRow) + , elementContent "rowOff" (toAttrVal _mrkRowOff)] + +drawingObjToElement :: DrawingObject RefId -> Element +drawingObjToElement Picture{..} = + elementList "pic" attrs elements + where + attrs = catMaybes [ "macro" .=? _picMacro + , "fPublished" .=? justTrue _picPublished] + elements = [ toElement "nvPicPr" _picNonVisual + , toElement "blipFill" _picBlipFill + , toElement "spPr" _picShapeProperties ] + +instance ToElement PicNonVisual where + toElement nm PicNonVisual{..} = + elementListSimple nm [toElement "cNvPr" _pnvDrawingProps] + +instance ToElement PicDrawingNonVisual where + toElement nm PicDrawingNonVisual{..} = + leafElement nm attrs + where + attrs = [ "id" .= _pdnvId + , "name" .= _pdnvName ] ++ + catMaybes [ "descr" .=? _pdnvDescription + , "hidden" .=? justTrue _pdnvHidden + , "title" .=? _pdnvTitle ] + +instance ToElement (BlipFillProperties RefId) where + toElement nm BlipFillProperties{..} = + elementListSimple nm elements + where + elements = catMaybes [ (\rId -> leafElement (a"blip") [ odr "embed" .= rId ]) <$> _bfpImageInfo + , fillModeToElement <$> _bfpFillMode ] + +fillModeToElement :: FillMode -> Element +fillModeToElement FillStretch = emptyElement (a"stretch") +fillModeToElement FillTile = emptyElement (a"stretch") + +instance ToElement ShapeProperties where + toElement nm ShapeProperties{..} = elementListSimple nm elements + where + elements = catMaybes [ toElement (a"xfrm") <$> _spXfrm + , geometryToElement <$> _spGeometry + , toElement (a"ln") <$> _spOutline ] + +instance ToElement Transform2D where + toElement nm Transform2D{..} = elementList nm attrs elements + where + attrs = catMaybes [ "rot" .=? justNonDef (Angle 0) _trRot + , "flipH" .=? justTrue _trFlipH + , "flipV" .=? justTrue _trFlipV ] + elements = catMaybes [ toElement (a"off") <$> _trOffset + , toElement (a"ext") <$> _trExtents ] + +geometryToElement :: Geometry -> Element +geometryToElement PresetGeometry = emptyElement (a"prstGeom") + +instance ToElement LineProperties where + toElement nm LineProperties{..} = + elementListSimple nm $ catMaybes [ lineFillToElement <$> _lnFill ] + +lineFillToElement :: LineFill -> Element +lineFillToElement LineNoFill = emptyElement (a"noFill") + +instance ToElement ClientData where + toElement nm ClientData{..} = leafElement nm attrs + where + attrs = catMaybes [ "fLocksWithSheet" .=? justFalse _cldLcksWithSheet + , "fPrintsWithSheet" .=? justFalse _cldPrintsWithSheet + ] + +instance ToElement Point2D where + toElement nm Point2D{..} = leafElement nm [ "x" .= _pt2dX + , "y" .= _pt2dY + ] + +instance ToElement PositiveSize2D where + toElement nm PositiveSize2D{..} = leafElement nm [ "cx" .= _ps2dX + , "cy" .= _ps2dY ] + +instance ToAttrVal Coordinate where + toAttrVal (UnqCoordinate x) = toAttrVal x + toAttrVal (UniversalMeasure unit x) = toAttrVal x <> unitToText unit + where + unitToText UnitCm = "cm" + unitToText UnitMm = "mm" + unitToText UnitIn = "in" + unitToText UnitPt = "pt" + unitToText UnitPc = "pc" + unitToText UnitPi = "pi" + +instance ToAttrVal PositiveCoordinate where + toAttrVal (PositiveCoordinate x) = toAttrVal x + +instance ToAttrVal EditAs where + toAttrVal EditAsAbsolute = "absolute" + toAttrVal EditAsOneCell = "oneCell" + toAttrVal EditAsTwoCell = "twoCell" + +instance ToAttrVal Angle where + toAttrVal (Angle x) = toAttrVal x + +-- | Add DrawingML namespace to name +a :: Text -> Name +a x = Name + { nameLocalName = x + , nameNamespace = Just drawingNs + , namePrefix = Nothing + } + +drawingNs :: Text +drawingNs = "http://schemas.openxmlformats.org/drawingml/2006/main" + +-- | Add Spreadsheet DrawingML namespace to name +xdr :: Text -> Name +xdr x = Name + { nameLocalName = x + , nameNamespace = Just xlDrawingNs + , namePrefix = Nothing + } + +xlDrawingNs :: Text +xlDrawingNs = "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" diff --git a/src/Codec/Xlsx/Types/Internal.hs b/src/Codec/Xlsx/Types/Internal.hs --- a/src/Codec/Xlsx/Types/Internal.hs +++ b/src/Codec/Xlsx/Types/Internal.hs @@ -1,10 +1,20 @@ +{-# LANGUAGE CPP #-} module Codec.Xlsx.Types.Internal where -import Data.Text (Text) +import Control.Arrow +import Data.Text (Text) -import Codec.Xlsx.Writer.Internal +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Writer.Internal + newtype RefId = RefId { unRefId :: Text } deriving (Show, Eq, Ord) instance ToAttrVal RefId where - toAttrVal = toAttrVal . unRefId + toAttrVal = toAttrVal . unRefId + +instance FromAttrVal RefId where + fromAttrVal t = first RefId <$> fromAttrVal t diff --git a/src/Codec/Xlsx/Types/Internal/ContentTypes.hs b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Types/Internal/ContentTypes.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Codec.Xlsx.Types.Internal.ContentTypes where + +import Control.Arrow +import Data.Map (Map) +import qualified Data.Map as M +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 +#endif + +import Codec.Xlsx.Parser.Internal + +data Override = Override + { ovrPartName :: FilePath + , ovrContentType :: Text + } deriving (Eq, Show) + +newtype ContentTypes = ContentTypes + { ctTypes :: Map FilePath Text + } deriving (Eq, Show) + +lookup :: FilePath -> ContentTypes -> Maybe Text +lookup path = M.lookup path . ctTypes + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} +instance FromCursor ContentTypes where + fromCursor cur = do + let items = cur $/ element (ct"Override") >=> fromCursor + return . ContentTypes . M.fromList $ map (ovrPartName &&& ovrContentType) items + +instance FromCursor Override where + fromCursor cur = do + ovrPartName <- T.unpack <$> attribute "PartName" cur + ovrContentType <- attribute "ContentType" cur + return Override{..} + +-- | Add package relationship namespace to name +ct :: Text -> Name +ct x = Name + { nameLocalName = x + , nameNamespace = Just contentTypesNs + , namePrefix = Nothing + } + +contentTypesNs :: Text +contentTypesNs = "http://schemas.openxmlformats.org/package/2006/content-types" diff --git a/src/Codec/Xlsx/Types/Internal/Relationships.hs b/src/Codec/Xlsx/Types/Internal/Relationships.hs --- a/src/Codec/Xlsx/Types/Internal/Relationships.hs +++ b/src/Codec/Xlsx/Types/Internal/Relationships.hs @@ -60,6 +60,11 @@ base = fromJustNote "joinRel base path" $ parseURIReference abs relPath = fromJustNote "joinRel relative path" $ parseURIReference rel +relFrom :: FilePath -> FilePath -> FilePath +relFrom path base = uriToString id (pathURI `relativeFrom` baseURI) "" + where + baseURI = fromJustNote "joinRel base path" $ parseURIReference base + pathURI = fromJustNote "joinRel relative path" $ parseURIReference path findRelByType :: Text -> Relationships -> Maybe Relationship findRelByType t (Relationships m) = find ((==t) . relType) (Map.elems m) 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 @@ -17,7 +17,7 @@ , Fill(..) , FillPattern(..) , Font(..) - , NumberFormat(..), numberFormatId + , NumberFormat(..), numberFormatId, idToStdNumberFormat , Protection(..) -- * Supporting enumerations , CellHorizontalAlignment(..) @@ -650,6 +650,37 @@ numberFormatId NfMmSs1Decimal = 47 -- mmss.0 numberFormatId NfExponent1Decimal = 48 -- ##0.0E+0 numberFormatId NfTextPlaceHolder = 49 -- @ + +idToStdNumberFormat :: Int -> Maybe NumberFormat +idToStdNumberFormat 0 = Just NfGeneral -- General +idToStdNumberFormat 1 = Just NfZero -- 0 +idToStdNumberFormat 2 = Just Nf2Decimal -- 0.00 +idToStdNumberFormat 3 = Just NfMax3Decimal -- #,##0 +idToStdNumberFormat 4 = Just NfThousandSeparator2Decimal -- #,##0.00 +idToStdNumberFormat 9 = Just NfPercent -- 0% +idToStdNumberFormat 10 = Just NfPercent2Decimal -- 0.00% +idToStdNumberFormat 11 = Just NfExponent2Decimal -- 0.00E+00 +idToStdNumberFormat 12 = Just NfSingleSpacedFraction -- # ?/? +idToStdNumberFormat 13 = Just NfDoubleSpacedFraction -- # ??/?? +idToStdNumberFormat 14 = Just NfMmDdYy -- mm-dd-yy +idToStdNumberFormat 15 = Just NfDMmmYy -- d-mmm-yy +idToStdNumberFormat 16 = Just NfDMmm -- d-mmm +idToStdNumberFormat 17 = Just NfMmmYy -- mmm-yy +idToStdNumberFormat 18 = Just NfHMm12Hr -- h:mm AM/PM +idToStdNumberFormat 19 = Just NfHMmSs12Hr -- h:mm:ss AM/PM +idToStdNumberFormat 20 = Just NfHMm -- h:mm +idToStdNumberFormat 21 = Just NfHMmSs -- h:mm:ss +idToStdNumberFormat 22 = Just NfMdyHMm -- m/d/yy h:mm +idToStdNumberFormat 37 = Just NfThousandsNegativeParens -- #,##0 ;(#,##0) +idToStdNumberFormat 38 = Just NfThousandsNegativeRed -- #,##0 ;[Red](#,##0) +idToStdNumberFormat 39 = Just NfThousands2DecimalNegativeParens -- #,##0.00;(#,##0.00) +idToStdNumberFormat 40 = Just NfTousands2DecimalNEgativeRed -- #,##0.00;[Red](#,##0.00) +idToStdNumberFormat 45 = Just NfMmSs -- mm:ss +idToStdNumberFormat 46 = Just NfOptHMmSs -- [h]:mm:ss +idToStdNumberFormat 47 = Just NfMmSs1Decimal -- mmss.0 +idToStdNumberFormat 48 = Just NfExponent1Decimal -- ##0.0E+0 +idToStdNumberFormat 49 = Just NfTextPlaceHolder -- @ +idToStdNumberFormat _ = Nothing -- | Protection properties -- 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,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | This module provides a function for serializing structured `Xlsx` into lazy bytestring module Codec.Xlsx.Writer ( fromXlsx @@ -7,9 +8,10 @@ import qualified Codec.Archive.Zip as Zip import Control.Arrow (second) -import Control.Lens hiding (transform) +import Control.Lens hiding (transform, (.=)) import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () +import Data.List (foldl') import Data.Map (Map) import qualified Data.Map as M import Data.Maybe @@ -32,6 +34,7 @@ #endif import Codec.Xlsx.Types +import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair import qualified Codec.Xlsx.Types.Internal.CommentTable as CommentTable import Codec.Xlsx.Types.Internal.CustomProperties @@ -47,21 +50,28 @@ t = round pt utcTime = posixSecondsToUTCTime pt entries = Zip.toEntry "[Content_Types].xml" t (contentTypesXml files) : - map (\fd -> Zip.toEntry (T.unpack $ fdName fd) t (fdContents fd)) files + map (\fd -> Zip.toEntry (fdPath fd) t (fdContents fd)) files + -- TODO: root files should be only core.xml, app.xml and workbook.xml files = sheetFiles ++ customPropFiles ++ [ FileData "docProps/core.xml" - "application/vnd.openxmlformats-package.core-properties+xml" $ coreXml utcTime "xlsxwriter" + "application/vnd.openxmlformats-package.core-properties+xml" + "metadata/core-properties" $ coreXml utcTime "xlsxwriter" , FileData "docProps/app.xml" - "application/vnd.openxmlformats-officedocument.extended-properties+xml" $ appXml (xlsx ^. xlSheets) + "application/vnd.openxmlformats-officedocument.extended-properties+xml" + "xtended-properties" $ appXml (xlsx ^. xlSheets) , FileData "xl/workbook.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" $ bookXml (xlsx ^. xlSheets) (xlsx ^. xlDefinedNames) + "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" + "officeDocument" $ bookXml (xlsx ^. xlSheets) (xlsx ^. xlDefinedNames) , FileData "xl/styles.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" $ unStyles (xlsx ^. xlStyles) + "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" + "styles" $ unStyles (xlsx ^. xlStyles) , FileData "xl/sharedStrings.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" $ ssXml shared + "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" + "sharedStrings" $ ssXml shared , FileData "xl/_rels/workbook.xml.rels" - "application/vnd.openxmlformats-package.relationships+xml" bookRelsXml - , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" rootRelXml + "application/vnd.openxmlformats-package.relationships+xml" "relationships" bookRelsXml + , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" + "relationships" rootRelXml ] rootRelXml = renderLBS def . toDocument $ Relationships.fromList rootRels rootFiles = customPropFileRels ++ @@ -75,39 +85,95 @@ True -> ([], []) False -> ([ FileData "docProps/custom.xml" "application/vnd.openxmlformats-officedocument.custom-properties+xml" + "custom-properties" (customPropsXml (CustomProperties customProps)) ], [ ("custom-properties", "docProps/custom.xml") ]) bookRelsXml = renderLBS def . toDocument $ bookRels sheetCount - sheetFiles = concat $ zipWith3 singleSheelFiles [1..] sheetCells sheets + sheetFiles = concat $ zipWith3 singleSheetFiles [1..] sheetCells sheets sheets = xlsx ^. xlSheets . to M.elems sheetCount = length sheets shared = sstConstruct sheets sheetCells = map (transformSheetData shared) sheets -singleSheelFiles :: Int -> Cells -> Worksheet -> [FileData] -singleSheelFiles n cells ws = sheetFile:filesForComments +singleSheetFiles :: Int -> Cells -> Worksheet -> [FileData] +singleSheetFiles n cells ws = sheetFile:otherFiles where - sheetFile = FileData ("xl/worksheets/sheet" <> txti n <> ".xml") - "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" $ - sheetXml ws cells - filesForComments = if null comments then [] else [commentsFile, sheetRels] + 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) + +commentsFiles :: Int -> Cells -> [FileData] +commentsFiles n cells = + if null comments then [] else [commentsFile] + where comments = concatMap (\(row, rowCells) -> mapMaybe (maybeCellComment row) rowCells) cells maybeCellComment row (col, cell) = do comment <- xlsxComment cell return (mkCellRef (row, col), comment) commentsFile = FileData commentsPath "application/vnd.openxmlformats-officedocument.spreadsheetml.comments+xml" + "comments" commentsBS - commentsPath = "xl/comments" <> txti n <> ".xml" + commentsPath = "xl/comments" <> show n <> ".xml" commentsBS = renderLBS def . toDocument $ CommentTable.fromList comments - sheetRels = FileData ("xl/worksheets/_rels/sheet" <> txti n <> ".xml.rels") - "application/vnd.openxmlformats-package.relationships+xml" sheetRelsXml - sheetRelsXml = renderLBS def . toDocument $ Relationships.fromList - [relEntry 1 "comments" ("../comments" <> show n <> ".xml")] -data FileData = FileData { fdName :: Text +drawingFiles :: Int -> Maybe Drawing -> ([FileData], [FileData]) +drawingFiles _ Nothing = ([], []) +drawingFiles n(Just dr) = ([drawingFile], referenced) + where + drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml" + drawingFile = FileData drawingFilePath + "application/vnd.openxmlformats-officedocument.drawing+xml" + "drawing" drawingXml + drawingXml = renderLBS def{rsNamespaces=nss} $ toDocument dr' + nss = [ ("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing") + , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") + , ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] + dr' = Drawing{ _xdrAnchors = reverse anchors' } + (anchors', images, _) = foldl' collectImage ([], [], 1) (dr ^. xdrAnchors) + collectImage :: ([Anchor RefId], [Maybe FileInfo], Int) -> Anchor FileInfo + -> ([Anchor RefId], [Maybe FileInfo], Int) + collectImage (as, fis, i) anch0 = + case anch0 ^. anchObject of + pic@Picture{} -> + let anch = anch0{_anchObject = pic & picBlipFill . bfpImageInfo ?~ RefId ("rId" <> txti i)} + fi = pic ^. picBlipFill . bfpImageInfo + in (anch:as, fi:fis, i + 1) + imageFiles = [ FileData ("xl/media/" <> _fiFilename) + _fiContentType + "image" _fiContents + | FileInfo{..} <- reverse (catMaybes images) ] + drawingRels = FileData ("xl/drawings/_rels/drawing" <> show n <> ".xml.rels") + "application/vnd.openxmlformats-package.relationships+xml" + "relationships" drawingRelsXml + drawingRelsXml = renderLBS def . toDocument . Relationships.fromList $ + [ relEntry i fdRelType (fdPath `relFrom` drawingFilePath) + | (i, FileData{..}) <- zip [1..] imageFiles ] + referenced = case images of + [] -> [] + _ -> drawingRels:imageFiles + + +data FileData = FileData { fdPath :: FilePath , fdContentType :: Text - , fdContents :: L.ByteString} + , fdRelType :: Text + , fdContents :: L.ByteString } type Cells = [(Int, [(Int, XlsxCell)])] @@ -158,9 +224,10 @@ | XlsxBool Bool deriving (Show, Eq) data XlsxCell = XlsxCell - { xlsxCellStyle :: Maybe Int - , xlsxCellValue :: Maybe XlsxCellData - , xlsxComment :: Maybe Comment + { xlsxCellStyle :: Maybe Int + , xlsxCellValue :: Maybe XlsxCellData + , xlsxComment :: Maybe Comment + , xlsxCellFormula :: Maybe CellFormula } deriving (Show, Eq) xlsxCellType :: XlsxCell -> Text @@ -168,32 +235,32 @@ xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxBool _)} = "b" xlsxCellType _ = "n" -- default in SpreadsheetML schema, TODO: add other types -value :: XlsxCell -> Text -value XlsxCell{xlsxCellValue=Just(XlsxSS i)} = txti i -value XlsxCell{xlsxCellValue=Just(XlsxDouble d)} = txtd d -value XlsxCell{xlsxCellValue=Just(XlsxBool True)} = "1" -value XlsxCell{xlsxCellValue=Just(XlsxBool False)} = "0" -value _ = error "value undefined" +value :: XlsxCellData -> Text +value (XlsxSS i) = txti i +value (XlsxDouble d) = txtd d +value (XlsxBool True) = "1" +value (XlsxBool False) = "0" transformSheetData :: SharedStringTable -> Worksheet -> Cells transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells) where transformRow = second (map transformCell) - transformCell (c, Cell{_cellValue=v, _cellStyle=s, _cellComment=comment}) = - (c, XlsxCell s (fmap transformValue v) comment) + transformCell (c, Cell{..}) = + (c, XlsxCell _cellStyle (fmap transformValue _cellValue) _cellComment _cellFormula) transformValue (CellText t) = XlsxSS (sstLookupText shared t) transformValue (CellDouble dbl) = XlsxDouble dbl transformValue (CellBool b) = XlsxBool b transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) -sheetXml :: Worksheet -> Cells -> L.ByteString -sheetXml ws rows = renderLBS def $ Document (Prologue [] Nothing []) root [] +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 $ @@ -203,7 +270,8 @@ ] ++ map (Just . NodeElement . toElement "conditionalFormatting") cfPairs ++ [ nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges, - NodeElement . toElement "pageSetup" <$> pageSetup + NodeElement . toElement "pageSetup" <$> pageSetup, + NodeElement . (\_ -> leafElement "drawing" [ odr "id" .= ("rId" <> txti nextRId) ]) <$> drawing ] cType = xlsxCellType cwEl cw = NodeElement $! Element "col" (M.fromList @@ -222,7 +290,9 @@ mergeE1 t = NodeElement $! Element "mergeCell" (M.fromList [("ref",t)]) [] cellEl r (icol, cell) = nEl "c" (M.fromList (cellAttrs (mkCellRef (r, icol)) cell)) - [nEl "v" M.empty [NodeContent $ value cell] | isJust $ xlsxCellValue 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)] @@ -230,7 +300,7 @@ bookXml :: Map Text Worksheet -> DefinedNames -> L.ByteString bookXml wss (DefinedNames names) = renderLBS def $ Document (Prologue [] Nothing []) root [] where - numNames = [(txti i, name) | (i, name) <- zip [1..] (M.keys wss)] + numNames = [(txti i, name) | (i, name) <- zip [(1::Int)..] (M.keys wss)] -- The @bookViews@ element is not required according to the schema, but its -- absence can cause Excel to crash when opening the print preview @@ -271,7 +341,7 @@ where root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" $ Element "Types" M.empty $ - map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", fdName fd]), + map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", T.pack $ fdPath fd]), ("ContentType", fdContentType fd)]) []) fds -- | fully qualified XML name 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,8 @@ , countedElementList , elementList , elementListSimple + , leafElement + , emptyElement , elementContent , elementContentPreserved , elementValue @@ -27,6 +29,9 @@ , txti , txtb , txtd + , justNonDef + , justTrue + , justFalse ) where import Data.Text (Text) @@ -81,6 +86,12 @@ elementListSimple :: Name -> [Element] -> Element elementListSimple nm els = elementList nm [] els +leafElement :: Name -> [(Name, Text)] -> Element +leafElement nm attrs = elementList nm attrs [] + +emptyElement :: Name -> Element +emptyElement nm = elementList nm [] [] + elementContent0 :: Name -> [(Name, Text)] -> Text -> Element elementContent0 nm attrs txt = Element { elementName = nm @@ -109,10 +120,11 @@ class ToAttrVal a where toAttrVal :: a -> Text -instance ToAttrVal Text where toAttrVal = id -instance ToAttrVal String where toAttrVal = fromString -instance ToAttrVal Int where toAttrVal = fromString . show -instance ToAttrVal Double where toAttrVal = fromString . show +instance ToAttrVal Text where toAttrVal = id +instance ToAttrVal String where toAttrVal = fromString +instance ToAttrVal Int where toAttrVal = txti +instance ToAttrVal Integer where toAttrVal = txti +instance ToAttrVal Double where toAttrVal = fromString . show instance ToAttrVal Bool where toAttrVal True = "true" @@ -176,5 +188,15 @@ txtb :: Bool -> Text txtb = T.toLower . T.pack . show -txti :: Int -> Text +txti :: (Integral a) => a -> Text txti = toStrict . toLazyText . decimal + +justNonDef :: (Eq a) => a -> a -> Maybe a +justNonDef defVal a | a == defVal = Nothing + | otherwise = Just a + +justFalse :: Bool -> Maybe Bool +justFalse = justNonDef True + +justTrue :: Bool -> Maybe Bool +justTrue = justNonDef False diff --git a/test/DataTest.hs b/test/DataTest.hs --- a/test/DataTest.hs +++ b/test/DataTest.hs @@ -5,6 +5,7 @@ import Control.Lens import Control.Monad.State.Lazy import Data.ByteString.Lazy (ByteString) +import Data.Map (Map) import qualified Data.Map as M import Data.Time.Clock.POSIX (POSIXTime) import qualified Data.Vector as V @@ -24,9 +25,11 @@ import Codec.Xlsx import Codec.Xlsx.Formatted import Codec.Xlsx.Parser.Internal +import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CommentTable import Codec.Xlsx.Types.Internal.CustomProperties as CustomProperties import Codec.Xlsx.Types.Internal.SharedStringTable +import Codec.Xlsx.Writer.Internal import Diff @@ -36,7 +39,7 @@ [ testProperty "col2int . int2col == id" $ \(Positive i) -> i == col2int (int2col i) , testCase "write . read == id" $ - testXlsx @=? toXlsx (fromXlsx testTime testXlsx) + testXlsx @==? toXlsx (fromXlsx testTime testXlsx) , testCase "fromRows . toRows == id" $ testCellMap1 @=? fromRows (toRows testCellMap1) , testCase "fromRight . parseStyleSheet . renderStyleSheet == id" $ @@ -47,22 +50,37 @@ [testSharedStringTableWithEmpty] @=? testParsedSharedStringTablesWithEmpty , testCase "correct comments parsing" $ [testCommentTable] @=? testParsedComments + , testCase "correct drawing parsing" $ + [testDrawing] @==? parseDrawing testDrawingFile + , testCase "write . read == id for Drawings" $ + [testDrawing] @==? parseDrawing testWrittenDrawing , testCase "correct custom properties parsing" $ [testCustomProperties] @==? testParsedCustomProperties , testCase "proper results from `formatted`" $ testFormattedResult @==? testRunFormatted + , testCase "formatted . toFormattedCells = id" $ do + let fmtd = formatted testFormattedCells minimalStyleSheet + testFormattedCells @==? toFormattedCells (formattedCellMap fmtd) (formattedMerges fmtd) + (formattedStyleSheet fmtd) , testCase "proper results from `conditionalltyFormatted`" $ testCondFormattedResult @==? testRunCondFormatted + , testCase "toXlsxEither: properly formatted" $ + Right testXlsx @==? toXlsxEither (fromXlsx testTime testXlsx) + , testCase "toXlsxEither: invalid format" $ + Left InvalidZipArchive @==? toXlsxEither "this is not a valid XLSX file" ] testXlsx :: Xlsx testXlsx = Xlsx sheets minimalStyles definedNames customProperties where sheets = M.fromList [("List1", sheet1), ("Another sheet", sheet2)] - sheet1 = Worksheet cols rowProps testCellMap1 ranges sheetViews pageSetup cFormatting + sheet1 = Worksheet cols rowProps testCellMap1 drawing ranges sheetViews pageSetup cFormatting sheet2 = def & wsCells .~ testCellMap2 rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] cols = [ColumnsWidth 1 10 15 1] + drawing = Just $ testDrawing { _xdrAnchors = [pic] } + pic = head (testDrawing ^. xdrAnchors) & anchObject . picBlipFill . bfpImageInfo ?~ fileInfo + fileInfo = FileInfo "dummy.png" "image/png" "fake contents" ranges = [mkRange (1,1) (1,2), mkRange (2,2) (10, 5)] minimalStyles = renderStyleSheet minimalStyleSheet definedNames = DefinedNames [("SampleName", Nothing, "A10:A20")] @@ -94,16 +112,22 @@ rules2 = [ cfRule ContainsErrors 3 ] testCellMap1 :: CellMap -testCellMap1 = M.fromList [ ((1, 2), cd1), ((1, 5), cd2) - , ((3, 1), cd3), ((3, 2), cd4), ((3, 7), cd5) - ] +testCellMap1 = M.fromList [ ((1, 2), cd1_2), ((1, 5), cd1_5) + , ((3, 1), cd3_1), ((3, 2), cd3_2), ((3, 7), cd3_7) + , ((4, 1), cd4_1), ((4, 2), cd4_2), ((4, 3), cd4_3) + ] where cd v = def {_cellValue=Just v} - cd1 = cd (CellText "just a text") - cd2 = cd (CellDouble 42.4567) - cd3 = cd (CellText "another text") - cd4 = def -- shouldn't it be skipped? - cd5 = cd (CellBool True) + cd1_2 = cd (CellText "just a text") + cd1_5 = cd (CellDouble 42.4567) + cd3_1 = cd (CellText "another text") + cd3_2 = def -- shouldn't it be skipped? + cd3_7 = cd (CellBool True) + cd4_1 = cd (CellDouble 1) + cd4_2 = cd (CellDouble 2) + cd4_3 = (cd (CellDouble (1+2))) { _cellFormula = + Just $ simpleCellFormula "A4+B4" + } testCellMap2 :: CellMap testCellMap2 = M.fromList [ ((1, 2), def & cellValue ?~ CellText "something here") @@ -238,6 +262,75 @@ |] +testDrawing = Drawing [ anchor ] + where + anchor = Anchor + { _anchAnchoring = anchoring + , _anchObject = pic + , _anchClientData = def } + anchoring = TwoCellAnchor + { tcaFrom = unqMarker ( 0, 0) ( 0, 0) + , tcaTo = unqMarker (12, 320760) (33, 38160) + , tcaEditAs = EditAsAbsolute } + pic = Picture + { _picMacro = Nothing + , _picPublished = False + , _picNonVisual = nonVis + , _picBlipFill = bfProps + , _picShapeProperties = shProps } + nonVis = PicNonVisual $ PicDrawingNonVisual + { _pdnvId = 0 + , _pdnvName = "Picture 1" + , _pdnvDescription = Just "" + , _pdnvHidden = False + , _pdnvTitle = Nothing } + bfProps = BlipFillProperties + { _bfpImageInfo = Just (RefId "rId1") + , _bfpFillMode = Just FillStretch } + shProps = ShapeProperties + { _spXfrm = Just trnsfrm + , _spGeometry = Just PresetGeometry + , _spOutline = Just $ LineProperties (Just LineNoFill) } + trnsfrm = Transform2D + { _trRot = Angle 0 + , _trFlipH = False + , _trFlipV = False + , _trOffset = Just (unqPoint2D 0 0) + , _trExtents = Just (PositiveSize2D (PositiveCoordinate 10074240) + (PositiveCoordinate 5402520)) } + +parseDrawing :: ByteString -> [UnresolvedDrawing] +parseDrawing bs = fromCursor . fromDocument $ parseLBS_ def bs + +testDrawingFile :: ByteString +testDrawingFile = [r| + + + + + 00 + 00 + + + 12320760 + 3338160 + + + + + + + + + + + + +|] + +testWrittenDrawing :: ByteString +testWrittenDrawing = renderLBS def $ toDocument testDrawing + testCustomProperties :: CustomProperties testCustomProperties = CustomProperties.fromList [ ("testTextProp", VtLpwstr "test text property value") @@ -286,11 +379,13 @@ cell11 = Cell { _cellStyle = Just 1 , _cellValue = Just (CellText "text at A1") - , _cellComment = Nothing } + , _cellComment = Nothing + , _cellFormula = Nothing } cell2 = Cell { _cellStyle = Just 2 , _cellValue = Just (CellDouble 1.23) - , _cellComment = Nothing } + , _cellComment = Nothing + , _cellFormula = Nothing } merges = [] styleSheet = minimalStyleSheet & styleSheetCellXfs %~ (++ [cellXf1, cellXf2]) @@ -345,6 +440,16 @@ , _cfrDxfId = Just 2 , _cfrPriority = 1 , _cfrStopIfTrue = Nothing } + +testFormattedCells :: Map (Int, Int) FormattedCell +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) 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.3 +Version: 0.2.4 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -38,9 +38,11 @@ , Codec.Xlsx.Types.Comment , Codec.Xlsx.Types.Common , Codec.Xlsx.Types.ConditionalFormatting + , Codec.Xlsx.Types.Drawing , Codec.Xlsx.Types.Internal , Codec.Xlsx.Types.Internal.CfPair , Codec.Xlsx.Types.Internal.CommentTable + , Codec.Xlsx.Types.Internal.ContentTypes , Codec.Xlsx.Types.Internal.CustomProperties , Codec.Xlsx.Types.Internal.Relationships , Codec.Xlsx.Types.Internal.SharedStringTable @@ -62,10 +64,12 @@ , conduit >= 1.0.0 , containers >= 0.5.0.0 , data-default + , errors , extra , filepath , lens >= 3.8 && < 5 , mtl >= 2.1 + , mtl-compat , network-uri , old-locale >= 1.0.0.5 , safe >= 0.3