92 lines
2.8 KiB
Haskell
92 lines
2.8 KiB
Haskell
{-# 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)
|
|
|