xlsx (empty) → 0.0.1
raw patch · 8 files changed
+813/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, bytestring, conduit, containers, digest, filepath, old-locale, old-time, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, utf8-string, xlsx, xml-conduit, xml-types, zip-archive, zlib
Files
- LICENSE +19/−0
- Setup.hs +2/−0
- src/Codec/Xlsx.hs +118/−0
- src/Codec/Xlsx/Parser.hs +322/−0
- src/Codec/Xlsx/Writer.hs +221/−0
- src/Test.hs +30/−0
- test/DataTest.hs +23/−0
- xlsx.cabal +78/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Codec/Xlsx.hs view
@@ -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
+ src/Codec/Xlsx/Parser.hs view
@@ -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
+ src/Codec/Xlsx/Writer.hs view
@@ -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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\+\<Properties xmlns=\"http://schemas.openxmlformats.org/officeDocument/2006/extended-properties\" xmlns:vt=\"http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes\"><TotalTime>0</TotalTime></Properties>"++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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\+\<styleSheet xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\"></styleSheet>"++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 = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\+\<Relationships xmlns=\"http://schemas.openxmlformats.org/package/2006/relationships\"><Relationship Id=\"rId1\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument\" Target=\"xl/workbook.xml\"/><Relationship Id=\"rId2\" Type=\"http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties\" Target=\"docProps/core.xml\"/><Relationship Id=\"rId3\" Type=\"http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties\" Target=\"docProps/app.xml\"/></Relationships>"++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
+ src/Test.hs view
@@ -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 = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\+\<styleSheet xmlns=\"http://schemas.openxmlformats.org/spreadsheetml/2006/main\"><numFmts count=\"1\"><numFmt formatCode=\"GENERAL\" numFmtId=\"164\"/></numFmts><fonts count=\"4\"><font><name val=\"Courier New\"/><charset val=\"1\"/><family val=\"2\"/><sz val=\"10\"/></font><font><name val=\"Arial\"/><family val=\"0\"/><sz val=\"10\"/></font><font><name val=\"Arial\"/><family val=\"0\"/><sz val=\"10\"/></font><font><name val=\"Arial\"/><family val=\"0\"/><sz val=\"10\"/></font></fonts><fills count=\"2\"><fill><patternFill patternType=\"none\"/></fill><fill><patternFill patternType=\"gray125\"/></fill></fills><borders count=\"1\"><border diagonalDown=\"false\" diagonalUp=\"false\"><left/><right/><top/><bottom/><diagonal/></border></borders><cellStyleXfs count=\"20\"><xf applyAlignment=\"true\" applyBorder=\"true\" applyFont=\"true\" applyProtection=\"true\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"164\"><alignment horizontal=\"general\" indent=\"0\" shrinkToFit=\"false\" textRotation=\"0\" vertical=\"bottom\" wrapText=\"false\"/><protection hidden=\"false\" locked=\"true\"/></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"1\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"1\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"2\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"2\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"0\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"1\" numFmtId=\"43\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"1\" numFmtId=\"41\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"1\" numFmtId=\"44\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"1\" numFmtId=\"42\"></xf><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"true\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"1\" numFmtId=\"9\"></xf></cellStyleXfs><cellXfs count=\"1\"><xf applyAlignment=\"false\" applyBorder=\"false\" applyFont=\"false\" applyProtection=\"false\" borderId=\"0\" fillId=\"0\" fontId=\"0\" numFmtId=\"164\" xfId=\"0\"></xf></cellXfs><cellStyles count=\"6\"><cellStyle builtinId=\"0\" customBuiltin=\"false\" name=\"Normal\" xfId=\"0\"/><cellStyle builtinId=\"3\" customBuiltin=\"false\" name=\"Comma\" xfId=\"15\"/><cellStyle builtinId=\"6\" customBuiltin=\"false\" name=\"Comma [0]\" xfId=\"16\"/><cellStyle builtinId=\"4\" customBuiltin=\"false\" name=\"Currency\" xfId=\"17\"/><cellStyle builtinId=\"7\" customBuiltin=\"false\" name=\"Currency [0]\" xfId=\"18\"/><cellStyle builtinId=\"5\" customBuiltin=\"false\" name=\"Percent\" xfId=\"19\"/></cellStyles></styleSheet>"++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"]
+ test/DataTest.hs view
@@ -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)
+ xlsx.cabal view
@@ -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+