{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData          #-}
{-# LANGUAGE TemplateHaskell     #-}

-- | Writes Excel files from a stream, which allows creation of
--   large Excel files while remaining in constant memory.
module Codec.Xlsx.Writer.Stream
  ( writeXlsx
  , writeXlsxWithSharedStrings
  , SheetWriteSettings(..)
  , defaultSettings
  , wsSheetView
  , wsZip
  , wsColumnProperties
  , wsRowProperties
  , wsStyles
  -- *** Shared strings
  , sharedStrings
  , sharedStringsStream
  ) where

import Codec.Archive.Zip.Conduit.UnZip
import Codec.Archive.Zip.Conduit.Zip
import Codec.Xlsx.Parser.Internal (n_)
import Codec.Xlsx.Parser.Stream
import Codec.Xlsx.Types (ColumnsProperties (..), RowProperties (..),
                         Styles (..), _AutomaticHeight, _CustomHeight,
                         emptyStyles, rowHeightLens)
import Codec.Xlsx.Types.Cell
import Codec.Xlsx.Types.Common
import Codec.Xlsx.Types.Internal.Relationships (odr, pr)
import Codec.Xlsx.Types.SheetViews
import Codec.Xlsx.Writer.Internal (nonEmptyElListSimple, toAttrVal, toElement,
                                   txtd, txti)
import Codec.Xlsx.Writer.Internal.Stream
import Conduit (PrimMonad, yield, (.|))
import qualified Conduit as C
#ifdef USE_MICROLENS
import Data.Traversable.WithIndex
import Lens.Micro.Platform
#else
import Control.Lens
#endif
import Control.Monad.Catch
import Control.Monad.Reader.Class
import Control.Monad.State.Strict
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import Data.Coerce
import Data.Conduit (ConduitT)
import qualified Data.Conduit.List as CL
import Data.Foldable (fold, traverse_)
import Data.List
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
import Data.Word
import Data.XML.Types
import Text.Printf
import Text.XML (toXMLElement)
import qualified Text.XML as TXML
import Text.XML.Stream.Render
import Text.XML.Unresolved (elementToEvents)


upsertSharedStrings :: MonadState SharedStringState m => Row -> m [(Text,Int)]
upsertSharedStrings :: forall (m :: * -> *).
MonadState SharedStringState m =>
Row -> m [(Text, Int)]
upsertSharedStrings Row
row =
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadState SharedStringState m =>
Text -> m (Text, Int)
upsertSharedString [Text]
items
  where
    items :: [Text]
    items :: [Text]
items = Row
row forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. Lens' Row CellRow
ri_cell_row forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
IndexedTraversal Int (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Cell (Maybe CellValue)
cellValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' CellValue Text
_CellText

-- | Process sheetItems into shared strings structure to be put into
--   'writeXlsxWithSharedStrings'
sharedStrings :: Monad m  => ConduitT Row b m (Map Text Int)
sharedStrings :: forall (m :: * -> *) b. Monad m => ConduitT Row b m (Map Text Int)
sharedStrings = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall (m :: * -> *).
Monad m =>
ConduitT Row (Text, Int) m (Map Text Int)
sharedStringsStream forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) b a o.
(Monad m, Monoid b) =>
(a -> b) -> ConduitT a o m b
CL.foldMap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. k -> a -> Map k a
Map.singleton)

-- | creates a unique number for every encountered string in the stream
--   This is used for creating a required structure in the xlsx format
--   called shared strings. Every string get's transformed into a number
--
--   exposed to allow further processing, we also know the map after processing
--   but I don't think conduit provides a way of getting that out.
--   use 'sharedStrings' to just get the map
sharedStringsStream :: Monad m  =>
  ConduitT Row (Text, Int) m (Map Text Int)
sharedStringsStream :: forall (m :: * -> *).
Monad m =>
ConduitT Row (Text, Int) m (Map Text Int)
sharedStringsStream = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Iso' SharedStringState (Map Text Int)
string_map) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s i o r.
Monad m =>
s -> ConduitT i o (StateT s m) r -> ConduitT i o m s
C.execStateC SharedStringState
initialSharedString forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Foldable f) =>
(a -> m (f b)) -> ConduitT a b m ()
CL.mapFoldableM forall (m :: * -> *).
MonadState SharedStringState m =>
Row -> m [(Text, Int)]
upsertSharedStrings

