diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,11 @@ +0.1.0.4 + * fixed generated xml so it gets read by MS Excel with no warnings (thanks Dmitriy Nikitinskiy ) + * improved shared strings collection by using Vector (thanks Dmitriy Nikitinskiy ) + * empty xml elements don't get emmitted anymore (thanks Philipp Hausmann ) + * imporoved and cleaned up core.xml generation +0.1.0.3 + * added "str" cells content extraction as text + * added a notice that formulas in are not yet supported 0.1.0 * better tests and documentation * lenses for worksheets/cells 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 @@ -5,11 +5,10 @@ ) where import qualified Codec.Archive.Zip as Zip +import Control.Arrow (second) import Control.Lens hiding (transform) -import Control.Monad.Trans.State import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8() -import Data.List import Data.Map (Map) import qualified Data.Map as M import Data.Maybe @@ -20,6 +19,10 @@ import Data.Text.Lazy.Builder (toLazyText) import Data.Text.Lazy.Builder.Int import Data.Text.Lazy.Builder.RealFloat +import qualified Data.Set as S +import Data.Vector (Vector) +import qualified Data.Vector as V +import Numeric.Search.Range (searchFromTo) import System.Locale import System.Time import Text.XML @@ -39,13 +42,13 @@ [ FileData "docProps/core.xml" "application/vnd.openxmlformats-package.core-properties+xml" $ coreXml (toUTCTime ct) "xlsxwriter" , FileData "docProps/app.xml" - "application/vnd.openxmlformats-officedocument.extended-properties+xml" appXml + "application/vnd.openxmlformats-officedocument.extended-properties+xml" $ appXml (xlsx ^. xlSheets) , FileData "xl/workbook.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" $ bookXml (xlsx ^. xlSheets) , FileData "xl/styles.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" $ unStyles (xlsx ^. xlStyles) , FileData "xl/sharedStrings.xml" - "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" $ ssXml shared + "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" $ ssXml $ V.toList shared , FileData "xl/_rels/workbook.xml.rels" "application/vnd.openxmlformats-package.relationships+xml" $ bookRelXml sheetCount , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" rootRelXml @@ -57,7 +60,11 @@ (n, cells, w) <- zip3 [1..] sheetCells sheets] sheets = xlsx ^. xlSheets . to M.elems sheetCount = length sheets - (sheetCells, shared) = runState (mapM collectSharedTransform sheets) [] + shared = V.fromList $ S.elems $ S.fromList $ concatMap (concatMap celltext . M.elems . _wsCells) sheets + sheetCells = map (transformSheetData shared) sheets + celltext (Cell{_cellValue=v}) = case v of + Just(CellText a) -> [a] + _ -> [] data FileData = FileData { fdName :: Text , fdContentType :: Text @@ -65,19 +72,45 @@ coreXml :: CalendarTime -> Text -> L.ByteString coreXml created creator = - renderLBS def $ Document (Prologue [] Nothing []) root [] + renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root [] where + nss = [ ("cp", "http://schemas.openxmlformats.org/package/2006/metadata/core-properties") + , ("dc", "http://purl.org/dc/elements/1.1/") + , ("dcterms", "http://purl.org/dc/terms/") + , ("xsi","http://www.w3.org/2001/XMLSchema-instance") + ] + namespaced = nsName nss date = T.pack $ formatCalendarTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" created - nsAttrs = M.fromList [("xmlns:dcterms", "http://purl.org/dc/terms/")] - root = Element (nm "http://schemas.openxmlformats.org/package/2006/metadata/core-properties" "coreProperties") nsAttrs - [nEl (nm "http://purl.org/dc/terms/" "created") - (M.fromList [(nm "http://www.w3.org/2001/XMLSchema-instance" "type", "dcterms:W3CDTF")]) [NodeContent date], - nEl (nm "http://purl.org/dc/elements/1.1/" "creator") M.empty [NodeContent creator], - nEl (nm "http://schemas.openxmlformats.org/package/2006/metadata/core-properties" "version") M.empty [NodeContent "0"]] + root = Element (namespaced "cp" "coreProperties") M.empty + [ nEl (namespaced "dcterms" "created") + (M.fromList [(namespaced "xsi" "type", "dcterms:W3CDTF")]) [NodeContent date] + , nEl (namespaced "dc" "creator") M.empty [NodeContent creator] + , nEl (namespaced "cp" "lastModifiedBy") M.empty [NodeContent creator] + ] -appXml :: L.ByteString -appXml = "\ -\0" +appXml :: Map Text Worksheet -> L.ByteString +appXml s = renderLBS def $ Document (Prologue [] Nothing []) root [] + where + nsAttrs = M.fromList [("xmlns:vt", "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")] + root = Element (extPropNm "Properties") nsAttrs + [ extPropEl "TotalTime" [NodeContent "0"] + , extPropEl "HeadingPairs" [ + vTypeEl "vector" (M.fromList [("size", "2"), ("baseType", "variant")]) + [ vTypeEl0 "variant" + [vTypeEl0 "lpstr" [NodeContent "Worksheets"]] + , vTypeEl0 "variant" + [vTypeEl0 "i4" [NodeContent $ txti $ M.size s]] + ] + ] + , extPropEl "TitlesOfParts" [ + vTypeEl "vector" (M.fromList [("size", txti $ M.size s),("baseType","lpstr")]) $ + map (vTypeEl0 "lpstr" . return . NodeContent) $ M.keys s + ] + ] + extPropNm n = nm "http://schemas.openxmlformats.org/officeDocument/2006/extended-properties" n + extPropEl n = nEl (extPropNm n) M.empty + vTypeEl0 n = vTypeEl n M.empty + vTypeEl = nEl . nm "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" data XlsxCellData = XlsxSS Int | XlsxDouble Double @@ -100,39 +133,27 @@ value XlsxCell{xlsxCellValue=Just(XlsxBool False)} = "0" value _ = error "value undefined" -collectSharedTransform :: Worksheet -> State [Text] [(Int, [(Int, XlsxCell)])] -collectSharedTransform ws = transformed +transformSheetData :: Vector Text -> Worksheet -> [(Int, [(Int, XlsxCell)])] +transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells) where - transformed = mapM transformRow $ toRows (ws ^. wsCells) - transformRow (r, cells) = do - cells' <- mapM transform cells - return (r, cells') - transform (c, Cell{_cellValue=v, _cellStyle=s}) = - case v of - Just(CellText t) -> do - shared <- get - case t `elemIndex` shared of - Just i -> - return (c, XlsxCell s (Just $ XlsxSS i)) - Nothing -> do - put $ shared ++ [t] - return (c, XlsxCell s (Just $ XlsxSS (length shared))) - Just(CellDouble dbl) -> - return (c, XlsxCell s (Just $ XlsxDouble dbl)) - Just(CellBool b) -> - return (c, XlsxCell s (Just $ XlsxBool b)) - Nothing -> - return (c, XlsxCell s Nothing) + transformRow = second (map transformCell) + transformCell (c, Cell{_cellValue=v, _cellStyle=s}) = + (c, XlsxCell s (fmap transformValue v)) + transformValue (CellText t) = + let Just i = searchFromTo (\p -> shared V.! p >= t) 0 (V.length shared - 1) + in XlsxSS i + transformValue (CellDouble dbl) = XlsxDouble dbl + transformValue (CellBool b) = XlsxBool b sheetXml :: [ColumnsWidth] -> Map Int RowProperties -> [(Int, [(Int, XlsxCell)])] -> [Text]-> L.ByteString sheetXml cws rh rows merges = renderLBS def $ Document (Prologue [] Nothing []) root [] where cType = xlsxCellType root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ - Element "worksheet" M.empty - [nEl "cols" M.empty $ map cwEl cws, - nEl "sheetData" M.empty $ map rowEl rows, - nEl "mergeCells" M.empty $ map mergeE1 merges] + Element "worksheet" M.empty $ catMaybes + [nonEmptyNmEl "cols" M.empty $ map cwEl cws, + justNmEl "sheetData" M.empty $ map rowEl rows, + nonEmptyNmEl "mergeCells" M.empty $ map mergeE1 merges] cwEl cw = NodeElement $! Element "col" (M.fromList [("min", txti $ cwMin cw), ("max", txti $ cwMax cw), ("width", txtd $ cwWidth cw), ("style", txti $ cwStyle cw)]) [] rowEl (r, cells) = nEl "row" @@ -197,6 +218,21 @@ map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", fdName fd]), ("ContentType", fdContentType fd)]) []) fds +-- | fully qualified XML name +qName :: Text -> Text -> Text -> Name +qName n ns p = + Name + { nameLocalName = n + , nameNamespace = Just ns + , namePrefix = Just p + } + +-- | fully qualified XML name from prefix to ns URL mapping +nsName :: [(Text, Text)] -> Text -> Text -> Name +nsName nss p n = qName n ns p + where + ns = fromJust $ lookup p nss + nm :: Text -> Text -> Name nm ns n = Name { nameLocalName = n @@ -208,6 +244,17 @@ where addNS' (NodeElement e) = NodeElement $ addNS namespace e addNS' n = n + +-- | Creates an element with the given name, attributes and children, +-- if there is at least one child. Otherwise returns `Nothing`. +nonEmptyNmEl :: Name -> Map Name Text -> [Node] -> Maybe Node +nonEmptyNmEl _ _ [] = Nothing +nonEmptyNmEl name attrs nodes = justNmEl name attrs nodes + +-- | Creates an element with the given name, attributes and children. +-- Always returns a node/`Just`. +justNmEl :: Name -> Map Name Text -> [Node] -> Maybe Node +justNmEl name attrs nodes = Just $ nEl name attrs nodes nEl :: Name -> Map Name Text -> [Node] -> Node nEl name attrs nodes = NodeElement $ Element name attrs nodes diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -6,7 +6,7 @@ import Control.Lens import qualified Data.ByteString.Lazy as L import qualified Data.Map as M -import Data.Text (Text) +import Data.Text (Text,pack) import System.Time @@ -21,7 +21,68 @@ styles :: Styles styles = Styles "\ -\" +\\ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\ \ +\" main :: IO () main = do @@ -33,11 +94,11 @@ where cols = [ColumnsWidth 1 10 15 1] rowProps = M.fromList [(1, RowProps (Just 50) (Just 3))] - cells = M.fromList [((r, c), v) | (c, v) <- zip [1..] row, r <- [1..10000]] - row = [ xText "column1" - , xText "column2" - , xEmpty - , xText "column4" - , xDouble 42.12345 - , xText "False"] + cells = M.fromList [((r, c), v) | r <- [1..10000], (c, v) <- zip [1..] (row r) ] + row r = [ xText $ pack $ "column1-r" ++ show r + , xText $ pack $ "column2-r" ++ show r + , xEmpty + , xText $ pack $ "column4-r" ++ show r + , xDouble 42.12345 + , xText "False"] sheets = M.fromList [("List", Worksheet cols rowProps cells [])] -- wtf merges? diff --git a/xlsx.cabal b/xlsx.cabal --- a/xlsx.cabal +++ b/xlsx.cabal @@ -1,6 +1,6 @@ Name: xlsx -Version: 0.1.0.3 +Version: 0.1.0.4 Synopsis: Simple and incomplete Excel file parser/writer Description: @@ -53,6 +53,8 @@ , old-time >= 1.1.0.1 , old-locale >= 1.0.0.5 , data-default == 0.5.* + , vector >= 0.10 + , binary-search Default-Language: Haskell2010 @@ -78,6 +80,8 @@ , old-time , old-locale , data-default == 0.5.* + , vector >= 0.10 + , binary-search Default-Language: Haskell2010 test-suite data-test