diff --git a/LICENSE b/LICENSE
--- a/LICENSE
+++ b/LICENSE
@@ -1,4 +1,4 @@
-Copyright (c) 2016 Heinrich Apfelmus
+Copyright (c) 2016-2024 Heinrich Apfelmus
All rights reserved.
diff --git a/Main.hs b/Main.hs
deleted file mode 100644
--- a/Main.hs
+++ /dev/null
@@ -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 = "" ++ code ++ " :: "++ s ++ "
"
- 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)
diff --git a/Setup.hs b/Setup.hs
deleted file mode 100644
--- a/Setup.hs
+++ /dev/null
@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain
diff --git a/hyper-haskell-server.cabal b/hyper-haskell-server.cabal
--- a/hyper-haskell-server.cabal
+++ b/hyper-haskell-server.cabal
@@ -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
-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
+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
diff --git a/src/HyperHaskell/Interpreter.hs b/src/HyperHaskell/Interpreter.hs
new file mode 100644
--- /dev/null
+++ b/src/HyperHaskell/Interpreter.hs
@@ -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 = "" ++ code ++ " :: "++ s ++ "
"
+ 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)
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/src/Main.hs
@@ -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 ]