diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2012 Kirill Zaborsky + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Codec/Xlsx.hs b/src/Codec/Xlsx.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx.hs @@ -0,0 +1,118 @@ +module Codec.Xlsx( + Xlsx(..), + WorksheetFile(..), + Styles(..), + ColumnsWidth(..), + RowHeights, + Worksheet(..), + CellValue(..), + Cell(..), + CellData(..), + int2col, + col2int, + foldRows, + toList, + fromList + ) where + +import Control.Arrow +import Data.Char +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap (IntMap) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.LocalTime (LocalTime) +import qualified Codec.Archive.Zip as Zip +import qualified Data.ByteString.Lazy as L + + +data Xlsx = Xlsx{ xlArchive :: Zip.Archive + , xlSharedStrings :: IntMap Text + , xlStyles :: Styles + , xlWorksheetFiles :: [WorksheetFile] + } + +data Styles = Styles L.ByteString + deriving Show + + +data WorksheetFile = WorksheetFile { wfName :: Text + , wfPath :: FilePath + } + deriving Show + +-- | Column range (from cwMin to cwMax) width +data ColumnsWidth = ColumnsWidth { cwMin :: Int + , cwMax :: Int + , cwWidth :: Double + } + deriving Show + +type RowHeights = Map Int Double + +data Worksheet = Worksheet { wsName :: Text -- ^ worksheet name + , wsMinX :: Int -- ^ minimum non-empty column number (1-based) + , wsMaxX :: Int -- ^ maximum non-empty column number (1-based) + , wsMinY :: Int -- ^ minimum non-empty row number (1-based) + , wsMaxY :: Int -- ^ maximum non-empty row number (1-based) + , wsColumns :: [ColumnsWidth] -- ^ column widths + , wsRowHeights :: RowHeights -- ^ custom row height map + , wsCells :: Map (Int,Int) CellData -- ^ data mapped by (column, row) pairs + } + deriving Show + +data CellValue = CellText Text | CellDouble Double | CellLocalTime LocalTime + deriving Show + + +data Cell = Cell { cellIx :: (Text, Int) + , cellData :: CellData + } + deriving Show + +data CellData = CellData { cdStyle :: Maybe Int + , cdValue :: Maybe CellValue + } + deriving Show + +-- | convert column number (starting from 1) to its textual form (e.g. 3 -> "C") +int2col :: Int -> Text +int2col = T.pack . reverse . map int2let . base26 + where + int2let 0 = 'Z' + int2let x = chr $ (x - 1) + ord 'A' + base26 0 = [] + base26 i = let i' = (i `mod` 26) + i'' = if i' == 0 then 26 else i' + in seq i' (i' : base26 ((i - i'') `div` 26)) + +-- | reverse to 'int2col' +col2int :: Text -> Int +col2int = T.foldl' (\i c -> i * 26 + let2int c) 0 + where + let2int c = 1 + ord c - ord 'A' + +-- | fold worksheet by row, then by column, so for region A1:B2 you'll get fold order like A1, A2, B1, B2 +foldRows :: (Int -> Int -> Maybe CellData -> a -> a) -> a -> Worksheet -> a +foldRows f i Worksheet{wsMinX=minX, wsMaxX=maxX, + wsMinY=minY, wsMaxY=maxY, wsCells=cells} = foldr foldRow i [minX..maxX] + where + foldRow x acc = foldr (\y -> f x y $ Map.lookup (x,y) cells) acc [minY..maxY] + +toList :: Worksheet -> [[Maybe CellData]] +toList Worksheet{wsMinX=minX, wsMaxX=maxX, + wsMinY=minY, wsMaxY=maxY, wsCells=cells} = + [[Map.lookup (x,y) cells | x <- [minX..maxX]] | y <- [minY..maxY]] + +fromList :: Text -> [ColumnsWidth] -> RowHeights -> [[Maybe CellData]] -> Worksheet +fromList sName cw rh d = Worksheet sName 1 maxX 1 maxY cw rh $ Map.fromList cellList + where + maxY = max (length d + 1) (maximum' $ Map.keys rh) + maximum' l = if null l then minBound else maximum l + maxX = maximum' $ map length d + filterMap f p = map f . filter p + cellList = filterMap (second fromJust) (isJust . snd) + $ concatMap (\(y,ds) -> map (\(x,v) -> ((x,y),v)) (zip [1..] ds)) + $ zip [1..] d diff --git a/src/Codec/Xlsx/Parser.hs b/src/Codec/Xlsx/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Parser.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Codec.Xlsx.Parser( + xlsx, + sheet, + cellSource, + sheetRowSource + ) where + +import Control.Applicative +import Control.Monad (join) +import Control.Monad.IO.Class() +import Data.Function (on) +import qualified Data.IntMap as M +import qualified Data.IntSet as S +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import Data.Ord +import Prelude hiding (sequence) + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Char8() + +import qualified Codec.Archive.Zip as Zip +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.XML.Types +import System.FilePath +import Text.XML as X +import Text.XML.Cursor +import qualified Text.XML.Stream.Parse as Xml + +import Codec.Xlsx + + +type MapRow = Map.Map Text Text + + +-- | Read archive and preload 'Xlsx' fields +xlsx :: FilePath -> IO Xlsx +xlsx fname = do + ar <- Zip.toArchive <$> L.readFile fname + ss <- getSharedStrings ar + st <- getStyles ar + ws <- getWorksheetFiles ar + return $ Xlsx ar ss st ws + + +-- | Get data from specified worksheet as conduit source. +cellSource :: MonadThrow m => Xlsx -> Int -> [Text] -> Source m [Cell] +cellSource x sheetN cols = getSheetCells x sheetN + $= filterColumns (S.fromList $ map col2int cols) + $= groupRows + $= reverseRows + + +decimal :: Monad m => Text -> m Int +decimal t = case T.decimal t of + Right (d, _) -> return d + _ -> fail "invalid decimal" + +rational :: Monad m => Text -> m Double +rational t = case T.rational t of + Right (r, _) -> return r + _ -> fail "invalid rational" + + +sheet :: MonadThrow m => Xlsx -> Int -> m Worksheet +sheet Xlsx{xlArchive=ar, xlSharedStrings=ss, xlWorksheetFiles=sheets} sheetN + | sheetN < 0 || sheetN >= length sheets + = fail "parseSheet: Invalid sheet number" + | otherwise + = collect parse + where + filename = wfPath $ sheets !! sheetN + sName = wfName $ sheets !! sheetN + file = fromJust $ Zip.fromEntry <$> Zip.findEntryByPath filename ar + doc = case parseLBS def file of + Left _ -> error "could not read file" + Right d -> d + tc :: Cursor + tc = fromDocument doc + parse = (tc $/ parseColumns, tc $/ parseRows) + parseColumns :: Cursor -> [ColumnsWidth] + parseColumns = element (n"cols") &/ element (n"col") >=> parseColumn + parseColumn :: Cursor -> [ColumnsWidth] + parseColumn c = do + min <- c $| attribute "min" >=> decimal + max <- c $| attribute "max" >=> decimal + width <- c $| attribute "width" >=> rational + return $ ColumnsWidth min max width + parseRows :: Cursor -> [(Int, Maybe Double, [(Int, Int, CellData)])] + parseRows = 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 + return (r, ht, c $/ element (n"c") >=> parseCell) + parseCell :: Cursor -> [(Int, Int, CellData)] + parseCell cell = do + (c, r) <- T.span (>'9') <$> (cell $| attribute "r") + return (col2int c, int r, CellData s d) + where + s = listToMaybe $ cell $| attribute "s" >=> decimal + t = fromMaybe "n" $ listToMaybe $ cell $| attribute "t" + d = listToMaybe $ cell $/ element (n"v") &/ content >=> extractValue + extractValue v = case t of + "n" -> + case T.rational v of + Right (d, _) -> [CellDouble d] + _ -> [] + "s" -> + case T.decimal v of + Right (d, _) -> maybeToList $ fmap CellText $ M.lookup d ss + _ -> [] + _ -> [] + collect (cw, rd) = return $ Worksheet sName minX maxX minY maxY cw rowMap cellMap + where + (rowMap, (minX, maxX, minY, maxY, cellMap)) = foldr collectRow rInit rd + rInit = (Map.empty, (maxBound, minBound, maxBound, minBound, Map.empty)) + collectRow (_, Nothing, cells) (rowMap, cellData) = + (rowMap, foldr collectCell cellData cells) + collectRow (n, Just h, cells) (rowMap, cellData) = + (Map.insert n h rowMap, foldr collectCell cellData cells) + collectCell (x, y, cd) (minX, maxX, minY, maxY, cellMap) = + (min minX x, max maxX x, min minY y, max maxY y, Map.insert (x,y) cd cellMap) + + +-- | Get all rows from specified worksheet. +sheetRowSource :: MonadThrow m => Xlsx -> Int -> Source m MapRow +sheetRowSource x sheetN + = getSheetCells x sheetN + $= groupRows + $= reverseRows + $= mkMapRows + +-- | Make 'Conduit' from 'mkMapRowsSink'. +mkMapRows :: Monad m => Conduit [Cell] m MapRow +mkMapRows = sequence mkMapRowsSink =$= CL.concatMap id + + +-- | Make 'MapRow' from list of 'Cell's. +mkMapRowsSink :: Monad m => Sink [Cell] m [MapRow] +mkMapRowsSink = do + header <- fromMaybe [] <$> CL.head + rows <- CL.consume + + return $ map (mkMapRow header) rows + where + mkMapRow header row = Map.fromList $ zipCells header row + + zipCells :: [Cell] -> [Cell] -> [(Text, Text)] + zipCells [] _ = [] + zipCells header [] = map (\h -> (txt h, "")) header + zipCells header@(h:hs) row@(r:rs) = + case comparing (fst . cellIx) h r of + LT -> (txt h , "" ) : zipCells hs row + EQ -> (txt h , txt r) : zipCells hs rs + GT -> ("" , txt r) : zipCells header rs + + txt = fromMaybe "" . cv + cv Cell{cellData=CellData{cdValue=Just(CellText t)}} = Just t + cv _ = Nothing + +reverseRows :: Monad m => Conduit [a] m [a] +reverseRows = CL.map reverse +groupRows = CL.groupBy ((==) `on` (snd.cellIx)) +filterColumns cs = CL.filter ((`S.member` cs) . col2int . fst . cellIx) + + +getSheetCells + :: MonadThrow m => Xlsx -> Int -> Source m Cell +getSheetCells (Xlsx{xlArchive=ar, xlSharedStrings=ss, xlWorksheetFiles=sheets}) sheetN + | sheetN < 0 || sheetN >= length sheets + = error "parseSheet: Invalid sheet number" + | otherwise + = case xmlSource ar (wfPath $ sheets !! sheetN) of + Nothing -> error "An impossible happened" + Just xml -> xml $= mkXmlCond (getCell ss) + + +-- | Parse single cell from xml stream. +getCell + :: MonadThrow m => M.IntMap Text -> Sink Event m (Maybe Cell) +getCell ss = Xml.tagName (n"c") cAttrs cParser + where + cAttrs = do + cellIx <- Xml.requireAttr "r" + style <- Xml.optionalAttr "s" + typ <- Xml.optionalAttr "t" + Xml.ignoreAttrs + return (cellIx,style,typ) + + maybeCellDouble Nothing = Nothing + maybeCellDouble (Just t) = either (const Nothing) (\(d,_) -> Just (CellDouble d)) $ T.rational t + + cParser (ix,style,typ) = do + val <- case typ of + Just "inlineStr" -> liftA (fmap CellText) (tagSeq ["is", "t"]) + Just "s" -> liftA (fmap CellText) (tagSeq ["v"] >>= + return . join . fmap ((`M.lookup` ss).int)) + Just "n" -> liftA maybeCellDouble $ tagSeq ["v"] + _ -> liftA maybeCellDouble $ tagSeq ["v"] + return $ Cell (mkCellIx ix) $ CellData (int <$> style) val + + mkCellIx ix = let (c,r) = T.span (>'9') ix + in (c,int r) + + +-- | Add sml namespace to name +n x = Name + {nameLocalName = x + ,nameNamespace = Just "http://schemas.openxmlformats.org/spreadsheetml/2006/main" + ,namePrefix = Nothing} + +-- | Add office document relationship namespace to name +odr x = Name + {nameLocalName = x + ,nameNamespace = Just "http://schemas.openxmlformats.org/officeDocument/2006/relationships" + ,namePrefix = Nothing} + +-- | Add package relationship namespace to name +pr x = Name + {nameLocalName = x + ,nameNamespace = Just "http://schemas.openxmlformats.org/package/2006/relationships" + ,namePrefix = Nothing} + + +-- | Get text from several nested tags +tagSeq :: MonadThrow m => [Text] -> Sink Event m (Maybe Text) +tagSeq (x:xs) + = Xml.tagNoAttr (n x) + $ foldr (\x -> Xml.force "" . Xml.tagNoAttr (n x)) Xml.content xs + +tagSeq _ = error "no tags in tag sequence" + + +-- | Get xml event stream from the specified file inside the zip archive. +xmlSource + :: MonadThrow m => Zip.Archive -> FilePath -> Maybe (Source m Event) +xmlSource ar fname + = Xml.parseLBS Xml.def + . Zip.fromEntry + <$> Zip.findEntryByPath fname ar + + +-- Get shared strings (if there are some) into IntMap. +getSharedStrings + :: (MonadThrow m, Functor m) + => Zip.Archive -> m (M.IntMap Text) +getSharedStrings x + = case xmlSource x "xl/sharedStrings.xml" of + Nothing -> return M.empty + Just xml -> (M.fromAscList . zip [0..]) <$> getText xml + +-- | Fetch all text from xml stream. +getText xml = xml $= mkXmlCond Xml.contentMaybe $$ CL.consume + + +getStyles :: (MonadThrow m, Functor m) => Zip.Archive -> m Styles +getStyles ar = case Zip.fromEntry <$> Zip.findEntryByPath "xl/styles.xml" ar of + Nothing -> return (Styles L.empty) + Just xml -> return (Styles xml) + +getWorksheetFiles :: (MonadThrow m, Functor m) => Zip.Archive -> m [WorksheetFile] +getWorksheetFiles ar = case xmlSource ar "xl/workbook.xml" of + Nothing -> + error "invalid workbook" + Just xml -> do + sheetData <- xml $= mkXmlCond getSheetData $$ CL.consume + wbRels <- getWbRels ar + return [WorksheetFile n ("xl" T.unpack (fromJust $ lookup rId wbRels)) | (n, rId) <- sheetData] + +getSheetData = Xml.tagName (n"sheet") attrs return + where + attrs = do + name <- Xml.requireAttr "name" + rId <- Xml.requireAttr (odr "id") + Xml.ignoreAttrs + return (name, rId) + +getWbRels :: (MonadThrow m, Functor m) => Zip.Archive -> m [(Text, Text)] +getWbRels ar = case xmlSource ar "xl/_rels/workbook.xml.rels" of + Nothing -> return [] + Just xml -> xml $$ parseWbRels + +parseWbRels = Xml.force "relationships required" $ + Xml.tagNoAttr (pr"Relationships") $ + Xml.many $ Xml.tagName (pr"Relationship") attr return + where + attr = do + target <- Xml.requireAttr "Target" + id <- Xml.requireAttr "Id" + Xml.ignoreAttrs + return (id, target) + +--------------------------------------------------------------------- + + +int :: Text -> Int +int = either error fst . T.decimal + + +-- | Create conduit from xml sink +-- Resulting conduit filters nodes that `f` can consume and skips everything +-- else. +-- +-- FIXME: Some benchmarking required: maybe it's not very efficient to `peek`i +-- each element twice. It's possible to swap call to `f` and `CL.peek`. +mkXmlCond f = sequenceSink () $ const + $ CL.peek >>= maybe -- try get current event form the stream + (return Stop) -- stop if stream is empty + (\_ -> f >>= maybe -- try consume current event + (CL.drop 1 >> return (Emit () [])) -- skip it if can't process + (return . Emit () . (:[]))) -- return result otherwise diff --git a/src/Codec/Xlsx/Writer.hs b/src/Codec/Xlsx/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Xlsx/Writer.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} +module Codec.Xlsx.Writer ( + writeXlsx, + writeXlsxStyles + ) where + +import qualified Codec.Archive.Zip as Zip +import Control.Monad.Trans.State +import Data.ByteString.Lazy.Char8() +import qualified Data.ByteString.Lazy as L +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Text.Lazy.Builder.Int +import Data.Text.Lazy.Builder.RealFloat +import Data.Time.Calendar +import Data.Time.LocalTime +import System.Locale +import System.Time +import Text.XML + +import Codec.Xlsx + + +-- | writes list of worksheets as xlsx file +writeXlsx :: FilePath -> [Worksheet] -> IO () +writeXlsx p = writeXlsxStyles p emptyStylesXml + +-- | writes list of worksheets and their styling as xlsx file +writeXlsxStyles :: FilePath -> L.ByteString -> [Worksheet] -> IO () +writeXlsxStyles p s d = constructXlsx s d >>= L.writeFile p + +data FileData = FileData { fdName :: Text + , fdContentType :: Text + , fdContents :: L.ByteString} + +constructXlsx :: L.ByteString -> [Worksheet] -> IO L.ByteString +constructXlsx s ws = do + ct <- getClockTime + let + TOD t _ = ct + utct = toUTCTime ct + (sheetCells, shared) = runState (mapM collectSharedTransform ws) [] + sheetNumber = length ws + sheetFiles = [FileData (T.concat ["xl/worksheets/sheet", txti n, ".xml"]) "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" $ + sheetXml (wsColumns w) (wsRowHeights w) cells | (n, cells, w) <- zip3 [1..] sheetCells ws] + files = sheetFiles ++ + [ FileData "docProps/core.xml" "application/vnd.openxmlformats-package.core-properties+xml" $ coreXml utct "xlsxwriter" + , FileData "docProps/app.xml" "application/vnd.openxmlformats-officedocument.extended-properties+xml" appXml + , FileData "xl/workbook.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" $ bookXml ws + , FileData "xl/styles.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" s + , FileData "xl/sharedStrings.xml" "application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" $ ssXml shared + , FileData "xl/_rels/workbook.xml.rels" "application/vnd.openxmlformats-package.relationships+xml" $ bookRelXml sheetNumber + , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" rootRelXml ] + entries = Zip.toEntry "[Content_Types].xml" t (contentTypesXml files) : + map (\fd -> Zip.toEntry (T.unpack $ fdName fd) t (fdContents fd)) files + ar = foldr Zip.addEntryToArchive Zip.emptyArchive entries + return $ Zip.fromArchive ar + + +coreXml :: CalendarTime -> Text -> L.ByteString +coreXml created creator = + renderLBS def $ Document (Prologue [] Nothing []) root [] + where + date = T.pack $ formatCalendarTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" created + nsAttrs = [("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") + [(nm "http://www.w3.org/2001/XMLSchema-instance" "type", "dcterms:W3CDTF")] [NodeContent date], + nEl (nm "http://purl.org/dc/elements/1.1/" "creator") [] [NodeContent creator], + nEl (nm "http://schemas.openxmlformats.org/package/2006/metadata/core-properties" "version") [] [NodeContent "0"]] + +appXml :: L.ByteString +appXml = "\ +\0" + +data XlsxCellData = XlsxSS Int | XlsxDouble Double +data XlsxCell = XlsxCell{ xlsxCellStyle :: Maybe Int + , xlsxCellValue :: Maybe XlsxCellData + } + +xlsxCellType :: XlsxCell -> Text +xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxSS _)} = "s" +xlsxCellType _ = "n" -- default type, TODO: fix cell output? + +value :: XlsxCell -> Text +value XlsxCell{xlsxCellValue=Just(XlsxSS i)} = txti i +value XlsxCell{xlsxCellValue=Just(XlsxDouble d)} = txtd d +value _ = error "value undefined" + + +collectSharedTransform :: Worksheet -> State [Text] [[XlsxCell]] +collectSharedTransform d = transformed + where + transformed = mapM (mapM transform) $ toList d + transform Nothing = return $ XlsxCell Nothing Nothing + transform (Just CellData{cdValue=v, cdStyle=s}) = + case v of + Just(CellText t) -> do + shared <- get + case t `elemIndex` shared of + Just i -> + return $ XlsxCell s (Just $ XlsxSS i) + Nothing -> do + put $ shared ++ [t] + return $ XlsxCell s (Just $ XlsxSS (length shared)) + Just(CellDouble dbl) -> + return $ XlsxCell s (Just $ XlsxDouble dbl) + Just(CellLocalTime t) -> + return $ XlsxCell s (Just $ XlsxDouble (xlsxDoubleTime t)) + Nothing -> + return $ XlsxCell s Nothing + +xlsxDoubleTime :: LocalTime -> Double +xlsxDoubleTime LocalTime{localDay=day,localTimeOfDay=time} = + fromIntegral (diffDays day xlsxEpochStart) + timeFraction time + where + xlsxEpochStart = fromGregorian 1899 12 30 + timeFraction = fromRational . timeOfDayToDayFraction + +sheetXml :: [ColumnsWidth] -> RowHeights -> [[XlsxCell]] -> L.ByteString +sheetXml cws rh d = renderLBS def $ Document (Prologue [] Nothing []) root [] + where + rows = zip [1..] d + numCols = zip [int2col n | n <- [1..]] + cType = xlsxCellType + root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ + Element "worksheet" [] + [nEl "cols" [] $ map cwEl cws, + nEl "sheetData" [] $ map rowEl rows] + cwEl cw = NodeElement $! Element "col" + [("min", txti $ cwMin cw), ("max", txti $ cwMax cw), ("width", txtd $ cwWidth cw)] [] + rowEl (r, cells) = nEl "row" + (ht ++ [("r", txti r), ("hidden", "false"), ("outlineLevel", "0"), + ("collapsed", "false"), ("customFormat", "false"), + ("customHeight", txtb hasHeight)]) + $ map (cellEl r) (numCols cells) + where + (ht, hasHeight) = case M.lookup r rh of + Just h -> ([("ht", txtd h)], True) + Nothing -> ([], False) + cellEl r (col, cell) = + nEl "c" (cellAttrs r col cell) [nEl "v" [] [NodeContent $ value cell] | isJust $ xlsxCellValue cell] + cellAttrs r col cell = cellStyleAttr cell ++ [("r", T.concat [col, txti r]), ("t", cType cell)] + cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] + cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] + +bookXml :: [Worksheet] -> L.ByteString +bookXml wss = renderLBS def $ Document (Prologue [] Nothing []) root [] + where + numNames = [(txti i, wsName ws) | (i, ws) <- zip [1..] wss] + root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ Element "workbook" [] + [nEl "sheets" [] $ + map (\(n, name) -> nEl "sheet" + [("name", name), ("sheetId", n), ("state", "visible"), + (rId, T.concat ["rId", n])] []) numNames] + rId = nm "http://schemas.openxmlformats.org/officeDocument/2006/relationships" "id" + +emptyStylesXml :: L.ByteString +emptyStylesXml = "\ +\" + +ssXml :: [Text] -> L.ByteString +ssXml ss = + renderLBS def $ Document (Prologue [] Nothing []) root [] + where + root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ Element "sst" [] $ + map (\s -> nEl "si" [] [nEl "t" [] [NodeContent s]]) ss + +bookRelXml :: Int -> L.ByteString +bookRelXml n = renderLBS def $ Document (Prologue [] Nothing []) root [] + where + root = addNS "http://schemas.openxmlformats.org/package/2006/relationships" $ + Element "Relationships" [] $ + map (\sn -> relEl sn (T.concat ["worksheets/sheet", txti sn, ".xml"]) "worksheet") [1..n] + ++ + [relEl (n + 1) "styles.xml" "styles", relEl (n + 2) "sharedStrings.xml" "sharedStrings"] + relEl i target typ = + nEl "Relationship" + [("Id", T.concat ["rId", txti i]), ("Target", target), + ("Type", T.concat ["http://schemas.openxmlformats.org/officeDocument/2006/relationships/", typ])] [] + +rootRelXml :: L.ByteString +rootRelXml = "\ +\" + +contentTypesXml :: [FileData] -> L.ByteString +contentTypesXml fds = renderLBS def $ Document (Prologue [] Nothing []) root [] + where + root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" $ + Element "Types" [] $ + map (\fd -> nEl "Override" [("PartName", T.concat ["/", fdName fd]), + ("ContentType", fdContentType fd)] []) fds + +nm :: Text -> Text -> Name +nm ns n = Name + { nameLocalName = n + , nameNamespace = Just ns + , namePrefix = Nothing} + +addNS :: Text -> Element -> Element +addNS namespace (Element (Name ln _ _) as ns) = Element (Name ln (Just namespace) Nothing) as (map addNS' ns) + where + addNS' (NodeElement e) = NodeElement $ addNS namespace e + addNS' n = n + +nEl :: Name -> [(Name, Text)] -> [Node] -> Node +nEl name attrs nodes = NodeElement $ Element name attrs nodes + +txti :: Int -> Text +txti = toStrict . toLazyText . decimal + +txtd :: Double -> Text +txtd = toStrict . toLazyText . realFloat + +txtb :: Bool -> Text +txtb = T.toLower . T.pack . show diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +import Codec.Xlsx +import Codec.Xlsx.Writer +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import Data.Text (Text) +import Data.Time.Calendar +import Data.Time.LocalTime + + + +xText :: Text -> Maybe CellData +xText t = Just CellData{cdValue=Just $ CellText t, cdStyle=Just 0} + +xDate :: LocalTime -> Maybe CellData +xDate d = Just CellData{cdValue=Just $ CellLocalTime d, cdStyle=Just 0} + +xDouble :: Double -> Maybe CellData +xDouble d = Just CellData{cdValue=Just $ CellDouble d, cdStyle=Just 0} + +styles :: L.ByteString +styles = "\ +\" + +main :: IO () +main = writeXlsxStyles "test.xlsx" styles [fromList "List" cols rows sheet] + where + cols = [ColumnsWidth 1 10 15] + rows = M.fromList [(1,50)] + sheet = replicate 10000 [xText "column1", xText "column2", Nothing, xText "column4", xDate $! LocalTime (fromGregorian 2012 05 06) (TimeOfDay 7 30 50), xDouble 42.12345, xText "False"] diff --git a/test/DataTest.hs b/test/DataTest.hs new file mode 100644 --- /dev/null +++ b/test/DataTest.hs @@ -0,0 +1,23 @@ +module Main (main) where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) + +import Test.QuickCheck +import Test.HUnit +import Control.Monad + +import Codec.Xlsx + + +main = defaultMain tests + +tests = + [ testGroup "Behaves to spec" + [ testProperty "col to name" prop_col2name + ] + ] + +prop_col2name (Positive i) = i == (col2Int $ int2col i) + where types = (i::Int) diff --git a/xlsx.cabal b/xlsx.cabal new file mode 100644 --- /dev/null +++ b/xlsx.cabal @@ -0,0 +1,78 @@ +Name: xlsx + +Version: 0.0.1 + +Synopsis: Simple and incomplete Excel file parser/writer +Description: + This library can help you to get some data read and written in Office + Open XML xlsx format. Small subset of xlsx format is supported. + TODO: add link to ECMA standard. + +Homepage: https://github.com/qrilka/xlsx +Bug-Reports: https://github.com/qrilka/xlsx/issues +License: MIT +License-file: LICENSE +Author: Tim, Max, Kirill Zaborsky +Maintainer: qrilka@gmail.com + +Category: Codec +Build-type: Simple + +Cabal-version: >=1.8 + + +Library + Hs-source-dirs: src + Exposed-modules: Codec.Xlsx, Codec.Xlsx.Parser, Codec.Xlsx.Writer + + Build-depends: base == 4.* + ,containers + ,transformers + ,bytestring + ,text + ,conduit == 0.4.* + ,xml-types == 0.3.* + ,xml-conduit == 0.7.* + ,zip-archive == 0.1.* + ,digest == 0.0.* + ,zlib + ,utf8-string + ,time + ,old-time + ,old-locale + ,filepath + +Executable test + Hs-source-dirs: src + Other-modules: Codec.Xlsx, Codec.Xlsx.Parser, Codec.Xlsx.Writer + ghc-options: -Wall -threaded + + main-is: Test.hs + + Build-depends: base, containers, transformers, bytestring, text + ,conduit == 0.4.* + ,xml-types == 0.3.* + ,xml-conduit == 0.7.* + ,zip-archive == 0.1.* + ,digest > 0.0.0.1 + ,zlib + ,utf8-string + ,time + ,old-time + ,old-locale + ,filepath + +test-suite data-test + type: exitcode-stdio-1.0 + main-is: DataTest.hs + hs-source-dirs: test/ + Build-Depends: base, QuickCheck >= 2, HUnit, + xlsx, + test-framework, + test-framework-hunit, + test-framework-quickcheck2 + +source-repository head + type: git + location: git://github.com/qrilka/xlsx.git +