-- | Settings for writing a single sheet.
data SheetWriteSettings = MkSheetWriteSettings
  { SheetWriteSettings -> [SheetView]
_wsSheetView        :: [SheetView]
  , SheetWriteSettings -> ZipOptions
_wsZip              :: ZipOptions -- ^ Enable zipOpt64=True if you intend writing large xlsx files, zip needs 64bit for files over 4gb.
  , SheetWriteSettings -> [ColumnsProperties]
_wsColumnProperties :: [ColumnsProperties]
  , SheetWriteSettings -> Map Int RowProperties
_wsRowProperties    :: Map Int RowProperties
  , SheetWriteSettings -> Styles
_wsStyles           :: Styles
  }
instance Show  SheetWriteSettings where
  -- ZipOptions lacks a show instance-}
  show :: SheetWriteSettings -> String
show (MkSheetWriteSettings [SheetView]
s ZipOptions
_ [ColumnsProperties]
y Map Int RowProperties
r Styles
_) = forall r. PrintfType r => String -> r
printf String
"MkSheetWriteSettings{ _wsSheetView=%s, _wsColumnProperties=%s, _wsZip=defaultZipOptions, _wsRowProperties=%s }" (forall a. Show a => a -> String
show [SheetView]
s) (forall a. Show a => a -> String
show [ColumnsProperties]
y) (forall a. Show a => a -> String
show Map Int RowProperties
r)
makeLenses ''SheetWriteSettings

defaultSettings :: SheetWriteSettings
defaultSettings :: SheetWriteSettings
defaultSettings = MkSheetWriteSettings
  { _wsSheetView :: [SheetView]
_wsSheetView = []
  , _wsColumnProperties :: [ColumnsProperties]
_wsColumnProperties = []
  , _wsRowProperties :: Map Int RowProperties
_wsRowProperties = forall a. Monoid a => a
mempty
  , _wsStyles :: Styles
_wsStyles = Styles
emptyStyles
  , _wsZip :: ZipOptions
_wsZip = ZipOptions
defaultZipOptions {
  zipOpt64 :: Bool
zipOpt64 = Bool
False
  -- There is a magick number in the zip archive package,
  -- https://hackage.haskell.org/package/zip-archive-0.4.1/docs/src/Codec.Archive.Zip.html#local-6989586621679055672
  -- if we enable 64bit the number doesn't align causing the test to fail.
  }
  }



-- | Transform a 'Row' stream into a stream that creates the xlsx file format
--   (to be consumed by sinkfile for example)
--  This first runs 'sharedStrings' and then 'writeXlsxWithSharedStrings'.
--  If you want xlsx files this is the most obvious function to use.
--  the others are exposed in case you can cache the shared strings for example.
--
--  Note that the current implementation concatenates everything into a single sheet.
--  In other words there is no support for writing multiple sheets
writeXlsx :: MonadThrow m
    => PrimMonad m
    => SheetWriteSettings -- ^ use 'defaultSettings'
    -> ConduitT () Row m () -- ^ the conduit producing sheetitems
    -> ConduitT () ByteString m Word64 -- ^ result conduit producing xlsx files
writeXlsx :: forall (m :: * -> *).
(MonadThrow m, PrimMonad m) =>
SheetWriteSettings
-> ConduitT () Row m () -> ConduitT () ByteString m Word64
writeXlsx SheetWriteSettings
settings ConduitT () Row m ()
sheetC = do
    Map Text Int
sstrings  <- ConduitT () Row m ()
sheetC forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) b. Monad m => ConduitT Row b m (Map Text Int)
sharedStrings
    forall (m :: * -> *).
