html

src/Rlp/HindleyMilner/Visual.hs

@@ -0,0 +1,133 @@
+{-# LANGUAGE LexicalNegation #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Rlp.HindleyMilner.Visual
+    (
+    )
+    where
+--------------------------------------------------------------------------------
+import Control.Monad
+import System.IO
+import Data.Text                        qualified as T
+import Data.Text.IO                     qualified as T
+import Data.Pretty
+import Data.String                      (IsString(..))
+import Data.Foldable
+import Misc.CofreeF
+import Control.Exception
+
+import Data.Functor.Foldable
+
+import Text.Blaze.Html5                 as H
+import Text.Blaze.Html5.Attributes      as A
+import Text.Blaze.Html.Renderer.String
+import Clay                             (Css, (?), px, pct, (**), (|>), (|+)
+                                        , (|~))
+import Clay                             qualified as C
+import Clay.Render                      qualified as C
+import Language.Javascript.JMacro
+import Language.Javascript.JQuery       qualified as JQuery
+
+import Core.Syntax                      as Core
+import Rlp.AltSyntax                    as Rlp
+import Rlp.HindleyMilner
+
+import Prelude hiding ((**))
+--------------------------------------------------------------------------------
+
+type AnnExpr = Cofree (RlpExprF PsName)
+
+tooltips :: Css
+tooltips = do
+    ".has-type" ? do
+        C.position     C.relative
+        C.display      C.inlineBlock
+        C.borderBottom (px 1) C.dotted C.black
+    ".has-type.hovering" ? do
+        C.background C.green
+    ".has-type.hovering" |> ".type-text" ? do
+        C.display      C.block
+        C.opacity      1
+        C.position     C.fixed
+        C.overflowWrap C.breakWord
+    ".has-type" |> ".type-text" ? do
+        C.display      C.none
+        C.overflowWrap C.breakWord
+        C.maxWidth     (pct 50)
+
+stylesheet :: Css
+stylesheet = tooltips
+
+numbers :: Int -> Html
+numbers n = docTypeHtml do
+    H.head do
+        H.title "naturals"
+        H.style "doge"
+    body do
+        pre "a list of nats"
+        ul $ forM_ [1..n] (li . toHtml)
+
+withTooltip :: Html -> Html -> Html
+withTooltip normal hover =
+    H.div ! class_ "has-type"
+        $ normal *> (H.div ! class_ "type-text" $ hover)
+
+-- withTooltip :: Html -> Html -> Html
+-- withTooltip normal hover =
+--     H.div ! class_ "has-type"
+--           -- ! onload "installHoverListener(this)"
+--         $ normal
+
+annExpr :: (ann -> Doc) -> AnnExpr ann -> Html
+annExpr sf = code . cata \case
+    t :<$ InL (LitF l)   -> withTooltip (rpretty l) (sf' t)
+    t :<$ InL (VarF n)   -> withTooltip (rpretty n) (sf' t)
+    t :<$ InL (AppF f x) -> withTooltip (f *> " " *> x) (sf' t)
+    t :<$ InL (LamF bs e) -> withTooltip ("λ" *> bs' *> " -> " *> e) (sf' t)
+        where
+            bs' = fromString . render . hsep $ prettyPrec appPrec1 <$> bs
+  where
+    sf' = fromString . show . sf
+
+rootScript :: JStat
+rootScript = [jmacro|
+    $(".has-type").on("mouseover mouseout", \e {
+        e.stopPropagation();
+        $(this).toggleClass("hovering", e.type === "mouseover");
+        var o = $(this).children(".type-text")[0];
+        var x = e.clientX;
+        var y = e.clientY;
+        o.style.top = (y + 20) + 'px';
+        o.style.left = (x + 20) + 'px';
+    });
+|]
+
+jsScript :: (IsString s, JsToDoc w, JMacro w) => w -> s
+jsScript = fromString . show . renderJs
+
+rootPage :: Html -> Html
+rootPage html = docTypeHtml do
+    H.head do
+        H.title "naturals"
+        H.style (toHtml . C.render $ stylesheet)
+    H.body do
+        html
+        script ! src (fromString $ "https:" ++ JQuery.url) $ ""
+        script ! src "https://code.jquery.com/ui/1.13.2/jquery-ui.min.js" $ ""
+        script (fromString . show . renderJs $ rootScript)
+
+renderTmp :: Html -> IO ()
+renderTmp = writeFile "/tmp/t.html" . renderHtml
+
+renderTmp' :: Html -> IO ()
+renderTmp' = writeFile "/tmp/t.html" . renderHtml . rootPage
+
+renderExpr :: RlpExpr PsName -> IO ()
+renderExpr e = case runHM' . annotate $ e of
+    Left es -> error (show es)
+    Right e' -> renderTmp' . annExpr (fromString . show) $ e'
+
+renderExpr' :: RlpExpr PsName -> IO ()
+renderExpr' e = case runHM' . solve $ e of
+    Left es -> error (show es)
+    Right e' -> renderTmp' . annExpr pretty $ e'
+