Impl very basic & naive serialization

Makefile

@@ -5,7 +5,7 @@ cli: build
 	stack exec cli
 
 sandbox: build
-	stack exec sandbox -- ./examples/bar.xlsx
+	stack exec sandbox -- ./examples/static1.xlsx
 
 build:
 	stack build

aeson-xlsx.cabal

@@ -2,7 +2,7 @@
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: d40d8b1d44aed81cc99eef50f0d5800cf250e174ebff6ff690d912f8d398aada
+-- hash: 9279c803562d5e92a613baa69ca3d38b9ece2b3cef933c49eabbe066254834a8
 
 name:           aeson-xlsx
 version:        0.1.0.0
@@ -24,37 +24,43 @@ extra-source-files:
 library
   hs-source-dirs:
       src
-  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards
+  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards DeriveGeneric
   build-depends:
       aeson
     , base >=4.7 && <5
     , base-unicode-symbols
     , bytestring
     , containers
+    , data-default
     , lens
     , mtl
+    , scientific
     , text
     , transformers
     , xlsx
   exposed-modules:
       Data.Aeson.Xlsx
+      Data.Aeson.Xlsx.Types
+      Data.Aeson.Xlsx.Utils
   other-modules:
       Paths_aeson_xlsx
   default-language: Haskell2010
 
 executable cli
   main-is: exe/CLI.hs
-  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards
+  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards DeriveGeneric
   build-depends:
       aeson
     , aeson-xlsx
     , base >=4.7 && <5
     , base-unicode-symbols
     , bytestring
     , containers
+    , data-default
     , lens
     , mtl
     , optparse-applicative
+    , scientific
     , text
     , transformers
     , xlsx
@@ -64,17 +70,19 @@ executable cli
 
 executable sandbox
   main-is: exe/Sandbox.hs
-  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards
+  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards DeriveGeneric
   build-depends:
       aeson
     , aeson-xlsx
     , base >=4.7 && <5
     , base-unicode-symbols
     , bytestring
     , containers
+    , data-default
     , groom
     , lens
     , mtl
+    , scientific
     , text
     , transformers
     , xlsx
@@ -87,17 +95,19 @@ test-suite spec
   main-is: Spec.hs
   hs-source-dirs:
       test
-  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards
+  default-extensions: UnicodeSyntax OverloadedStrings RecordWildCards DeriveGeneric
   build-depends:
       aeson
     , aeson-xlsx
     , base >=4.7 && <5
     , base-unicode-symbols
     , bytestring
     , containers
+    , data-default
     , hspec
     , lens
     , mtl
+    , scientific
     , text
     , transformers
     , xlsx

exe/Sandbox.hs

@@ -1,24 +1,30 @@
 module Main where
 
 import Prelude.Unicode
+import Debug.Trace (trace)
 import System.Environment (getArgs)
 import Control.Exception (Exception, SomeException, throwIO)
 import Control.Monad.Except (ExceptT(..), runExceptT)
 import Control.Monad.Trans.Except (except)
 import Control.Monad ((>=>), guard, void)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
-import Control.Lens ((^?), (^.))
-import Data.Maybe (fromJust)
+import Control.Lens ((^?), (^.), view)
+import Data.Maybe (isJust, fromJust, fromMaybe)
 import qualified Data.Map as Map
-import Data.Map (Map)
+import Data.Map (Map, (!), (!?))
+import Data.Default (def)
 import Data.Typeable
 import Data.Aeson
+import Data.ByteString.Lazy.Char8 (unpack)
+import qualified Data.ByteString.Lazy.Char8 as LBSC8
 import Data.ByteString.Lazy (ByteString)
-import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy as LBS
 import Codec.Xlsx
-import Codec.Xlsx.Formatted (FormattedCell, toFormattedCells)
+import Codec.Xlsx.Types.StyleSheet
+import Codec.Xlsx.Formatted (FormattedCell, toFormattedCells, formattedCell)
 import Text.Groom
+import Data.Aeson.Xlsx
 
 data AesonXlsxError
   = ConversionError
@@ -27,25 +33,72 @@ data AesonXlsxError
 
 instance Exception AesonXlsxError
 
+type FormattedCellMap = Map (Int, Int) FormattedCell
+
 load ∷ FilePath → IO (Xlsx, StyleSheet)
 load file = do
-  xlsx ← liftIO $ toXlsx <$> L.readFile file
+  xlsx ← liftIO $ toXlsx <$> LBS.readFile file
   let styles = xlsx ^. xlStyles
-  stylesheet ← either throwIO return (parseStyleSheet styles)
+  stylesheet ← either throwIO return $ parseStyleSheet styles
   return (xlsx, stylesheet)
 
 main ∷ IO ()
 main = do
   args ← getArgs
   guard $ not ∘ null $ args
   (xlsx, stylesheet) ← load $ head args