(MonadThrow m, PrimMonad m) =>
SheetWriteSettings
-> Map Text Int
-> ConduitT () Row m ()
-> ConduitT () ByteString m Word64
writeXlsxWithSharedStrings SheetWriteSettings
settings Map Text Int
sstrings ConduitT () Row m ()
sheetC


-- TODO maybe should use bimap instead: https://hackage.haskell.org/package/bimap-0.4.0/docs/Data-Bimap.html
-- it guarantees uniqueness of both text and int
-- | This write Excel file with a shared strings lookup table.
--   It appears that it is optional.
--   Failed lookups will result in valid xlsx.
--   There are several conditions on shared strings,
--
--      1. Every text to int is unique on both text and int.
--      2. Every Int should have a gap no greater than 1. [("xx", 3), ("yy", 4)] is okay, whereas [("xx", 3), ("yy", 5)] is not.
--      3. It's expected this starts from 0.
--
--   Use 'sharedStringsStream' to get a good shared strings table.
--   This is provided because the user may have a more efficient way of
--   constructing this table than the library can provide,
--   for example through database operations.
writeXlsxWithSharedStrings :: MonadThrow m => PrimMonad m
    => SheetWriteSettings
    -> Map Text Int -- ^ shared strings table
    -> ConduitT () Row m ()
    -> ConduitT () ByteString m Word64
writeXlsxWithSharedStrings :: forall (m :: * -> *).
(MonadThrow m, PrimMonad m) =>
SheetWriteSettings
-> Map Text Int
-> ConduitT () Row m ()
-> ConduitT () ByteString m Word64
writeXlsxWithSharedStrings SheetWriteSettings
settings Map Text Int
sharedStrings' ConduitT () Row m ()
items =
  forall (m :: * -> *).
PrimMonad m =>
SheetWriteSettings
-> Map Text Int
-> ConduitT () Row m ()
-> ConduitT () (ZipEntry, ZipData m) m ()
combinedFiles SheetWriteSettings
settings Map Text Int
sharedStrings' ConduitT () Row m ()
items forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
(MonadThrow m, PrimMonad m) =>
ZipOptions -> ConduitM (ZipEntry, ZipData m) ByteString m Word64
zipStream (SheetWriteSettings
settings forall s a. s -> Getting a s a -> a
^. Lens' SheetWriteSettings ZipOptions
wsZip)

-- massive amount of boilerplate needed for excel to function
boilerplate :: forall m . PrimMonad m  => SheetWriteSettings -> Map Text Int -> [(ZipEntry,  ZipData m)]
boilerplate :: forall (m :: * -> *).
PrimMonad m =>
SheetWriteSettings -> Map Text Int -> [(ZipEntry, ZipData m)]
boilerplate SheetWriteSettings
settings Map Text Int
sharedStrings' =
  [ (Text -> ZipEntry
zipEntry Text
"xl/sharedStrings.xml", forall (m :: * -> *). ConduitM () ByteString m () -> ZipData m
ZipDataSource forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Map Text Int -> forall i. ConduitT i Event m ()
writeSst Map Text Int
sharedStrings' forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). PrimMonad m => ConduitT Event ByteString m ()
eventsToBS)
  , (Text -> ZipEntry
zipEntry Text
"[Content_Types].xml", forall (m :: * -> *). ConduitM () ByteString m () -> ZipData m
ZipDataSource forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeContentTypes forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). PrimMonad m => ConduitT Event ByteString m ()
eventsToBS)
  , (Text -> ZipEntry
zipEntry Text
"xl/workbook.xml", forall (m :: * -> *). ConduitM () ByteString m () -> ZipData m
ZipDataSource forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeWorkbook forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). PrimMonad m => ConduitT Event ByteString m ()
eventsToBS)
  , (Text -> ZipEntry
zipEntry Text
"xl/styles.xml", forall (m :: * -> *). ByteString -> ZipData m
ZipDataByteString forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ SheetWriteSettings
settings forall s a. s -> Getting a s a -> a
^. Lens' SheetWriteSettings Styles
wsStyles)
  , (Text -> ZipEntry
zipEntry Text
"xl/_rels/workbook.xml.rels", forall (m :: * -> *). ConduitM () ByteString m () -> ZipData m
ZipDataSource forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeWorkbookRels forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). PrimMonad m => ConduitT Event ByteString m ()
eventsToBS)
  , (Text -> ZipEntry
zipEntry Text
"_rels/.rels", forall (m :: * -> *). ConduitM () ByteString m () -> ZipData m
ZipDataSource forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeRootRels forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). PrimMonad m => ConduitT Event ByteString m ()
eventsToBS)
  ]

