cube/zenzicubi.co
cube/zenzicubi.co
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lift rendercells to either string a

Browse Source
This commit is contained in:
queue-miscreant 2025-07-29 00:59:42 -05:00
parent 4cfca44e6c
commit b5785fff56
1 changed files with 14 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
posts/number-number/2/Diagonal.hs
View File

@ -15,26 +15,23 @@ instance Show RowNumber where
-- Rendered cell data, along with its row number and an optional value to show instead -- Rendered cell data, along with its row number and an optional value to show instead
data RenderCell a = RC { data RenderCell a = RC {
cellRow :: Maybe RowNumber, -- Nothing if this is a header; Just . RC otherwise cellRow :: Maybe RowNumber, -- Nothing if this is a header; Just . RC otherwise
cellForceShow :: Maybe String, -- TODO: Either String a cellData :: Either String a -- Left if fixed display data, a otherwise
cellData :: Maybe a
} deriving Functor } deriving Functor
-- If a forced value is availaible, use it; otherwise, show the inside -- If a forced value is availaible, use it; otherwise, show the inside
instance Show a => Show (RenderCell a) where instance Show a => Show (RenderCell a) where
show (RC _ Nothing (Just x)) = show x show (RC _ (Left s)) = s
show (RC _ Nothing Nothing) = "" show (RC _ (Right x)) = show x
show (RC _ (Just s) _) = s
-- Lift a RenderCell over Either to an Either over RenderCells -- Lift a RenderCell over Either to an Either over RenderCells
-- If the force-string is set, then a `Left` version with a Nothing value is returned -- 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 :: RenderCell (Either a b) -> Either (RenderCell a) (RenderCell b)
liftRC (RC rn Nothing Nothing) = Left $ RC rn Nothing Nothing liftRC (RC rn (Left x)) = Left $ RC rn $ Left x
liftRC (RC rn (Just x) _) = Left $ RC rn (Just x) Nothing liftRC (RC rn (Right (Left v))) = Left $ RC rn $ Right v
liftRC (RC rn Nothing (Just (Left v))) = Left $ RC rn Nothing $ Just v liftRC (RC rn (Right (Right v))) = Right $ RC rn $ Right v
liftRC (RC rn Nothing (Just (Right v))) = Right $ RC rn Nothing $ Just v
-- Single column with a fixed header and data coming from a row number -- Single column with a fixed header and data coming from a row number
newColumn header f = columns f (\_ -> Headed $ RC Nothing (Just header) Nothing) [()] newColumn header f = columns f (\_ -> Headed $ RC Nothing (Left header)) [()]
-- Numbered rows of data, as opposed to data for rendering -- Numbered rows of data, as opposed to data for rendering
data DiagRow a = DR { data DiagRow a = DR {
@ -44,7 +41,7 @@ data DiagRow a = DR {
-- Same as `newColumn`, but reads into a DiagRow's row numberRows -- Same as `newColumn`, but reads into a DiagRow's row numberRows
-- The display function `f` is used to convert the value to a String -- The display function `f` is used to convert the value to a String
newColumnR header f = newColumn header (\_ c -> RC (Just $ rowNumber c) (Just $ f $ rowNumber c) Nothing) newColumnR header f = newColumn header (\_ c -> RC (Just $ rowNumber c) (Left $ f $ rowNumber c))
-- Number rows with the title "Sequence" -- Number rows with the title "Sequence"
numberColumn = newColumnR "Sequence" show numberColumn = newColumnR "Sequence" show
@ -55,16 +52,16 @@ ellipsisColumn = newColumnR "..." (const "...")
-- The ellipsis row is mapped to a cells which always display as ellipses -- The ellipsis row is mapped to a cells which always display as ellipses
-- The remaining rows are `Right` if they lie on the main diagonal, or `Left` otherwise -- The remaining rows are `Right` if they lie on the main diagonal, or `Left` otherwise
diagBox' n = columns cell headCell [0..n] diagBox' n = columns cell headCell [0..n]
where cell _ (DR Ellipsis _) = RC (Just Ellipsis) (Just "...") Nothing where cell _ (DR Ellipsis _) = RC (Just Ellipsis) (Left "...")
cell i (DR rn rd) = RC (Just rn) Nothing $ Just $ (if RN i == rn then Right else Left) (rd !! i) cell i (DR rn rd) = RC (Just rn) $ Right $ (if RN i == rn then Right else Left) (rd !! i)
headCell i = Headed $ RC Nothing (Just $ show i) Nothing headCell i = Headed $ RC Nothing (Left $ show i)
diagBox n = numberColumn <> diagBox' n <> ellipsisColumn diagBox n = numberColumn <> diagBox' n <> ellipsisColumn
displayRows f = (displayTable .) . tagRows' displayRows f = (displayTable .) . tagRows'
where -- Tag rows by (predicate function, extra value) tuples where -- Tag rows by (predicate function, extra value) tuples
tagRows' [] r@(RC rn _ _) = Left r -- Tag missing things as left 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 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 displayTable row = case bimap liftRC (fmap liftRC) row of
(Left (Left r)) -> Left r (Left (Left r)) -> Left r
(Left (Right r)) -> Right $ f r (Left (Right r)) -> Right $ f r