xlsx 0.2.3 → 0.2.4
raw patch · 15 files changed
+1341/−233 lines, 15 filesdep +errorsdep +mtl-compat
Dependencies added: errors, mtl-compat
Files
- CHANGELOG.markdown +6/−0
- src/Codec/Xlsx/Formatted.hs +76/−30
- src/Codec/Xlsx/Parser.hs +174/−112
- src/Codec/Xlsx/Parser/Internal.hs +15/−4
- src/Codec/Xlsx/Types.hs +111/−24
- src/Codec/Xlsx/Types/Common.hs +0/−1
- src/Codec/Xlsx/Types/Drawing.hs +595/−0
- src/Codec/Xlsx/Types/Internal.hs +13/−3
- src/Codec/Xlsx/Types/Internal/ContentTypes.hs +55/−0
- src/Codec/Xlsx/Types/Internal/Relationships.hs +5/−0
- src/Codec/Xlsx/Types/StyleSheet.hs +32/−1
- src/Codec/Xlsx/Writer.hs +110/−40
- src/Codec/Xlsx/Writer/Internal.hs +27/−5
- test/DataTest.hs +117/−12
- xlsx.cabal +5/−1
CHANGELOG.markdown view
@@ -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 <brad.ediger@madriska.com>)+ 0.2.3 ----- * added conditional formatting support
src/Codec/Xlsx/Formatted.hs view
@@ -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' --
src/Codec/Xlsx/Parser.hs view
@@ -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
src/Codec/Xlsx/Parser/Internal.hs view
@@ -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
src/Codec/Xlsx/Types.hs view
@@ -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 @\<f\>@ and inline strings from @\<is\>@ -- 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 ]+ }
src/Codec/Xlsx/Types/Common.hs view
@@ -46,7 +46,6 @@ | XlsxRichText [RichTextRun] deriving (Show, Eq, Ord) - -- | A formula -- -- See 18.18.35 "ST_Formula (Formula)" (p. 2457)
+ src/Codec/Xlsx/Types/Drawing.hs view
@@ -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"
src/Codec/Xlsx/Types/Internal.hs view
@@ -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
+ src/Codec/Xlsx/Types/Internal/ContentTypes.hs view
@@ -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"
src/Codec/Xlsx/Types/Internal/Relationships.hs view
@@ -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)
src/Codec/Xlsx/Types/StyleSheet.hs view
@@ -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 --
src/Codec/Xlsx/Writer.hs view
@@ -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
src/Codec/Xlsx/Writer/Internal.hs view
@@ -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
test/DataTest.hs view
@@ -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 @@ </comments> |] +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|+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>+<xdr:wsDr xmlns:xdr="http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing" xmlns:a="http://schemas.openxmlformats.org/drawingml/2006/main" xmlns:r="http://schemas.openxmlformats.org/officeDocument/2006/relationships">+ <xdr:twoCellAnchor editAs="absolute">+ <xdr:from>+ <xdr:col>0</xdr:col><xdr:colOff>0</xdr:colOff>+ <xdr:row>0</xdr:row><xdr:rowOff>0</xdr:rowOff>+ </xdr:from>+ <xdr:to>+ <xdr:col>12</xdr:col><xdr:colOff>320760</xdr:colOff>+ <xdr:row>33</xdr:row><xdr:rowOff>38160</xdr:rowOff>+ </xdr:to>+ <xdr:pic>+ <xdr:nvPicPr><xdr:cNvPr id="0" name="Picture 1" descr=""/><xdr:cNvPicPr/></xdr:nvPicPr>+ <xdr:blipFill><a:blip r:embed="rId1"></a:blip><a:stretch/></xdr:blipFill>+ <xdr:spPr>+ <a:xfrm><a:off x="0" y="0"/><a:ext cx="10074240" cy="5402520"/></a:xfrm>+ <a:prstGeom prst="rect"><a:avLst/></a:prstGeom><a:ln><a:noFill/></a:ln>+ </xdr:spPr>+ </xdr:pic>+ <xdr:clientData/>+ </xdr:twoCellAnchor>+</xdr:wsDr>+|]++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
xlsx.cabal view
@@ -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