combinedFiles :: PrimMonad m
  => SheetWriteSettings
  -> Map Text Int
  -> ConduitT () Row m ()
  -> ConduitT () (ZipEntry, ZipData m) m ()
combinedFiles :: forall (m :: * -> *).
PrimMonad m =>
SheetWriteSettings
-> Map Text Int
-> ConduitT () Row m ()
-> ConduitT () (ZipEntry, ZipData m) m ()
combinedFiles SheetWriteSettings
settings Map Text Int
sharedStrings' ConduitT () Row m ()
items =
  forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
C.yieldMany forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
PrimMonad m =>
SheetWriteSettings -> Map Text Int -> [(ZipEntry, ZipData m)]
boilerplate SheetWriteSettings
settings  Map Text Int
sharedStrings' forall a. Semigroup a => a -> a -> a
<>
    [(Text -> ZipEntry
zipEntry Text
"xl/worksheets/sheet1.xml", forall (m :: * -> *). ConduitM () ByteString m () -> ZipData m
ZipDataSource forall a b. (a -> b) -> a -> b
$
       ConduitT () Row m ()
items forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) r i o res.
Monad m =>
r -> ConduitT i o (ReaderT r m) res -> ConduitT i o m res
C.runReaderC SheetWriteSettings
settings (forall (m :: * -> *).
MonadReader SheetWriteSettings m =>
Map Text Int -> ConduitT Row Event m ()
writeWorkSheet Map Text Int
sharedStrings') forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). PrimMonad m => ConduitT Event ByteString m ()
eventsToBS )]

el :: Monad m => Name -> Monad m => forall i.  ConduitT i Event m () -> ConduitT i Event m ()
el :: forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el Name
x = forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
x forall a. Monoid a => a
mempty

--   Clark notation is used a lot for xml namespaces in this module:
--   <https://hackage.haskell.org/package/xml-types-0.3.8/docs/Data-XML-Types.html#t:Name>
--   Name has an IsString instance which parses it
override :: Monad m => Text -> Text -> forall i.  ConduitT i Event m ()
override :: forall (m :: * -> *).
Monad m =>
Text -> Text -> forall i. ConduitT i Event m ()
override Text
content' Text
part =
    forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"{http://schemas.openxmlformats.org/package/2006/content-types}Override"
      (Name -> Text -> Attributes
attr Name
"ContentType" Text
content'
       forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"PartName" Text
part) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | required by Excel.
writeContentTypes :: Monad m => forall i.  ConduitT i Event m ()
writeContentTypes :: forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeContentTypes = forall (m :: * -> *).
Monad m =>
Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc Name
"{http://schemas.openxmlformats.org/package/2006/content-types}Types" forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
Monad m =>
Text -> Text -> forall i. ConduitT i Event m ()
override Text
"application/vnd.openxmlformats-officedocument.spreadsheetml.sheet.main+xml" Text
"/xl/workbook.xml"
    forall (m :: * -> *).
Monad m =>
Text -> Text -> forall i. ConduitT i Event m ()
override Text
"application/vnd.openxmlformats-officedocument.spreadsheetml.sharedStrings+xml" Text
"/xl/sharedStrings.xml"
    forall (m :: * -> *).
Monad m =>
Text -> Text -> forall i. ConduitT i Event m ()
override Text
"application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml" Text
"/xl/styles.xml"
    forall (m :: * -> *).
Monad m =>
Text -> Text -> forall i. ConduitT i Event m ()
override Text
"application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" Text
"/xl/worksheets/sheet1.xml"
    forall (m :: * -> *).