-  let worksheet = fromJust $ xlsx ^? ixSheet sheetName
-      cells     = worksheet ^. wsCells
-      merges    = worksheet ^. wsMerges
-      fcells    = toFormattedCells cells merges stylesheet
-  putStrLn $ groom $ Map.lookup (2, 2) fcells
+  let worksheet   = fromJust $ xlsx ^? ixSheet sheetName
+      cells       = worksheet ^. wsCells
+      merges      = worksheet ^. wsMerges
+      full        = toFormattedCells cells merges stylesheet
+      significant = significantCells full
+  -- putStrLn "full:"
+  -- putStrLn $ groom $ full
+  -- putStrLn "significant:"
+  -- putStrLn $ groom $ significant
+  -- putStrLn $ groom $ Map.lookup (2, 2) significant
+  LBSC8.putStrLn $ encode $ toMatrix significant
   return ()
-    where sheetName = "форма 1"
+    where sheetName = "Лист1"
+
+-- style
+-- formula
+-- value
+
+type Coords = (Int, Int)
+type Dimensions = (Coords, Coords)
+
+dimensions ∷ FormattedCellMap → Dimensions
+dimensions cells = ((x1, y1), (x2, y2))
+  where
+    x1   = minimum cols
+    y1   = minimum rows
+    x2   = maximum cols
+    y2   = maximum rows
+    rows = fst <$> keys
+    cols = snd <$> keys
+    keys = Map.keys cells
+
+rowCells ∷ FormattedCellMap → [Int] → Int → [FormattedCell]
+rowCells cells cols row = fromMaybe def ∘ cellAt <$> cols
+  where
+    cellAt col = cells !? (row, col)
+
+-- [i, j]
+
+toMatrix ∷ FormattedCellMap → [[FormattedCell]]
+toMatrix cells = rowCells cells cols <$> rows
+  where
+    rows = fst <$> keys
+    cols = snd <$> keys
+    keys = Map.keys cells
+
+significantCells ∷ FormattedCellMap → FormattedCellMap
+significantCells = Map.filter hasFilterOrFormula
+  where
+    hasFilterOrFormula = (||) <$> hasValue <*> hasFormula
+    hasValue           = isJust ∘ (view $ formattedCell ∘ cellValue)
+    hasFormula         = isJust ∘ (view $ formattedCell ∘ cellFormula)
 
 type Result' = Either String Int
 

package.yaml

@@ -15,6 +15,7 @@ default-extensions:
   - UnicodeSyntax
   - OverloadedStrings
   - RecordWildCards
+  - DeriveGeneric
 
 library:
   source-dirs:
@@ -46,6 +47,8 @@ dependencies:
   - base-unicode-symbols
   - text
   - bytestring
+  - scientific
+  - data-default
   - transformers
   - containers
   - mtl

src/Data/Aeson/Xlsx.hs

@@ -1 +1,129 @@
 module Data.Aeson.Xlsx where
