socket

2024-04-24 13:10:26 -06:00
parent 3c234e6002
commit 6f5c7ee284
6 changed files with 194 additions and 20 deletions
--- a/app/Server.hs
+++ b/app/Server.hs
@@ -30,6 +30,7 @@ import Control.Lens                 hiding ((.=))

 import Compiler.RLPC
 import Compiler.JustRun
+import GM

 -- import Misc.CofreeF
 -- import Rlp.AltSyntax
@@ -62,7 +63,7 @@ instance FromJSON Command where

 data Response = Annotated Value
              | PartiallyAnnotated Value
-              | Evaluated Value
+              | Evaluated [GmState]
              | Error Value
              deriving (Generic)
              deriving (ToJSON)
@@ -87,5 +88,5 @@ respond (Annotate s)

 respond (Evaluate s)
    = justLexParseGmEval (T.unpack s)
-    & either (Error . toJSON) (Evaluated . toJSON)
+    & either (Error . toJSON) Evaluated

--- a/src/Compiler/RlpcError.hs
+++ b/src/Compiler/RlpcError.hs
@@ -23,6 +23,9 @@ import Data.Text                qualified as T
 import GHC.Exts                 (IsString(..))
 import Control.Lens
 import Compiler.Types
+import GHC.Generics             ( Generic, Generic1
+                                , Generically(..), Generically1(..) )
+import Data.Aeson               (ToJSON1(..), ToJSON(..))
 ----------------------------------------------------------------------------------

 data MsgEnvelope e = MsgEnvelope
@@ -30,10 +33,18 @@ data MsgEnvelope e = MsgEnvelope
   , _msgDiagnostic  :: e
   , _msgSeverity    :: Severity
   }
-   deriving (Functor, Show)
+   deriving (Functor, Show, Generic, Generic1)

 newtype RlpcError = Text [Text]
-               deriving Show
+               deriving (Show, Generic)
+
+deriving via Generically1 MsgEnvelope
+    instance ToJSON1 MsgEnvelope
+deriving via Generically (MsgEnvelope e)
+    instance ToJSON e => ToJSON (MsgEnvelope e)
+
+deriving via Generically RlpcError
+    instance ToJSON RlpcError

 instance IsString RlpcError where
    fromString = Text . pure . T.pack
@@ -47,7 +58,10 @@ instance IsRlpcError RlpcError where
 data Severity = SevWarning
              | SevError
              | SevDebug Text -- ^ Tag
-              deriving Show
+              deriving (Show, Generic)
+
+deriving via Generically Severity
+    instance ToJSON Severity

 makeLenses ''MsgEnvelope

--- a/src/Compiler/Types.hs
+++ b/src/Compiler/Types.hs
@@ -20,6 +20,9 @@ import Data.Functor.Apply
 import Data.Functor.Bind
 import Control.Lens             hiding ((<<~))
 import Language.Haskell.TH.Syntax   (Lift)
+import GHC.Generics             ( Generic, Generic1
+                                , Generically(..), Generically1(..) )
+import Data.Aeson               (ToJSON1(..), ToJSON(..))
 --------------------------------------------------------------------------------

 -- | Token wrapped with a span (line, column, absolute, length)
@@ -47,7 +50,10 @@ data SrcSpan = SrcSpan
    !Int -- ^ Column
    !Int -- ^ Absolute
    !Int -- ^ Length
-    deriving (Show, Lift)
+    deriving (Show, Lift, Generic)
+
+deriving via Generically SrcSpan
+    instance ToJSON SrcSpan

 tupling :: Iso' SrcSpan (Int, Int, Int, Int)
 tupling = iso (\ (SrcSpan a b c d) -> (a,b,c,d))
--- a/visualisers/gmvis/package-lock.json
+++ b/visualisers/gmvis/package-lock.json
@@ -7,10 +7,21 @@
    "": {
      "name": "gmvis",
      "version": "0.0.1",
+      "dependencies": {
+        "ace-builds": "^1.32.7",
+        "react": "16.13.0",
+        "react-ace": "^10.1.0",
+        "react-dom": "16.13.0"
+      },
      "devDependencies": {
        "shadow-cljs": "2.28.3"
      }
    },