Monad m =>
Text -> Text -> forall i. ConduitT i Event m ()
override Text
"application/vnd.openxmlformats-package.relationships+xml" Text
"/xl/_rels/workbook.xml.rels"
    forall (m :: * -> *).
Monad m =>
Text -> Text -> forall i. ConduitT i Event m ()
override Text
"application/vnd.openxmlformats-package.relationships+xml" Text
"/_rels/.rels"

-- | required by Excel.
writeWorkbook :: Monad m => forall i.  ConduitT i Event m ()
writeWorkbook :: forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeWorkbook = forall (m :: * -> *).
Monad m =>
Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc (Text -> Name
n_ Text
"workbook") forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el (Text -> Name
n_ Text
"sheets") forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag (Text -> Name
n_ Text
"sheet")
        (Name -> Text -> Attributes
attr Name
"name" Text
"Sheet1"
         forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"sheetId" Text
"1" forall a. Semigroup a => a -> a -> a
<>
         Name -> Text -> Attributes
attr (Text -> Name
odr Text
"id") Text
"rId3") forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

doc :: Monad m => Name ->  forall i.  ConduitT i Event m () -> ConduitT i Event m ()
doc :: forall (m :: * -> *).
Monad m =>
Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc Name
root ConduitT i Event m ()
docM = do
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Event
EventBeginDocument
  forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el Name
root ConduitT i Event m ()
docM
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Event
EventEndDocument

relationship :: Monad m => Text -> Int -> Text ->  forall i.  ConduitT i Event m ()
relationship :: forall (m :: * -> *).
Monad m =>
Text -> Int -> Text -> forall i. ConduitT i Event m ()
relationship Text
target Int
id' Text
type' =
  forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag (Text -> Name
pr Text
"Relationship")
    (Name -> Text -> Attributes
attr Name
"Type" Text
type'
      forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"Id" (String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ String
"rId" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
id')
      forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"Target" Text
target
    ) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

writeWorkbookRels :: Monad m => forall i.  ConduitT i Event m ()
writeWorkbookRels :: forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeWorkbookRels = forall (m :: * -> *).
Monad m =>
Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc (Text -> Name
pr Text
"Relationships") forall a b. (a -> b) -> a -> b
$  do
  forall (m :: * -> *).
Monad m =>
Text -> Int -> Text -> forall i. ConduitT i Event m ()
relationship Text
"sharedStrings.xml" Int
1 Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/sharedStrings"
  forall (m :: * -> *).
Monad m =>
Text -> Int -> Text -> forall i. ConduitT i Event m ()
relationship Text
"worksheets/sheet1.xml" Int
3 Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/worksheet"
  forall (m :: * -> *).
Monad m =>
Text -> Int -> Text -> forall i. ConduitT i Event m ()
relationship Text
"styles.xml" Int
2 Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/styles"

writeRootRels :: Monad m => forall i.  ConduitT i Event m ()
writeRootRels :: forall (m :: * -> *) i. Monad m => ConduitT i Event m ()
writeRootRels = forall (m :: * -> *).
Monad m =>
Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc (Text -> Name
pr Text
"Relationships") forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *).
Monad m =>
Text -> Int -> Text -> forall i. ConduitT i Event m ()
relationship Text
"xl/workbook.xml" Int
1 Text
"http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"


zipEntry :: Text -> ZipEntry
zipEntry :: Text -> ZipEntry
zipEntry Text
x = ZipEntry
  { zipEntryName :: Either Text ByteString
zipEntryName = forall a b. a -> Either a b
Left Text
x
  , zipEntryTime :: LocalTime
zipEntryTime = Day -> TimeOfDay -> LocalTime
LocalTime (forall a. Enum a => Int -> a
toEnum Int
0) TimeOfDay
midnight
  , zipEntrySize :: Maybe Word64
zipEntrySize = forall a. Maybe a
Nothing
  , zipEntryExternalAttributes :: Maybe Word32
zipEntryExternalAttributes = forall a. Maybe a
Nothing
  }

