119 lines
5.0 KiB
Haskell
119 lines
5.0 KiB
Haskell
{-# LANGUAGE TupleSections #-}
|
|
-- Module for displaying diagonals over Colonnades
|
|
module Diagonal where
|
|
|
|
import Colonnade
|
|
import Data.List (lookup)
|
|
import Data.Profunctor
|
|
import Data.Bifunctor
|
|
|
|
-- Row numbers, as integers with two extra values at the end
|
|
data RowNumber = RN Int | Ellipsis | Omega deriving Eq
|
|
instance Show RowNumber where
|
|
show (RN n) = show n
|
|
show Ellipsis = "..."
|
|
show Omega = "ω"
|
|
|
|
-- Rendered cell data, along with its row number and an optional value to show instead
|
|
data RenderCell a = RC {
|
|
cellRow :: Maybe RowNumber, -- Nothing if this is a header; Just . RC otherwise
|
|
cellData :: Either String a -- Left if fixed display data, a otherwise
|
|
} deriving Functor
|
|
|
|
-- If a forced value is availaible, use it; otherwise, show the inside
|
|
instance Show a => Show (RenderCell a) where
|
|
show (RC _ (Left s)) = s
|
|
show (RC _ (Right x)) = show x
|
|
|
|
-- Lift a RenderCell over Either to an Either over RenderCells
|
|
-- If the force-string is set (cellData is a Left), then a `Left` version is produced
|
|
liftRC :: RenderCell (Either a b) -> Either (RenderCell a) (RenderCell b)
|
|
liftRC (RC rn (Left x)) = Left $ RC rn $ Left x
|
|
liftRC (RC rn (Right (Left v))) = Left $ RC rn $ Right v
|
|
liftRC (RC rn (Right (Right v))) = Right $ RC rn $ Right v
|
|
|
|
-- Single column with a fixed header and data coming from a row number
|
|
newColumn header f = columns f (\_ -> Headed $ RC Nothing (Left header)) [()]
|
|
|
|
-- Numbered rows of data, as opposed to data for rendering
|
|
data DiagRow a = DR {
|
|
rowNumber :: RowNumber, -- Row number
|
|
rowLabels :: [(String, String)], -- Extra labelling lookup for this row, which should not be manipulated
|
|
rowData :: [a] -- Actual row data
|
|
} deriving Functor
|
|
|
|
-- Same as `newColumn`, but reads into a DiagRow's row numberRows
|
|
-- The display function `f` is used to convert the value to a String
|
|
newColumnR header f = newColumn header (\_ c -> RC (Just $ rowNumber c) (Left $ f $ rowNumber c))
|
|
|
|
-- Additional column from a label on the row
|
|
labelColumn header = newColumn header (\_ (DR rn rl rd) -> RC (Just rn) $ Left $ maybe "" id $ lookup header rl)
|
|
|
|
-- Number rows with the title "Sequence"
|
|
numberColumn = newColumnR "Sequence" show
|
|
-- Column of ellipses
|
|
ellipsisColumn = newColumnR "..." (const "...")
|
|
|
|
-- Create a Colonnade over DiagRows by mapping them into lists
|
|
-- The ellipsis row is mapped to cells which always display as ellipses
|
|
diagBox' n = columns cell headCell [0..n]
|
|
where cell _ (DR Ellipsis _ _) = RC (Just Ellipsis) (Left "...")
|
|
cell i (DR rn _ rd) = RC (Just rn) $ Right $ (Just i, rd !! i)
|
|
headCell i = Headed $ RC Nothing (Left $ show i)
|
|
|
|
diagBox n = numberColumn <> diagBox' n <> ellipsisColumn
|
|
|
|
displayRows f = (displayTable .) . tagRows'
|
|
where -- Tag rows by (predicate function, extra value) tuples
|
|
tagRows' [] r@(RC rn _) = Left r -- Tag missing things as left
|
|
tagRows' ((p, f):ps) r@(RC rn _) = if p == rn then Right (f, r) else tagRows' ps r -- Match found, tag right
|
|
displayTable row = case bimap liftRC (fmap liftRC) row of
|
|
(Left (Left r)) -> Left r
|
|
(Left (Right r)) -> Right $ f r
|
|
(Right (g, r)) -> Right $ g $ either id id r
|
|
|
|
-- Build a list of `DiagRow`s from xs, terminated by an ellipsis and an Omega row (y)
|
|
rowsOmega :: [[a]] -> [a] -> [DiagRow a]
|
|
rowsOmega xs y = zipWith (\x n -> DR (RN n) [] x) xs [0..] ++ [DR Ellipsis [] [], DR Omega [] y]
|
|
|
|
-- Build a labelled list of `DiagRow`s from labelled sequences xs, terminated by an ellipsis and an Omega row (y)
|
|
-- l is the label name to use in the DiagRow
|
|
rowsOmegaLabelled :: String -> [(String, [a])] -> [a] -> [DiagRow a]
|
|
rowsOmegaLabelled l xs y = zipWith (\(x, y) n -> DR (RN n) [(l, x)] y) xs [0..] ++ [DR Ellipsis [] [], DR Omega [] y]
|
|
|
|
-- rmap over a Colonnade using the first function in `ps` which does not return Nothing
|
|
-- If no functions match, `f` is used instead.
|
|
renderCells f ps = rmap $ tryOne ps where
|
|
tryOne [] c = f c
|
|
tryOne (p:ps) c = case p c of
|
|
Just new -> new
|
|
Nothing -> tryOne ps c
|
|
|
|
-- Mark a diagonal using the function f
|
|
-- Cells are expected to be of the format (Maybe {columnNumber}, data)
|
|
-- Diagonal n is the one where the difference between the row number and column number is n
|
|
-- Nonmatches go to Nothing
|
|
markDiagonal n f (RC (Just (RN r)) x) = case x of
|
|
Left _ -> Nothing
|
|
Right (Nothing, y) -> Nothing
|
|
Right (Just x, y) -> if r - x == n then Just $ f y else Nothing
|
|
markDiagonal n f (RC _ x) = Nothing
|
|
|
|
-- Mark certain row numbers using the function f
|
|
-- Nonmatches go to Nothing
|
|
markRows rns f x@(RC (Just rn) _)
|
|
| rn `elem` rns = Just $ f x
|
|
| otherwise = Nothing
|
|
markRows _ _ (RC _ _) = Nothing
|
|
|
|
-- Show the pure cell data without the column index
|
|
showCell (RC _ (Left s)) = s
|
|
showCell (RC _ (Right (_, x))) = show x
|
|
|
|
-- Demo some data with emphasized rows and a diagonal
|
|
displayDiagData :: Show a => [RowNumber] -> Int -> Colonnade Headed (DiagRow a) String
|
|
displayDiagData rows = renderCells showCell [
|
|
markDiagonal 0 (("Red " ++) . show),
|
|
markRows rows (("Green " ++) . showCell)
|
|
] . diagBox
|