Rewrite text table generation

app/Main.hs

@@ -36,8 +36,9 @@ import Text.Blaze.Html5 ((!))
 import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
 import Text.Printf (PrintfArg, printf)
 
-import qualified Data.Text.Lazy as Text
-import qualified Data.Text.Lazy.Encoding as Encoding
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Encoding
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
@@ -45,6 +46,7 @@ import qualified Unicode.Char.General.Blocks as UnicodeBlocks
 import qualified Unicode.Char.General.Names as UnicodeNames
 
 import qualified UToy.Decode as Decode
+import qualified UToy.Table as Table
 import qualified UToy.Parsers as Parsers
 
 main :: IO ()
@@ -69,20 +71,24 @@ newtype HexModel = HexModel
   }
 
 instance MimeRender PlainText HexModel where
-  mimeRender _ model = Encoding.encodeUtf8 $ Text.intercalate "\n" $ concat
-    [ [ Text.pack $ unwords $ map showByteHex bytes
-      , Text.intercalate "  " $
-        Text.pack (unwords $ map showByteBin bytes)
-        : case eiC of
-          Left err -> [Text.pack err]
-          Right c -> map Text.pack
-            [ [c]
-            , printf "U+%04X" c
-            , intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
-            ]
+  mimeRender _ model = BL.fromStrict $ Encoding.encodeUtf8 $
+    Table.render "  " $ concat
+      [ [ [ Table.cl $ Text.pack $ unwords $ map showByteHex bytes
+          ]
+        , map Table.cl (Text.pack (unwords $ map showByteBin bytes)
+          : case eiC of
+            Left err ->
+              [ Text.pack err
+              ]
+            Right c ->
+              [ Text.pack $ printf "U+%04X" c
+              , Text.pack $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
+              , Text.pack $ fromMaybe "" $ blockName c
+              ]
+          )
+        ]
+      | (bytes, eiC) <- model.codepoints
       ]
-    | (bytes, eiC) <- model.codepoints
-    ]
 
 instance MimeRender HTML HexModel where
   mimeRender _ model = renderHtml $ H.docTypeHtml $ do
@@ -103,10 +109,6 @@ instance MimeRender HTML HexModel where
               H.td $ H.code $ printfHtml "U+%04X" c
               H.td $ H.code $ H.toHtml $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
               H.td $ H.toHtml $ fromMaybe "" $ blockName c
-    where
-
-      blockName :: Char -> Maybe String
-      blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
 
 -- Utilities
 
@@ -116,6 +118,9 @@ showByteHex = printf "      %02X"
 showByteBin :: Word8 -> String
 showByteBin = printf "%8b"
 
+blockName :: Char -> Maybe String
+blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
+
 orThrow :: Either a b -> (a -> ServerError) -> Handler b
 orThrow (Left err) f = throwError $ f err
 orThrow (Right val) _ = pure val

src/UToy/Table.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+
+module UToy.Table (Cell, cl, cr, render) where
+
+import Data.Text (Text)
+
+import qualified Data.Text as Text
+
+data Cell = C Align Text
+
+data Align = AlignLeft | AlignRight
+
+cl :: Text -> Cell
+cl = C AlignLeft
+
+cr :: Text -> Cell
+cr = C AlignRight
+
+render :: Text -> [[Cell]] -> Text
+render delim cells = Text.intercalate "\n" $ map showRow cells
+  where
+    showRow = Text.intercalate delim . map showCell . zipLongest columnWidths
+
+    showCell (L width) = Text.replicate width " "
+    showCell (R _) = error "unreachable"
+    showCell (B width (C align x)) = justify x
+      where 
+        justify = case align of
+          AlignLeft -> Text.justifyLeft width ' '
+          AlignRight -> Text.justifyRight width ' '
+
+    columnWidths = foldl go' [] cells
+
+    go' counts row = map (zipped id cellLength max) $ zipLongest counts row
+
+    cellLength (C _ x) = Text.length x
+
+data Zipped a b
+  = L a
+  | R b
+  | B a b
+
+zipped
+  :: (a -> t)
+  -> (b -> t)
+  -> (t -> t -> t)
+  -> Zipped a b
+  -> t
+zipped fl _ _ (L x) = fl x
+zipped _ fr _ (R x) = fr x
+zipped fl fr fb (B x y) = fb (fl x) (fr y)
+
+zipLongest :: [a] -> [b] -> [Zipped a b]
+zipLongest [] ys = map R ys
+zipLongest xs [] = map L xs
+zipLongest (x:xs) (y:ys) = B x y : zipLongest xs ys

utoy.cabal

@@ -23,6 +23,7 @@ library
   exposed-modules:
       UToy.Decode
       UToy.Parsers
+      UToy.Table
   other-modules:
       Paths_utoy
   hs-source-dirs: