utoy/app/Main.hs

{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}

module Main (main) where

import Data.Char (chr)
import Data.FileEmbed (embedFile)
import Data.Foldable (for_)
import Data.List (intercalate)
import Data.Maybe (fromMaybe, maybeToList)
import Data.Text (Text)
import Data.Word (Word8)
import Network.HTTP.Media ((//), (/:))
import Network.Wai (Application)
import Servant
  ( Accept (..)
  , Handler
  , MimeRender (..)
  , Server
  , ServerError (..)
  , PlainText
  , Proxy (..)
  , Capture
  , Get
  , err400
  , serve
  , throwError
  , (:>)
  , (:<|>) (..)
  )
import Text.Blaze.Html5 ((!))
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Printf (PrintfArg, printf)

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
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 ()
main = Warp.run 3000 app

app :: Application
app = serve (Proxy :: Proxy API) server

type API =
  "bytes" :> Capture "bytes" Text :> Get '[PlainText, HTML] BytesModel
  :<|> "codepoints" :> Capture "codepoints" Text :> Get '[PlainText] CodepointsModel

server :: Server API
server =
  bytesR :<|> codepointsR
  where
    bytesR bytesP = do
      bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
      pure $ BytesModel $ Decode.decodeUtf8 bytes

    codepointsR codepointsP = do
      codepoints' <- Parsers.parseCodepoints codepointsP `orThrow` const err400
      pure $ mkCodepointsModel codepoints'

-- /bytes/<bytes>

newtype BytesModel = BytesModel
  { codepoints :: [([Word8], Either String Char)]
  }

instance MimeRender PlainText BytesModel where
  mimeRender _ model = renderText $
    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 ->
              [ "Decoding error: " <> Text.pack err
              ]
            Right c ->
              [ Text.pack [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
      ]

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 "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 $ do
                H.input ! A.value (H.toValue [c]) ! A.style "text-align: center; width: 2em; font-size: 1em;"
              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

-- /codepoints/<codepoints>

newtype CodepointsModel = CodepointsModel
  { codepoints :: [(Word, Either String Char)]
  }

mkCodepointsModel :: [(Word, Word)] -> CodepointsModel
mkCodepointsModel = CodepointsModel . map go . concatMap (uncurry enumFromTo)
  where
    go codepoint = (codepoint, toChar codepoint)

    toChar codepoint
      | codepoint > 0x10FFFF = Left "Would be too big (maximum: U+10FFFF)"
      | isSurrogate codepoint = Left "Is a surrogate"
      | otherwise = Right $ chr $ fromIntegral codepoint

    isSurrogate codepoint = 0xD800 <= codepoint && codepoint <= 0xDFFF

instance MimeRender PlainText CodepointsModel where
  mimeRender _ model = renderText $ Table.render "  "
    [ map Table.cl (Text.pack (printf "0x%X" codepoint)
      : case eiC of
        Left err ->
          [ "Decoding error: " <> Text.pack err
          ]
        Right c ->
          [ Text.pack [c]
          , Text.pack $ printf "U+%04X" c
          , Text.pack $ intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases c)
          , Text.pack $ fromMaybe "" $ blockName c
          ]
      )
    | (codepoint, eiC) <- model.codepoints
    ]

-- Utilities

renderText :: Text -> BL.ByteString
renderText = BL.fromStrict . Encoding.encodeUtf8

showByteHex :: Word8 -> String
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

printfHtml :: PrintfArg a => String -> a -> H.Html
printfHtml fmt = (H.toHtml :: String -> H.Html) . printf fmt

-- HTML routes

data HTML

instance Accept HTML where
  contentType _ = "text" // "html" /: ("charset", "utf-8")