+    "node_modules/ace-builds": {
+      "version": "1.33.1",
+      "resolved": "https://registry.npmjs.org/ace-builds/-/ace-builds-1.33.1.tgz",
+      "integrity": "sha512-pj5mcXV1n3s86UI4SWUt8X0ltN8cTaYcvF76cSmvy5i2ZDtXX9KkjVcYTGkCV7ox6VUrzqHByeqH0xRsMjXi4g=="
+    },
    "node_modules/asn1.js": {
      "version": "4.10.1",
      "resolved": "https://registry.npmjs.org/asn1.js/-/asn1.js-4.10.1.tgz",
@@ -341,6 +352,11 @@
        "minimalistic-assert": "^1.0.0"
      }
    },
+    "node_modules/diff-match-patch": {
+      "version": "1.0.5",
+      "resolved": "https://registry.npmjs.org/diff-match-patch/-/diff-match-patch-1.0.5.tgz",
+      "integrity": "sha512-IayShXAgj/QMXgB0IWmKx+rOPuGMhqm5w6jvFxmVenXKIzRqTAAsbBPT3kWQeGANj3jGgvcvv4yK6SxqYmikgw=="
+    },
    "node_modules/diffie-hellman": {
      "version": "5.0.3",
      "resolved": "https://registry.npmjs.org/diffie-hellman/-/diffie-hellman-5.0.3.tgz",
@@ -595,6 +611,32 @@
      "integrity": "sha512-RHxMLp9lnKHGHRng9QFhRCMbYAcVpn69smSGcq3f36xjgVVWThj4qqLbTLlq7Ssj8B+fIQ1EuCEGI2lKsyQeIw==",
      "dev": true
    },
+    "node_modules/js-tokens": {
+      "version": "4.0.0",
+      "resolved": "https://registry.npmjs.org/js-tokens/-/js-tokens-4.0.0.tgz",
+      "integrity": "sha512-RdJUflcE3cUzKiMqQgsCu06FPu9UdIJO0beYbPhHN4k6apgJtifcoCtT9bcxOpYBtpD2kCM6Sbzg4CausW/PKQ=="
+    },
+    "node_modules/lodash.get": {
+      "version": "4.4.2",
+      "resolved": "https://registry.npmjs.org/lodash.get/-/lodash.get-4.4.2.tgz",
+      "integrity": "sha512-z+Uw/vLuy6gQe8cfaFWD7p0wVv8fJl3mbzXh33RS+0oW2wvUqiRXiQ69gLWSLpgB5/6sU+r6BlQR0MBILadqTQ=="
+    },
+    "node_modules/lodash.isequal": {
+      "version": "4.5.0",
+      "resolved": "https://registry.npmjs.org/lodash.isequal/-/lodash.isequal-4.5.0.tgz",
+      "integrity": "sha512-pDo3lu8Jhfjqls6GkMgpahsF9kCyayhgykjyLMNFTKWrpVdAQtYyB4muAMWozBB4ig/dtWAmsMxLEI8wuz+DYQ=="
+    },
+    "node_modules/loose-envify": {
+      "version": "1.4.0",
+      "resolved": "https://registry.npmjs.org/loose-envify/-/loose-envify-1.4.0.tgz",
+      "integrity": "sha512-lyuxPGr/Wfhrlem2CL/UcnUc1zcqKAImBDzukY7Y5F/yQiNdko6+fRLevlw1HgMySw7f611UIY408EtxRSoK3Q==",
+      "dependencies": {
+        "js-tokens": "^3.0.0 || ^4.0.0"
+      },
+      "bin": {
+        "loose-envify": "cli.js"
+      }
+    },
    "node_modules/md5.js": {
      "version": "1.3.5",
      "resolved": "https://registry.npmjs.org/md5.js/-/md5.js-1.3.5.tgz",
@@ -668,6 +710,14 @@
        "vm-browserify": "^1.0.1"
      }
    },
