diff --git a/app/Main.hs b/app/Main.hs index ab8ea47..0386eff 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/UToy/Table.hs b/src/UToy/Table.hs new file mode 100644 index 0000000..a3c3d3b --- /dev/null +++ b/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 diff --git a/utoy.cabal b/utoy.cabal index 4af2fa6..fa8996a 100644 --- a/utoy.cabal +++ b/utoy.cabal @@ -23,6 +23,7 @@ library exposed-modules: UToy.Decode UToy.Parsers + UToy.Table other-modules: Paths_utoy hs-source-dirs: