diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Robert O'Callahan + +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/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +import Xlsx.Writer +import Xlsx.Sheet + +main = saveXlsx "rcallahan" [("shump", [toRow (1::Int,2::Int)])] "test.xlsx" diff --git a/Xlsx/Parse.hs b/Xlsx/Parse.hs new file mode 100644 --- /dev/null +++ b/Xlsx/Parse.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances, FlexibleContexts #-} +module Xlsx.Parse where + +import Data.XML.Types +import Text.XML +import Text.XML.Stream.Parse +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector as V +import Data.Vector (Vector) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Conduit +import qualified Data.Conduit.List as CL +import Control.Applicative hiding (many) +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Trans.Resource +import Data.Attoparsec.Text +import Data.Default +import Data.Char +import Xlsx.Types + +parseCoord :: Text -> Maybe (Int, Int) +parseCoord t = go 0 $ map ord $ T.unpack t where + a = ord 'A' + z = ord 'Z' + zero = ord '0' + nine = ord '9' + go n [] = Nothing + go n cs@(c:cs') | c <= z && c >= a = go (n*26 + c - a + 1) cs' + | n == 0 = Nothing + | otherwise = go' n 0 cs + go' m n [] = Just (n, m) + go' m n (c:cs) | c <= nine && c >= zero = go' m (n*10 + c - zero) cs + | otherwise = Nothing + +tagLocal n = tagPredicate (\Name {nameLocalName = l} -> n == l) + +tagLocalNoAttr n c = tagLocal n ignoreAttrs $ const c + +sharedStringSink :: (Monad m, MonadThrow m) => Sink ByteString m (Vector Text) +sharedStringSink = parseBytes def =$= (force "sst" $ tagLocal "sst" parseCount vecsink) where + parseCount = requireAttr "uniqueCount" <* ignoreAttrs + text = tagLocalNoAttr "t" $ content + rich = do + ts <- many $ tagLocalNoAttr "r" $ do + tagLocalNoAttr "rPr" skipPr + force "t" $ tagLocalNoAttr "t" $ content + case ts of + [] -> return Nothing + l -> return $ Just $ T.concat l + vecsink c = V.replicateM (read $ T.unpack c) $ force "si" $ tagLocalNoAttr "si" $ + force "r or t" $ orE text rich + skipPr = do + mbevent <- CL.peek + case mbevent of + Just j@(EventEndElement n) | nameLocalName n == "rPr" -> return () + Nothing -> monadThrow $ XmlException "no rPr closing tag" Nothing + _ -> CL.drop 1 >> skipPr + + +rawRows :: (Monad m, MonadThrow m) => ConduitM ByteString [((Int, Int), Cell)] m () +rawRows = parseBytes def =$= skiptorows where + skiptorows = do + mbevent <- await + case mbevent of + Nothing -> monadThrow $ XmlException "sheetData expected" Nothing + Just j@(EventBeginElement n _) | nameLocalName n == "sheetData" -> rowsink + _ -> skiptorows + row = tagLocalNoAttr "row" $ many $ tagLocal "c" ((,) <$> requireAttr "r" <*> optionalAttr "t" <* ignoreAttrs) $ \(coord, mbt) -> do + coord' <- case parseCoord coord of + Nothing -> monadThrow $ XmlException ("invalid coordinate: " ++ T.unpack coord) Nothing + Just j -> return j + f <- tagLocalNoAttr "f" content + cellv <- case mbt of + Just typ | typ == "inlineStr" -> InlineString <$> (force "is" $ tagLocalNoAttr "is" $ force "t" $ tagLocalNoAttr "t" content) + | otherwise -> do + v <- tagLocalNoAttr "v" content + return $ case v of + Nothing -> Empty + Just j | typ == "str" -> InlineString j + | typ == "b" -> Boolean $ j == "1" + | typ == "s" -> SharedString $ read $ T.unpack j + | typ == "e" -> Error j + | otherwise -> error $ show typ + Nothing -> do + v <- tagLocalNoAttr "v" content + return $ case v of + Just j -> case parseOnly scientific j of + Left l -> error $ l + Right r -> Number r + _ -> Empty + return (coord', (cellv, f)) + rowsink = do + mbrow <- row + case mbrow of + Just j -> yield j >> rowsink + Nothing -> return () + +unsparseSheet :: (Monad m, MonadThrow m) => ConduitM [((Int, Int), Cell)] [((Int, Int), Cell)] m () +unsparseSheet = flip evalStateT 1 go where + go = do + mb <- lift await + case mb of + Nothing -> return () + Just r -> case r of + [] -> lift $ yield [] + cs@(((r,_),_):_) -> do + cur <- get + if r > cur then lift $ replicateM_ (r - cur) (yield []) else return () + lift $ yield cs + put $ r + 1 + go + +sheetRows :: (Applicative m, Monad m, MonadThrow m, FromRow a) => ConduitM ByteString a (ReaderT (Vector Text) m) () +sheetRows = rawRows =$= unsparseSheet =$= CL.mapM fromRow diff --git a/Xlsx/Sheet.hs b/Xlsx/Sheet.hs new file mode 100644 --- /dev/null +++ b/Xlsx/Sheet.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} +module Xlsx.Sheet where + +import Data.Monoid +import Data.Char +import Text.Blaze +import Text.Blaze.Internal +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Text as T +import Xlsx.Types hiding (Empty) + +decl :: Markup +decl = Content $ Static "\n" + +renderSheet :: [Row] -> Markup +renderSheet rows = Append decl $ wrksh where + wrksh = AddAttribute "bla" " xmlns=\"" "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ + AddAttribute "xmlns:r" " xmlns:r=\"" "http://schemas.openxmlformats.org/officeDocument/2006/relationships" $ + AddAttribute "xmlns:mc" " xmlns:mc=\"" "http://schemas.openxmlformats.org/markup-compatibility/2006" $ + AddAttribute "mc:Ignorable" " mc:Ignorable=\"" "x14ac" $ + AddAttribute "xmlns:x14ac" " xmlns:x14ac=\"" "http://schemas.microsoft.com/office/spreadsheetml/2009/9/ac" $ + Parent "worksheet" "" $ + Parent "sheetData" "" $ go 1 rows + go _ [] = Empty + go n (r:rs) = Append (r n) (go (n+1) rs) diff --git a/Xlsx/Types.hs b/Xlsx/Types.hs new file mode 100644 --- /dev/null +++ b/Xlsx/Types.hs @@ -0,0 +1,14 @@ +module Xlsx.Types + ( Cell + , CellValue(..) + , Row + , FromCell(..) + , FromRow(..) + , ToCell(..) + , ToRow(..) + , unsparse + ) where + +import Xlsx.Types.Internal +import Xlsx.Types.Class +import Xlsx.Types.Instances diff --git a/Xlsx/Types/Class.hs b/Xlsx/Types/Class.hs new file mode 100644 --- /dev/null +++ b/Xlsx/Types/Class.hs @@ -0,0 +1,21 @@ +module Xlsx.Types.Class where + +import Xlsx.Types.Internal +import Control.Applicative +import Control.Monad.Reader +import Data.Vector (Vector) +import Data.Text (Text) +import Text.Blaze.Internal + +class FromRow a where + fromRow :: (Applicative m, Monad m) => [((Int, Int), Cell)] -> ReaderT (Vector Text) m a + +class FromCell a where + fromCell :: (Applicative m, Monad m) => Cell -> ReaderT (Vector Text) m a + +class ToRow a where + toRow :: a -> Row + +class ToCell a where + toCell :: a -> Markup + diff --git a/Xlsx/Types/Instances.hs b/Xlsx/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/Xlsx/Types/Instances.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances, UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Xlsx.Types.Instances where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.Identity +import Data.Char +import Data.Scientific +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.ByteString (ByteString) +import qualified Data.Vector as V +import Text.Blaze +import Text.Blaze.Internal hiding (Empty) +import Xlsx.Types.Internal +import Xlsx.Types.Class + +instance ToCell Integer where + toCell = numericCell + +instance ToCell Int where + toCell = numericCell + +instance ToCell Float where + toCell = numericCell + +instance ToCell Double where + toCell = numericCell + +inlineStr :: Markup -> Markup +inlineStr s = AddAttribute "t" " t=\"" "inlineStr" $ Parent "c" "" $ Parent "is" "" $ + Parent "t" "" s + +instance ToCell ByteString where + toCell = inlineStr . unsafeByteString + +instance ToCell Text where + toCell = inlineStr . toMarkup + +instance ToCell [Char] where + toCell = inlineStr . toMarkup + +rowValue :: Int -> ChoiceString +rowValue n = Text $ T.pack $ show n + +spanRange :: Int -> ChoiceString +spanRange n = Text $ "1:" <> (T.pack $ show n) + +cellName :: Int -> Int -> Markup -> Markup +cellName r c = AddAttribute "r" " r=\"" cell where + cell = Text $ T.pack $ int2col c <> show r + int2col = 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)) + +mkRow :: ChoiceString -> (Int -> Markup) -> Row +mkRow spn m n = AddAttribute "r" " r=\"" (rowValue n) $ AddAttribute "spans" " spans=\"" spn $ + Parent "row" "" $ m n + +instance (ToCell a, ToCell b) => ToRow (a, b) where + toRow (a, b) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) where + spn = spanRange 2 + +instance (ToCell a, ToCell b, ToCell c) => ToRow (a, b, c) where + toRow (a, b, c) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) <> (cellName r 3 $ toCell c) where + spn = spanRange 3 + +instance (ToCell a, ToCell b, ToCell c, ToCell d) => ToRow (a, b, c, d) where + toRow (a, b, c, d) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) <> (cellName r 3 $ toCell c) <> + (cellName r 4 $ toCell d) where + spn = spanRange 3 + +instance (ToCell a, ToCell b, ToCell c, ToCell d, ToCell e) => ToRow (a, b, c, d, e) where + toRow (a, b, c, d, e) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) <> (cellName r 3 $ toCell c) <> + (cellName r 4 $ toCell d) <> (cellName r 5 $ toCell e) where + spn = spanRange 5 + +instance (ToCell a, ToCell b, ToCell c, ToCell d, ToCell e, ToCell f) => ToRow (a, b, c, d, e, f) where + toRow (a, b, c, d, e, f) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) <> (cellName r 3 $ toCell c) <> + (cellName r 4 $ toCell d) <> (cellName r 5 $ toCell e) <> (cellName r 6 $ toCell f) where + spn = spanRange 6 + +instance (ToCell a, ToCell b, ToCell c, ToCell d, ToCell e, ToCell f, ToCell g) => ToRow (a, b, c, d, e, f, g) where + toRow (a, b, c, d, e, f, g) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) <> (cellName r 3 $ toCell c) <> + (cellName r 4 $ toCell d) <> (cellName r 5 $ toCell e) <> (cellName r 6 $ toCell f) <> + (cellName r 7 $ toCell g) where + spn = spanRange 7 + +instance (ToCell a, ToCell b, ToCell c, ToCell d, ToCell e, ToCell f, ToCell g, ToCell h) => + ToRow (a, b, c, d, e, f, g, h) where + toRow (a, b, c, d, e, f, g, h) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) <> (cellName r 3 $ toCell c) <> + (cellName r 4 $ toCell d) <> (cellName r 5 $ toCell e) <> (cellName r 6 $ toCell f) <> + (cellName r 7 $ toCell g) <> (cellName r 8 $ toCell h) where + spn = spanRange 8 + +instance (ToCell a, ToCell b, ToCell c, ToCell d, ToCell e, ToCell f, ToCell g, ToCell h, ToCell i) => + ToRow (a, b, c, d, e, f, g, h, i) where + toRow (a, b, c, d, e, f, g, h, i) = mkRow spn $ \r -> + (cellName r 1 $ toCell a) <> (cellName r 2 $ toCell b) <> (cellName r 3 $ toCell c) <> + (cellName r 4 $ toCell d) <> (cellName r 5 $ toCell e) <> (cellName r 6 $ toCell f) <> + (cellName r 7 $ toCell g) <> (cellName r 8 $ toCell h) <> (cellName r 9 $ toCell i)where + spn = spanRange 9 + +instance ToCell a => ToRow [a] where + toRow cs = mkRow (spanRange $ length cs) $ \r -> mconcat $ map (\(n,c) -> cellName r n $ toCell c) $ zip [1..] cs + +numericCell :: (Num a, ToMarkup a) => a -> Markup +numericCell v = Parent "c" "" $ Parent "v" "" $ toMarkup v + +unsparse :: [((Int, Int), Cell)] -> [Cell] +unsparse cols = go 1 cols where + go _ [] = [] + go n cs@(((_,n'),c):cs') | n' > n = (Empty, Nothing) : go (n+1) cs + | otherwise = c : go (n+1) cs' + +instance FromCell (Text) where + fromCell (SharedString si,_) = (V.! si) <$> ask + fromCell (InlineString s,_) = pure s + fromCell _ = error "expected text" + +instance FromCell (Int) where + fromCell (Number n,_) = pure $ floor n + fromCell _ = error "expected number" + +instance FromCell (Double) where + fromCell (Number n,_) = pure $ toRealFloat n + fromCell _ = error "expected number" + +instance FromCell (Bool) where + fromCell (Number n,_) = pure $ n == 1 + fromCell _ = error "expected bool" + +instance (FromCell a) => FromCell (Maybe a) where + fromCell (Error {},_) = pure Nothing + fromCell (Empty,_) = pure Nothing + fromCell o = Just <$> fromCell o + +instance (FromCell a) => FromRow (Identity a) where + fromRow r = case unsparse r of + [a] -> Identity <$> fromCell a + _ -> error "columns" + +instance (FromCell a, FromCell b) => FromRow (a,b) where + fromRow r = case unsparse r of + [a,b] -> (,) <$> fromCell a <*> fromCell b + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c) => FromRow (a,b,c) where + fromRow r = case unsparse r of + [a,b,c] -> (,,) <$> fromCell a <*> fromCell b <*> fromCell c + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d) => FromRow (a,b,c,d) where + fromRow r = case unsparse r of + [a,b,c,d] -> (,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e) => FromRow (a,b,c,d,e) where + fromRow r = case unsparse r of + [a,b,c,d,e] -> (,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f) => FromRow (a,b,c,d,e,f) where + fromRow r = case unsparse r of + [a,b,c,d,e,f] -> (,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g) => FromRow (a,b,c,d,e,f,g) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g] -> (,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h) => FromRow (a,b,c,d,e,f,g,h) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h] -> (,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i) => FromRow (a,b,c,d,e,f,g,h,i) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i] -> (,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j) => FromRow (a,b,c,d,e,f,g,h,i,j) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j] -> (,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k) => FromRow (a,b,c,d,e,f,g,h,i,j,k) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k] -> (,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l] -> (,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m] -> (,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n] -> (,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o] -> (,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p] -> (,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q] -> (,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r] -> (,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s] -> (,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s, FromCell t) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t] -> (,,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s <*> fromCell t + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s, FromCell t, FromCell u) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u] -> (,,,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s <*> fromCell t <*> fromCell u + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s, FromCell t, FromCell u, FromCell v) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v] -> (,,,,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s <*> fromCell t <*> fromCell u <*> fromCell v + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s, FromCell t, FromCell u, FromCell v, FromCell w) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w] -> (,,,,,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s <*> fromCell t <*> fromCell u <*> fromCell v <*> fromCell w + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s, FromCell t, FromCell u, FromCell v, FromCell w, FromCell x) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x] -> (,,,,,,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s <*> fromCell t <*> fromCell u <*> fromCell v <*> fromCell w <*> fromCell x + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s, FromCell t, FromCell u, FromCell v, FromCell w, FromCell x, FromCell y) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y] -> (,,,,,,,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s <*> fromCell t <*> fromCell u <*> fromCell v <*> fromCell w <*> fromCell x <*> fromCell y + _ -> error "columns" + +instance (FromCell a, FromCell b, FromCell c, FromCell d, FromCell e, FromCell f, FromCell g, FromCell h, FromCell i, FromCell j, FromCell k, FromCell l, FromCell m, FromCell n, FromCell o, FromCell p, FromCell q, FromCell r, FromCell s, FromCell t, FromCell u, FromCell v, FromCell w, FromCell x, FromCell y, FromCell z) => FromRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) where + fromRow r = case unsparse r of + [a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z] -> (,,,,,,,,,,,,,,,,,,,,,,,,,) <$> fromCell a <*> fromCell b <*> fromCell c <*> fromCell d <*> fromCell e <*> fromCell f <*> fromCell g <*> fromCell h <*> fromCell i <*> fromCell j <*> fromCell k <*> fromCell l <*> fromCell m <*> fromCell n <*> fromCell o <*> fromCell p <*> fromCell q <*> fromCell r <*> fromCell s <*> fromCell t <*> fromCell u <*> fromCell v <*> fromCell w <*> fromCell x <*> fromCell y <*> fromCell z + _ -> error "columns" diff --git a/Xlsx/Types/Internal.hs b/Xlsx/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/Xlsx/Types/Internal.hs @@ -0,0 +1,10 @@ +module Xlsx.Types.Internal where + +import Text.Blaze.Internal +import Data.Scientific +import Data.Text (Text) + +data CellValue = InlineString Text | SharedString Int | Number Scientific | Boolean Bool | Date Text | Error Text | Empty deriving (Read, Show, Eq) +type Cell = (CellValue, Maybe Text) + +type Row = Int -> Markup diff --git a/Xlsx/Writer.hs b/Xlsx/Writer.hs new file mode 100644 --- /dev/null +++ b/Xlsx/Writer.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +module Xlsx.Writer (toRow, sheetsLBS, saveXlsx) where + +import Codec.Archive.Zip +import Data.Monoid +import Xlsx.Types hiding (Empty) +import Xlsx.Sheet +import Text.Blaze.Internal +import Text.Blaze.Renderer.Utf8 +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Text.Lazy (Text) +import Data.Time.Format +import Data.Time.Clock.POSIX +import Data.Time.Clock +import System.Locale +import qualified Data.Text as T + +contentTypes :: Int -> Markup +contentTypes n = Append decl $ types $ Append (Content $ Static "") sheets where + sheets = mconcat $ map sheet [1..n] + types = AddAttribute "xmlns" " xmlns=\"" "http://schemas.openxmlformats.org/package/2006/content-types" . + Parent "Types" "" + conttype = AddAttribute "ContentType" " ContentType=\"" + sheet :: Int -> Markup + sheet n = conttype "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" $ + AddAttribute "PartName" " PartName=\"" (String $ "/xl/worksheet/sheet" ++ show n ++ ".xml") $ + Parent "Override" "" Empty + +rootRelXml :: ByteString +rootRelXml = "" + +appXml :: ByteString +appXml = "\n0" + +{-appXml :: [T.Text] -> Markup +appXml sheets = Append decl $ + AddAttribute "xmlns" " xmlns=\"" "http://schemas.openxmlformats.org/officeDocument/2006/extended-properties" $ + AddAttribute "xmlns:vt" " xmlns:vt=\"" "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" $ + Parent "Properties" "" $ + Append (Content $ Static "Microsoft Excel0falseWorksheets1") $ + Append (Parent "TitlesOfParts" "" $ + AddAttribute "baseType" " baseType=\"" "lpstr" $ + AddAttribute "size" " size=\"" (String $ show $ length sheets) $ + Parent "vt:vector" "" sheetMarkup) $ + Content $ Static "falsefalsefalse14.0300" where + sheetMarkup = foldr step Empty sheets + step s = Append $ Parent "vt:lpstr" "" (Content $ Text s) -} + +coreXml :: FormatTime t => T.Text -> t -> Markup +coreXml name time = Append decl $ + AddAttribute "xmlns:cp" " xmlns:cp=\"" "http://schemas.openxmlformats.org/package/2006/metadata/core-properties" $ + AddAttribute "xmlns:dc" " xmlns:dc=\"" "http://purl.org/dc/elements/1.1/" $ + AddAttribute "xmlns:dcterms" " xmlns:dcterms=\"" "http://purl.org/dc/terms/" $ + AddAttribute "xmlns:dcmitype" " xmlns:dcmitype=\"" "http://purl.org/dc/dcmitype/" $ + AddAttribute "xmlns:xsi" " xmlns:xsi=\"" "http://www.w3.org/2001/XMLSchema-instance" $ + Parent "cp:coreProperties" "" $ + Append (Parent "dc:creator" "" name') $ + Append (Parent "cp:lastModifiedBy" "" name') $ + Append (w3cdtf $ Parent "dcterms:created" "" time') $ + w3cdtf $ Parent "dcterms:modified" "" time' where + w3cdtf = AddAttribute "xsi:type" " xsi:type=\"" "dcterms:W3CDTF" + name' = Content $ Text name + time' = Content $ Text $ T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" time + +theme1 :: Markup +theme1 = decl + +workbook :: [T.Text] -> Markup +workbook sheets = Append decl $ + AddAttribute "xmlns" " xmlns=\"" "http://schemas.openxmlformats.org/spreadsheetml/2006/main" $ + AddAttribute "xmlns:r" " xmlns:r=\"" "http://schemas.openxmlformats.org/officeDocument/2006/relationships" $ + Parent "workbook" "" $ Parent "sheets" "" $ sheets' where + sheets' = mconcat $ map sheettag $ zip [1..] sheets + sheettag :: (Int, T.Text) -> Markup + sheettag (n, s) = AddAttribute "name" " name=\"" (Text s) $ + AddAttribute "sheetId" " sheetId=\"" (String $ show n) $ + AddAttribute "r:id" " r:id=\"" (String $ "rId" ++ show n) $ + Parent "sheet" "" Empty + +workbookRels :: Int -> Markup +workbookRels sheets = Append decl $ + AddAttribute "xmlns" " xmlns=\"" "http://schemas.openxmlformats.org/package/2006/relationships" $ + Parent "Relationships" "" $ Append sheets' otherrels where + sheets' = mconcat $ map sheetrel [1..sheets] + typeattr = AddAttribute "Type" " Type=\"" + styles = typeattr "http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles" + rId n = AddAttribute "Id" " Id=\"" (String $ "rId" ++ show n) + target = AddAttribute "Target" " Target=\"" + sheetrel :: Int -> Markup + sheetrel n = typeattr "http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet" $ + rId n $ target (String $ "worksheets/sheet" ++ show n ++ ".xml") reltag + reltag = Parent "Relationship" "" Empty + otherrels = rId (sheets+1) $ target "styles.xml" $ + typeattr "http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles" reltag + +styles :: ByteString +styles = "\n" + +sheetsLBS :: UTCTime -> T.Text -> [(T.Text, [Row])] -> ByteString +sheetsLBS time creator sheets = fromArchive $ foldr addEntryToArchive emptyArchive entries where + t = round $ utcTimeToPOSIXSeconds time + entries = [toEntry "[Content_Types].xml" t (renderMarkup $ contentTypes $ length sheets), + toEntry "_rels/.rels" t rootRelXml, + toEntry "docProps/app.xml" t appXml, + toEntry "docProps/core.xml" t (renderMarkup $ coreXml creator time), + toEntry "xl/styles.xml" t styles, + toEntry "xl/workbook.xml" t (renderMarkup $ workbook $ map fst sheets), + toEntry "xl/theme/theme1.xml" t (renderMarkup theme1), + toEntry "xl/_rels/workbook.xml.rels" t (renderMarkup $ workbookRels $ length sheets)] ++ sheets' + sheets' = map (\(n,(_,rs)) -> toEntry ("xl/worksheets/sheet" ++ show n ++ ".xml") t (renderMarkup $ renderSheet rs)) $ + zip [1..] sheets + +saveXlsx :: T.Text -> [(T.Text, [Row])] -> FilePath -> IO () +saveXlsx creator sheets path = do + curtime <- getCurrentTime + L.writeFile path $ sheetsLBS curtime creator sheets diff --git a/xlsior.cabal b/xlsior.cabal new file mode 100644 --- /dev/null +++ b/xlsior.cabal @@ -0,0 +1,37 @@ +-- Initial xlsior.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: xlsior +version: 0.1.0.0 +synopsis: Streaming Excel file generation and parsing +description: Streaming Excel file generation and parsing +license: MIT +license-file: LICENSE +author: rcallahan +maintainer: ropoctl@gmail.com +-- copyright: +category: Codec +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Xlsx.Writer, Xlsx.Sheet, Xlsx.Parse, Xlsx.Types + other-modules: Xlsx.Types.Internal, Xlsx.Types.Class, Xlsx.Types.Instances + other-extensions: OverloadedStrings + build-depends: base >=4.7 && <4.8, zip-archive >=0.2 && <0.3, blaze-markup >=0.6 && <0.7, text, bytestring, time, old-locale, vector, conduit, xml-conduit, data-default, exceptions, conduit-extra, resourcet, xml-types, mtl, attoparsec, scientific + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall -O2 + ghc-prof-options: -fprof-auto + +Test-Suite test + main-is: Test.hs + type: exitcode-stdio-1.0 + -- other-modules: + other-extensions: OverloadedStrings + build-depends: base >=4.7 && <4.8, zip-archive >=0.2 && <0.3, blaze-markup >=0.6 && <0.7, text, bytestring, time, old-locale + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall -O2 + ghc-prof-options: -fprof-auto