eventsToBS :: PrimMonad m  => ConduitT Event ByteString m ()
eventsToBS :: forall (m :: * -> *). PrimMonad m => ConduitT Event ByteString m ()
eventsToBS = forall (m :: * -> *). PrimMonad m => ConduitT Event Builder m ()
writeEvents forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *).
PrimMonad m =>
ConduitT Builder ByteString m ()
C.builderToByteString

writeSst ::  Monad m  => Map Text Int  -> forall i.  ConduitT i Event m ()
writeSst :: forall (m :: * -> *).
Monad m =>
Map Text Int -> forall i. ConduitT i Event m ()
writeSst Map Text Int
sharedStrings' = forall (m :: * -> *).
Monad m =>
Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc (Text -> Name
n_ Text
"sst") forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el (Text -> Name
n_ Text
"si") forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el (Text -> Name
n_ Text
"t") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) i. Monad m => Text -> ConduitT i Event m ()
content forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
                  ) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Text
_, Int
i) (Text
_, Int
y :: Int) -> forall a. Ord a => a -> a -> Ordering
compare Int
i Int
y) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Text Int
sharedStrings'

writeEvents ::  PrimMonad m => ConduitT Event Builder m ()
writeEvents :: forall (m :: * -> *). PrimMonad m => ConduitT Event Builder m ()
writeEvents = forall (m :: * -> *).
Monad m =>
RenderSettings -> ConduitT Event Builder m ()
renderBuilder (forall a. Default a => a
def {rsPretty :: Bool
rsPretty=Bool
False})

sheetViews :: forall m . MonadReader SheetWriteSettings m => forall i . ConduitT i Event m ()
sheetViews :: forall (m :: * -> *) i.
MonadReader SheetWriteSettings m =>
ConduitT i Event m ()
sheetViews = do
  [SheetView]
sheetView <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SheetWriteSettings [SheetView]
wsSheetView

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SheetView]
sheetView) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el (Text -> Name
n_ Text
"sheetViews") forall a b. (a -> b) -> a -> b
$ do
    let
        view' :: [Element]
        view' :: [Element]
view' = Text -> Element -> Element
setNameSpaceRec Text
spreadSheetNS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Element
toXMLElement forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall a. ToElement a => Name -> a -> Element
toElement (Text -> Name
n_ Text
"sheetView") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SheetView]
sheetView

    forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
C.yieldMany forall a b. (a -> b) -> a -> b
$ Element -> [Event]
elementToEvents forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Element]
view'

spreadSheetNS :: Text
spreadSheetNS :: Text
spreadSheetNS = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ Name -> Maybe Text
nameNamespace forall a b. (a -> b) -> a -> b
$ Text -> Name
n_ Text
""

setNameSpaceRec :: Text -> Element -> Element
setNameSpaceRec :: Text -> Element -> Element
setNameSpaceRec Text
space Element
xelm =
    Element
xelm {elementName :: Name
elementName = ((Element -> Name
elementName Element
xelm ){nameNamespace :: Maybe Text
nameNamespace =
                                    forall a. a -> Maybe a
Just Text
space })
      , elementNodes :: [Node]
elementNodes = Element -> [Node]
elementNodes Element
xelm forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
                                    NodeElement Element
x -> Element -> Node
NodeElement (Text -> Element -> Element
setNameSpaceRec Text
space Element
x)
                                    Node
y -> Node
y
    }

columns :: MonadReader SheetWriteSettings m => ConduitT Row Event m ()
columns :: forall (m :: * -> *).
MonadReader SheetWriteSettings m =>
ConduitT Row Event m ()
columns = do
  [ColumnsProperties]
colProps <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SheetWriteSettings [ColumnsProperties]
wsColumnProperties
  let cols :: Maybe TXML.Element
      cols :: Maybe Element
cols = Name -> [Element] -> Maybe Element
nonEmptyElListSimple (Text -> Name
n_ Text
"cols") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. ToElement a => Name -> a -> Element
toElement (Text -> Name
n_ Text
"col")) [ColumnsProperties]
colProps
  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
