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

Move common html code to its own function

Browse Source
This commit is contained in:
Paul Brinkmeier 2023-03-12 20:53:43 +01:00
parent 9881b44fa2
commit 3fd4177cd4
1 changed files with 40 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
app/Main.hs
View File

@ -108,23 +108,18 @@ instance MimeRender PlainText BytesModel where
]
instance MimeRender HTML BytesModel 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 $ \(bytes, eiC) -> do
H.tr $ do
H.td $ H.pre $ H.toHtml $ unlines $ map unwords [map showByteHex bytes, map showByteBin bytes]
case eiC of
Left err ->
H.td ! A.colspan "4" $ H.toHtml $ "Decoding error: " ++ 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
mimeRender _ model = renderHtml $ documentWithBody $ do
H.table $ for_ model.codepoints $ \(bytes, eiC) -> do
H.tr $ do
H.td $ H.pre $ H.toHtml $ unlines $ map unwords [map showByteHex bytes, map showByteBin bytes]
case eiC of
Left err ->
H.td ! A.colspan "4" $ H.toHtml $ "Decoding error: " ++ 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
-- /codepoints/<codepoints>
@ -162,23 +157,18 @@ instance MimeRender PlainText CodepointsModel where
]
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
mimeRender _ model = renderHtml $ documentWithBody $ 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>
@ -187,18 +177,13 @@ newtype TextModel = TextModel
}
instance MimeRender HTML TextModel 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_ (Text.unpack model.text) $ \c -> do
H.tr $ 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
mimeRender _ model = renderHtml $ documentWithBody $ do
H.table $ for_ (Text.unpack model.text) $ \c -> do
H.tr $ 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
-- Utilities
@ -221,6 +206,15 @@ orThrow (Right val) _ = pure val
printfHtml :: PrintfArg a => String -> a -> H.Html
printfHtml fmt = (H.toHtml :: String -> H.Html) . printf fmt
documentWithBody :: H.Html -> H.Html
documentWithBody body =
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 body
-- HTML routes
data HTML