type-checker and working visualiser

visualisers/hmvis/public/css/main.css

@@ -41,13 +41,13 @@ body {
 
 .annotation-wrapper
 { display: inline-block
+; padding-bottom: 1em
+; border-style: solid
+; border-color: green
+; border-width: 0 0 4px 0
 }
 
 .annotation-wrapper .annotation
-{ display: hidden
-}
-
-.annotation-wrapper.hovering .annotation
-{ display: sticky
+{ position: fixed
 }
 

visualisers/hmvis/public/index.html

@@ -16,6 +16,7 @@
     <div class="split left">
 <pre id="editor">id = \x -&gt x
 twice f x = f (f x)
+flip f x y = f y x
 </pre>
     </div>
     <div class="split right" id="output">

visualisers/hmvis/src/hmvis/annotated.cljs

@@ -1,41 +1,46 @@
 (ns hmvis.annotated
   (:require [cljs.core.match :refer-macros [match]]
-            ; [cljsx.core :refer [jsx> react> defcomponent]]
-            ; [react :as react]
-            ; [react-dom :as react-dom]
+            [cljsx.core :refer [jsx> react> defcomponent]]
+            [react :as react]
+            [react-dom :as react-dom]
             [reagent.core :as r]
             [reagent.dom :as rdom]
-            [clojure.pprint :refer [cl-format]]))
+            [clojure.pprint :refer [cl-format]]
+            [hmvis.ppr :as ppr]))
 
 (defonce tc-input (r/atom nil))
 
 (defonce current-annotation-text (r/atom nil))
 
-(def app-prec  10)
-(def app-prec1 11)
-
 (defn hsep [& as]
   (let [f (fn [a b] (str a " " b))]
     (reduce f as)))
 
-; (defn maybe-parens [c s]
-;   (if c
-;       (react> (<> "(" s ")"))
-;       s))
+(defn maybe-parens [c s]
+  (if c
+      [:<> "(" s ")"]
+      s))
 
 (defn formatln [fs & rest]
   (apply cl-format true (str fs "~%") rest))
 
-(defn Typed [t & children]
-  (formatln "type: ~S" t)
-   [:div {:class "annotation-wrapper"
-          :onMouseEnter #(do (println "doge")
-                             (reset! current-annotation-text "doge"))
-          :onMouseLeave #(reset! current-annotation-text nil)}
-      children])
+(defn Annotation [text visible?]
+  (if visible?
+      [:div {:class "annotation"}
+       text]
+      nil))
 
-(defn Annotation []
-  [:p (or @current-annotation-text "<nil>")])
+(def nesting-rainbow (cycle ["red" "orange" "yellow"
+                             "green" "blue" "purple"]))
+
+(defn Typed [t child]
+  (let [hovering? (r/atom false)]
+    (fn []
+        [:div {:class "annotation-wrapper"
+               :on-mouse-enter #(reset! hovering? true)
+               :on-mouse-leave #(reset! hovering? false)}
+         child
+         [Annotation t @hovering?]])))
 
 (declare Expr)
 
@@ -49,18 +54,20 @@
   [:code var-id])
 
 (defn AppExpr [f x]
-  [:<> [Expr app-prec f]
+  [:<> [Expr ppr/app-prec f]
        " "
-       [Expr app-prec1 x]])
+       [Expr ppr/app-prec1 x]])
 
 (defn Expr [p {e :e t :type}]
   (match e
     {:InL {:tag "LamF" :contents [bs body & _]}}
-      [LambdaExpr bs body]
+      (maybe-parens (< ppr/app-prec1 p)
+                    [Typed t [LambdaExpr bs body]])
     {:InL {:tag "VarF" :contents var-id}}
-      [VarExpr var-id]
+      [Typed t [VarExpr var-id]]
     {:InL {:tag "AppF" :contents [f x]}}
-      [AppExpr f x]
+      (maybe-parens (< ppr/app-prec p)
+                    [Typed t [AppExpr f x]])
     :else [:code "<expr>"]))
 
 (defn render-decl [{name :name body :body}]
@@ -68,23 +75,11 @@
            (str name " = ") [Expr 0 body] #_ (render-expr body)
            [:br]])
 
-(defn Thing []
-  [:h1 @current-annotation-text])
-
 (defn type-checker []
   [:div
-   [Thing]
-   #_ [:button {:on-click #(reset! current-annotation-text "doge")}]])
-
-; (defcomponent TypeChecker props
-;   (react>
-;     (<div>
-;       (<Thing>)
-;       (<button :onClick #(do (reset! current-annotation-text "doge")
-;                              (formatln "thing: ~S" @current-annotation-text)) >)
-;       #_ (map render-decl (or @tc-input [])))))
+   (map render-decl (or @tc-input []))])
 
 (defn init []
   (rdom/render [type-checker]
-               (js/document.querySelector "#type-check")))
+               (js/document.querySelector "#output")))
 

visualisers/hmvis/src/hmvis/ppr.cljs

@@ -0,0 +1,41 @@
+(ns hmvis.ppr
+    (:require [cljs.core.match :refer-macros [match]]))
+
+(def app-prec  10)
+(def app-prec1 11)
+
+(defn- maybe-parens [c s]
+  (if c
+      (str "(" s ")")
+      s))
+
+(defn- hsep [& as]
+  (let [f (fn [a b] (str a " " b))]
+    (reduce f as)))
+
+(declare expr)
+
+(defn lambda-expr [binds body]
+  (hsep "λ" (apply hsep binds) "->" (expr body)))
+
+(defn app-expr [f x]
+  (hsep (expr app-prec f) (expr app-prec1 x)))
+
+(defn var-expr [var-id]
+  var-id)
+
+(defn expr
+  ([exp] (expr 0 exp))
+
+  ([p {e :e}]
+    (match e
+           {:InL {:tag "LamF" :contents [bs body & _]}}
+           (maybe-parens (< app-prec1 p)
+                         (lambda-expr bs body))
+           {:InL {:tag "VarF" :contents var-id}}
+           (var-expr var-id)
+           {:InL {:tag "AppF" :contents [f x]}}
+           (maybe-parens (< app-prec p)
+                         (app-expr f x))
+           :else [:code "<expr>"])))
+