diff options
Diffstat (limited to 'lambda-calcul/haskell')
17 files changed, 731 insertions, 43 deletions
diff --git a/lambda-calcul/haskell/app/Main.hs b/lambda-calcul/haskell/app/Main.hs index 0b40f60..769d2f0 100644 --- a/lambda-calcul/haskell/app/Main.hs +++ b/lambda-calcul/haskell/app/Main.hs @@ -1,12 +1,62 @@ import Minilang.IO (runEval) +import Minilang.REPL (withTerminal) +import Minilang.Server (startServer, waitServer) +import Options.Applicative import System.IO (stdin, stdout) +import System.Posix.IO (stdInput) import System.Posix.Terminal (queryTerminal) -import System.Posix (stdInput) -import Minilang.REPL (withTerminal) + +data RunMode + = Local + | Server + deriving (Eq, Show) + +data Options = Options + { serverPort :: Int, + runMode :: RunMode + } + deriving (Eq, Show) + +optionsParser :: ParserInfo Options +optionsParser = + info + (helper <*> minilangOptions) + ( header "Minilang" + <> fullDesc + ) + +minilangOptions :: Parser Options +minilangOptions = + Options <$> portOption <*> runModeOption + +portOption :: Parser Int +portOption = + option + auto + ( long "port" + <> short 'p' + <> value 7890 + <> metavar "INT" + <> help "port to listent on (default: 7890)" + ) + +runModeOption :: Parser RunMode +runModeOption = + flag + Local + Server + ( long "server" + <> short 'S' + <> help "run in server mode, listening for client REPLs over HTTP" + ) main :: IO () main = do - hasTty <- queryTerminal stdInput - if hasTty - then withTerminal - else runEval stdin stdout + Options {..} <- execParser optionsParser + case runMode of + Local -> do + hasTty <- queryTerminal stdInput + if hasTty + then withTerminal + else runEval stdin stdout + Server -> startServer serverPort >>= waitServer diff --git a/lambda-calcul/haskell/minilang.cabal b/lambda-calcul/haskell/minilang.cabal index 039e4f0..46f74c4 100644 --- a/lambda-calcul/haskell/minilang.cabal +++ b/lambda-calcul/haskell/minilang.cabal @@ -26,18 +26,22 @@ source-repository head library exposed-modules: Minilang.IO + Minilang.Lambda Minilang.Lambda.Unify Minilang.Lambda.DeBruijn Minilang.Lambda.Eval Minilang.Lambda.Infer Minilang.Lambda.Parser + Minilang.Log Minilang.REPL Minilang.REPL.Haskeline Minilang.REPL.IO + Minilang.REPL.Net Minilang.REPL.Pure Minilang.REPL.Purer Minilang.REPL.Run Minilang.REPL.Types + Minilang.Server hs-source-dirs: src default-extensions: @@ -60,16 +64,21 @@ library , data-default , directory , exceptions + , fast-logger , filepath , haskeline , megaparsec , mtl , stm , text + , time , unordered-containers , wai + , wai-app-static + , wai-extra , websockets , wai-websockets + , warp default-language: Haskell2010 test-suite minilang-test @@ -137,5 +146,6 @@ executable lambda base , containers , minilang + , optparse-applicative , unix default-language: Haskell2010 diff --git a/lambda-calcul/haskell/public/images/connect.png b/lambda-calcul/haskell/public/images/connect.png Binary files differnew file mode 100644 index 0000000..84c95c4 --- /dev/null +++ b/lambda-calcul/haskell/public/images/connect.png diff --git a/lambda-calcul/haskell/public/images/connected.png b/lambda-calcul/haskell/public/images/connected.png Binary files differnew file mode 100644 index 0000000..d85177d --- /dev/null +++ b/lambda-calcul/haskell/public/images/connected.png diff --git a/lambda-calcul/haskell/public/index.html b/lambda-calcul/haskell/public/index.html new file mode 100644 index 0000000..2672e8d --- /dev/null +++ b/lambda-calcul/haskell/public/index.html @@ -0,0 +1,27 @@ +<!DOCTYPE HTML> +<html> + <head> + <meta charset="UTF-8"> + <title>Minilang</title> + <link rel="stylesheet" href="minilang.css" > + <link rel="icon" + type="image/png" + href="/pi.png"> + <link href="https://fonts.googleapis.com/css?family=Inconsolata&display=swap" rel="stylesheet"> + </head> + <body> + <div class="edit"> + <textarea id="program"></textarea> + <div> + <button id="send">Send</button> + </div> + </div> + <div id="repl"> + <div class="command"> + <input id="command" class="disconnected" /> + <img id="connect" src="images/connect.png" /> + </div> + <div id="minilang"></div> + </div> + <script src="repl.js"></script> +</body></html> diff --git a/lambda-calcul/haskell/public/minilang.css b/lambda-calcul/haskell/public/minilang.css new file mode 100644 index 0000000..2e20838 --- /dev/null +++ b/lambda-calcul/haskell/public/minilang.css @@ -0,0 +1,67 @@ +html { + font-family: Inconsolata, Courier; +} + +div#minilang { + height: 90vh; + overflow-y: auto; +} + +div.edit { + width: 50vw; + height: 90vh; + float: left; +} + +textarea#program { + width: 100%; + height: 90%; + padding: 1em; + font-family: Inconsolata, Courier; + font-size: 12pt; + resize: none; + white-space: pre; + spellcheck: false; + autocomplete: off; + autocapitalize: none; + wrap: off; +} + +div#repl { + width: 45vw; + float: right; +} + +div.output { + width: 90%; + white-space: pre-wrap; + padding: 0em 1em 0 1em; +} + +div.command { + height: 2em; +} + +.command input { + display: inline-block; + vertical-align: middle; + font-family: Inconsolata; + font-size: 12pt; + border: none; + width: 80%; + margin: 0em 1em 0em 1em; +} + +.connected { + background-color: #aaf; +} + +.disconnected { + background-color: #faa; +} + +.command img { + display: inline-block; + vertical-align: middle; + height: 2em; +} diff --git a/lambda-calcul/haskell/public/pi.png b/lambda-calcul/haskell/public/pi.png Binary files differnew file mode 100644 index 0000000..373307d --- /dev/null +++ b/lambda-calcul/haskell/public/pi.png diff --git a/lambda-calcul/haskell/public/repl.js b/lambda-calcul/haskell/public/repl.js new file mode 100644 index 0000000..12ce03a --- /dev/null +++ b/lambda-calcul/haskell/public/repl.js @@ -0,0 +1,108 @@ +var websocket = undefined; + +function connect() { + websocket = (function() { + const host = window.location.host; + const ws = new WebSocket("ws://" + host + "/repl/1235"); + ws.binaryType = "arraybuffer"; + return ws; + })(); + + websocket.onopen = function(e) { + document.getElementById("command").classList.remove("disconnected"); + document.getElementById("command").classList.add("connected"); + document.getElementById("connect").src = "images/connected.png"; + document.getElementById("connect").removeEventListener("click", connect); + }; + + websocket.onclose = function(e) { + document.getElementById("command").classList.remove("connected"); + document.getElementById("command").classList.add("disconnected"); + document.getElementById("connect").src = "images/connect.png"; + document.getElementById("connect").addEventListener("click", connect); + }; + + websocket.onmessage = function(e) { + const reader = new FileReader(); + reader.addEventListener('loadend', readMessageAndAppend(reader)); + + if(e.data instanceof ArrayBuffer) { + reader.readAsText(new Blob([e.data])); + } else { + reader.readAsText(e.data); + } + }; +} + +var commandHistory = []; + +function appendOutput(text) { + const root = document.getElementById("minilang"); + const sub = document.createElement("div"); + sub.classList.add("output"); + sub.appendChild(text); + if(root.firstChild) { + root.insertBefore(sub, root.firstChild); + } else { + root.appendChild(sub); + } +}; + +function formatResult(text) { + const result = JSON.parse(text); + if (result.tag === "Msg") { + return result.contents; + } + return text; +} + +function readMessageAndAppend(reader) { + return () => { + appendOutput(document.createTextNode(formatResult(reader.result))); + }; +}; + +function makeCommand(val) { + if(val === ":env") { + return {tag:"Com",contents:{tag:"DumpEnv"}}; + } else if(val === ":clear") { + return {tag:"Com",contents:{tag:"ClearEnv"}}; + } else if(val === ":help") { + return {tag:"Com",contents:{tag:"Help"}}; + } else { + return {tag:"In",contents:val}; + } +}; + +function sendCommand(e) { + const input = document.getElementById("command"); + if (e.keyCode == 13) { + const command = makeCommand(input.value); + appendOutput(document.createTextNode("> "+ input.value)); + commandHistory.push(input.value); + websocket.send(JSON.stringify(command)); + input.value = ""; + return false; + } else if(e.keyCode == 38) { + input.value = commandHistory.pop() || ""; + return false; + } + + return true; +}; + +function loadText(e) { + const text = document.getElementById("program").value; + const command = {tag:"Com", + contents:{ tag:"Load", + contents:{ tag:"Data", + contents:text}}}; + websocket.send(JSON.stringify(command)); + return false; +}; + +document.getElementById("command").addEventListener("keyup", sendCommand); +document.getElementById("connect").addEventListener("click", connect); +document.getElementById("send").addEventListener("click", loadText); + +connect(); diff --git a/lambda-calcul/haskell/src/Minilang/Lambda.hs b/lambda-calcul/haskell/src/Minilang/Lambda.hs new file mode 100644 index 0000000..9d0f3cf --- /dev/null +++ b/lambda-calcul/haskell/src/Minilang/Lambda.hs @@ -0,0 +1,25 @@ +module Minilang.Lambda where + +import Minilang.Lambda.DeBruijn (eval, fromDeBruijn, toDeBruijn) +import Minilang.Lambda.Eval (Env, Term) +import Minilang.Lambda.Infer (Context, TypeError, infer) +import Minilang.Lambda.Parser (AST, desugar) +import Minilang.Lambda.Unify (Type) + +-- | Top-level evaluator +-- Load an AST into given `Env` and `Context`, returning an extended +-- `Env` and `Context` with declarations bound +loadProgram :: + AST -> + Env -> + Context -> + Either TypeError (Term, Type, Env, Context) +-- loadProgram (Let d r) ρ γ = do +-- (ρ', γ') <- checkD 0 d ρ γ +-- loadProgram r ρ' γ' +loadProgram expr env context = + let term = desugar expr + in case infer term of + Left typeError -> Left typeError + Right typ -> + Right (fromDeBruijn $ eval (toDeBruijn term), typ, env, context) diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs index 58f8ba6..7f7aad7 100644 --- a/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs +++ b/lambda-calcul/haskell/src/Minilang/Lambda/Eval.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE DeriveAnyClass #-} + module Minilang.Lambda.Eval where -import Data.Text (Text, unpack) -import Debug.Trace (trace) +import Data.Aeson (FromJSON, ToJSON) +import Data.Text (Text) +import GHC.Generics (Generic) data Term = Var Text | Lam Text Term | App Term Term - deriving (Show, Read, Eq) + deriving (Show, Read, Eq, Generic, ToJSON, FromJSON) type Env = [(Text, Term)] diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs index 94fecb3..2e1814e 100644 --- a/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs +++ b/lambda-calcul/haskell/src/Minilang/Lambda/Infer.hs @@ -1,13 +1,16 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} module Minilang.Lambda.Infer where import Control.Monad.State (MonadState (..), StateT, evalStateT, modify) +import Data.Aeson (FromJSON, ToJSON) import Data.Bifunctor (first) import Data.Char (chr, ord) import qualified Data.List as List import qualified Data.Map as Map import Data.Text (Text, pack) +import GHC.Generics (Generic) import qualified Minilang.Lambda.Eval as Eval import Minilang.Lambda.Unify (Type (..), UnifyError, apply, unify) import Prelude hiding (lookup) @@ -48,8 +51,11 @@ typeOf (Var _ t) = t typeOf (Lam _ _ t) = t typeOf (App _ _ t) = t -data Context = Context {nextVar :: Int, typeContext :: Map.Map Text Type} - deriving (Eq, Show) +data Context = Context + { nextVar :: Int, + typeContext :: Map.Map Text Type + } + deriving (Eq, Show, Generic, ToJSON, FromJSON) annotate :: Eval.Term -> Either TypeError (ATerm Type) annotate t = diff --git a/lambda-calcul/haskell/src/Minilang/Lambda/Unify.hs b/lambda-calcul/haskell/src/Minilang/Lambda/Unify.hs index df66113..f3fff04 100644 --- a/lambda-calcul/haskell/src/Minilang/Lambda/Unify.hs +++ b/lambda-calcul/haskell/src/Minilang/Lambda/Unify.hs @@ -1,15 +1,18 @@ -- ported from https://www.cs.cornell.edu/courses/cs3110/2011sp/Lectures/lec26-type-inference/type-inference.htm {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveAnyClass #-} module Minilang.Lambda.Unify where import Data.Text (Text) +import GHC.Generics (Generic) +import Data.Aeson (ToJSON, FromJSON) type Identifier = Text data Type = TyVar Text | Type :-> Type - deriving (Show, Eq) + deriving (Show, Eq, Generic, ToJSON, FromJSON) infixr 5 :-> diff --git a/lambda-calcul/haskell/src/Minilang/Log.hs b/lambda-calcul/haskell/src/Minilang/Log.hs new file mode 100644 index 0000000..bae4f19 --- /dev/null +++ b/lambda-calcul/haskell/src/Minilang/Log.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall -Werror #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} + +-- | A simple logger that reads `LogEntry` from a `TBChan` and dumps JSON-formatted +-- strings to `stdout`. +module Minilang.Log + ( -- * Types + LoggerEnv, + + -- * Constructor & Destructor + newLog, + stopLogger, + fakeLogger, + + -- * Logging functions + logInfo, + logError, + withLog, + ) +where + +import Control.Concurrent.Async (Async, async, cancel) +import Control.Concurrent.STM (TChan, atomically, newTChan, readTChan, writeTChan) +import Control.Monad (forever) +import Control.Monad.Trans (MonadIO (..)) +import Data.Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Text (Text) +import Data.Time.Clock + ( UTCTime, + diffUTCTime, + getCurrentTime, + ) +import System.IO (Handle, stdout) + +-- | Environment to control a logger thread. +data LoggerEnv m = LoggerEnv + { logger :: Maybe Logger, + loggerId :: Text, + logInfo :: forall a. (ToJSON a) => a -> m (), + logError :: forall a. (ToJSON a) => a -> m (), + withLog :: forall a b. (ToJSON a) => a -> m b -> m b, + stopLogger :: m () + } + +type Logger = TChan BS.ByteString + +fakeLogger :: (MonadIO m) => LoggerEnv m +fakeLogger = LoggerEnv Nothing "foo" (const $ pure ()) (const $ pure ()) (const id) (pure ()) + +-- | Starts an asynchronous log-processing thread and returns an initialised `LoggerEnv`. +newLog :: (MonadIO m) => Text -> m (LoggerEnv m) +newLog loggerId = liftIO $ do + chan <- liftIO $ atomically newTChan + loggerThread <- async $ runLog chan stdout + return $ + LoggerEnv + { logger = Just chan, + logInfo = logEvent' chan loggerId, + logError = logError' chan loggerId, + withLog = withLog' chan loggerId, + stopLogger = stopLogger' loggerThread, + loggerId + } + +runLog :: TChan BS.ByteString -> Handle -> IO a +runLog chan hdl = forever $ do + toLog <- atomically $ readTChan chan + BS.hPutStr hdl . (<> "\n") $ toLog + +stopLogger' :: (MonadIO m) => Async () -> m () +stopLogger' = liftIO . cancel + +logEvent' :: (ToJSON a, MonadIO m) => Logger -> Text -> a -> m () +logEvent' chan logId message = do + ts <- liftIO getCurrentTime + liftIO $ + atomically $ + writeTChan chan $ + LBS.toStrict $ + encode $ + object + [ "timestamp" .= ts, + "loggerId" .= logId, + "message" .= message + ] + +withLog' :: (ToJSON a, MonadIO m) => Logger -> Text -> a -> m b -> m b +withLog' chan logId message act = do + startTime <- liftIO getCurrentTime + logStart chan logId startTime message + b <- act + endTime <- liftIO getCurrentTime + logEnd chan logId startTime endTime message + pure b + +logStart :: (ToJSON a, MonadIO m) => Logger -> Text -> UTCTime -> a -> m () +logStart chan logId ts command = + liftIO $ + atomically $ + writeTChan chan $ + LBS.toStrict $ + encode $ + object + [ "timestamp" .= ts, + "servicer" .= logId, + "message" .= command + ] + +logEnd :: (ToJSON a, MonadIO m) => Logger -> Text -> UTCTime -> UTCTime -> a -> m () +logEnd chan logId ts en outcome = + liftIO $ + atomically $ + writeTChan chan $ + LBS.toStrict $ + encode $ + object + [ "timestamp" .= en, + "durationMs" .= (diffUTCTime en ts * 1000), + "servicer" .= logId, + "message" .= outcome + ] + +logError' :: (ToJSON a, MonadIO m) => Logger -> Text -> a -> m () +logError' chan logId err = liftIO $ do + ts <- liftIO getCurrentTime + liftIO $ + atomically $ + writeTChan chan $ + LBS.toStrict $ + encode $ + object + [ "timestamp" .= ts, + "servicer" .= logId, + "error" .= err + ] diff --git a/lambda-calcul/haskell/src/Minilang/REPL/Net.hs b/lambda-calcul/haskell/src/Minilang/REPL/Net.hs new file mode 100644 index 0000000..1bafeaa --- /dev/null +++ b/lambda-calcul/haskell/src/Minilang/REPL/Net.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | A version of REPL that interacts through a websocket. +module Minilang.REPL.Net where + +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TVar +import Control.Monad.Catch +import Control.Monad.State +import Data.Aeson + ( ToJSON, + eitherDecode, + encode, + object, + (.=), + ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LBS +import Data.Either (fromRight) +import Data.Map as Map +import Data.Serialize hiding (encode) +import Data.Text (Text, pack, unpack) +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Minilang.Log +import Minilang.REPL (withInputs) +import Minilang.REPL.Purer (purerREPL) +import Minilang.REPL.Run (runREPL) +import Minilang.REPL.Types +import Network.Wai (Application) +import Network.Wai.Handler.WebSockets +import qualified Network.WebSockets as WS +import System.Directory (getCurrentDirectory) +import System.FilePath (takeFileName, (</>)) + +-- | Configuration of the WS server +data ServerConfig = ServerConfig + { -- | The host/IP to listen on. If 0.0.0.0, then the server listens + configHost :: String, + -- | The port to listen on. If 0, a random port will be assigned. + configPort :: Int + } + deriving (Eq, Show) + +data NetEnv = NetEnv + { connection :: WS.Connection, + logger :: LoggerEnv IO, + repl :: TVar REPLEnv + -- , storage :: FileStorage + } + +newtype Net m a = Net {runNet :: StateT NetEnv m a} + deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MonadState NetEnv) + +instance Serialize In where + put out = do + let bs = encode out + putWord64be (fromIntegral $ LBS.length bs) + putLazyByteString bs + + get = do + len <- getWord64be + bs <- getLazyByteString (fromIntegral len) + case eitherDecode bs of + Right out -> pure out + Left err -> fail err + +-- doStore :: In -> Net IO (Either Text ()) +-- doStore out = do +-- fs <- gets storage +-- res <- liftIO $ store fs (pure $ Right out) handleStorageResult +-- case res of +-- WriteSucceed _ -> pure $ Right () +-- err -> pure $ Left (pack $ show err) +-- where +-- handleStorageResult (Right (WriteSucceed _)) = pure $ Right () +-- handleStorageResult (Right err) = pure $ Left $ pack $ show err +-- handleStorageResult (Left err) = pure $ Left $ pack err + +netLog :: (ToJSON a) => a -> Net IO () +netLog logEntry = gets logger >>= liftIO . flip logInfo logEntry + +instance MonadREPL (Net IO) where + input = do + inp <- gets connection >>= lift . wsReceive + -- res <- doStore inp + -- case res of + -- Right () -> netLog (object ["action" .= ("input" :: Text), "content" .= inp]) + -- Left txt -> netLog (object ["action" .= ("storageError" :: Text), "content" .= txt]) + netLog (object ["action" .= ("input" :: Text), "content" .= inp]) + pure inp + + output a = do + gets connection >>= lift . wsSend a + netLog (object ["action" .= ("output" :: Text), "content" .= a]) + + prompt = pure () + getEnv = gets repl >>= lift . readTVarIO + setEnv e' = gets repl >>= lift . atomically . flip writeTVar e' + + -- TODO what does this mean? perhaps it coiuld be used to load some + -- virtual files edited by user in their env? + load = const (pure (Right "")) + +instance (MonadThrow m) => MonadThrow (Net m) where + throwM = lift . throwM + +instance (MonadCatch m) => MonadCatch (Net m) where + Net m `catch` f = Net $ m `catch` \e -> runNet (f e) + +-- instance TypeChecker (Net IO) where +-- emit (CheckD ev) = gets logger >>= \env -> liftIO $ logInfo env ev +-- emit _ = pure () + +wsReceive :: WS.Connection -> IO In +wsReceive cnx = + fromRight (In "") . eitherDecode <$> WS.receiveData cnx + +wsSend :: Out -> WS.Connection -> IO () +wsSend out cnx = + WS.sendBinaryData cnx (encode out) + +safeDecodeUtf8 :: ByteString -> Text +safeDecodeUtf8 = decodeUtf8With lenientDecode + +clientHandler :: LoggerEnv IO -> TVar (Map ByteString (TVar REPLEnv)) -> WS.PendingConnection -> IO () +clientHandler loggerEnv envs cnx = do + let path = WS.requestPath $ WS.pendingRequest cnx + logInfo loggerEnv $ object ["action" .= ("StartedREPL" :: Text), "path" .= safeDecodeUtf8 path] + conn <- WS.acceptRequest cnx + -- storageFile <- mkStorageFile path + -- withStorage storageFile $ \fileStorage -> do + replEnv <- newREPLEnv + WS.withPingThread conn 30 (pure ()) $ + evalStateT (runNet runREPL) (NetEnv conn loggerEnv replEnv) + where + newREPLEnv = newTVarIO initialREPL + +-- findOrCreateREPL :: (H.Store IO store) => store -> ByteString -> IO (TVar REPLEnv) +-- findOrCreateREPL storageFile path = do +-- (env, shouldLoad) <- atomically $ do +-- envMaps <- readTVar envs +-- (newEnv, shouldLoad) <- case Map.lookup path envMaps of +-- Nothing -> newTVar initialREPL >>= \v -> pure (v, True) +-- Just e -> pure (e, False) +-- writeTVar envs (Map.insert path newEnv envMaps) +-- pure (newEnv, shouldLoad) +-- -- FIXME there is a race condition here +-- if shouldLoad +-- then replay storageFile env +-- else pure env + +-- mkStorageFile path = do +-- let f = takeFileName (unpack (safeDecodeUtf8 path)) +-- dir <- getCurrentDirectory +-- pure $ defaultOptions {storageFilePath = dir </> f} + +-- replay :: (H.Store IO store) => store -> TVar REPLEnv -> IO (TVar REPLEnv) +-- replay storage envVar = do +-- res <- H.load storage +-- case res of +-- LoadSucceed coms -> do +-- atomically $ do +-- env <- readTVar envVar +-- let newEnv = withInputs env coms +-- writeTVar envVar (purerREPL newEnv) +-- logInfo loggerEnv $ +-- object +-- [ "action" .= ("Loaded" :: Text), +-- "numCommands" .= length coms +-- ] +-- pure envVar +-- err -> do +-- logInfo loggerEnv $ object ["action" .= ("ErrorLoading" :: Text), "error" .= pack (show err)] +-- pure envVar + +runNetREPL :: LoggerEnv IO -> TVar (Map ByteString (TVar REPLEnv)) -> Application -> Application +runNetREPL loggerEnv envs = websocketsOr WS.defaultConnectionOptions (clientHandler loggerEnv envs) diff --git a/lambda-calcul/haskell/src/Minilang/REPL/Run.hs b/lambda-calcul/haskell/src/Minilang/REPL/Run.hs index a4b50f4..c90ecde 100644 --- a/lambda-calcul/haskell/src/Minilang/REPL/Run.hs +++ b/lambda-calcul/haskell/src/Minilang/REPL/Run.hs @@ -10,11 +10,12 @@ import Control.Monad.Catch import Data.Text hiding (replicate) import qualified Data.Text as Text import Debug.Trace (trace) +import Minilang.Lambda (loadProgram) import Minilang.Lambda.DeBruijn (eval, fromDeBruijn, toDeBruijn) +import Minilang.Lambda.Eval (newEnv) import Minilang.Lambda.Infer (infer, newContext) import Minilang.Lambda.Parser (desugar, parse) import Minilang.REPL.Types -import Minilang.Lambda.Eval (newEnv) -- | Run a REPL session runREPL :: @@ -49,41 +50,40 @@ handleCommand :: (MonadCatch m, MonadREPL m) => Command -> m () -handleCommand ClearEnv = getEnv >>= \e -> setEnv (e{env = newEnv, context = newContext}) +handleCommand ClearEnv = getEnv >>= \e -> setEnv (e {env = newEnv, context = newContext}) handleCommand DumpEnv = - getEnv >>= \REPLEnv{..} -> - output (CurrentEnv env context) + getEnv >>= \REPLEnv {..} -> + output (CurrentEnv env context) handleCommand (Load (File file)) = do - t <- load file - case t of - Left err -> output (Msg $ pack $ show err) - Right prog -> loadProgramInEnv prog + t <- load file + case t of + Left err -> output (Msg $ pack $ show err) + Right prog -> loadProgramInEnv prog handleCommand (Load (Data prog)) = loadProgramInEnv prog -handleCommand (Set (StepTypeChecker st)) = getEnv >>= \e -> setEnv (e{stepTypeCheck = st}) -handleCommand (Set (DebugParser st)) = getEnv >>= \e -> setEnv (e{debugParser = st}) +handleCommand (Set (StepTypeChecker st)) = getEnv >>= \e -> setEnv (e {stepTypeCheck = st}) +handleCommand (Set (DebugParser st)) = getEnv >>= \e -> setEnv (e {debugParser = st}) handleCommand Help = - output (Msg helpText) + output (Msg helpText) loadProgramInEnv :: (MonadCatch m, MonadREPL m) => Text -> m () -loadProgramInEnv prog = undefined -- do --- repl@REPLEnv{rho = ρ, gamma = γ, debugParser} <- getEnv --- case runParser program (ParserState debugParser) "" (unpack prog) of --- Left err -> output (Msg $ pack $ show err) --- Right e -> --- ( do --- (ρ', γ') <- loadProgram e ρ γ --- setEnv (repl{rho = ρ', gamma = γ'}) --- output (Msg makeMessage) --- ) --- `catch` \(TypingError err) -> output (Msg err) --- where --- makeMessage = --- "Loaded \"" --- <> ( if Text.length prog > 15 --- then Text.take 15 prog <> "..." --- else prog --- ) --- <> "\"" +loadProgramInEnv prog = do + repl@REPLEnv {env, context} <- getEnv + case parse prog of + Left err -> output (Msg $ pack $ show err) + Right e -> do + case loadProgram e env context of + Left typeError -> output (Msg $ pack $ show typeError) + Right (term, typ, env', context') -> do + setEnv (repl {env = env', context = context'}) + output (Evaluated term typ) + where + makeMessage = + "Loaded \"" + <> ( if Text.length prog > 15 + then Text.take 15 prog <> "..." + else prog + ) + <> "\"" diff --git a/lambda-calcul/haskell/src/Minilang/REPL/Types.hs b/lambda-calcul/haskell/src/Minilang/REPL/Types.hs index 383987b..3a82018 100644 --- a/lambda-calcul/haskell/src/Minilang/REPL/Types.hs +++ b/lambda-calcul/haskell/src/Minilang/REPL/Types.hs @@ -78,7 +78,7 @@ data Out | CurrentEnv Env Context | Msg Text | Bye - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, ToJSON, FromJSON) data Flag = StepTypeChecker Bool diff --git a/lambda-calcul/haskell/src/Minilang/Server.hs b/lambda-calcul/haskell/src/Minilang/Server.hs new file mode 100644 index 0000000..5c34db4 --- /dev/null +++ b/lambda-calcul/haskell/src/Minilang/Server.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE TypeApplications #-} + +-- | An HTTP server providing a basic REPL and text editor to work +-- collaboratively on Minilang code. +module Minilang.Server where + +import Control.Concurrent.Async +import Control.Concurrent.STM.TVar +import Data.Aeson + ( Value, + decode, + object, + (.=), + ) +import Data.ByteString.Lazy (fromStrict) +import Data.Default +import Data.Text (Text) +import Minilang.Log +import Minilang.REPL.Net +import Network.Wai +import Network.Wai.Application.Static +import Network.Wai.Handler.Warp as Warp +import Network.Wai.Middleware.RequestLogger +import Network.Wai.Middleware.RequestLogger.JSON +import System.Log.FastLogger (fromLogStr) +import Control.Concurrent.Async + +data Server = Server + { serverThread :: Maybe (Async ()) + -- ^If the server is running, this will contain the underlying + , serverPort :: Int + -- ^The actual port this server is listening on. Useful when + } + +-- | Starts HTTP server on given port. +-- This server serves static files from public/ directory and also +-- exposes a WebSocket-based REPL under `/repl` path. +startServer :: Int -> IO Server +startServer serverPort = do + envs <- newTVarIO mempty + logger <- newLog "minilang" + loggerMiddleware <- runHTTPLog logger + let app = loggerMiddleware $ runNetREPL logger envs staticResources + (port, action) <- startWarp serverPort app + thread <- async action + logInfo logger $ object ["action" .= ("Started" :: Text), "port" .= port] + pure $ Server (Just thread) port + where + startWarp 0 app = do + (port, socket) <- openFreePort + pure (port, Warp.runSettingsSocket defaultSettings socket app) + startWarp port app = pure (port, Warp.run port app) + + runHTTPLog logger = + mkRequestLogger $ + def + { outputFormat = CustomOutputFormatWithDetails formatAsJSON, + destination = Callback (\str -> logInfo logger (decode @Value $ fromStrict $ fromLogStr str)) + } + +stopServer :: Server -> IO () +stopServer (Server (Just th) _) = cancel th +stopServer _ = pure () + +waitServer :: Server -> IO () +waitServer (Server (Just th) _) = wait th +waitServer _ = pure () + +-- | Serve static resources under `public/` directory +staticResources :: Application +staticResources = staticApp (defaultFileServerSettings "public") |
