hyper-haskell-server 0.2.3.1 → 0.2.4.0
raw patch · 6 files changed
+491/−392 lines, 6 filesdep ~deepseqdep ~scottysetup-changed
Dependency ranges changed: deepseq, scotty
Files
- LICENSE +1/−1
- Main.hs +0/−347
- Setup.hs +0/−2
- hyper-haskell-server.cabal +45/−42
- src/HyperHaskell/Interpreter.hs +310/−0
- src/Main.hs +135/−0
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2016 Heinrich Apfelmus+Copyright (c) 2016-2024 Heinrich Apfelmus All rights reserved.
− Main.hs
@@ -1,347 +0,0 @@-{------------------------------------------------------------------------------ HyperHaskell-------------------------------------------------------------------------------}-{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTSyntax, ExistentialQuantification, RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-module Main where--import Control.Concurrent-import Control.DeepSeq-import Control.Monad-import Control.Monad.Catch- ( SomeException- , catch- , displayException- , fromException- )-import Control.Exception- ( AsyncException(UserInterrupt)- , evaluate- )-import Data.List (groupBy)-import Data.Maybe (catMaybes)-import Data.Typeable-import Text.Read (readMaybe)---- System environment and Inter-Process-Communication (IPC)-import Foreign.C.Types ( CInt )-import GHC.IO.Handle.FD ( fdToHandle )-import System.Environment as System-import System.FilePath.Posix as System-import System.IO as System---- Haskell interpreter-import Language.Haskell.Interpreter hiding (eval, setImports)-import qualified Language.Haskell.Interpreter as Hint---- Haskell language parsing-import qualified Language.Haskell.Exts as Haskell---- web-import Data.Aeson (toJSON, (.=))-import qualified Data.Aeson as JSON-import qualified Data.ByteString.Char8 as B-import Data.Text as T (Text, concat, pack)-import Data.String (fromString)-import qualified Web.Scotty as Web---- Interpreter-import Hyper.Internal as Hyper--say = putStrLn--{------------------------------------------------------------------------------ Main-------------------------------------------------------------------------------}-defaultPort :: Int-defaultPort = 8024--main :: IO ()-main = do- -- get port number from environment- env <- System.getEnvironment- let port = maybe defaultPort id $ readMaybe =<< Prelude.lookup "PORT" env-- -- get file descriptor (pipe) from the first argument- args <- System.getArgs- let writeReady = case args of- (x:_) -> maybe (return ()) writeReadyMsgToFD $ readMaybe x- _ -> return ()-- -- Start interpreter and web server. See NOTE [MainThread]- (hint, interpreterLoop) <- newInterpreter writeReady- forkIO $ Web.scotty port (jsonAPI hint)- interpreterLoop---- | Write the message "ready" to the specified file descriptor (pipe).-writeReadyMsgToFD :: CInt -> IO ()-writeReadyMsgToFD fd0 = do- handle <- GHC.IO.Handle.FD.fdToHandle (fromIntegral fd0)- System.hSetBinaryMode handle False- System.hSetEncoding handle System.utf8- System.hSetBuffering handle LineBuffering- System.hPutStr handle "ready"---{- NOTE [MainThread]--We fork the web server and run GHC in the main thread.-This is because GHC registers handlers for signals like SIGTERM,-but for some reason, these handlers only work correctly if GHC-also has the main thread.---}--{------------------------------------------------------------------------------ Exported JSON REST API-------------------------------------------------------------------------------}-jsonAPI :: Hint -> Web.ScottyM ()-jsonAPI hint = do- Web.post "/cancel" $ do- liftIO $ cancel hint- Web.json $ JSON.object [ "status" .= t "ok" ]- Web.post "/setExtensions" $- Web.json . result =<< liftIO . setExtensions hint =<< Web.param "query"- Web.post "/setImports" $- Web.json . result =<< liftIO . setImports hint =<< Web.param "query"- Web.post "/setSearchPath" $ do- x <- Web.param "query"- y <- Web.param "dir"- Web.json . result =<< (liftIO $ setSearchPath hint x y)- Web.post "/loadFiles" $- Web.json . result =<< liftIO . loadFiles hint =<< Web.param "query"- Web.post "/eval" $ do- Web.json . result =<< liftIO . eval hint =<< Web.param "query"--t :: String -> Text-t s = fromString s---- | Convert an interpreter result to JSON.-result :: JSON.ToJSON a => Result a -> JSON.Value-result (Left e) = JSON.object [ "status" .= t "error", "errors" .= err e]- where- err e = toJSON $ case e of- UnknownError s -> [t s]- WontCompile xs -> map (t . errMsg) xs- NotAllowed s -> [t s]- GhcException s -> [t s]-result (Right x) = JSON.object [ "status" .= t "ok", "value" .= toJSON x ]--instance JSON.ToJSON Graphic where- toJSON g = JSON.object [ "type" .= t "html", "value" .= gHtml g ]--{------------------------------------------------------------------------------ Exported interpreter functions-------------------------------------------------------------------------------}-setExtensions :: Hint -> [String] -> IO (Result ())-setImports :: Hint -> [String] -> IO (Result ())-setSearchPath :: Hint -> String -> FilePath -> IO (Result ())-loadFiles :: Hint -> [FilePath] -> IO (Result ())-eval :: Hint -> String -> IO (Result Graphic)---- | Set Haskell language extensions used in the current interpreter session.-setExtensions hint xs = run hint $ Hint.set [Hint.languageExtensions Hint.:= ys]- where- readExtension :: String -> Extension- readExtension x = case readMaybe x of- Nothing -> error $ "Unknown language extension: " ++ x- Just x -> x- ys = map readExtension $ filter (not . null) xs----- | Set module imports used in the current interpreter session.--- NOTE: We implicitly always load the Prelude and Hyper modules-setImports hint = run hint . Hint.setImportsF- . (++ map simpleImport ["Prelude", "Hyper"])- . map (parseImport . words)- . filter (not . null)--moduleImport m q = Hint.ModuleImport m q NoImportList--simpleImport :: String -> Hint.ModuleImport-simpleImport m = moduleImport m NotQualified--parseImport :: [String] -> Hint.ModuleImport-parseImport (x:xs) = if x == "import" then parse xs else parse (x:xs)- where- parse ("qualified":m:"as":alias:[]) = moduleImport m (QualifiedAs $ Just alias)- parse ("qualified":m:[]) = moduleImport m (QualifiedAs Nothing)- parse (m:"as":alias:[]) = moduleImport m (ImportAs alias)- parse (m:[]) = moduleImport m NotQualified----- | Set search path for loading `.hs` source files-setSearchPath hint xs dir = run hint $ Hint.set [Hint.searchPath Hint.:= paths]- where paths = [if isRelative x then dir </> x else x | x <- splitSearchPath xs]---- | Load `.hs` source files.-loadFiles hint xs = run hint $ do- -- liftIO . print =<< Hint.get Hint.searchPath- Main.finalizeSession -- finalize the old session- Hint.loadModules $ filter (not . null) xs---- | Evaluate an input cell.-eval hint input = run hint $ do- extensions <- Hint.get Hint.languageExtensions- mgs <- forM (parsePrompts extensions input) $ \prompt -> case prompt of- Expr code -> do- -- To show the result of an expression,- -- we wrap results into an implicit call to Hyper.display- m <- Hint.interpret ("Hyper.displayIO " ++ Hint.parens code)- (as :: IO Graphic)- liftIO $ do- g <- m- x <- evaluate (force g) -- See NOTE [EvaluateToNF]- return $ Just x- Other code -> do- -- Otherwise, there is nothing to show and we pass the code on to GHC- Hint.runStmt code- return Nothing- TypeOf code -> do- -- Query type information- let pre s = "<pre>" ++ code ++ " :: "++ s ++ "</pre>"- Just . Hyper.html . T.pack . pre <$> Hint.typeOf code- Unknown code -> do- return . Just . string $ "Unknown interpreter command :" ++ code- return . combineGraphics $ catMaybes mgs--combineGraphics :: [Graphic] -> Graphic-combineGraphics xs = Graphic { gHtml = T.concat $ map gHtml xs }---- | Statements that we can evaluate.-type Stmt = Haskell.Stmt Haskell.SrcSpanInfo--data Prompt = Expr String | TypeOf String | Other String | Unknown String---- | Parse an input cell into a list of prompts to evaluate-parsePrompts :: [Hint.Extension] -> String -> [Prompt]-parsePrompts extensions =- map parsePrompt . map unlines . groupByIndent . stripIndent . lines- where- indent xs = if null xs then 0 else length . takeWhile (== ' ') $ head xs - stripIndent xs = map (drop $ indent xs) xs- groupByIndent = groupBy (\x y -> indent [y] > 0)-- parsePrompt code@(':':command) = case words command of- ("type":xs) -> TypeOf $ unwords xs- (x:_) -> Unknown x- [] -> Unknown "(empty)"- parsePrompt code =- case Haskell.parseStmtWithMode mode code :: Haskell.ParseResult Stmt of- Haskell.ParseOk (Haskell.Qualifier _ _) -> Expr code- _ -> Other code-- exts = map (Haskell.parseExtension . show) extensions- mode = Haskell.defaultParseMode { Haskell.extensions = exts }---{- NOTE [EvaluateToNF]--We evaluate the result in the interpreter thread to full normal form,-because it may be that this evaluation does not terminate,-in which case the user is likely to trigger a `UserInterrupt` asynchronous exception.-But this exception is only delivered to and handled by the interpreter thread.-Otherwise, the web server would be stuck trying to evaluate the result-in order to serialize it, with no way for the user to interrupt this.---}--{------------------------------------------------------------------------------ Internal interpreter functions-------------------------------------------------------------------------------}--- | -finalizeSession :: Interpreter ()-finalizeSession = do- Main.setImportsInternal- Hint.runStmt ("Hyper.Internal.finalizeSession")---- | Clear imports and import only the "Hyper.Internal" module qualified.-setImportsInternal :: Interpreter ()-setImportsInternal = do- let name = "Hyper.Internal"- Hint.setImportsF [Hint.ModuleImport name (QualifiedAs $ Just name) NoImportList]--{---- | Run an interpreter action with only the "Hyper.Internal" module loaded.-withInternal :: Interpreter a -> Interpreter a-withInternal m = do- xs <- Hint.getLoadedModules- let name = "Hyper.Internal"- Hint.setImportsQ [Hint.ModuleImport name (QualifiedAs $ Just name) NoImportList]- a <- m- Hint.setImportsQ xs- return a--}--{------------------------------------------------------------------------------ Interpreter Thread-------------------------------------------------------------------------------}-type Result a = Either InterpreterError a--toInterpreterError :: SomeException -> InterpreterError-toInterpreterError e = case fromException e of- Just e -> e- Nothing -> UnknownError (displayException e)--#if MIN_VERSION_base(4,8,0)-#else-displayException :: SomeException -> String-displayException = show-#endif---- | Haskell Interpreter.-data Hint = Hint- { run :: forall a. Interpreter a -> IO (Result a)- , cancel :: IO ()- }--data Action where- Action :: Interpreter a -> MVar (Result a) -> Action--debug s = liftIO $ putStrLn s---- | Create and initialize a Haskell interpreter.--- Arguments:--- writeReady = function to call when the interpreter is ready to evaluate expressions.-newInterpreter :: IO () -> IO (Hint, IO ()) -- ^ (send commands, interpreter loop)-newInterpreter writeReady = do- vin <- newEmptyMVar- evalThreadId <- newEmptyMVar -- ThreadID of the thread responsible for evaluation- - let- handler :: Interpreter ()- handler = do- debug "Waiting for Haskell expression"- Action ma vout <- liftIO $ takeMVar vin- let right = liftIO . putMVar vout . Right =<< ma- let left = liftIO . putMVar vout . Left . toInterpreterError- debug "Got Haskell expression, evaluating"- right `catch` left- debug "Wrote result"- - run :: Interpreter a -> IO (Result a)- run ma = do- vout <- newEmptyMVar- putMVar vin (Action ma vout)- a <- takeMVar vout- case a of- Right _ -> return ()- Left e -> debug $ show e- return a- - cancel :: IO ()- cancel = do- t <- readMVar evalThreadId- throwTo t UserInterrupt- -- NOTE: `throwTo` may block if the thread `t` has masked asynchronous execptions.- debug "UserInterrupt, evaluation cancelled"- - interpreterLoop :: IO ()- interpreterLoop = do- putMVar evalThreadId =<< myThreadId- -- NOTE: The failure branch of `catch` will `mask` asynchronous exceptions.- let go = forever $ handler `catch` (\UserInterrupt -> return ())- void $ runInterpreter $ liftIO writeReady >> go-- return (Hint run cancel, interpreterLoop)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
hyper-haskell-server.cabal view
@@ -1,51 +1,54 @@-Name: hyper-haskell-server-Version: 0.2.3.1-Synopsis: Server back-end for the HyperHaskell graphical Haskell interpreter-Description:+cabal-version: 3.0+name: hyper-haskell-server+version: 0.2.4.0+synopsis: Server back-end for the HyperHaskell graphical Haskell interpreter+description: This package is part of the /HyperHaskell/ project and provides the server back-end. .-Category: Compilers/Interpreters-Homepage: https://github.com/HeinrichApfelmus/hyper-haskell-License: BSD3-License-file: LICENSE-Author: Heinrich Apfelmus-Maintainer: Heinrich Apfelmus <apfelmus quantentunnel de>-Copyright: (c) Heinrich Apfelmus 2016-2024+category: Compilers/Interpreters+homepage: https://github.com/HeinrichApfelmus/hyper-haskell+license: BSD-3-Clause+license-file: LICENSE -Cabal-version: >= 1.10-Build-type: Simple-Tested-With: - GHC == 8.0.2- , GHC == 8.2.2- , GHC == 8.4.4- , GHC == 8.6.5- , GHC == 8.8.4+author: Heinrich Apfelmus+maintainer: Heinrich Apfelmus <apfelmus quantentunnel de>+copyright: (c) Heinrich Apfelmus 2016-2024++tested-with: , GHC == 8.10.7 , GHC == 9.2.8 , GHC == 9.4.7- , GHC == 9.6.4- , GHC == 9.8.1+ , GHC == 9.6.7+ , GHC == 9.8.4+ , GHC == 9.10.1+ , GHC == 9.12.2 -Source-repository head- type: git- location: git://github.com/HeinrichApfelmus/hyper-haskell.git- subdir: haskell/hyper-haskell-server/+source-repository head+ type: git+ location: https://github.com/HeinrichApfelmus/hyper-haskell.git+ subdir: haskell/hyper-haskell-server/ -Executable hyper-haskell-server- build-depends: base >= 4.6 && < 4.20- , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.3)- , bytestring >= 0.9 && < 0.13- , deepseq >= 1.2 && < 1.6- , exceptions >= 0.6 && < 0.11- , filepath >= 1.0 && < 1.6- , haskell-src-exts >= 1.17 && < 1.24- , hint >= 0.8 && < 0.10- , hyper == 0.2.*- , text >= 0.11 && < 2.2- , transformers >= 0.3 && < 0.7- , scotty >= 0.6 && < 0.22- ghc-options: -threaded- cpp-Options: -DCABAL- main-is: Main.hs- default-language: Haskell2010+executable hyper-haskell-server+ ghc-options: -threaded+ cpp-options: -DCABAL+ default-language: Haskell2010++ build-depends:+ , aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.3)+ , base >= 4.6 && < 4.22+ , bytestring >= 0.9 && < 0.13+ , deepseq >= 1.2 && < 1.7+ , exceptions >= 0.6 && < 0.11+ , filepath >= 1.0 && < 1.6+ , haskell-src-exts >= 1.17 && < 1.24+ , hint >= 0.8 && < 0.10+ , hyper >= 0.2 && < 0.3+ , text >= 0.11 && < 2.2+ , transformers >= 0.3 && < 0.7+ , scotty >= 0.20 && < 0.23++ hs-source-dirs: src+ main-is: Main.hs+ other-modules:+ HyperHaskell.Interpreter
+ src/HyperHaskell/Interpreter.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HyperHaskell.Interpreter+ ( -- * Interpreter session+ Hint+ , Result (..)+ , Hint.InterpreterError (..)+ , Hint.errMsg+ , newInterpreter++ -- * Interpreter actions+ , cancel+ , setExtensions+ , setImports+ , setSearchPath+ , loadFiles+ , eval+ ) where++import Control.Concurrent+ ( MVar+ , forkIO+ , myThreadId+ , throwTo+ , newEmptyMVar+ , putMVar+ , readMVar+ , takeMVar+ )+import Control.DeepSeq+ ( force+ )+import Control.Exception+ ( AsyncException (UserInterrupt)+ , evaluate+ )+import Control.Monad+ ( forever+ , forM+ , void+ )+import Control.Monad.Catch+ ( SomeException+ , catch+ , displayException+ , fromException+ )+import Control.Monad.IO.Class+ ( liftIO+ )+import Data.List+ ( groupBy+ )+import Data.Maybe+ ( fromMaybe+ , catMaybes+ )+import Hyper.Internal+ ( Graphic (..)+ )+import Text.Read+ ( readMaybe+ )++import qualified Data.Text as T+import qualified Language.Haskell.Interpreter as Hint+import qualified Language.Haskell.Exts as Haskell+import qualified Hyper.Internal as Hyper+import qualified System.FilePath.Posix as System++{-----------------------------------------------------------------------------+ Interpreter+ Exports+------------------------------------------------------------------------------}+-- | Set Haskell language extensions used in the current interpreter session.+setExtensions :: Hint -> [String] -> IO (Result ())+setExtensions hint xs =+ run hint $ Hint.set [Hint.languageExtensions Hint.:= ys]+ where+ readExtension :: String -> Hint.Extension+ readExtension x = case readMaybe x of+ Nothing -> error $ "Unknown language extension: " ++ x+ Just x -> x+ ys = map readExtension $ filter (not . null) xs++-- | Set module imports used in the current interpreter session.+--+-- NOTE: We implicitly always load the "Prelude" and "Hyper" modules.+setImports :: Hint -> [String] -> IO (Result ())+setImports hint =+ run hint . Hint.setImportsF+ . (++ map simpleImport ["Prelude", "Hyper"])+ . map (parseImport . words)+ . filter (not . null)++mkModuleImport :: String -> Hint.ModuleQualification -> Hint.ModuleImport+mkModuleImport m q = Hint.ModuleImport m q Hint.NoImportList++simpleImport :: String -> Hint.ModuleImport+simpleImport m = mkModuleImport m Hint.NotQualified++parseImport :: [String] -> Hint.ModuleImport+parseImport (x:xs) =+ if x == "import" then parse xs else parse (x:xs)+ where+ parse ["qualified", m, "as", alias] =+ mkModuleImport m (Hint.QualifiedAs $ Just alias)+ parse ["qualified", m] = mkModuleImport m (Hint.QualifiedAs Nothing)+ parse [m, "as", alias] = mkModuleImport m (Hint.ImportAs alias)+ parse [m] = mkModuleImport m Hint.NotQualified++-- | Set search path for loading `.hs` source files+setSearchPath :: Hint -> String -> FilePath -> IO (Result ())+setSearchPath hint xs dir =+ run hint $ Hint.set [Hint.searchPath Hint.:= paths]+ where+ paths =+ [ if System.isRelative x then dir System.</> x else x+ | x <- System.splitSearchPath xs+ ]++-- | Load `.hs` source files.+loadFiles :: Hint -> [FilePath] -> IO (Result ())+loadFiles hint xs = run hint $ do+ -- liftIO . print =<< Hint.get Hint.searchPath+ finalizeSession -- finalize the old session+ Hint.loadModules $ filter (not . null) xs++-- | Evaluate an input cell.+eval :: Hint -> String -> IO (Result Graphic)+eval hint input = run hint $ do+ extensions <- Hint.get Hint.languageExtensions+ mgs <- forM (parsePrompts extensions input) $ \prompt -> case prompt of+ Expr code -> do+ -- To show the result of an expression,+ -- we wrap results into an implicit call to Hyper.display+ m <- Hint.interpret ("Hyper.displayIO " ++ Hint.parens code)+ (Hint.as :: IO Graphic)+ liftIO $ do+ g <- m+ x <- evaluate (force g) -- See NOTE [EvaluateToNF]+ pure $ Just x+ Other code -> do+ -- Otherwise, there is nothing to show and we pass the code on to GHC+ Hint.runStmt code+ pure Nothing+ TypeOf code -> do+ -- Query type information+ let pre s = "<pre>" ++ code ++ " :: "++ s ++ "</pre>"+ Just . Hyper.html . T.pack . pre <$> Hint.typeOf code+ Unknown code -> do+ pure . Just . Hyper.string+ $ "Unknown interpreter command :" ++ code+ pure . combineGraphics $ catMaybes mgs++combineGraphics :: [Graphic] -> Graphic+combineGraphics xs = Graphic { gHtml = T.concat $ map gHtml xs }++-- | Statements that we can evaluate.+type Stmt = Haskell.Stmt Haskell.SrcSpanInfo++data Prompt+ = Expr String+ | TypeOf String+ | Other String+ | Unknown String++-- | Parse an input cell into a list of prompts to evaluate+parsePrompts :: [Hint.Extension] -> String -> [Prompt]+parsePrompts extensions =+ map parsePrompt . map unlines . groupByIndent . stripIndent . lines+ where+ indent xs = if null xs then 0 else length . takeWhile (== ' ') $ head xs + stripIndent xs = map (drop $ indent xs) xs+ groupByIndent = groupBy (\x y -> indent [y] > 0)++ parsePrompt code@(':':command) = case words command of+ ("type":xs) -> TypeOf $ unwords xs+ (x:_) -> Unknown x+ [] -> Unknown "(empty)"+ parsePrompt code =+ case Haskell.parseStmtWithMode mode code :: Haskell.ParseResult Stmt of+ Haskell.ParseOk (Haskell.Qualifier _ _) -> Expr code+ _ -> Other code++ exts = map (Haskell.parseExtension . show) extensions+ mode = Haskell.defaultParseMode { Haskell.extensions = exts }++{- NOTE [EvaluateToNF]++We evaluate the result in the interpreter thread to full normal form,+because it may be that this evaluation does not terminate,+in which case the user is likely to trigger a `UserInterrupt` asynchronous exception.+But this exception is only delivered to and handled by the interpreter thread.+Otherwise, the web server would be stuck trying to evaluate the result+in order to serialize it, with no way for the user to interrupt this.++-}++{-----------------------------------------------------------------------------+ Interpreter+ Internals+------------------------------------------------------------------------------}+-- | Finalize a session.+finalizeSession :: Hint.Interpreter ()+finalizeSession = do+ setImportsInternal+ Hint.runStmt ("Hyper.Internal.finalizeSession")++-- | Clear imports and import only the "Hyper.Internal" module qualified.+setImportsInternal :: Hint.Interpreter ()+setImportsInternal = do+ let name = "Hyper.Internal"+ Hint.setImportsF+ [Hint.ModuleImport name (Hint.QualifiedAs $ Just name) Hint.NoImportList]++{-+-- | Run an interpreter action with only the "Hyper.Internal" module loaded.+withInternal :: Interpreter a -> Interpreter a+withInternal m = do+ xs <- Hint.getLoadedModules+ let name = "Hyper.Internal"+ Hint.setImportsQ [Hint.ModuleImport name (QualifiedAs $ Just name) NoImportList]+ a <- m+ Hint.setImportsQ xs+ pure a+-}++{-----------------------------------------------------------------------------+ Interpreter+ Thread+------------------------------------------------------------------------------}+type Result a = Either Hint.InterpreterError a++toInterpreterError :: SomeException -> Hint.InterpreterError+toInterpreterError e = case fromException e of+ Just e -> e+ Nothing -> Hint.UnknownError (displayException e)++#if MIN_VERSION_base(4,8,0)+#else+displayException :: SomeException -> String+displayException = show+#endif++-- | Haskell Interpreter.+data Hint = Hint+ { run :: forall a. Hint.Interpreter a -> IO (Result a)+ , cancel :: IO ()+ }++data Action where+ Action :: Hint.Interpreter a -> MVar (Result a) -> Action++debug :: Hint.MonadIO m => String -> m ()+debug s = liftIO $ putStrLn s++-- | Create and initialize a Haskell interpreter.+-- Arguments:+-- writeReady = function to call when the interpreter is ready to evaluate expressions.+newInterpreter :: IO () -> IO (Hint, IO ()) -- ^ (send commands, interpreter loop)+newInterpreter writeReady = do+ vin <- newEmptyMVar+ evalThreadId <- newEmptyMVar -- ThreadID of the thread responsible for evaluation++ let+ handler :: Hint.Interpreter ()+ handler = do+ debug "Waiting for Haskell expression"+ Action ma vout <- liftIO $ takeMVar vin+ let right = liftIO . putMVar vout . Right =<< ma+ let left = liftIO . putMVar vout . Left . toInterpreterError+ debug "Got Haskell expression, evaluating"+ right `catch` left+ debug "Wrote result"++ run :: Hint.Interpreter a -> IO (Result a)+ run ma = do+ vout <- newEmptyMVar+ putMVar vin (Action ma vout)+ a <- takeMVar vout+ case a of+ Right _ -> pure ()+ Left e -> debug $ show e+ pure a++ cancel :: IO ()+ cancel = do+ t <- readMVar evalThreadId+ throwTo t UserInterrupt+ -- NOTE: `throwTo` may block if the thread `t` has masked asynchronous execptions.+ debug "UserInterrupt, evaluation cancelled"++ interpreterLoop :: IO ()+ interpreterLoop = do+ putMVar evalThreadId =<< myThreadId+ -- NOTE: The failure branch of `catch` will `mask` asynchronous exceptions.+ let go = forever $ handler `catch` (\UserInterrupt -> pure ())+ (e :: Either Hint.InterpreterError ()) <- Hint.runInterpreter $ do+ liftIO writeReady+ go+ case e of+ Left e' -> print e'+ Right _ -> pure ()++ pure (Hint run cancel, interpreterLoop)
+ src/Main.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE InstanceSigs #-}+module Main where++import Control.Concurrent+ ( forkIO+ )+import Control.Monad.Catch+ ( SomeException+ , catch+ , displayException+ , fromException+ )+import Control.Monad.IO.Class+ ( liftIO+ )+import Data.Aeson+ ( toJSON+ , (.=)+ )+import Data.Maybe+ ( fromMaybe+ )+import Data.String+ ( fromString+ )+import Foreign.C.Types+ ( CInt+ )+import GHC.IO.Handle.FD+ ( fdToHandle+ )+import Hyper.Internal+ ( Graphic (..)+ )+import Text.Read+ ( readMaybe+ )++import qualified Data.Aeson as JSON+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified HyperHaskell.Interpreter as H+import qualified System.Environment as System+import qualified System.FilePath.Posix as System+import qualified System.IO as System+import qualified Web.Scotty as Web++-- Interpreter+say :: String -> IO ()+say = putStrLn++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+defaultPort :: Int+defaultPort = 8024++main :: IO ()+main = do+ -- get port number from environment+ env <- System.getEnvironment+ let port = fromMaybe defaultPort $ readMaybe =<< Prelude.lookup "PORT" env++ -- get file descriptor (pipe) from the first argument+ args <- System.getArgs+ let writeReady = case args of+ (x:_) -> maybe (pure ()) writeReadyMsgToFD $ readMaybe x+ _ -> pure ()++ -- Start interpreter and web server. See NOTE [MainThread]+ (hint, interpreterLoop) <- H.newInterpreter writeReady+ forkIO $ Web.scotty port (jsonAPI hint)+ interpreterLoop++-- | Write the message "ready" to the specified file descriptor (pipe).+writeReadyMsgToFD :: CInt -> IO ()+writeReadyMsgToFD fd0 = do+ handle <- GHC.IO.Handle.FD.fdToHandle (fromIntegral fd0)+ System.hSetBinaryMode handle False+ System.hSetEncoding handle System.utf8+ System.hSetBuffering handle System.LineBuffering+ System.hPutStr handle "ready"++{- NOTE [MainThread]++We fork the web server and run GHC in the main thread.+This is because GHC registers handlers for signals like SIGTERM,+but for some reason, these handlers only work correctly if GHC+also has the main thread.++-}++{-----------------------------------------------------------------------------+ Exported JSON REST API+------------------------------------------------------------------------------}+jsonAPI :: H.Hint -> Web.ScottyM ()+jsonAPI hint = do+ Web.post "/cancel" $ do+ liftIO $ H.cancel hint+ Web.json $ JSON.object [ "status" .= t "ok" ]+ Web.post "/setExtensions" $+ Web.json . result =<< liftIO . H.setExtensions hint =<< getParam "query"+ Web.post "/setImports" $+ Web.json . result =<< liftIO . H.setImports hint =<< getParam "query"+ Web.post "/setSearchPath" $ do+ x <- getParam "query"+ y <- getParam "dir"+ Web.json . result =<< liftIO (H.setSearchPath hint x y)+ Web.post "/loadFiles" $+ Web.json . result =<< liftIO . H.loadFiles hint =<< getParam "query"+ Web.post "/eval" $ do+ Web.json . result =<< liftIO . H.eval hint =<< getParam "query"++getParam :: Web.Parsable a => TL.Text -> Web.ActionM a+getParam = Web.formParam++t :: String -> T.Text+t = fromString++-- | Convert an interpreter result to JSON.+result :: JSON.ToJSON a => H.Result a -> JSON.Value+result (Left e) = JSON.object [ "status" .= t "error", "errors" .= err e]+ where+ err e = toJSON $ case e of+ H.UnknownError s -> [t s]+ H.WontCompile xs -> map (t . H.errMsg) xs+ H.NotAllowed s -> [t s]+ H.GhcException s -> [t s]+result (Right x) = JSON.object [ "status" .= t "ok", "value" .= toJSON x ]++instance JSON.ToJSON Graphic where+ toJSON :: Graphic -> JSON.Value+ toJSON g = JSON.object [ "type" .= t "html", "value" .= gHtml g ]