+    "node_modules/object-assign": {
+      "version": "4.1.1",
+      "resolved": "https://registry.npmjs.org/object-assign/-/object-assign-4.1.1.tgz",
+      "integrity": "sha512-rJgTQnkUnH1sFw8yT6VSU3zD3sWmu6sZhIseY8VX+GRu3P6F7Fu+JNDoXfklElbLJSnc3FUQHVe4cU5hj+BcUg==",
+      "engines": {
+        "node": ">=0.10.0"
+      }
+    },
    "node_modules/object-inspect": {
      "version": "1.13.1",
      "resolved": "https://registry.npmjs.org/object-inspect/-/object-inspect-1.13.1.tgz",
@@ -770,6 +820,16 @@
      "integrity": "sha512-3ouUOpQhtgrbOa17J7+uxOTpITYWaGP7/AhoR3+A+/1e9skrzelGi/dXzEYyvbxubEF6Wn2ypscTKiKJFFn1ag==",
      "dev": true
    },
+    "node_modules/prop-types": {
+      "version": "15.8.1",
+      "resolved": "https://registry.npmjs.org/prop-types/-/prop-types-15.8.1.tgz",
+      "integrity": "sha512-oj87CgZICdulUohogVAR7AjlC0327U4el4L6eAvOqCeudMDVU0NThNaV+b9Df4dXgSP1gXMTnPdhfe/2qDH5cg==",
+      "dependencies": {
+        "loose-envify": "^1.4.0",
+        "object-assign": "^4.1.1",
+        "react-is": "^16.13.1"
+      }
+    },
    "node_modules/public-encrypt": {
      "version": "4.0.3",
      "resolved": "https://registry.npmjs.org/public-encrypt/-/public-encrypt-4.0.3.tgz",
@@ -839,6 +899,54 @@
        "safe-buffer": "^5.1.0"
      }
    },
+    "node_modules/react": {
+      "version": "16.13.0",
+      "resolved": "https://registry.npmjs.org/react/-/react-16.13.0.tgz",
+      "integrity": "sha512-TSavZz2iSLkq5/oiE7gnFzmURKZMltmi193rm5HEoUDAXpzT9Kzw6oNZnGoai/4+fUnm7FqS5dwgUL34TujcWQ==",
+      "dependencies": {
+        "loose-envify": "^1.1.0",
+        "object-assign": "^4.1.1",
+        "prop-types": "^15.6.2"
+      },
+      "engines": {
+        "node": ">=0.10.0"
+      }
+    },
+    "node_modules/react-ace": {
+      "version": "10.1.0",
+      "resolved": "https://registry.npmjs.org/react-ace/-/react-ace-10.1.0.tgz",
+      "integrity": "sha512-VkvUjZNhdYTuKOKQpMIZi7uzZZVgzCjM7cLYu6F64V0mejY8a2XTyPUIMszC6A4trbeMIHbK5fYFcT/wkP/8VA==",
+      "dependencies": {
+        "ace-builds": "^1.4.14",
+        "diff-match-patch": "^1.0.5",
+        "lodash.get": "^4.4.2",
+        "lodash.isequal": "^4.5.0",
+        "prop-types": "^15.7.2"
+      },
+      "peerDependencies": {
+        "react": "^0.13.0 || ^0.14.0 || ^15.0.1 || ^16.0.0 || ^17.0.0 || ^18.0.0",
+        "react-dom": "^0.13.0 || ^0.14.0 || ^15.0.1 || ^16.0.0 || ^17.0.0 || ^18.0.0"
+      }
+    },
+    "node_modules/react-dom": {
+      "version": "16.13.0",
+      "resolved": "https://registry.npmjs.org/react-dom/-/react-dom-16.13.0.tgz",
+      "integrity": "sha512-y09d2c4cG220DzdlFkPTnVvGTszVvNpC73v+AaLGLHbkpy3SSgvYq8x0rNwPJ/Rk/CicTNgk0hbHNw1gMEZAXg==",
+      "dependencies": {
+        "loose-envify": "^1.1.0",
+        "object-assign": "^4.1.1",
+        "prop-types": "^15.6.2",
+        "scheduler": "^0.19.0"
+      },
+      "peerDependencies": {
+        "react": "^16.0.0"
+      }
+    },
+    "node_modules/react-is": {
+      "version": "16.13.1",
+      "resolved": "https://registry.npmjs.org/react-is/-/react-is-16.13.1.tgz",
+      "integrity": "sha512-24e6ynE2H+OKt4kqsOvNd8kBpV65zoxbA4BVsEOB3ARVWQki/DHzaUoC5KuON/BiccDaCCTZBuOcfZs70kR8bQ=="
+    },
    "node_modules/readable-stream": {
      "version": "2.3.8",
      "resolved": "https://registry.npmjs.org/readable-stream/-/readable-stream-2.3.8.tgz",
@@ -908,6 +1016,15 @@
        }
      ]
    },
