paul/utoy
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add HTML version of /codepoints

Browse Source
This commit is contained in:
Paul Brinkmeier 2023-03-12 20:50:33 +01:00
parent 36f9bb390d
commit 9881b44fa2
1 changed files with 22 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
app/Main.hs
View File

@ -62,7 +62,7 @@ app = serve (Proxy :: Proxy API) server
type API =
"bytes" :> Capture "bytes" Text :> Get '[PlainText, HTML] BytesModel
:<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText] CodepointsModel
:<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText, HTML] CodepointsModel
:<|> "text" :> Capture "text" Text :> Get '[HTML] TextModel
server :: Server API
@ -121,9 +121,8 @@ instance MimeRender HTML BytesModel where
Left err ->
H.td ! A.colspan "4" $ H.toHtml $ "Decoding error: " ++ err
Right c -> do
H.td $ do
H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
H.td $ H.code $ printfHtml "U+%04X" c
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
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.code $ H.toHtml $ fromMaybe "" $ blockName c
@ -162,6 +161,25 @@ instance MimeRender PlainText CodepointsModel where
| (codepoint, eiC) <- model.codepoints
]
instance MimeRender HTML CodepointsModel where
mimeRender _ model = renderHtml $ H.docTypeHtml $ do
H.head $ do
H.meta ! A.charset "utf-8"
H.title "utoy"
H.style $ H.toHtml $ Encoding.decodeUtf8 $(embedFile "static/utoy.css")
H.body $ do
H.table $ for_ model.codepoints $ \(codepoint, eiC) ->
H.tr $ do
H.td $ H.code $ H.toHtml $ Text.pack $ printf "0x%X" codepoint
case eiC of
Left err -> do
H.td ! A.colspan "4" $ H.code $ H.toHtml $ "Decoding error: " <> Text.pack err
Right c -> do
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [c])
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.code $ H.toHtml $ fromMaybe "" $ blockName c
-- /text/<text>
newtype TextModel = TextModel