C.yieldMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Event]
elementToEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Element
toXMLElement) Maybe Element
cols

writeWorkSheet :: MonadReader SheetWriteSettings  m => Map Text Int  -> ConduitT Row Event m ()
writeWorkSheet :: forall (m :: * -> *).
MonadReader SheetWriteSettings m =>
Map Text Int -> ConduitT Row Event m ()
writeWorkSheet Map Text Int
sharedStrings' = forall (m :: * -> *).
Monad m =>
Name -> forall i. ConduitT i Event m () -> ConduitT i Event m ()
doc (Text -> Name
n_ Text
"worksheet") forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) i.
MonadReader SheetWriteSettings m =>
ConduitT i Event m ()
sheetViews
    forall (m :: * -> *).
MonadReader SheetWriteSettings m =>
ConduitT Row Event m ()
columns
    forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el (Text -> Name
n_ Text
"sheetData") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
C.awaitForever (forall (m :: * -> *).
MonadReader SheetWriteSettings m =>
Map Text Int -> Row -> ConduitT Row Event m ()
mapRow Map Text Int
sharedStrings')

mapRow :: MonadReader SheetWriteSettings m => Map Text Int -> Row -> ConduitT Row Event m ()
mapRow :: forall (m :: * -> *).
MonadReader SheetWriteSettings m =>
Map Text Int -> Row -> ConduitT Row Event m ()
mapRow Map Text Int
sharedStrings' Row
sheetItem = do
  Maybe Double
mRowProp <- forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview forall a b. (a -> b) -> a -> b
$ Lens' SheetWriteSettings (Map Int RowProperties)
wsRowProperties forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (RowIndex -> Int
unRowIndex RowIndex
rowIx) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' RowProperties (Maybe RowHeight)
rowHeightLens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s t a b.
(Conjoined p, Applicative f) =>
Traversing p f s t a b -> Over p f s t a b -> Over p f s t a b
failing Prism' RowHeight Double
_CustomHeight Prism' RowHeight Double
_AutomaticHeight
  let rowAttr :: Attributes
      rowAttr :: Attributes
rowAttr = Attributes
ixAttr forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Name -> Text -> Attributes
attr Name
"ht" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Text
txtd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
mRowProp)
  forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag (Text -> Name
n_ Text
"row") Attributes
rowAttr forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall i (t :: * -> *) (f :: * -> *) a b.
(TraversableWithIndex i t, Applicative f) =>
(i -> a -> f b) -> t a -> f (t b)
itraverse (forall (m :: * -> *).
Monad m =>
Map Text Int -> RowIndex -> Int -> Cell -> ConduitT Row Event m ()
mapCell Map Text Int
sharedStrings' RowIndex
rowIx) (Row
sheetItem forall s a. s -> Getting a s a -> a
^. Lens' Row CellRow
ri_cell_row)
  where
    rowIx :: RowIndex
rowIx = Row
sheetItem forall s a. s -> Getting a s a -> a
^. Lens' Row RowIndex
ri_row_index
    ixAttr :: Attributes
ixAttr = Name -> Text -> Attributes
attr Name
"r" forall a b. (a -> b) -> a -> b
$ forall a. ToAttrVal a => a -> Text
toAttrVal RowIndex
rowIx

mapCell ::
  Monad m => Map Text Int -> RowIndex -> Int -> Cell -> ConduitT Row Event m ()
mapCell :: forall (m :: * -> *).
Monad m =>
Map Text Int -> RowIndex -> Int -> Cell -> ConduitT Row Event m ()
mapCell Map Text Int
sharedStrings' RowIndex
rix Int
cix' Cell
cell =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall s a. Getting Any s a -> s -> Bool
has (Lens' Cell (Maybe CellValue)
cellValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just) Cell
cell Bool -> Bool -> Bool
|| forall s a. Getting Any s a -> s -> Bool
has (Lens' Cell (Maybe Int)
cellStyle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just) Cell
cell) forall a b. (a -> b) -> a -> b
$
  forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag (Text -> Name
n_ Text
"c") Attributes
celAttr forall a b. (a -> b) -> a -> b
$
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall s a. Getting Any s a -> s -> Bool
has (Lens' Cell (Maybe CellValue)
cellValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just) Cell
cell) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
Monad m =>
Name
-> forall i.
   Monad m =>
   ConduitT i Event m () -> ConduitT i Event m ()
