{-# 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.Text.Lazy as Text
import qualified Data.Text.Lazy.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.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 = Encoding.encodeUtf8 $ Text.intercalate "\n" $ concat
    [ [ Text.pack $ unwords $ map showByteHex bytes
      , Text.intercalate "  " $
        Text.pack (unwords $ map showByteBin bytes)
        : case eiC of
          Left err -> [Text.pack err]
          Right c -> map Text.pack
            [ [c]
            , printf "U+%04X" c
            , intercalate ", " $ maybeToList (UnicodeNames.name c) ++ map (++ "*") (UnicodeNames.nameAliases 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
    where

      blockName :: Char -> Maybe String
      blockName c = UnicodeBlocks.blockName . UnicodeBlocks.blockDefinition <$> UnicodeBlocks.block c

-- Utilities

showByteHex :: Word8 -> String
showByteHex = printf "      %02X"

showByteBin :: Word8 -> String
showByteBin = printf "%8b"

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