+
+import Prelude.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Control.Lens (Lens', (^?), (^.), to, views)
+import Control.Lens.Prism (_Just)
+import Data.Scientific (fromFloatDigits)
+import Data.Aeson
+import Codec.Xlsx
+import Codec.Xlsx.Formatted
+import Codec.Xlsx.Writer.Internal (toAttrVal)
+import Data.Aeson.Xlsx.Utils (omitNulls)
+
+instance ToJSON FormattedCell where
+  toJSON FormattedCell {..} = omitNulls
+    [ "cell"    .= _formattedCell
+    , "style"   .= _formattedFormat
+    , "colSpan" .= toSpan _formattedColSpan
+    , "rowSpan" .= toSpan _formattedRowSpan
+    ]
+    where
+      toSpan 1 = Nothing
+      toSpan x = Just x
+
+instance ToJSON Cell where
+  toJSON x = omitNulls
+    [ "value"   .= (x ^. cellValue)
+    , "formula" .= (x ^? formula)
+    ]
+    where
+      formula = cellFormula ∘ _Just ∘ to (formulaText ∘ _cellfExpression) ∘ _Just
+      formulaText ∷ FormulaExpression → Maybe Text
+      formulaText (NormalFormula f) = Just $ unFormula f
+      formulaText (SharedFormula _) = Nothing
+
+instance ToJSON CellValue where
+  toJSON (CellText x)   = String x
+  toJSON (CellDouble x) = Number $ fromFloatDigits x
+  toJSON (CellBool x)   = Bool x
+  toJSON (CellRich x)   = String $ T.concat $ _richTextRunText <$> x
+  toJSON (CellError x)  = String $ toAttrVal x
+
+-- | `Format` to cell CSS properties.
+instance ToJSON Format where
+  toJSON x = omitNulls
+    [ "align-content"         .= (x ^? formatAlignment ∘ _Just ∘ alignmentHorizontal ∘ _Just)
+    , "justify-content"       .= (x ^? formatAlignment ∘ _Just ∘ alignmentVertical ∘ _Just)
+    , "word-wrap"             .= views (formatAlignment ∘ _Just ∘ alignmentWrapText ∘ _Just) toWordWrap x
+    , "border-left-style"     .= (x ^? (formatBorder ∘ _Just ∘ borderLeft  ∘ _Just ∘ borderStyleLine ∘ _Just))
+    , "border-right-style"    .= (x ^? (formatBorder ∘ _Just ∘ borderRight ∘ _Just ∘ borderStyleLine ∘ _Just))
+    , "border-left-color"     .= (x ^? (formatBorder ∘ _Just ∘ borderLeft  ∘ _Just ∘ borderStyleColor ∘ _Just))
+    , "border-right-color"    .= (x ^? (formatBorder ∘ _Just ∘ borderRight ∘ _Just ∘ borderStyleColor ∘ _Just))
+    , "font-family"           .= (x ^? (formatFont ∘ _Just ∘ fontName ∘ _Just))
+    , "font-weight"           .= views (formatFont ∘ _Just ∘ fontBold ∘ _Just) toFontWeight x
+    , "font-style"            .= views (formatFont ∘ _Just ∘ fontItalic ∘ _Just) toFontStyle x
+    , "color"                 .= (x ^? (formatFont ∘ _Just ∘ fontColor ∘ _Just))
+    , "text-decoration-style" .= (x ^? (formatFont ∘ _Just ∘ fontUnderline ∘ _Just))
+    , "vertical-align"        .= (x ^? (formatFont ∘ _Just ∘ fontVertAlign ∘ _Just))
+    , "background-color"      .= (x ^? (formatFill ∘ _Just ∘ fillPattern ∘ _Just ∘ fillPatternBgColor ∘ _Just))
+    ]
+    where
+      toWordWrap ∷ Bool → Maybe Text
+      toWordWrap True  = Just "normal"
+      toWordWrap False = Nothing
+
+      toFontWeight ∷ Bool → Maybe Text
+      toFontWeight True  = Just "bold"
+      toFontWeight False = Nothing
+
+      toFontStyle ∷ Bool → Maybe Text
+      toFontStyle True  = Just "italic"
+      toFontStyle False = Nothing
+
+-- | `CellHorizontalAlignment` to CSS 'align-content' property.
+instance ToJSON CellHorizontalAlignment where
+  toJSON CellHorizontalAlignmentCenter           = "center"        -- center
+  toJSON CellHorizontalAlignmentCenterContinuous = "center"        -- centerContinuous
+  toJSON CellHorizontalAlignmentDistributed      = "space-between" -- distributed
+  toJSON CellHorizontalAlignmentFill             = "space-between" -- fill
+  toJSON CellHorizontalAlignmentGeneral          = "normal"        -- general
+  toJSON CellHorizontalAlignmentJustify          = "stretch"       -- justify
+  toJSON CellHorizontalAlignmentLeft             = "start"         -- left
+  toJSON CellHorizontalAlignmentRight            = "end"           -- right
+
+-- | `CellVerticalAlignment` to CSS `justify-content` property.
+instance ToJSON CellVerticalAlignment where
+  toJSON CellVerticalAlignmentBottom      = "end"           -- bottom
+  toJSON CellVerticalAlignmentCenter      = "center"        -- center
+  toJSON CellVerticalAlignmentDistributed = "space-between" -- distributed
+  toJSON CellVerticalAlignmentJustify     = "stretch"       -- justify
+  toJSON CellVerticalAlignmentTop         = "start"         -- top
+
+-- | `FontUnderline` to CSS `text-decoration-style` property.
+instance ToJSON FontUnderline where
+  toJSON FontUnderlineSingle           = "solid"  -- single
+  toJSON FontUnderlineDouble           = "double" -- double
+  toJSON FontUnderlineSingleAccounting = "solid"  -- singleAccounting
+  toJSON FontUnderlineDoubleAccounting = "double" -- doubleAccounting
+  toJSON FontUnderlineNone             = "inherit"
+
+-- | `FontVerticalAlignment` to CSS `vertical-align` property.
+instance ToJSON FontVerticalAlignment where
+  toJSON FontVerticalAlignmentBaseline    = "baseline" -- baseline
+  toJSON FontVerticalAlignmentSubscript   = "sub"      -- subscript
+  toJSON FontVerticalAlignmentSuperscript = "super"    -- superscript
+
+-- | `Color` to RGBA string value.
+instance ToJSON Color where
+  toJSON c = String $ views (colorARGB ∘ _Just) toColor c
+    where
+      toColor = T.cons '#' ∘ T.drop 2
+
+-- | `LineStyle` to CSS `border-style` property.
+instance ToJSON LineStyle where
+  toJSON LineStyleDashDot          = "dashed"
+  toJSON LineStyleDashDotDot       = "dotted"
+  toJSON LineStyleDashed           = "dashed"
+  toJSON LineStyleDotted           = "dotted"
+  toJSON LineStyleDouble           = "double"
+  toJSON LineStyleHair             = "solid"
+  toJSON LineStyleMedium           = "solid"
+  toJSON LineStyleMediumDashDot    = "dashed"
+  toJSON LineStyleMediumDashDotDot = "dotted"
+  toJSON LineStyleMediumDashed     = "dashed"
+  toJSON LineStyleNone             = "none"
+  toJSON LineStyleSlantDashDot     = "dashed"
+  toJSON LineStyleThick            = "solid"
+  toJSON LineStyleThin             = "solid"