el (Text -> Name
n_ Text
"v") forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) i. Monad m => Text -> ConduitT i Event m ()
content forall a b. (a -> b) -> a -> b
$ Map Text Int -> Cell -> Text
renderCell Map Text Int
sharedStrings' Cell
cell
  where
    cix :: ColumnIndex
cix = Int -> ColumnIndex
ColumnIndex Int
cix'
    celAttr :: Attributes
celAttr  = Name -> Text -> Attributes
attr Name
"r" Text
ref forall a. Semigroup a => a -> a -> a
<>
      Map Text Int -> Cell -> Attributes
renderCellType Map Text Int
sharedStrings' Cell
cell
      forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Name -> Text -> Attributes
attr Name
"s" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Text
txti) (Cell
cell forall s a. s -> Getting a s a -> a
^. Lens' Cell (Maybe Int)
cellStyle)
    ref :: Text
    ref :: Text
ref = coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ (RowIndex, ColumnIndex) -> CellRef
singleCellRef (RowIndex
rix, ColumnIndex
cix)

renderCellType :: Map Text Int -> Cell -> Attributes
renderCellType :: Map Text Int -> Cell -> Attributes
renderCellType Map Text Int
sharedStrings' Cell
cell =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty
  (Name -> Text -> Attributes
attr Name
"t" forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Int -> CellValue -> Text
renderType Map Text Int
sharedStrings')
  forall a b. (a -> b) -> a -> b
$ Cell
cell forall s a. s -> Getting (First a) s a -> Maybe a
^? Lens' Cell (Maybe CellValue)
cellValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

renderCell :: Map Text Int -> Cell -> Text
renderCell :: Map Text Int -> Cell -> Text
renderCell Map Text Int
sharedStrings' Cell
cell =  Map Text Int -> CellValue -> Text
renderValue Map Text Int
sharedStrings' CellValue
val
  where
    val :: CellValue
    val :: CellValue
val = forall a. a -> Maybe a -> a
fromMaybe (Text -> CellValue
CellText forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$ Cell
cell forall s a. s -> Getting (First a) s a -> Maybe a
^? Lens' Cell (Maybe CellValue)
cellValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just

renderValue :: Map Text Int -> CellValue -> Text
renderValue :: Map Text Int -> CellValue -> Text
renderValue Map Text Int
sharedStrings' = \case
  CellText Text
x ->
    -- if we can't find it in the sst, print the string
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
x forall a. ToAttrVal a => a -> Text
toAttrVal forall a b. (a -> b) -> a -> b
$ Map Text Int
sharedStrings' forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
x
  CellDouble Double
x -> forall a. ToAttrVal a => a -> Text
toAttrVal Double
x
  CellBool Bool
b -> forall a. ToAttrVal a => a -> Text
toAttrVal Bool
b
  CellRich [RichTextRun]
_ -> forall a. HasCallStack => String -> a
error String
"rich text is not supported yet"
  CellError ErrorType
err  -> forall a. ToAttrVal a => a -> Text
toAttrVal ErrorType
err


renderType :: Map Text Int -> CellValue -> Text
renderType :: Map Text Int -> CellValue -> Text
renderType Map Text Int
sharedStrings' = \case
  CellText Text
x ->
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"str" (forall a b. a -> b -> a
const Text
"s") forall a b. (a -> b) -> a -> b
$ Map Text Int
sharedStrings' forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Text
x
  CellDouble Double
_ -> Text
"n"
  CellBool Bool
_ -> Text
"b"
  CellRich [RichTextRun]
_ -> Text
"r"
  CellError ErrorType
_ -> Text
"e"