begin hm visualiser

app/CoreDriver.hs

@@ -15,10 +15,11 @@ import GM
 
 driver :: RLPCIO ()
 driver = forFiles_ $ \f ->
-    withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
+    withSource f (lexCoreR >=> parseCoreProgR >=> undefined >=> evalProgR)
 
 driverSource :: T.Text -> RLPCIO ()
-driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
+driverSource = lexCoreR >=> parseCoreProgR
+            >=> undefined >=> evalProgR >=> printRes
     where
         printRes = liftIO . print . view _1
 

app/Main.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 ----------------------------------------------------------------------------------
+import Control.Lens             hiding (argument)
 import Compiler.RLPC
 import Compiler.RlpcError
 import Control.Exception
@@ -23,6 +24,7 @@ import Control.Lens.Combinators hiding (argument)
 
 import CoreDriver               qualified
 import RlpDriver                qualified
+import Server                   qualified
 ----------------------------------------------------------------------------------
 
 optParser :: ParserInfo RLPCOptions
@@ -74,7 +76,11 @@ options = RLPCOptions
         <> metavar "rlp|core"
         <> help "the language to be compiled -- see README"
         )
-    <*> some (argument str $ metavar "FILES...")
+    <*> switch
+        (  long "server"
+        <> short 's'
+        )
+    <*> many (argument str $ metavar "FILES...")
     where
         infixr 9 #
         f # x = f x
@@ -107,7 +113,9 @@ mmany v = liftA2 (<>) v (mmany v)
 main :: IO ()
 main = do
     opts <- execParser optParser
-    void $ evalRLPCIO opts dispatch
+    if opts ^. rlpcServer
+    then Server.server
+    else void $ evalRLPCIO opts dispatch
 
 dispatch :: RLPCIO ()
 dispatch = getLang >>= \case

app/RlpDriver.hs

@@ -15,5 +15,5 @@ import GM
 
 driver :: RLPCIO ()
 driver = forFiles_ $ \f ->
-    withSource f (parseRlpProgR >=> desugarRlpProgR >=> evalProgR)
+    withSource f (parseRlpProgR >=> undefined >=> desugarRlpProgR >=> evalProgR)
 

app/Server.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE LambdaCase, BlockArguments #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Server
+    ( server
+    )
+    where
+--------------------------------------------------------------------------------
+import GHC.Generics                 (Generic, Generically(..))
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.Text.IO                 qualified as T
+import Data.Pretty
+import Data.Aeson
+import Control.Applicative
+import Control.Monad
+import Control.Concurrent
+import Network.WebSockets           qualified as WS
+
+import Data.Functor.Foldable
+
+import Misc.CofreeF
+import Rlp.AltSyntax
+import Rlp.HindleyMilner
+import Rlp.AltParse
+--------------------------------------------------------------------------------
+
+server :: IO ()
+server = do
+    WS.runServer "127.0.0.1" 9002 application
+
+application :: WS.ServerApp
+application pending =
+    WS.acceptRequest pending >>= talk
+
+newtype Command = Annotate Text
+
+instance FromJSON Command where
+    parseJSON = withObject "command object" $ \v -> do
+        cmd :: Text <- v .: "command"
+        case cmd of
+            "annotate" -> Annotate <$> v .: "data"
+            _          -> empty
+
+data Response = Annotated Value
+              | PartiallyAnnotated Value
+    deriving (Generic)
+    deriving (ToJSON)
+        via Generically Response
+
+talk :: WS.Connection -> IO ()
+talk conn = forever $ do
+    msg <- WS.receiveData @Text conn
+    T.putStrLn $ "received: " <> msg
+    case decodeStrictText msg of
+        Just c -> doCommand c
+        Nothing -> WS.sendTextData @Text conn "\"error while parsing json\""
+
+doCommand :: Command -> IO ()
+doCommand (Annotate s) = undefined
+
+parse = undefined
+
+serialisedAnnotated :: Cofree (RlpExprF PsName) (Type PsName)
+                    -> Value
+serialisedAnnotated = cata \case
+    t :<$ e -> object [ "e" .= e, "type" .= rout @Text t ]
+

rlp.cabal

@@ -92,6 +92,9 @@ library
                     , clay
                     , jmacro
                     , js-jquery
+                    , aeson
+                    , lens-aeson
+                    -- , servant
 
     hs-source-dirs:   src
     default-language: GHC2021
@@ -112,6 +115,7 @@ executable rlpc
     main-is:          Main.hs
     other-modules:    RlpDriver
                     , CoreDriver
+                    , Server
 
     build-depends: base >=4.17.0.0 && <4.20.0.0
                  , rlp

