diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog for `haskell` + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), +and this project adheres to the +[Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## Unreleased + +## 0.1.0.0 - YYYY-MM-DD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright value (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of value nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,316 @@ +# clerk + +`clerk` is a library for declarative spreadsheet generation using a Haskell eDSL. + +It extends upon the [work](https://youtu.be/1xGoa-zEOrQ) of Kudasov by making the tables' layout more flexible. + +## Features + +`clerk` produces a styled spreadsheet with some data and formulas on it. These formulas will be calculated by the target spreadsheet system. + +The library supports + +- typed cell references - `Cell Double` +- type-safe arithmetic operations - `(a :: Cell Double) + (b :: Cell Double)` +- range references - `a |:| b` -> `A1:B1` +- formulas - `(e :: Expr Double) = "SUM" |$| [(a |:| b)]` -> `SUM(A1:B1)` +- conditional styles, formatting, column widths + +The example below demonstrates some of these features. + +## Example + +This is a demo program that uses `clerk` to produce an `xlsx` file that looks as follows: + + + +Alternatively, with formulas enabled: + + + +This file has a sheet with several tables. These are tables for +constants' header, a table per a constant's value (three of them), volume & pressure header, volume & pressure values. +Let's see how we can construct such a sheet. + +### Imports + +First, we import the necessary stuff. + +```haskell +module Example (main) where +import Clerk +import Codec.Xlsx qualified as X +import Codec.Xlsx.Formatted qualified as X +import Control.Lens ((%~), (&), (?~)) +import Data.ByteString.Lazy qualified as L +import Data.Text qualified as T +import Data.Time.Clock.POSIX (getPOSIXTime) +import Control.Monad (void) +``` + +### Inputs + +Following that, we declare a number of data types that we'll use to store the input values. + +A type for constants' headers. + +```haskell +data ConstantsHeader = ConstantsHeader + { hConstant :: String + , hSymbol :: String + , hValue :: String + , hUnits :: String + } + +constantsHeader :: ConstantsHeader +constantsHeader = + ConstantsHeader + { hConstant = "constant" + , hSymbol = "symbol" + , hValue = "value" + , hUnits = "units" + } +``` + +A type for constants' data. + +```haskell +data ConstantsData a = ConstantsData + { name :: String + , symbol :: String + , value :: a + , units :: String + } +``` + +Additionally, we declare a helper type that will store all constants together. + +```haskell +data ConstantsInput = ConstantsInput + { gas :: ConstantsData Double + , nMoles :: ConstantsData Double + , temperature :: ConstantsData Double + } + +constants :: ConstantsInput +constants = + ConstantsInput + { gas = ConstantsData "GAS CONSTANT" "R" 0.08206 "L.atm/mol.K" + , nMoles = ConstantsData "NUMBER OF MOLES" "n" 1 "moles" + , temperature = ConstantsData "TEMPERATURE(K)" "T" 273.2 "K" + } +``` + +A type for the Volume & Pressure header. + +```haskell +data ValuesHeader = ValuesHeader + { hVolume :: String + , hPressure :: String + } + +valuesHeader :: ValuesHeader +valuesHeader = + ValuesHeader + { hVolume = "VOLUME (L)" + , hPressure = "PRESSURE (atm)" + } +``` + +The last type is for volume inputs. We just generate them + +```haskell +newtype Volume = Volume + { volume :: Double + } + +volumeData :: [Volume] +volumeData = take 10 $ Volume <$> [1 ..] +``` + +### Styles + +Following the headers and data types, we define the styles. Let's start with colors. +We select several color codes and store them into `colors` + +```haskell +data Colors = Colors + { lightBlue :: T.Text + , lightGreen :: T.Text + , blue :: T.Text + , green :: T.Text + } + +colors :: Colors +colors = + Colors + { lightGreen = "90CCFFCC" + , lightBlue = "90CCFFFF" + , blue = "FF99CCFF" + , green = "FF00FF00" + } +``` + +Next, we convert them to `FormatCell` function + +```haskell +colorBlue :: FormatCell +colorBlue = mkColorStyle colors.blue + +colorLightBlue :: FormatCell +colorLightBlue = mkColorStyle colors.lightBlue + +colorGreen :: FormatCell +colorGreen = mkColorStyle colors.green + +colorMixed :: FormatCell +colorMixed coords idx = mkColorStyle (if even idx then colors.lightGreen else colors.lightBlue) coords idx +``` + +Additionally, we compose a transform for the number format + +```haskell +-- | allow 2 decimal digits +nf2decimal :: FCTransform +nf2decimal fc = fc & X.formattedFormat %~ (\ff -> ff & X.formatNumberFormat ?~ X.StdNumberFormat X.Nf2Decimal) +``` + +And a transform for centering the cell contents + +```haskell +alignCenter :: FCTransform +alignCenter = horizontalAlignment X.CellHorizontalAlignmentCenter +``` + +### `Builder`s + +Now, we are able to compose the `Builder`s for tables. + +A builder for the constants header. + + + +```haskell +constantsHeaderBuilder :: Builder ConstantsHeader CellData (Coords, Coords) +constantsHeaderBuilder = do + tl <- columnWidth 20 (alignCenter <| colorBlue) hConstant + columnWidth_ 8 (alignCenter <| colorBlue) hSymbol + column_ (alignCenter <| colorBlue) hValue + tr <- columnWidth 13 (alignCenter <| colorBlue) hUnits + return (unCell tl, unCell tr) +``` + +A builder for a constant. We'll use this builder for each constant separately +as each constant produces cells of a specific type. + + + +```haskell +constantBuilder :: forall a. ToCellData a => Builder (ConstantsData a) CellData (Coords, Cell a) +constantBuilder = do + topLeft <- column colorLightBlue name + column_ colorLightBlue symbol + value <- column (nf2decimal <| colorLightBlue) value + column_ colorLightBlue units + return (unCell topLeft, value) +``` + +A builder for values' header. + + + +```haskell +valuesHeaderBuilder :: Builder ValuesHeader CellData Coords +valuesHeaderBuilder = do + tl <- columnWidth 12 colorGreen hVolume + columnWidth_ 16 colorGreen hPressure + return (unCell tl) +``` + +To pass values in a structured way, we make a helper type. + +```haskell +data ConstantsValues = ConstantsValues + { gas :: Cell Double + , nMoles :: Cell Double + , temperature :: Cell Double + } +``` + +A builder for volume & pressure (formulas enabled) + + + +```haskell +valuesBuilder :: ConstantsValues -> Builder Volume CellData () +valuesBuilder cv = do + volume' <- column colorMixed volume + let pressure' = ex cv.gas |*| ex cv.nMoles |*| ex cv.temperature |/| ex volume' + column_ (nf2decimal <| colorMixed) (const pressure') +``` + +### `SheetBuilder` + +The `SheetBuilder` is used to place builders onto a sheet and glue them together + +```haskell +full :: SheetBuilder () +full = do + (constantsHeaderTL, constantsHeaderTR) <- placeInput (Coords 2 2) constantsHeader constantsHeaderBuilder + (gasTL, gas) <- placeInput (overRow (+ 2) constantsHeaderTL) constants.gas constantBuilder + (nMolesTL, nMoles) <- placeInput (overRow (+ 1) gasTL) constants.nMoles constantBuilder + temperature <- snd <$> placeInput (overRow (+ 1) nMolesTL) constants.temperature constantBuilder + valuesHeaderTL <- placeInput (overCol (+ 2) constantsHeaderTR) valuesHeader valuesHeaderBuilder + placeInputs_ (overRow (+ 2) valuesHeaderTL) volumeData (valuesBuilder $ ConstantsValues{..}) +``` + +### Result + +Now, we can write the result and get the spreadsheet images that you've seen at the top of this tutorial. + +```haskell +writeWorksheet :: SheetBuilder a -> String -> IO () +writeWorksheet tb name = do + ct <- getPOSIXTime + let + xlsx = composeXlsx [("List 1", void tb)] + L.writeFile ("example-" <> name <> ".xlsx") $ X.fromXlsx ct xlsx + +writeEx :: IO () +writeEx = writeWorksheet full "1" + +main :: IO () +main = writeEx +``` + +Run + +```console +stack run +``` + +to get `example-1.xlsx`. + +With formulas enabled, `example-1.xlsx` looks like this: + + + +## Contribute + +### Prerequisites + +As this project uses `Nix` for dev environment, study the following prerequisites to set up the project + +- [Prerequisites](https://github.com/deemp/flakes#prerequisites) +- `Haskell` project [template](https://github.com/deemp/flakes/tree/main/templates/codium/haskell#readme) +- [Haskell](https://github.com/deemp/flakes/blob/main/README/Haskell.md) + +Next, run + +```sh +nix develop nix-dev/ +write-settings-json +codium . +``` + +and open a `Haskell` file. `HLS` should soon start giving you hints. 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Example qualified as E (main) + +main :: IO () +main = E.main diff --git a/clerk.cabal b/clerk.cabal new file mode 100644 --- /dev/null +++ b/clerk.cabal @@ -0,0 +1,103 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.35.0. +-- +-- see: https://github.com/sol/hpack + +name: clerk +version: 0.1.0.0 +synopsis: Declaratively describe spreadsheets and generate xlsx +description: Please see the README on GitHub at +category: spreadsheet +homepage: https://github.com/deemp/clerk#readme +bug-reports: https://github.com/deemp/clerk/issues +author: Danila Danko, Nickolay Kudasov +maintainer: Danila Danko +copyright: Danila Danko, Nickolay Kudasov +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/deemp/clerk + +library + exposed-modules: + Clerk + Example + other-modules: + Paths_clerk + hs-source-dirs: + src + default-extensions: + DataKinds + DeriveFunctor + FlexibleContexts + FlexibleInstances + OverloadedStrings + OverloadedRecordDot + GeneralizedNewtypeDeriving + RankNTypes + ImportQualifiedPost + InstanceSigs + NamedFieldPuns + RecordWildCards + TupleSections + MonoLocalBinds + TypeSynonymInstances + DuplicateRecordFields + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.9.0.0 && <5.0 + , bytestring >=0.10.8.0 + , containers >=0.5.0.0 + , data-default >=0.7.1.1 + , lens >=3.8 && <5.3 + , mtl >=2.1 + , text >=0.11.3.1 + , time >=1.4.0.1 + , transformers >=0.3.0.0 + , xlsx >=1.1.0.1 + default-language: Haskell2010 + +executable clerk + main-is: Main.hs + other-modules: + Paths_clerk + hs-source-dirs: + app + default-extensions: + DataKinds + DeriveFunctor + FlexibleContexts + FlexibleInstances + OverloadedStrings + OverloadedRecordDot + GeneralizedNewtypeDeriving + RankNTypes + ImportQualifiedPost + InstanceSigs + NamedFieldPuns + RecordWildCards + TupleSections + MonoLocalBinds + TypeSynonymInstances + DuplicateRecordFields + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.9.0.0 && <5.0 + , bytestring >=0.10.8.0 + , clerk + , containers >=0.5.0.0 + , data-default >=0.7.1.1 + , lens >=3.8 && <5.3 + , mtl >=2.1 + , text >=0.11.3.1 + , time >=1.4.0.1 + , transformers >=0.3.0.0 + , xlsx >=1.1.0.1 + default-language: Haskell2010 diff --git a/src/Clerk.hs b/src/Clerk.hs new file mode 100644 --- /dev/null +++ b/src/Clerk.hs @@ -0,0 +1,544 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} + +module Clerk ( + Builder, + Cell (unCell), + CellData, + Coords (Coords), + FCTransform, + FormatCell, + ToCellData, + SheetBuilder (..), + column, + columnWidth, + columnWidth_, + column_, + composeXlsx, + ex, + ex', + horizontalAlignment, + mkColorStyle, + overCol, + overRow, + placeInput, + placeInputs_, + (|+|), + (|-|), + (|*|), + (|/|), + (|:|), + (|^|), + (|$|), + (<|), + Expr(..) +) where + +import Codec.Xlsx qualified as X +import Codec.Xlsx.Formatted qualified as X +import Control.Lens (Identity (runIdentity), (%~), (&), (?~)) +import Control.Lens.Operators ((.~)) +import Control.Monad.State ( + MonadState, + StateT (StateT), + evalStateT, + get, + gets, + modify, + void, + ) +import Control.Monad.Trans.Writer (execWriter, runWriter) +import Control.Monad.Writer (MonadWriter (..), Writer) +import Data.Char (toUpper) +import Data.Default (Default (..)) +import Data.Foldable (Foldable (..)) +import Data.List (intercalate) +import Data.Map.Strict qualified as Map (Map, insert) +import Data.Maybe (isJust, maybeToList) +import Data.Text qualified as T + +-- Coords + +-- TODO Allow sheet addresses + +-- | Coords of a cell +data Coords = Coords {row :: Int, col :: Int} + +instance Show Coords where + show :: Coords -> String + show (Coords{..}) = toLetters col <> show row + +alphabet :: [String] +alphabet = (: "") <$> ['A' .. 'Z'] + +toLetters :: Int -> String +toLetters x = f "" (x - 1) + where + new :: Int -> String -> String + new cur acc = alphabet !! (cur `mod` 26) <> acc + f :: String -> Int -> String + f acc cur = if cur `div` 26 > 0 then f (new cur acc) (cur `div` 26 - 1) else new cur acc + +{- +>>>toLetters <$> [1, 26, 27, 52, 78] +["A","Z","AA","AZ","BZ"] +-} + +instance Num Coords where + (+) :: Coords -> Coords -> Coords + (+) (Coords r1 c1) (Coords r2 c2) = Coords (r1 + r2) (c1 + c2) + (*) :: Coords -> Coords -> Coords + (*) (Coords r1 c1) (Coords r2 c2) = Coords (r1 * r2) (c1 * c2) + (-) :: Coords -> Coords -> Coords + (-) (Coords r1 c1) (Coords r2 c2) = Coords (r1 - r2) (c1 - c2) + abs :: Coords -> Coords + abs (Coords r1 c1) = Coords (abs r1) (abs c1) + signum :: Coords -> Coords + signum (Coords r1 c1) = Coords (signum r1) (signum c1) + fromInteger :: Integer -> Coords + fromInteger x = Coords (fromIntegral (abs x)) (fromIntegral (abs x)) + +-- Cell + +-- | Index of an input +type Index = Int + +-- | Format a single cell depending on its coordinates, index, and data +type FormatCell = Coords -> Index -> CellData -> X.FormattedCell + +-- | Cell with contents, style, column props +data CellTemplate input output = CellTemplate + { mkOutput :: input -> output + , format :: FormatCell + , columnsProperties :: Maybe X.ColumnsProperties + } + +-- Transforms + +type FormattedMap = Map.Map (X.RowIndex, X.ColumnIndex) X.FormattedCell +type FMTransform = FormattedMap -> FormattedMap +type WSTransform = X.Worksheet -> X.Worksheet + +-- | A transform of the map of formats and a transform of a worksheet +data Transform = Transform {fmTransform :: FMTransform, wsTransform :: WSTransform} + +instance Semigroup Transform where + (<>) :: Transform -> Transform -> Transform + (Transform a1 b1) <> (Transform a2 b2) = Transform (a2 . a1) (b2 . b1) + +instance Monoid Transform where + mempty :: Transform + mempty = Transform id id + +instance Default Transform where + def :: Transform + def = mempty + +-- Template + +-- | Template for multiple cells +newtype Template input output = Template [CellTemplate input output] + deriving (Semigroup, Monoid) + +-- Builder + +-- | A builder +newtype Builder input output a = Builder {unBuilder :: StateT Coords (Writer (Template input output)) a} + deriving (Functor, Applicative, Monad, MonadState Coords, MonadWriter (Template input output)) + +-- | Run builder on given coordinates. Get a result and a template +runBuilder :: Builder input output a -> Coords -> (a, Template input output) +runBuilder builder coord = runWriter (evalStateT (unBuilder builder) coord) + +-- | Run builder on given coordinates. Get a template +evalBuilder :: Builder input output a -> Coords -> Template input output +evalBuilder builder coord = snd $ runBuilder builder coord + +-- | Run builder on given coordinates. Get a result +execBuilder :: Builder input output a -> Coords -> a +execBuilder builder coord = fst $ runBuilder builder coord + +type RenderTemplate m input output = (Monad m, ToCellData output) => Coords -> Index -> input -> Template input output -> m Transform +type RenderBuilderInputs m input output a = (Monad m, ToCellData output) => Builder input output a -> [input] -> m (Transform, a) +type RenderBuilderInput m input output a = (Monad m, ToCellData output) => Builder input output a -> input -> m (Transform, a) + +-- Render +-- meaning produce a transform + +-- | Render a builder with given coords and inputs. Return the result calculated using the topmost row +renderBuilderInputs :: (Monad m, ToCellData output) => Coords -> RenderTemplate m input output -> RenderBuilderInputs m input output a +renderBuilderInputs offset render builder inputs = ret + where + ts = + [ (coord, template) + | row <- [0 .. length inputs] + , let coord = offset + Coords{row, col = 0} + template = evalBuilder builder coord + ] + -- result obtained from the top row + a = execBuilder builder (offset + Coords{row = 0, col = 0}) + transform = + fold + <$> sequenceA + ( zipWith3 + ( \input inputIdx (coord, template) -> + render coord inputIdx input template + ) + inputs + [0 ..] + ts + ) + ret = (,a) <$> transform + +-- | Render a template with a given offset, input index and input +renderTemplate :: RenderTemplate m input output +renderTemplate Coords{..} inputIdx input (Template columns) = return $ fold ps + where + ps = + zipWith + ( \columnIdx mk -> + let + CellTemplate{..} = mk + cd' = toCellData (mkOutput input) + col' = (col + columnIdx) + coords' = Coords row col' + c = format coords' inputIdx cd' + fmTransform = Map.insert (fromIntegral row, fromIntegral col') c + wsTransform + -- add column width only once + | inputIdx == 0 = X.wsColumnsProperties %~ (\x -> x ++ maybeToList columnsProperties) + | otherwise = id + in + def{fmTransform, wsTransform} + ) + [0 ..] + columns + +-- Columns + +newtype ColumnsProperties = ColumnsProperties {unColumnsProperties :: X.ColumnsProperties} + +instance Default ColumnsProperties where + def :: ColumnsProperties + def = + ColumnsProperties + X.ColumnsProperties + { cpMin = 1 + , cpMax = 1 + , cpWidth = Nothing + , cpStyle = Nothing + , cpHidden = False + , cpCollapsed = False + , cpBestFit = False + } + +-- TODO fix doesn't work for non-first row +-- need to filter the final list + +-- | Produce a column with a given style and width and get a cell +columnWidthCell :: forall a input output. Maybe Double -> FormatCell -> (input -> output) -> Builder input output (Cell a) +columnWidthCell width format mkOutput = do + coords <- get + let columnsProperties = + Just $ + (unColumnsProperties def) + { X.cpMin = coords.col + , X.cpMax = coords.col + , X.cpWidth = width + } + tell (Template [CellTemplate{format, mkOutput, columnsProperties}]) + cell <- gets Cell + modify (\x -> x{col = (x.col) + 1}) + return cell + +columnWidth :: ToCellData output => Double -> FormatCell -> (input -> output) -> Builder input CellData (Cell a) +columnWidth width fmtCell mkOutput = columnWidthCell (Just width) fmtCell (toCellData . mkOutput) + +columnWidth_ :: ToCellData output => Double -> FormatCell -> (input -> output) -> Builder input CellData () +columnWidth_ width fmtCell mkOutput = void (columnWidth width fmtCell mkOutput) + +-- | Produce a column with a given style and get a cell +column :: ToCellData output => FormatCell -> (input -> output) -> Builder input CellData (Cell a) +column fmtCell mkOutput = columnWidthCell Nothing fmtCell (toCellData . mkOutput) + +-- | Produce a column with a given style +column_ :: ToCellData output => FormatCell -> (input -> output) -> Builder input CellData () +column_ fmtCell mkOutput = void (column fmtCell mkOutput) + +-- | Produce a transform and a result from inputs and a builder +composeTransformResult :: forall a input output. ToCellData output => RenderTemplate Identity input output -> Coords -> [input] -> Builder input output a -> (Transform, a) +composeTransformResult renderTemplate' offset input builder = runIdentity $ renderBuilderInputs offset renderTemplate' builder input + +-- | Produce a result +defaultTransformResult :: ToCellData output => Coords -> [input] -> Builder input output a -> (Transform, a) +defaultTransformResult = composeTransformResult renderTemplate + +-- TODO +-- Store current sheet info for formulas + +-- | Top monad to compose the results of Builders +newtype SheetBuilder a = SheetBuilder {unSheetBuilder :: Writer Transform a} + deriving (Functor, Applicative, Monad, MonadWriter Transform) + +class Functor a => Discardable a where + discard :: a b -> a () + +placeInputs :: ToCellData output => Coords -> [input] -> Builder input output a -> SheetBuilder a +placeInputs offset inputs b = do + let transformResult = defaultTransformResult offset inputs b + tell (fst transformResult) + return (snd transformResult) + +placeInput :: ToCellData output => Coords -> input -> Builder input output a -> SheetBuilder a +placeInput coords input = placeInputs coords [input] + +placeInputs_ :: ToCellData output => Coords -> [input] -> Builder input output a -> SheetBuilder () +placeInputs_ coords inputs b = void (placeInputs coords inputs b) + +placeInput_ :: ToCellData output => Coords -> input -> Builder input output a -> SheetBuilder () +placeInput_ coords input = placeInputs_ coords [input] + +composeXlsx :: [(T.Text, SheetBuilder ())] -> X.Xlsx +composeXlsx sheetBuilders = workBook' + where + getTransform x = execWriter $ unSheetBuilder x + workBook = X.formatWorkbook ((\(name, tf') -> (name, (getTransform tf').fmTransform X.def)) <$> sheetBuilders) X.def + filterWidths ws = ws & X.wsColumnsProperties %~ filter (isJust . X.cpWidth) + workBook' = + workBook + & X.xlSheets + %~ \sheets -> zipWith (\x (name, ws) -> (name, (getTransform x).wsTransform ws & filterWidths)) (snd <$> sheetBuilders) sheets + +{- Lib. Formulas -} + +-- | Formula expressions +data Expr t + = Add (Expr t) (Expr t) + | Sub (Expr t) (Expr t) + | Mul (Expr t) (Expr t) + | Div (Expr t) (Expr t) + | Function String [Expr t] + | Range (Expr t) (Expr t) + | ExprCell (Cell t) + deriving (Functor) + +-- | Change phantom type of an Expr +ex' :: forall b a. Expr a -> Expr b +ex' = toExpr + +-- | Something that can be turned into an expression +class ToExpr v where + toExpr :: v -> Expr t + +instance ToExpr (Cell a) where + toExpr :: Cell a -> Expr t + toExpr (Cell c) = ExprCell (Cell c) + +instance ToExpr Coords where + toExpr :: Coords -> Expr t + toExpr c = ExprCell (Cell c) + +toExprCell :: Cell a -> Coords +toExprCell (Cell c1) = c1 + +instance ToExpr (Expr a) where + toExpr :: Expr a -> Expr b + toExpr (Add l r) = Add (toExpr l) (toExpr r) + toExpr (Sub l r) = Sub (toExpr l) (toExpr r) + toExpr (Mul l r) = Mul (toExpr l) (toExpr r) + toExpr (Div l r) = Div (toExpr l) (toExpr r) + toExpr (Function name args) = Function name (toExpr <$> args) + toExpr (Range l r) = Range (toExpr l) (toExpr r) + toExpr (ExprCell (Cell c)) = ExprCell (Cell c) + +showOp2 :: (Show a, Show b) => String -> a -> b -> String +showOp2 operator c1 c2 = show c1 <> operator <> show c2 + +mkOp2 :: (ToExpr a, ToExpr b) => (Expr t -> Expr t -> Expr t) -> a -> b -> Expr t +mkOp2 f c1 c2 = f (toExpr c1) (toExpr c2) + +mkNumOp2 :: (Num t, ToExpr a, ToExpr b) => (Expr t -> Expr t -> Expr t) -> a -> b -> Expr t +mkNumOp2 = mkOp2 + +-- | Assemble a range expression +(|:|) :: Cell a -> Cell b -> Expr c +(|:|) = mkOp2 Range + +infixr 5 |:| + +-- | Assemble an addition expression +(|+|) :: Num a => Expr a -> Expr a -> Expr a +(|+|) = mkNumOp2 Add + +infixl 6 |+| + +-- | Assemble a subtraction expression +(|-|) :: Num a => Expr a -> Expr a -> Expr a +(|-|) = mkNumOp2 Sub + +infixl 6 |-| + +-- | Assemble a division expression +(|/|) :: Num a => Expr a -> Expr a -> Expr a +(|/|) = mkNumOp2 Div + +infixl 7 |/| + +-- | Assemble a multiplication expression +(|*|) :: Num a => Expr a -> Expr a -> Expr a +(|*|) = mkNumOp2 Mul + +infixl 6 |*| + +-- | Assemble a multiplication expression +(|^|) :: Num a => Expr a -> Expr a -> Expr a +(|^|) = mkNumOp2 Mul + +infixr 8 |^| + +-- | Assemble a function expression +(|$|) :: ToExpr a => String -> [a] -> Expr t +(|$|) n as = Function (toUpper <$> n) (toExpr <$> as) + +infixr 0 |$| + +instance Show (Expr t) where + show :: Expr t -> String + show (Add c1 c2) = showOp2 "+" c1 c2 + show (Sub c1 c2) = showOp2 "-" c1 c2 + show (Mul c1 c2) = showOp2 "*" c1 c2 + show (Div c1 c2) = showOp2 "/" c1 c2 + show (Range c1 c2) = showOp2 ":" c1 c2 + show (ExprCell (Cell e)) = show e + show (Function n as) = n <> "(" <> intercalate "," (show <$> as) <> ")" + +-- | Coordinates of a cell with a given phantom type +newtype Cell a = Cell {unCell :: Coords} deriving (Functor) + +cellCol :: Cell a -> Int +cellCol (Cell c) = c.col + +cellRow :: Cell a -> Int +cellRow (Cell c) = c.row + +overCol :: (Int -> Int) -> Coords -> Coords +overCol f (Coords row col) = Coords row (f col) + +overRow :: (Int -> Int) -> Coords -> Coords +overRow f (Coords row col) = Coords (f row) col + +instance Num (Cell a) where + (+) :: Cell a -> Cell a -> Cell a + (+) (Cell c1) (Cell c2) = Cell (c1 + c2) + (*) :: Cell a -> Cell a -> Cell a + (*) (Cell c1) (Cell c2) = Cell (c1 * c2) + (-) :: Cell a -> Cell a -> Cell a + (-) (Cell c1) (Cell c2) = Cell (c1 - c2) + abs :: Cell a -> Cell a + abs (Cell c1) = Cell (abs c1) + signum :: Cell a -> Cell a + signum (Cell c1) = Cell (signum c1) + fromInteger :: Integer -> Cell a + fromInteger x = Cell (fromInteger x) + +-- | Convert a typed cell to an expression +ex :: Cell a -> Expr a +ex = toExpr + +{- Lib.Example.Typechecks +>>>str = ex (Cell (Coords 1 1)) :: Expr String +>>> str |+| str +No instance for (Num String) arising from a use of `|+|' +In the expression: str |+| str +NOW In an equation for `it_a1TViD': it_a1TViD = str |+| str + +>>>int = ex (Cell (Coords 1 1)) :: Expr Int +>>>double = ex (Cell (Coords 2 5)) :: Expr Double +>>>ex' int |+| double +A1+E2 +-} + +mkColorStyle :: T.Text -> FormatCell +mkColorStyle color _ _ cd = + X.def + & X.formattedCell .~ dataCell cd + & X.formattedFormat + .~ ( X.def + & X.formatFill + ?~ ( X.def + & X.fillPattern + ?~ ( X.def + & ( X.fillPatternFgColor + ?~ (X.def & X.colorARGB ?~ color) + ) + & ( X.fillPatternType + ?~ X.PatternTypeSolid + ) + ) + ) + ) + +type FCTransform = X.FormattedCell -> X.FormattedCell + +infixl 5 <| +(<|) :: FCTransform -> FormatCell -> FormatCell +f <| fc = \coords idx cd -> f $ fc coords idx cd + +horizontalAlignment :: X.CellHorizontalAlignment -> FCTransform +horizontalAlignment alignment fc = + fc + & X.formattedFormat + %~ ( \ff -> + ff + & X.formatAlignment + ?~ ( X.def & X.alignmentHorizontal ?~ alignment + ) + ) + +-- | A union of some Cell components +data CellData + = CellFormula X.CellFormula + | CellValue X.CellValue + | CellComment X.Comment + +-- | Convert some Cell component into a cell +dataCell :: CellData -> X.Cell +dataCell cd = + X.def + & case cd of + CellValue d -> X.cellValue ?~ d + CellFormula d -> X.cellFormula ?~ d + CellComment d -> X.cellComment ?~ d + +class ToCellData a where + toCellData :: a -> CellData + +instance ToCellData String where + toCellData :: String -> CellData + toCellData = CellValue . X.CellText . T.pack + +instance ToCellData Int where + toCellData :: Int -> CellData + toCellData = CellValue . X.CellDouble . fromIntegral + +instance ToCellData Double where + toCellData :: Double -> CellData + toCellData = CellValue . X.CellDouble + +instance ToCellData Bool where + toCellData :: Bool -> CellData + toCellData = CellValue . X.CellBool + +instance ToCellData CellData where + toCellData :: CellData -> CellData + toCellData = id + +instance ToCellData (Expr a) where + toCellData :: Expr a -> CellData + toCellData e = + CellFormula + X.CellFormula + { X._cellfAssignsToName = False + , X._cellfCalculate = True + , X._cellfExpression = X.NormalFormula $ X.Formula $ T.pack $ show e + } diff --git a/src/Example.lhs b/src/Example.lhs new file mode 100644 --- /dev/null +++ b/src/Example.lhs @@ -0,0 +1,240 @@ + ## Example + +This is a demo program that uses `clerk` to produce an `xlsx` file that looks as follows: + + + +Alternatively, with formulas enabled: + + + +This file has a sheet with several tables. These are tables for +constants' header, a table per a constant's value (three of them), volume & pressure header, volume & pressure values. +Let's see how we can construct such a sheet. + + ### Imports + +First, we import the necessary stuff. + +> module Example (main) where +> import Clerk +> import Codec.Xlsx qualified as X +> import Codec.Xlsx.Formatted qualified as X +> import Control.Lens ((%~), (&), (?~)) +> import Data.ByteString.Lazy qualified as L +> import Data.Text qualified as T +> import Data.Time.Clock.POSIX (getPOSIXTime) +> import Control.Monad (void) + + ### Inputs + +Following that, we declare a number of data types that we'll use to store the input values. + +A type for constants' headers. + +> data ConstantsHeader = ConstantsHeader +> { hConstant :: String +> , hSymbol :: String +> , hValue :: String +> , hUnits :: String +> } +> +> constantsHeader :: ConstantsHeader +> constantsHeader = +> ConstantsHeader +> { hConstant = "constant" +> , hSymbol = "symbol" +> , hValue = "value" +> , hUnits = "units" +> } + +A type for constants' data. + +> data ConstantsData a = ConstantsData +> { name :: String +> , symbol :: String +> , value :: a +> , units :: String +> } + +Additionally, we declare a helper type that will store all constants together. + +> data ConstantsInput = ConstantsInput +> { gas :: ConstantsData Double +> , nMoles :: ConstantsData Double +> , temperature :: ConstantsData Double +> } +> +> constants :: ConstantsInput +> constants = +> ConstantsInput +> { gas = ConstantsData "GAS CONSTANT" "R" 0.08206 "L.atm/mol.K" +> , nMoles = ConstantsData "NUMBER OF MOLES" "n" 1 "moles" +> , temperature = ConstantsData "TEMPERATURE(K)" "T" 273.2 "K" +> } + +A type for the Volume & Pressure header. + +> data ValuesHeader = ValuesHeader +> { hVolume :: String +> , hPressure :: String +> } +> +> valuesHeader :: ValuesHeader +> valuesHeader = +> ValuesHeader +> { hVolume = "VOLUME (L)" +> , hPressure = "PRESSURE (atm)" +> } + +The last type is for volume inputs. We just generate them + +> newtype Volume = Volume +> { volume :: Double +> } +> +> volumeData :: [Volume] +> volumeData = take 10 $ Volume <$> [1 ..] + + ### Styles + +Following the headers and data types, we define the styles. Let's start with colors. +We select several color codes and store them into `colors` + +> data Colors = Colors +> { lightBlue :: T.Text +> , lightGreen :: T.Text +> , blue :: T.Text +> , green :: T.Text +> } +> +> colors :: Colors +> colors = +> Colors +> { lightGreen = "90CCFFCC" +> , lightBlue = "90CCFFFF" +> , blue = "FF99CCFF" +> , green = "FF00FF00" +> } + +Next, we convert them to `FormatCell` function + +> colorBlue :: FormatCell +> colorBlue = mkColorStyle colors.blue +> +> colorLightBlue :: FormatCell +> colorLightBlue = mkColorStyle colors.lightBlue +> +> colorGreen :: FormatCell +> colorGreen = mkColorStyle colors.green +> +> colorMixed :: FormatCell +> colorMixed coords idx = mkColorStyle (if even idx then colors.lightGreen else colors.lightBlue) coords idx + +Additionally, we compose a transform for the number format + +> -- | allow 2 decimal digits +> nf2decimal :: FCTransform +> nf2decimal fc = fc & X.formattedFormat %~ (\ff -> ff & X.formatNumberFormat ?~ X.StdNumberFormat X.Nf2Decimal) + +And a transform for centering the cell contents + +> alignCenter :: FCTransform +> alignCenter = horizontalAlignment X.CellHorizontalAlignmentCenter + + ### `Builder`s + +Now, we are able to compose the `Builder`s for tables. + +A builder for the constants header. + + + +> constantsHeaderBuilder :: Builder ConstantsHeader CellData (Coords, Coords) +> constantsHeaderBuilder = do +> tl <- columnWidth 20 (alignCenter <| colorBlue) hConstant +> columnWidth_ 8 (alignCenter <| colorBlue) hSymbol +> column_ (alignCenter <| colorBlue) hValue +> tr <- columnWidth 13 (alignCenter <| colorBlue) hUnits +> return (unCell tl, unCell tr) + +A builder for a constant. We'll use this builder for each constant separately +as each constant produces cells of a specific type. + + + +> constantBuilder :: forall a. ToCellData a => Builder (ConstantsData a) CellData (Coords, Cell a) +> constantBuilder = do +> topLeft <- column colorLightBlue name +> column_ colorLightBlue symbol +> value <- column (nf2decimal <| colorLightBlue) value +> column_ colorLightBlue units +> return (unCell topLeft, value) + +A builder for values' header. + + + +> valuesHeaderBuilder :: Builder ValuesHeader CellData Coords +> valuesHeaderBuilder = do +> tl <- columnWidth 12 colorGreen hVolume +> columnWidth_ 16 colorGreen hPressure +> return (unCell tl) + +To pass values in a structured way, we make a helper type. + +> data ConstantsValues = ConstantsValues +> { gas :: Cell Double +> , nMoles :: Cell Double +> , temperature :: Cell Double +> } + +A builder for volume & pressure (formulas enabled) + + + +> valuesBuilder :: ConstantsValues -> Builder Volume CellData () +> valuesBuilder cv = do +> volume' <- column colorMixed volume +> let pressure' = ex cv.gas |*| ex cv.nMoles |*| ex cv.temperature |/| ex volume' +> column_ (nf2decimal <| colorMixed) (const pressure') + + ### `SheetBuilder` + +The `SheetBuilder` is used to place builders onto a sheet and glue them together + +> full :: SheetBuilder () +> full = do +> (constantsHeaderTL, constantsHeaderTR) <- placeInput (Coords 2 2) constantsHeader constantsHeaderBuilder +> (gasTL, gas) <- placeInput (overRow (+ 2) constantsHeaderTL) constants.gas constantBuilder +> (nMolesTL, nMoles) <- placeInput (overRow (+ 1) gasTL) constants.nMoles constantBuilder +> temperature <- snd <$> placeInput (overRow (+ 1) nMolesTL) constants.temperature constantBuilder +> valuesHeaderTL <- placeInput (overCol (+ 2) constantsHeaderTR) valuesHeader valuesHeaderBuilder +> placeInputs_ (overRow (+ 2) valuesHeaderTL) volumeData (valuesBuilder $ ConstantsValues{..}) + + ### Result + +Now, we can write the result and get the spreadsheet images that you've seen at the top of this tutorial. + +> writeWorksheet :: SheetBuilder a -> String -> IO () +> writeWorksheet tb name = do +> ct <- getPOSIXTime +> let +> xlsx = composeXlsx [("List 1", void tb)] +> L.writeFile ("example-" <> name <> ".xlsx") $ X.fromXlsx ct xlsx +> +> writeEx :: IO () +> writeEx = writeWorksheet full "1" +> +> main :: IO () +> main = writeEx + +Run + +< stack run + +to get `example-1.xlsx`. + +With formulas enabled, `example-1.xlsx` looks like this: + +