Spreadsheet visualisation in PureScript Thermite

README.org

related:

• https://en.wikipedia.org/wiki/Befunge (via @rightfold)
• https://esolangs.org/wiki/Funciton

Main.purs

module Main where

import Prelude

import Control.Monad ((=<<))
import Data.Array (mapWithIndex, index, cons)
import Data.Lens (iso)
import Data.Foldable (sum)
import Data.Maybe
import React as R
import React.DOM as R
import React.DOM.Props as RP
import React.DOM.Props (style, onClick, href, target, className)
import Thermite hiding (defaultMain) as T
import Thermite.Try as T

type RowRecNamed =
  { qty         :: Int
  , description :: String
  , price       :: Number
  , total       :: Number
  }

columnHeaders = ["qty", "description", "price", "total"]

columnHeaderCellsNamed :: Array R.ReactElement
columnHeaderCellsNamed = mapWithIndex (\col -> systemCell 0 col) ("" `cons` columnHeaders)

rowsIndexed :: Array (Array SType)
rowsIndexed =
  [ [ SInt 1, SStr "partridge"   , SFloat 1.50, SFloat  1.50 ]
  , [ SInt 2, SStr "turtle doves", SFloat 3.00, SFloat  6.00 ]
  , [ SInt 5, SStr "golden rings", SFloat 7.00, SFloat 35.00 ]
  ] 

--------------------------------------------------------------------------------

extractColumn :: forall a. (SType -> Maybe a) -> Int -> Array (Array SType) -> Array (Maybe a)
extractColumn f col = map (f <=< (flap index) col)

--------------------------------------------------------------------------------

data SType = SStr String | SInt Int | SFloat Number | SBool Boolean

exS :: SType -> String
exS t = case t of
  SStr   x ->      x
  SInt   x -> show x
  SFloat x -> show x
  SBool  x -> show x

exSInt :: SType -> Maybe Int
exSInt = case _ of
  SInt   x -> pure x
  _        -> Nothing

exSStr :: SType -> Maybe String
exSStr = case _ of
  SStr x -> pure x
  _      -> Nothing

exSBool :: SType -> Maybe Boolean
exSBool = case _ of
  SBool x -> pure x
  _       -> Nothing

exSFloat :: SType -> Maybe Number
exSFloat = case _ of
  SFloat x -> pure x
  _        -> Nothing

liftRow :: Array SType -> RowRecNamed
liftRow r =
  { qty:         fromMaybe (-1)   $ exSInt   =<< index r 0
  , description: fromMaybe "???"  $ exSStr   =<< index r 1
  , price:       fromMaybe (-1.0) $ exSFloat =<< index r 2
  , total:       fromMaybe (-1.0) $ exSFloat =<< index r 3
  }

--------------------------------------------------------------------------------

columnHeadersIndexed :: Array R.ReactElement
columnHeadersIndexed =
  [ colIndexCell 0 0
  , colIndexCell 0 1
  , colIndexCell 0 2
  , colIndexCell 0 3
  , colIndexCell 0 4
  ]


renderRowNamed :: Int -> RowRecNamed -> Array R.ReactElement
renderRowNamed rowNum row =
  [ systemCell  rowNum 0 (show (rowNum + 1))
  , contentCell rowNum 1 (show row.qty)
  , contentCell rowNum 2 (row.description)
  , contentCell rowNum 3 (show row.price)
  , contentCell rowNum 4 (show row.total)
  ]

row cells = R.tr [] cells

contentCell  r c str = R.td [ className $ "cell row-" <> show r <> " col-" <> show c <> " content-cell" ] [ R.text str ]
systemCell   r c str = R.td [ className $ "cell row-" <> show r <> " col-" <> show c <> " system-cell"  ] [ R.text str ]
colIndexCell r c     = systemCell r c (show c)

--------------------------------------------------------------------------------

stylesheet =
  """
    .cell {
      padding: 7px;
      color: #555;
      border: 1px solid #ccc;
    }
    .system-cell { background: #ddd; color: #aaa; }
    .content-cell {
      background: #eee;
    }
    .cell.row-1 { background: lightgreen; }
    .cell.col-2 { background: yellow; }
  """

render :: T.Render _ _ _
render _ _ _ _ =
  [ R.h1    [] [ R.text "Spreadsheet" ]
  , R.style [] [ R.text stylesheet ]
  , R.table [] (columnHeadersIndexed <> (mapWithIndex (\i -> row <<< renderRowNamed i) (liftRow <$> rowsIndexed)))
  , R.br    [] []
  , R.table [] (columnHeaderCellsNamed <> (mapWithIndex (\i -> row <<< renderRowNamed i) (liftRow <$> rowsIndexed)))
  , R.br    [] []
  , R.ol    [] (R.li [] <<< pure <<< R.text <<< fromMaybe "#ERROR" <$> extractColumn exSStr 1 rowsIndexed)
  , R.br    [] []
  , R.ol    [] (R.li [] <<< pure <<< R.text <<< show <<< fromMaybe 0.0 <$> extractColumn exSFloat 3 rowsIndexed)
  , R.text     (show <<< sum $ fromMaybe 0.0 <$> extractColumn exSFloat 3 rowsIndexed)
  ]

spec :: T.Spec _ _ _ _
spec = T.simpleSpec T.defaultPerformAction render

main = T.defaultMain spec unit