src/Compiler/RLPC.hs

@@ -26,8 +26,9 @@ module Compiler.RLPC
     , DebugFlag(..), CompilerFlag(..)
     -- ** Lenses
     , rlpcLogFile, rlpcDFlags, rlpcEvaluator, rlpcInputFiles, rlpcLanguage
+    , rlpcServer
     -- * Misc. MTL-style functions
-    , liftErrorful, liftMaybe, hoistRlpcT
+    , liftErrorful, liftEither, liftMaybe, hoistRlpcT
     -- * Misc. Rlpc Monad -related types
     , RLPCOptions(RLPCOptions), IsRlpcError(..), RlpcError(..)
     , MsgEnvelope(..), Severity(..)
@@ -111,6 +112,11 @@ liftErrorful e = RLPCT $ lift (fmap liftRlpcError `mapErrorful` e)
 liftMaybe :: (Monad m) => Maybe a -> RLPCT m a
 liftMaybe m = RLPCT . lift . ErrorfulT . pure $ (m, [])
 
+liftEither :: (Monad m, IsRlpcError e)
+           => Either [e] a -> RLPCT m a
+liftEither = RLPCT . lift . ErrorfulT . pure
+           . either (const (Nothing,[])) ((,[]) . Just)
+
 hoistRlpcT :: (forall a. m a -> n a)
          -> RLPCT m a -> RLPCT n a
 hoistRlpcT f rma = RLPCT $ ReaderT $ \opt ->
@@ -123,6 +129,7 @@ data RLPCOptions = RLPCOptions
     , _rlpcEvaluator   :: Evaluator
     , _rlpcHeapTrigger :: Int
     , _rlpcLanguage    :: Maybe Language
+    , _rlpcServer      :: Bool
     , _rlpcInputFiles  :: [FilePath]
     }
     deriving Show
@@ -143,6 +150,7 @@ instance Default RLPCOptions where
         , _rlpcEvaluator = EvaluatorGM
         , _rlpcHeapTrigger = 200
         , _rlpcInputFiles = []
+        , _rlpcServer = False
         , _rlpcLanguage = Nothing
         }
 

src/Core/Syntax.hs

@@ -59,7 +59,9 @@ import Data.Functor.Classes
 import Data.Text                    qualified as T
 import Data.Char
 import Data.These
-import GHC.Generics                 (Generic, Generic1, Generically(..))
+import Data.Aeson
+import GHC.Generics                 ( Generic, Generic1
+                                    , Generically(..), Generically1(..))
 import Text.Show.Deriving
 import Data.Eq.Deriving
 import Data.Kind                    qualified
@@ -110,7 +112,7 @@ type Kind = Type
 --     deriving (Eq, Show, Lift)
 
 data Var = MkVar Name Type
-    deriving (Eq, Show, Lift)
+    deriving (Eq, Show, Lift, Generic)
 
 pattern (:^) :: Name -> Type -> Var
 pattern n :^ t = MkVar n t
@@ -780,3 +782,21 @@ instance Hashable b => Hashable1 (AlterF b)
 instance Hashable b => Hashable1 (BindingF b)
 instance Hashable b => Hashable1 (ExprF b)
 
+deriving via (Generically Rec)
+    instance ToJSON Rec
+deriving via (Generically Lit)
+    instance ToJSON Lit
+deriving via (Generically AltCon)
+    instance ToJSON AltCon
+deriving via (Generically Type)
+    instance ToJSON Type
+deriving via (Generically Var)
+    instance ToJSON Var
+
+deriving via (Generically1 (BindingF b))
+    instance ToJSON b => ToJSON1 (BindingF b)
+deriving via (Generically1 (AlterF b))
+    instance ToJSON b => ToJSON1 (AlterF b)
+deriving via (Generically1 (ExprF b))
+    instance ToJSON b => ToJSON1 (ExprF b)
+

src/Rlp/AltSyntax.hs

@@ -18,23 +18,29 @@ module Rlp.AltSyntax
 
     -- * Functor-related tools
     , Fix(..), Cofree(..), Sum(..), pattern Finl, pattern Finr
+
+    -- * Misc
+    , serialiseCofree
     )
     where
 --------------------------------------------------------------------------------
 import Data.Functor.Sum
 import Control.Comonad.Cofree
-import Data.Fix
+import Data.Fix                 hiding (cata)
+import Data.Functor.Foldable
 import Data.Function            (fix)
-import GHC.Generics             (Generic, Generic1)
+import GHC.Generics             ( Generic, Generic1
+                                , Generically(..), Generically1(..))
 import Data.Hashable
 import Data.Hashable.Lifted
 import GHC.Exts                 (IsString)
