server: simple servant-lucid stuff

1 files changed, 57 insertions, 0 deletions

diff --git a/server/Orphans.hs b/server/Orphans.hs
new file mode 100644
index 0000000..b46f728
--- /dev/null
+++ b/server/Orphans.hs
@@ -0,0 +1,57 @@
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+
+module Orphans where
+
+
+import           Control.Monad (forM_, unless)
+import qualified Data.Map      as M
+import           Data.Text     (Text)
+import           Lucid         (ToHtml)
+import           Lucid.Base    (ToHtml (toHtml))
+import           Lucid.Html5
+
+import           CheckDir
+import           CheckMap
+import           Types
+import           Util          (prettyprint)
+
+instance ToHtml Hint where
+  toHtml (Hint l m) = do
+    span_ [class_ "level"] $ toHtml (show l)
+    toHtml m
+
+
+instance ToHtml DirResult where
+  toHtml res@DirResult { .. } = do
+    h3_ $ toHtml (show $ maximumLintLevel res)
+    unless (null dirresultMissingAssets && null dirresultDeps) $ do
+      h2_ "Dependencies"
+      ul_ $ do
+        forM_ dirresultMissingAssets $ \(MissingAsset missing) -> do
+          li_ $ toHtml (prettyprint missing)
+        forM_ dirresultDeps $ \missing -> do
+          li_ $ toHtml (prettyprint missing)
+    unless (null dirresultMaps) $ do
+      h2_ "Maps"
+      flip M.foldMapWithKey dirresultMaps $ \name MapResult { .. } -> do
+        h3_ (toHtml name)
+        ul_ $ do
+          forM_ mapresultGeneral $ \lint ->
+            li_ (toHtml lint)
+          flip M.foldMapWithKey mapresultLayer $ \lint layers ->
+            li_ $ do
+              toHtml lint
+              toHtml ("(in layer" :: Text)
+              forM_ layers $ \layer ->
+                span_ [class_ "layer"] (toHtml layer)
+              toHtml (")" :: Text)
+          flip M.foldMapWithKey mapresultTileset $ \lint tilesets ->
+            li_ $ do
+              toHtml lint
+              toHtml ("( in layer" :: Text)
+              forM_ tilesets $ \tileset ->
+                span_ [class_ "tileset"] (toHtml tileset)
+              toHtml (")" :: Text)