ugh

app/CoreDriver.hs

@@ -10,6 +10,7 @@ import Control.Lens.Combinators
 
 import Core.Lex
 import Core.Parse
+-- import Core.SystemF
 import GM
 --------------------------------------------------------------------------------
 
@@ -18,7 +19,8 @@ driver = forFiles_ $ \f ->
     withSource f (lexCoreR >=> parseCoreProgR >=> evalProgR)
 
 driverSource :: T.Text -> RLPCIO ()
-driverSource = lexCoreR >=> parseCoreProgR >=> evalProgR >=> printRes
+driverSource = lexCoreR >=> parseCoreProgR
+           >=> 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,91 @@
+{-# LANGUAGE LambdaCase, BlockArguments #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Server
+    ( server
+    )
+    where
+--------------------------------------------------------------------------------
+import GHC.Generics                 (Generic, Generically(..))
+import Data.Text.Encoding           qualified as T
+import Data.Text                    (Text)
+import Data.Text                    qualified as T
+import Data.Text.IO                 qualified as T
+import Data.Pretty                  hiding (annotate, empty)
+import Data.Aeson                   ( ToJSON(..), Value, (.:)
+                                    , FromJSON(..), encode, withObject
+                                    , decodeStrictText)
+import Data.Function
+import Control.Arrow
+import Control.Applicative
+import Control.Monad
+import Control.Concurrent
+import Network.WebSockets           qualified as WS
+import Control.Exception
+import GHC.IO
+import Control.Lens                 hiding ((.=))
+
+-- import Control.Comonad
+-- import Data.Functor.Foldable
+
+import Compiler.RLPC
+import Compiler.JustRun
+
+-- import Misc.CofreeF
+-- import Rlp.AltSyntax
+-- import Rlp.HindleyMilner
+-- import Rlp.AltParse
+--------------------------------------------------------------------------------
+
+server :: IO ()
+server = do
+    T.putStrLn "rlpc server started at 127.0.0.1:9002"
+    WS.runServer "127.0.0.1" 9002 application
+
+application :: WS.ServerApp
+application pending = do
+    WS.acceptRequest pending >>= talk
+
+data Command = Annotate Text
+             | PartiallyAnnotate Text
+             | Evaluate Text
+             deriving Show
+
+instance FromJSON Command where
+    parseJSON = withObject "command object" $ \v -> do
+        cmd :: Text <- v .: "command"
+        case cmd of
+            "evaluate"           -> Evaluate <$> v .: "source"
+            "annotate"           -> Annotate <$> v .: "source"
+            "partially-annotate" -> PartiallyAnnotate <$> v .: "source"
+            _                    -> empty
+
+data Response = Annotated Value
+              | PartiallyAnnotated Value
+              | Evaluated Value
+              | Error Value
+              deriving (Generic)
+              deriving (ToJSON)
+                via Generically Response
+
+talk :: WS.Connection -> IO ()
+talk conn = (`catchAny` print) . forever $ do
+    msg <- WS.receiveData @Text conn
+    T.putStrLn $ "received: " <> msg
+    doCommand conn `traverse` decodeStrictText msg
+
+doCommand :: WS.Connection -> Command -> IO ()
+doCommand conn c = do
+    putStr "sending: "
+    let r = encode . respond $ c
+    print r
+    WS.sendTextData conn r
+
+respond :: Command -> Response
+respond (Annotate s)
+    = error "i'm a shitty programmer! try again with the dev branch lmfao"
+
+respond (Evaluate s)
+    = justLexParseGmEval (T.unpack s)
+    & either (Error . toJSON) (Evaluated . toJSON)
+