134 lines
4.1 KiB
Haskell
134 lines
4.1 KiB
Haskell
{-# 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'
|
|
|