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

module Main (main) where

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 =
  "hex" :> Capture "bytes" Text :> Get '[PlainText, HTML] HexModel

server :: Server API
server =
  hex
  where
    hex bytesP = do
      bytes <- Parsers.parseHexBytes bytesP `orThrow` const err400
      pure $ HexModel $ Decode.decodeUtf8 bytes

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

instance MimeRender PlainText HexModel where
  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
      ]

instance MimeRender HTML HexModel where
  mimeRender _ model = renderHtml $ H.docTypeHtml $ do
    H.head $ do
      H.meta ! A.charset "utf-8"
      H.title "utoy"
      H.style "html { font-size: 32px; font-family: 'Noto Sans', sans-serif; } td { padding: 0.5em 1em; } pre { margin: 0; font-size: 0.5em; } body { display: flex; justify-content: center; }"
    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

-- Utilities

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")