-import Control.Lens
+import Control.Lens             hiding ((.=))
 
 import Data.Functor.Foldable.TH
 import Text.Show.Deriving
 import Data.Eq.Deriving
 import Data.Text                qualified as T
+import Data.Aeson
 import Data.Pretty
 import Misc.Lift1
 
@@ -45,7 +51,7 @@ import Core.Syntax              qualified as Core
 type PsName = T.Text
 
 newtype Program b a = Program [Decl b a]
-    deriving Show
+    deriving (Show, Functor, Foldable, Traversable)
 
 programDecls :: Lens' (Program b a) [Decl b a]
 programDecls = lens (\ (Program ds) -> ds) (const Program)
@@ -53,7 +59,7 @@ programDecls = lens (\ (Program ds) -> ds) (const Program)
 data Decl b a = FunD b [Pat b] a
               | DataD b [b] [DataCon b]
               | TySigD b (Type b)
-              deriving (Show, Functor)
+              deriving (Show, Functor, Foldable, Traversable)
 
 data DataCon b = DataCon b [Type b]
     deriving (Show, Generic)
@@ -101,7 +107,7 @@ type RlpExpr b = Fix (RlpExprF b)
 data Pat b = VarP b
            | ConP b
            | AppP (Pat b) (Pat b)
-           deriving (Eq, Show, Generic)
+           deriving (Eq, Show, Generic, Generic1)
 
 deriveShow1 ''Alter
 deriveShow1 ''Binding
@@ -221,3 +227,21 @@ instance Core.HasArrowStops (Type b) (Type b) (Type b) (Type b) where
     arrowStops k (s Core.:-> t) = (Core.:->) <$> k s <*> Core.arrowStops k t
     arrowStops k t         = k t
 
+deriving via (Generically1 Pat)
+    instance ToJSON1 Pat
+deriving via (Generically (Pat b))
+    instance ToJSON b => ToJSON (Pat b)
+deriving via (Generically1 (Alter b))
+    instance ToJSON b => ToJSON1 (Alter b)
+deriving via (Generically1 (Binding b))
+    instance ToJSON b => ToJSON1 (Binding b)
+deriving via (Generically1 (ExprF b))
+    instance ToJSON b => ToJSON1 (ExprF b)
+deriving via (Generically1 (RlpExprF b))
+    instance ToJSON b => ToJSON1 (RlpExprF b)
+
+serialiseCofree :: (Functor f, ToJSON1 f, ToJSON a) => Cofree f a -> Value
+serialiseCofree = cata \case
+    ann :<$ e -> object [ "ann" .= ann
+                        , "val" .= toJSON1 e ]
+

src/Rlp/HindleyMilner.hs

@@ -163,11 +163,14 @@ fixtend :: Functor f => (f (Fix f) -> b) -> Fix f -> Cofree f b
 fixtend c (Fix f) = c f :< fmap (fixtend c) f
 
 infer :: RlpExpr PsName -> HM (Cofree (RlpExprF PsName) (Type PsName))
-infer = undefined
+infer = sequenceA . fixtend (infer1 . wrapFix)
 
 typeCheckRlpProgR :: (Monad m)
                   => Program PsName (RlpExpr PsName)
                   -> RLPCT m (Program PsName
                       (Cofree (RlpExprF PsName) (Type PsName)))
-typeCheckRlpProgR = undefined
+typeCheckRlpProgR = liftHM . traverse infer
+
+liftHM :: (Monad m) => HM a -> RLPCT m a
+liftHM = liftEither . runHM'
 

src/Rlp/HindleyMilner/Visual.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE LexicalNegation #-}
-{-# LANGUAGE QuasiQuotes #-}
 module Rlp.HindleyMilner.Visual
     (
     )
@@ -7,6 +6,7 @@ module Rlp.HindleyMilner.Visual
 --------------------------------------------------------------------------------
 import Control.Monad
 import System.IO
+import Data.Text                        (Text)
 import Data.Text                        qualified as T
 import Data.Text.IO                     qualified as T
 import Data.Pretty                      hiding (annotate)
@@ -17,15 +17,7 @@ import Control.Exception
 
 import Data.Functor.Foldable
 
-import Text.Blaze.Html5                 as H
+import Data.Aeson
-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
@@ -36,98 +28,3 @@ 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 :: (a -> Doc ann) -> AnnExpr a -> Html
-annExpr sf = code . cata \case
-    t :<$ InL (LitF l)   -> withTooltip (rout l) (sf' t)
-    t :<$ InL (VarF n)   -> withTooltip (rout 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 . show . hsep $ outPrec 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 out $ e'
-