+    "node_modules/scheduler": {
+      "version": "0.19.1",
+      "resolved": "https://registry.npmjs.org/scheduler/-/scheduler-0.19.1.tgz",
+      "integrity": "sha512-n/zwRWRYSUj0/3g/otKDRPMh6qv2SYMWNq85IEa8iZyAv8od9zDYpGSnpBEjNgcMNq6Scbu5KfIPxNF72R/2EA==",
+      "dependencies": {
+        "loose-envify": "^1.1.0",
+        "object-assign": "^4.1.1"
+      }
+    },
    "node_modules/set-function-length": {
      "version": "1.2.2",
      "resolved": "https://registry.npmjs.org/set-function-length/-/set-function-length-1.2.2.tgz",
--- a/visualisers/gmvis/package.json
+++ b/visualisers/gmvis/package.json
@@ -1,12 +1 @@
-{ "name": "gmvis"
-, "version": "0.0.1"
-, "private": true
-, "devDependencies":
-    { "shadow-cljs": "2.28.3"
-    }
-, "dependencies":
-    { "react": "16.13.0"
-    , "react-dom": "16.13.0"
-    }
-}
-
+{"name":"gmvis","version":"0.0.1","private":true,"devDependencies":{"shadow-cljs":"2.28.3"},"dependencies":{"ace-builds":"^1.32.7","react":"16.13.0","react-ace":"^10.1.0","react-dom":"16.13.0"}}
--- a/visualisers/gmvis/src/main.cljs
+++ b/visualisers/gmvis/src/main.cljs
@@ -1,12 +1,59 @@
-(ns main)
+(ns main
+    (:require
+      ["react-ace$default" :as AceEditor]
+      ["ace-builds/src-noconflict/mode-haskell"]
+      ["ace-builds/src-noconflict/theme-solarized_light"]
+      ["ace-builds/src-noconflict/keybinding-vim"]
+      [wscljs.client :as ws]
+      [wscljs.format :as fmt]
+      [clojure.string :as str]
+      [cljs.core.match :refer-macros [match]]))
+
+(defn display-errors [es]
+  (doseq [{{e :contents} :diagnostic} es]
+         (let [fmte (map #(str "  • " % "\n") e)]
+           (js/console.warn (apply str "message from rlpc:\n" fmte)))))
+
+(defn on-message [e]
+  (let [r (js->clj (js/JSON.parse (.-data e)) :keywordize-keys true)]
+    (match r
+           {:tag "Evaluated" :contents c}
+             (prn c)
+           :else
+             (js/console.warn "unrecognised response from rlp"))))
+
+(def +rlp-socket+ nil)
+
+(defn send [msg]
+  (ws/send +rlp-socket+ msg fmt/json))
+
+(defn on-open []
+  (println "socket opened")
+  (send {:command "evaluate"
+         :source (str/join "\n"
+                           ["fac n = case (==#) n 0 of"
+                            "  { <1> -> 1"
+                            "  ; <0> -> *# n (fac (-# n 1))"
+                            "  };"
+                            ""
+                            "main = fac 3;"])}))
+
+(defn init-rlp-socket []
+  (set! +rlp-socket+ (ws/create "ws://127.0.0.1:9002"
+                                {:on-message on-message
+                                 :on-open on-open
+                                 :on-close #(println "socket closed")
+                                 :on-error #(println "error: " %)})))

 ;; this is called before any code is reloaded
 (defn ^:dev/before-load stop []
+  (ws/close +rlp-socket+)
  (js/console.log "stop"))

 ;; start is called by init and after code reloading finishes
 (defn ^:dev/after-load start []
-  (js/console.log "start"))
+  (js/console.log "start")
+  (init-rlp-socket))

 ;; init is called ONCE when the page loads
 ;; this is called in the index.html and must be exported