Compare commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
9a4c1f17b7 | ||
|
|
3d104ef50c | ||
|
|
976fbada7e | ||
|
|
0d59ded2ec | ||
|
|
ab667742da | ||
|
|
647b5c2ad1 | ||
|
|
57173d14dd |
+42
-14
@@ -61,17 +61,17 @@ app :: Application
|
|||||||
app = serve (Proxy :: Proxy API) server
|
app = serve (Proxy :: Proxy API) server
|
||||||
|
|
||||||
type API =
|
type API =
|
||||||
"bytes" :> Capture "bytes" Text :> Get '[PlainText, HTML] BytesModel
|
"utf8" :> Capture "bytes" Text :> Get '[PlainText, HTML] Utf8Model
|
||||||
:<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText, HTML] CodepointsModel
|
:<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText, HTML] CodepointsModel
|
||||||
:<|> "text" :> Capture "text" Text :> Get '[HTML] TextModel
|
:<|> "text" :> Capture "text" Text :> Get '[PlainText, HTML] TextModel
|
||||||
|
|
||||||
server :: Server API
|
server :: Server API
|
||||||
server =
|
server =
|
||||||
bytesR :<|> codepointsR :<|> textR
|
utf8R :<|> codepointsR :<|> textR
|
||||||
where
|
where
|
||||||
bytesR bytesP = do
|
utf8R bytesP = do
|
||||||
bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
|
bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
|
||||||
pure $ BytesModel $ Decode.decodeUtf8 bytes
|
pure $ mkUtf8Model bytes
|
||||||
|
|
||||||
codepointsR codepointsP = do
|
codepointsR codepointsP = do
|
||||||
codepoints' <- Parsers.parseCodepoints codepointsP `orThrow` const err400
|
codepoints' <- Parsers.parseCodepoints codepointsP `orThrow` const err400
|
||||||
@@ -82,11 +82,14 @@ server =
|
|||||||
|
|
||||||
-- /bytes/<bytes>
|
-- /bytes/<bytes>
|
||||||
|
|
||||||
newtype BytesModel = BytesModel
|
newtype Utf8Model = Utf8Model
|
||||||
{ codepoints :: [([Word8], Either String Char)]
|
{ codepoints :: [([Word8], Either String Char)]
|
||||||
}
|
}
|
||||||
|
|
||||||
instance MimeRender PlainText BytesModel where
|
mkUtf8Model :: [Word8] -> Utf8Model
|
||||||
|
mkUtf8Model = Utf8Model . Decode.decodeUtf8
|
||||||
|
|
||||||
|
instance MimeRender PlainText Utf8Model where
|
||||||
mimeRender _ model = renderText $
|
mimeRender _ model = renderText $
|
||||||
Table.render " " $ concat
|
Table.render " " $ concat
|
||||||
[ [ [ Table.cl $ Text.pack $ unwords $ map showByteHex bytes
|
[ [ [ Table.cl $ Text.pack $ unwords $ map showByteHex bytes
|
||||||
@@ -99,7 +102,7 @@ instance MimeRender PlainText BytesModel where
|
|||||||
Right c ->
|
Right c ->
|
||||||
[ Text.pack [c]
|
[ Text.pack [c]
|
||||||
, Text.pack $ printf "U+%04X" c
|
, Text.pack $ printf "U+%04X" c
|
||||||
, Text.pack $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
|
, Text.pack $ intercalate ", " $ allNames c
|
||||||
, Text.pack $ fromMaybe "" $ blockName c
|
, Text.pack $ fromMaybe "" $ blockName c
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
@@ -107,7 +110,7 @@ instance MimeRender PlainText BytesModel where
|
|||||||
| (bytes, eiC) <- model.codepoints
|
| (bytes, eiC) <- model.codepoints
|
||||||
]
|
]
|
||||||
|
|
||||||
instance MimeRender HTML BytesModel where
|
instance MimeRender HTML Utf8Model where
|
||||||
mimeRender _ model = renderHtml $ documentWithBody $ do
|
mimeRender _ model = renderHtml $ documentWithBody $ do
|
||||||
H.table $ for_ model.codepoints $ \(bytes, eiC) -> do
|
H.table $ for_ model.codepoints $ \(bytes, eiC) -> do
|
||||||
H.tr $ do
|
H.tr $ do
|
||||||
@@ -118,7 +121,7 @@ instance MimeRender HTML BytesModel where
|
|||||||
Right c -> do
|
Right c -> do
|
||||||
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [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 $ 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 $ intercalate ", " $ allNames c
|
||||||
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
|
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
|
||||||
|
|
||||||
-- /codepoints/<codepoints>
|
-- /codepoints/<codepoints>
|
||||||
@@ -128,7 +131,14 @@ newtype CodepointsModel = CodepointsModel
|
|||||||
}
|
}
|
||||||
|
|
||||||
mkCodepointsModel :: [(Word, Word)] -> CodepointsModel
|
mkCodepointsModel :: [(Word, Word)] -> CodepointsModel
|
||||||
mkCodepointsModel = CodepointsModel . map go . concatMap (uncurry enumFromTo)
|
mkCodepointsModel =
|
||||||
|
CodepointsModel
|
||||||
|
-- Limit number of returned codepoints. Otherwise it's
|
||||||
|
-- too easy to provoke massive response bodies with requests like
|
||||||
|
-- /codepoints/0-99999999
|
||||||
|
. take 100000
|
||||||
|
. map go
|
||||||
|
. concatMap (uncurry enumFromTo)
|
||||||
where
|
where
|
||||||
go codepoint = (codepoint, toChar codepoint)
|
go codepoint = (codepoint, toChar codepoint)
|
||||||
|
|
||||||
@@ -149,7 +159,7 @@ instance MimeRender PlainText CodepointsModel where
|
|||||||
Right c ->
|
Right c ->
|
||||||
[ Text.pack [c]
|
[ Text.pack [c]
|
||||||
, Text.pack $ printf "U+%04X" c
|
, Text.pack $ printf "U+%04X" c
|
||||||
, Text.pack $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
|
, Text.pack $ intercalate ", " $ allNames c
|
||||||
, Text.pack $ fromMaybe "" $ blockName c
|
, Text.pack $ fromMaybe "" $ blockName c
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
@@ -167,7 +177,7 @@ instance MimeRender HTML CodepointsModel where
|
|||||||
Right c -> do
|
Right c -> do
|
||||||
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [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 $ 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 $ intercalate ", " $ allNames c
|
||||||
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
|
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
|
||||||
|
|
||||||
-- /text/<text>
|
-- /text/<text>
|
||||||
@@ -182,9 +192,21 @@ instance MimeRender HTML TextModel where
|
|||||||
H.tr $ do
|
H.tr $ do
|
||||||
H.td $ H.input ! A.class_ "charbox" ! A.value (H.toValue [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 $ 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 $ intercalate ", " $ allNames c
|
||||||
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
|
H.td $ H.code $ H.toHtml $ fromMaybe "" $ blockName c
|
||||||
|
|
||||||
|
instance MimeRender PlainText TextModel where
|
||||||
|
mimeRender _ model = renderText $ Table.render " "
|
||||||
|
[ map (Table.cl)
|
||||||
|
[ Text.pack [c]
|
||||||
|
, Text.pack $ printf "U+%04X" c
|
||||||
|
, Text.pack $ intercalate ", " $ allNames c
|
||||||
|
, Text.pack $ fromMaybe "" $ blockName c
|
||||||
|
]
|
||||||
|
| c <- Text.unpack model.text
|
||||||
|
]
|
||||||
|
|
||||||
|
|
||||||
-- Utilities
|
-- Utilities
|
||||||
|
|
||||||
renderText :: Text -> BL.ByteString
|
renderText :: Text -> BL.ByteString
|
||||||
@@ -196,6 +218,12 @@ showByteHex = printf " %02X"
|
|||||||
showByteBin :: Word8 -> String
|
showByteBin :: Word8 -> String
|
||||||
showByteBin = printf "%08b"
|
showByteBin = printf "%08b"
|
||||||
|
|
||||||
|
-- | Retrieve name and aliases (suffixed with @*@) of a 'Char'.
|
||||||
|
allNames :: Char -> [String]
|
||||||
|
allNames c =
|
||||||
|
maybeToList (UnicodeNames.name c)
|
||||||
|
++ map (++ "*") (UnicodeNames.nameAliases c)
|
||||||
|
|
||||||
blockName :: Char -> Maybe String
|
blockName :: Char -> Maybe String
|
||||||
blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
|
blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c
|
||||||
|
|
||||||
|
|||||||
+1
-1
@@ -1,7 +1,7 @@
|
|||||||
# Adapted from new-template.hsfiles
|
# Adapted from new-template.hsfiles
|
||||||
|
|
||||||
name: utoy
|
name: utoy
|
||||||
version: 0.3
|
version: 0.5
|
||||||
git: "https://git.pbrinkmeier.de/paul/utoy"
|
git: "https://git.pbrinkmeier.de/paul/utoy"
|
||||||
license: MIT
|
license: MIT
|
||||||
author: "Paul Brinkmeier"
|
author: "Paul Brinkmeier"
|
||||||
|
|||||||
+1
-1
@@ -17,7 +17,7 @@ cr :: Text -> Cell
|
|||||||
cr = C AlignRight
|
cr = C AlignRight
|
||||||
|
|
||||||
render :: Text -> [[Cell]] -> Text
|
render :: Text -> [[Cell]] -> Text
|
||||||
render delim cells = Text.intercalate "\n" $ map showRow cells
|
render delim cells = Text.unlines $ map showRow cells
|
||||||
where
|
where
|
||||||
showRow = Text.intercalate delim . map showCell . zipLongest columnWidths
|
showRow = Text.intercalate delim . map showCell . zipLongest columnWidths
|
||||||
|
|
||||||
|
|||||||
+1
-1
@@ -5,7 +5,7 @@ cabal-version: 1.12
|
|||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
|
|
||||||
name: utoy
|
name: utoy
|
||||||
version: 0.3
|
version: 0.5
|
||||||
author: Paul Brinkmeier
|
author: Paul Brinkmeier
|
||||||
maintainer: hallo@pbrinkmeier.de
|
maintainer: hallo@pbrinkmeier.de
|
||||||
copyright: 2023 Paul Brinkmeier
|
copyright: 2023 Paul Brinkmeier
|
||||||
|
|||||||
Reference in New Issue
Block a user