5452688 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Evaluate PSCi expressions in the browser (#2199)

5452688Phil Freeman10 years ago

psc-bundle/Main.hs+1−9

compare with golang

unifiedsplit

@@ -15,7 +15,7 @@ import Control.Monad.Error.Class

15import Control.Monad.Trans.Except

16import Control.Monad.IO.Class

18−import System.FilePath (takeFileName, takeDirectory)

18+import System.FilePath (takeDirectory)

19import System.FilePath.Glob (glob)

20import System.Exit (exitFailure)

21import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8)

@@ -37,14 +37,6 @@ data Options = Options

37 , optionsNamespace :: String

38 } deriving Show

40−-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.

41−guessModuleIdentifier :: (MonadError ErrorMessage m) => FilePath -> m ModuleIdentifier

42−guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)

43− where

44− guessModuleType "index.js" = pure Regular

45− guessModuleType "foreign.js" = pure Foreign

46− guessModuleType name = throwError $ UnsupportedModulePath name

47−

48-- | The main application function.

40-- | The main application function.

49-- This function parses the input files, performs dead code elimination, filters empty modules

41-- This function parses the input files, performs dead code elimination, filters empty modules

50-- and generates and prints the final Javascript bundle.

42-- and generates and prints the final Javascript bundle.

psci/Main.hs+259−27

@@ -1,9 +1,13 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DoAndIfThenElse #-}

3+{-# LANGUAGE GADTs #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE RecordWildCards #-}

8{-# LANGUAGE RecordWildCards #-}

6{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TemplateHaskell #-}

7{-# LANGUAGE TupleSections #-}

11{-# LANGUAGE TupleSections #-}

9module Main (main) where

13module Main (main) where

@@ -11,10 +15,22 @@ module Main (main) where

11import Prelude ()

15import Prelude ()

12import Prelude.Compat

16import Prelude.Compat

18+import Data.FileEmbed (embedStringFile)

14import Data.Monoid ((<>))

19import Data.Monoid ((<>))

20+import Data.String (IsString(..))

21+import Data.Text (Text, unpack)

22+import Data.Traversable (for)

15import Data.Version (showVersion)

23import Data.Version (showVersion)

17−import Control.Applicative (many)

25+import Control.Applicative (many, (<|>))

26+import Control.Concurrent (forkIO)

27+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar,

28+ tryPutMVar)

29+import Control.Concurrent.STM (TVar, atomically, newTVarIO, writeTVar,

30+ readTVarIO,

31+ TChan, newBroadcastTChanIO, dupTChan,

32+ readTChan, writeTChan)

33+import Control.Exception (fromException)

18import Control.Monad

34import Control.Monad

19import Control.Monad.IO.Class (liftIO)

35import Control.Monad.IO.Class (liftIO)

20import Control.Monad.Trans.Class

36import Control.Monad.Trans.Class

@@ -23,21 +39,33 @@ import Control.Monad.Trans.State.Strict (StateT, evalStateT)

23import Control.Monad.Trans.Reader (ReaderT, runReaderT)

39import Control.Monad.Trans.Reader (ReaderT, runReaderT)

25import qualified Language.PureScript as P

41import qualified Language.PureScript as P

42+import qualified Language.PureScript.Bundle as Bundle

26import Language.PureScript.Interactive

43import Language.PureScript.Interactive

45+import Network.HTTP.Types.Header (hContentType, hCacheControl,

46+ hPragma, hExpires)

47+import Network.HTTP.Types.Status (status200, status404, status503)

48+import qualified Network.Wai as Wai

49+import qualified Network.Wai.Handler.Warp as Warp

50+import qualified Network.Wai.Handler.WebSockets as WS

51+import qualified Network.WebSockets as WS

52+

28import qualified Options.Applicative as Opts

53import qualified Options.Applicative as Opts

30import qualified Paths_purescript as Paths

55import qualified Paths_purescript as Paths

32import System.Console.Haskeline

57import System.Console.Haskeline

58+import System.IO.UTF8 (readUTF8File)

33import System.Exit

59import System.Exit

60+import System.FilePath ((</>))

34import System.FilePath.Glob (glob)

61import System.FilePath.Glob (glob)

62+import System.Process (readProcessWithExitCode)

36-- | Command line options

64-- | Command line options

37data PSCiOptions = PSCiOptions

65data PSCiOptions = PSCiOptions

38 { psciMultiLineMode :: Bool

66 { psciMultiLineMode :: Bool

39 , psciInputFile :: [FilePath]

67 , psciInputFile :: [FilePath]

40− , psciInputNodeFlags :: [String]

68+ , psciBackend :: Backend

41 }

69 }

43multiLineMode :: Opts.Parser Bool

71multiLineMode :: Opts.Parser Bool

@@ -60,10 +88,21 @@ nodeFlagsFlag = Opts.option parser $

60 where

88 where

61 parser = words <$> Opts.str

89 parser = words <$> Opts.str

91+port :: Opts.Parser Int

92+port = Opts.option Opts.auto $

93+ Opts.long "port"

94+ <> Opts.short 'p'

95+ <> Opts.help "The web server port"

96+

97+backend :: Opts.Parser Backend

98+backend =

99+ (browserBackend <$> port)

100+ <|> (nodeBackend <$> nodeFlagsFlag)

101+

63psciOptions :: Opts.Parser PSCiOptions

102psciOptions :: Opts.Parser PSCiOptions

64psciOptions = PSCiOptions <$> multiLineMode

103psciOptions = PSCiOptions <$> multiLineMode

65 <*> many inputFile

104 <*> many inputFile

66− <*> nodeFlagsFlag

105+ <*> backend

106

68version :: Opts.Parser (a -> a)

107version :: Opts.Parser (a -> a)

69version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $

108version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $

@@ -92,6 +131,195 @@ getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do

92 go :: [String] -> InputT m String

131 go :: [String] -> InputT m String

93 go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "

132 go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "

133

134+-- | Make a JavaScript bundle for the browser.

135+bundle :: IO (Either Bundle.ErrorMessage String)

136+bundle = runExceptT $ do

137+ inputFiles <- liftIO (glob (".psci_modules" </> "node_modules" </> "*" </> "*.js"))

138+ input <- for inputFiles $ \filename -> do

139+ js <- liftIO (readUTF8File filename)

140+ mid <- Bundle.guessModuleIdentifier filename

141+ length js `seq` return (mid, js)

142+ Bundle.bundle input [] Nothing "PSCI"

143+

144+indexJS :: IsString string => string

145+indexJS = $(embedStringFile "psci/static/index.js")

146+

147+indexPage :: IsString string => string

148+indexPage = $(embedStringFile "psci/static/index.html")

149+

150+-- | All of the functions required to implement a PSCi backend

151+data Backend = forall state. Backend

152+ { _backendSetup :: IO state

153+ -- ^ Initialize, and call the continuation when the backend is ready

154+ , _backendEval :: state -> String -> IO ()

155+ -- ^ Evaluate JavaScript code

156+ , _backendReload :: state -> IO ()

157+ -- ^ Reload the compiled code

158+ , _backendShutdown :: state -> IO ()

159+ -- ^ Shut down the backend

160+ }

161+

162+-- | Commands which can be sent to the browser

163+data BrowserCommand

164+ = Eval (MVar String)

165+ -- ^ Evaluate the latest JS

166+ | Reload

167+ -- ^ Reload the page

168+

169+-- | State for the browser backend

170+data BrowserState = BrowserState

171+ { browserCommands :: TChan BrowserCommand

172+ -- ^ A channel which receives data when the compiled JS has

173+ -- been updated

174+ , browserShutdownNotice :: MVar ()

175+ -- ^ An MVar which becomes full when the server should shut down

176+ , browserIndexJS :: TVar (Maybe String)

177+ -- ^ A TVar holding the latest compiled JS

178+ , browserBundleJS :: TVar (Maybe String)

179+ -- ^ A TVar holding the latest bundled JS

180+ }

181+

182+browserBackend :: Int -> Backend

183+browserBackend serverPort = Backend setup evaluate reload shutdown

184+ where

185+ setup :: IO BrowserState

186+ setup = do

187+ shutdownVar <- newEmptyMVar

188+ cmdChan <- newBroadcastTChanIO

189+ indexJs <- newTVarIO Nothing

190+ bundleJs <- newTVarIO Nothing

191+

192+ let

193+ handleWebsocket :: WS.PendingConnection -> IO ()

194+ handleWebsocket pending = do

195+ conn <- WS.acceptRequest pending

196+ -- Fork a thread to keep the connection alive

197+ WS.forkPingThread conn 10

198+ -- Clone the command channel

199+ cmdChanCopy <- atomically $ dupTChan cmdChan

200+ -- Listen for commands

201+ forever $ do

202+ cmd <- atomically $ readTChan cmdChanCopy

203+ case cmd of

204+ Eval resultVar -> void $ do

205+ WS.sendTextData conn ("eval" :: Text)

206+ result <- WS.receiveData conn

207+ -- With many connected clients, all but one of

208+ -- these attempts will fail.

209+ tryPutMVar resultVar (unpack result)

210+ Reload -> do

211+ WS.sendTextData conn ("reload" :: Text)

212+

213+ shutdownHandler :: IO () -> IO ()

214+ shutdownHandler stopServer = void . forkIO $ do

215+ () <- takeMVar shutdownVar

216+ stopServer

217+

218+ onException :: Maybe Wai.Request -> SomeException -> IO ()

219+ onException req ex

220+ | Just (_ :: WS.ConnectionException) <- fromException ex

221+ = return () -- ignore websocket disconnects

222+ | otherwise = Warp.defaultOnException req ex

223+

224+ staticServer :: Wai.Application

225+ staticServer req respond =

226+ case Wai.pathInfo req of

227+ [] ->

228+ respond $ Wai.responseLBS status200

229+ [(hContentType, "text/html")]

230+ indexPage

231+ ["js", "index.js"] ->

232+ respond $ Wai.responseLBS status200

233+ [(hContentType, "application/javascript")]

234+ indexJS

235+ ["js", "latest.js"] -> do

236+ may <- readTVarIO indexJs

237+ case may of

238+ Nothing ->

239+ respond $ Wai.responseLBS status503 [] "Service not available"

240+ Just js ->

241+ respond $ Wai.responseLBS status200

242+ [ (hContentType, "application/javascript")

243+ , (hCacheControl, "no-cache, no-store, must-revalidate")

244+ , (hPragma, "no-cache")

245+ , (hExpires, "0")

246+ ]

247+ (fromString js)

248+ ["js", "bundle.js"] -> do

249+ may <- readTVarIO bundleJs

250+ case may of

251+ Nothing ->

252+ respond $ Wai.responseLBS status503 [] "Service not available"

253+ Just js ->

254+ respond $ Wai.responseLBS status200

255+ [ (hContentType, "application/javascript")]

256+ (fromString js)

257+ _ -> respond $ Wai.responseLBS status404 [] "Not found"

258+

259+ let browserState = BrowserState cmdChan shutdownVar indexJs bundleJs

260+ createBundle browserState

261+

262+ putStrLn $ "Serving http://localhost:" <> show serverPort <> "/. Waiting for connections..."

263+ _ <- forkIO $ Warp.runSettings ( Warp.setInstallShutdownHandler shutdownHandler

264+ . Warp.setPort serverPort

265+ . Warp.setOnException onException

266+ $ Warp.defaultSettings

267+ ) $

268+ WS.websocketsOr WS.defaultConnectionOptions

269+ handleWebsocket

270+ staticServer

271+ return browserState

272+

273+ createBundle :: BrowserState -> IO ()

274+ createBundle state = do

275+ putStrLn "Bundling Javascript..."

276+ ejs <- bundle

277+ case ejs of

278+ Left err -> do

279+ putStrLn (unlines (Bundle.printErrorMessage err))

280+ exitFailure

281+ Right js -> do

282+ atomically $ writeTVar (browserBundleJS state) (Just js)

283+

284+ reload :: BrowserState -> IO ()

285+ reload state = do

286+ createBundle state

287+ atomically $ writeTChan (browserCommands state) Reload

288+

289+ shutdown :: BrowserState -> IO ()

290+ shutdown state = putMVar (browserShutdownNotice state) ()

291+

292+ evaluate :: BrowserState -> String -> IO ()

293+ evaluate state js = liftIO $ do

294+ resultVar <- newEmptyMVar

295+ atomically $ do

296+ writeTVar (browserIndexJS state) (Just js)

297+ writeTChan (browserCommands state) (Eval resultVar)

298+ result <- takeMVar resultVar

299+ putStrLn result

300+

301+nodeBackend :: [String] -> Backend

302+nodeBackend nodeArgs = Backend setup eval reload shutdown

303+ where

304+ setup :: IO ()

305+ setup = return ()

306+

307+ eval :: () -> String -> IO ()

308+ eval _ _ = do

309+ writeFile indexFile "require('$PSCI')['$main']();"

310+ process <- findNodeProcess

311+ result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process

312+ case result of

313+ Just (ExitSuccess, out, _) -> putStrLn out

314+ Just (ExitFailure _, _, err) -> putStrLn err

315+ Nothing -> putStrLn "Couldn't find node.js"

316+

317+ reload :: () -> IO ()

318+ reload _ = return ()

319+

320+ shutdown :: () -> IO ()

321+ shutdown _ = return ()

322+

95-- | Get command line options and drop into the REPL

323-- | Get command line options and drop into the REPL

96main :: IO ()

324main :: IO ()

97main = getOpt >>= loop

325main = getOpt >>= loop

@@ -106,27 +334,31 @@ main = getOpt >>= loop

106 exitFailure

334 exitFailure

107 (externs, env) <- ExceptT . runMake . make $ modules

335 (externs, env) <- ExceptT . runMake . make $ modules

108 return (modules, externs, env)

336 return (modules, externs, env)

337+ case psciBackend of

338+ Backend setup eval reload (shutdown :: state -> IO ()) -> do

109− case e of

339+ case e of

110− Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure

340+ Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure

111− Right (modules, externs, env) -> do

341+ Right (modules, externs, env) -> do

112− historyFilename <- getHistoryFilename

342+ historyFilename <- getHistoryFilename

113− let settings = defaultSettings { historyFile = Just historyFilename }

343+ let settings = defaultSettings { historyFile = Just historyFilename }

114− initialState = PSCiState [] [] (zip (map snd modules) externs)

344+ initialState = PSCiState [] [] (zip (map snd modules) externs)

115− config = PSCiConfig inputFiles psciInputNodeFlags env

345+ config = PSCiConfig inputFiles env

116− runner = flip runReaderT config

346+ runner = flip runReaderT config

117− . flip evalStateT initialState

347+ . flip evalStateT initialState

118− . runInputT (setComplete completion settings)

348+ . runInputT (setComplete completion settings)

119− putStrLn prologueMessage

349+

120− runner go

121− where

122− go :: InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()

350+ go :: state -> InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()

123− go = do

351+ go state = do

124− c <- getCommand (not psciMultiLineMode)

352+ c <- getCommand (not psciMultiLineMode)

125− case c of

353+ case c of

126− Left err -> outputStrLn err >> go

354+ Left err -> outputStrLn err >> go state

127− Right Nothing -> go

355+ Right Nothing -> go state

356+ Right (Just QuitPSCi) -> do

128− Right (Just QuitPSCi) -> outputStrLn quitMessage

357+ outputStrLn quitMessage

358+ liftIO $ shutdown state

129− Right (Just c') -> do

359+ Right (Just c') -> do

130− handleInterrupt (outputStrLn "Interrupted.")

360+ handleInterrupt (outputStrLn "Interrupted.")

131− (withInterrupt (lift (handleCommand c')))

361+ (withInterrupt (lift (handleCommand (liftIO . eval state) (liftIO (reload state)) c')))

132− go

362+ go state

363+ putStrLn prologueMessage

364+ setup >>= runner . go

psci/static/index.htmlnew file+10

@@ -0,0 +1,10 @@

1+<!DOCTYPE html>

2+<html>

3+<head>

4+ <title>PureScript Interactive</title>

5+ <script src='js/bundle.js'></script>

6+ <script src='js/index.js'></script>

7+</head>

8+<body>

9+</body>

10+</html>

psci/static/index.jsnew file+63

@@ -0,0 +1,63 @@

1+var get = function get(uri, callback, onError) {

2+ var request = new XMLHttpRequest();

3+ request.addEventListener('load', function() {

4+ callback(request.responseText);

5+ });

6+ request.addEventListener('error', onError);

7+ request.open('GET', uri);

8+ request.send();

9+};

10+var evaluate = function evaluate(js) {

11+ var buffer = [];

12+ // Save the old console.log function

13+ var oldLog = console.log;

14+ console.log = function(s) {

15+ // Push log output into a temporary buffer

16+ // which will be returned to PSCi.

17+ buffer.push(s);

18+ };

19+ // Replace any require(...) statements with lookups on the PSCI object.

20+ var replaced = js.replace(/require$"[^"]*"$/g, function(s) {

21+ return "PSCI['" + s.substring(12, s.length - 2) + "']";

22+ });

23+ // Wrap the module and evaluate it.

24+ var wrapped =

25+ [ 'var module = {};'

26+ , '(function(module) {'

27+ , replaced

28+ , '})(module);'

29+ , 'return module.exports["$main"] && module.exports["$main"]();'

30+ ].join('\n');

31+ new Function(wrapped)();

32+ // Restore console.log

33+ console.log = oldLog;

34+ return buffer.join('\n');

35+};

36+window.onload = function() {

37+ var socket = new WebSocket('ws://0.0.0.0:' + location.port);

38+ var evalNext = function reload() {

39+ get('js/latest.js', function(response) {

40+ try {

41+ var result = evaluate(response);

42+ socket.send(result);

43+ } catch (ex) {

44+ socket.send(ex.stack);

45+ }

46+ }, function(err) {

47+ socket.send('Error sending JavaScript');

48+ });

49+ };

50+ socket.onopen = function() {

51+ console.log('Connected');

52+ socket.onmessage = function(event) {

53+ switch (event.data) {

54+ case 'eval':

55+ evalNext();

56+ break;

57+ case 'reload':

58+ location.reload();

59+ break;

60+ }

61+ };

62+ };

63+};

purescript.cabal+12−1

@@ -79,6 +79,8 @@ extra-source-files: examples/passing/*.purs

79 , examples/docs/bower_components/purescript-prelude/src/*.purs

80 , examples/docs/bower.json

81 , examples/docs/src/*.purs

82+ , psci/static/index.html

83+ , psci/static/index.js

82 , tests/support/package.json

84 , tests/support/package.json

83 , tests/support/bower.json

85 , tests/support/bower.json

84 , tests/support/setup-win.cmd

86 , tests/support/setup-win.cmd

@@ -338,18 +340,27 @@ executable psci

338 purescript -any,

340 purescript -any,

339 base-compat >=0.6.0,

341 base-compat >=0.6.0,

340 boxes >= 0.1.4 && < 0.2.0,

342 boxes >= 0.1.4 && < 0.2.0,

343+ bytestring -any,

341 containers -any,

344 containers -any,

342 directory -any,

345 directory -any,

343 filepath -any,

346 filepath -any,

347+ file-embed -any,

344 Glob -any,

348 Glob -any,

345 haskeline >= 0.7.0.0,

349 haskeline >= 0.7.0.0,

350+ http-types == 0.9.*,

346 mtl -any,

351 mtl -any,

347 optparse-applicative >= 0.12.1,

352 optparse-applicative >= 0.12.1,

348 parsec -any,

353 parsec -any,

349 process -any,

354 process -any,

355+ stm >= 0.2.4.0,

356+ text -any,

350 time -any,

357 time -any,

351 transformers -any,

358 transformers -any,

352− transformers-compat -any

359+ transformers-compat -any,

360+ wai == 3.*,

361+ wai-websockets == 3.*,

362+ warp == 3.*,

363+ websockets >= 0.9 && <0.10

353 main-is: Main.hs

364 main-is: Main.hs

354 buildable: True

365 buildable: True

355 hs-source-dirs: psci

366 hs-source-dirs: psci

src/Language/PureScript/Bundle.hs+11

@@ -6,6 +6,7 @@

6-- and generates the final Javascript bundle.

7module Language.PureScript.Bundle

8 ( bundle

9+ , guessModuleIdentifier

9 , ModuleIdentifier(..)

10 , ModuleIdentifier(..)

10 , moduleName

11 , moduleName

11 , ModuleType(..)

12 , ModuleType(..)

@@ -32,6 +33,8 @@ import Language.JavaScript.Parser.AST

33import qualified Paths_purescript as Paths

34import qualified Paths_purescript as Paths

36+import System.FilePath (takeFileName, takeDirectory)

37+

35-- | The type of error messages. We separate generation and rendering of errors using a data

38-- | The type of error messages. We separate generation and rendering of errors using a data

36-- type, in case we need to match on error types later.

39-- type, in case we need to match on error types later.

37data ErrorMessage

40data ErrorMessage

@@ -58,6 +61,14 @@ data ModuleIdentifier = ModuleIdentifier String ModuleType deriving (Show, Read,

58moduleName :: ModuleIdentifier -> String

61moduleName :: ModuleIdentifier -> String

59moduleName (ModuleIdentifier name _) = name

62moduleName (ModuleIdentifier name _) = name

64+-- | Given a filename, assuming it is in the correct place on disk, infer a ModuleIdentifier.

65+guessModuleIdentifier :: MonadError ErrorMessage m => FilePath -> m ModuleIdentifier

66+guessModuleIdentifier filename = ModuleIdentifier (takeFileName (takeDirectory filename)) <$> guessModuleType (takeFileName filename)

67+ where

68+ guessModuleType "index.js" = pure Regular

69+ guessModuleType "foreign.js" = pure Foreign

70+ guessModuleType name = throwError $ UnsupportedModulePath name

71+

61-- | A piece of code is identified by its module and its name. These keys are used to label vertices

72-- | A piece of code is identified by its module and its name. These keys are used to label vertices

62-- in the dependency graph.

73-- in the dependency graph.

63type Key = (ModuleIdentifier, String)

74type Key = (ModuleIdentifier, String)

src/Language/PureScript/Interactive.hs+25−28

@@ -38,8 +38,7 @@ import Language.PureScript.Interactive.Parser as Interactive

38import Language.PureScript.Interactive.Printer as Interactive

39import Language.PureScript.Interactive.Types as Interactive

41−import System.Exit

41+import System.FilePath ((</>))

42−import System.Process (readProcessWithExitCode)

44-- | Pretty-print errors

43-- | Pretty-print errors

45printErrors :: MonadIO m => P.MultipleErrors -> m ()

44printErrors :: MonadIO m => P.MultipleErrors -> m ()

@@ -91,25 +90,28 @@ make ms = do

91-- | Performs a PSCi command

90-- | Performs a PSCi command

92handleCommand

91handleCommand

93 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)

92 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)

94− => Command

93+ => (String -> m ())

95 -> m ()

94 -> m ()

95+ -> Command

96+ -> m ()

96−handleCommand ShowHelp = liftIO $ putStrLn helpMessage

97+handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage

97−handleCommand ResetState = handleResetState

98+handleCommand _ r ResetState = handleResetState r

98−handleCommand (Expression val) = handleExpression val

99+handleCommand c _ (Expression val) = handleExpression c val

99−handleCommand (Import im) = handleImport im

100+handleCommand _ _ (Import im) = handleImport im

100−handleCommand (Decls l) = handleDecls l

101+handleCommand _ _ (Decls l) = handleDecls l

101−handleCommand (TypeOf val) = handleTypeOf val

102+handleCommand _ _ (TypeOf val) = handleTypeOf val

102−handleCommand (KindOf typ) = handleKindOf typ

103+handleCommand _ _ (KindOf typ) = handleKindOf typ

103−handleCommand (BrowseModule moduleName) = handleBrowse moduleName

104+handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName

104−handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules

105+handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules

105−handleCommand (ShowInfo QueryImport) = handleShowImportedModules

106+handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules

106−handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

107+handleCommand _ _ QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."

107

108

108-- | Reset the application state

109-- | Reset the application state

109handleResetState

110handleResetState

110 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)

111 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)

111 => m ()

112 => m ()

113+ -> m ()

112−handleResetState = do

114+handleResetState reload = do

113 modify $ updateImportedModules (const [])

115 modify $ updateImportedModules (const [])

114 . updateLets (const [])

116 . updateLets (const [])

115 files <- asks psciLoadedFiles

117 files <- asks psciLoadedFiles

@@ -119,30 +121,25 @@ handleResetState = do

119 return (map snd modules, externs)

121 return (map snd modules, externs)

120 case e of

122 case e of

121 Left errs -> printErrors errs

123 Left errs -> printErrors errs

124+ Right (modules, externs) -> do

122− Right (modules, externs) -> modify (updateLoadedExterns (const (zip modules externs)))

125+ modify (updateLoadedExterns (const (zip modules externs)))

126+ reload

123

127

124-- | Takes a value expression and evaluates it with the current state.

128-- | Takes a value expression and evaluates it with the current state.

125−--

126−-- TODO: factor out the Node process runner, so that we can use PSCi in other settings.

127handleExpression

129handleExpression

128 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)

130 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)

131+ => (String -> m ())

129− => P.Expr

132+ -> P.Expr

130 -> m ()

133 -> m ()

131−handleExpression val = do

134+handleExpression evaluate val = do

132 st <- get

135 st <- get

133 let m = createTemporaryModule True st val

136 let m = createTemporaryModule True st val

134− nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags)

135 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m

137 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m

136 case e of

138 case e of

137 Left errs -> printErrors errs

139 Left errs -> printErrors errs

138 Right _ -> do

140 Right _ -> do

139− liftIO $ writeFile indexFile "require('$PSCI')['$main']();"

141+ js <- liftIO $ readFile (modulesDir </> "$PSCI" </> "index.js")

140− process <- liftIO findNodeProcess

142+ evaluate js

141− result <- liftIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process

142− case result of

143− Just (ExitSuccess, out, _) -> liftIO $ putStrLn out

144− Just (ExitFailure _, _, err) -> liftIO $ putStrLn err

145− Nothing -> liftIO $ putStrLn "Couldn't find node.js"

146

143

147-- |

144-- |

148-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,

145-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,

src/Language/PureScript/Interactive/Types.hs−1

@@ -13,7 +13,6 @@ import qualified Language.PureScript as P

13--

14data PSCiConfig = PSCiConfig

15 { psciLoadedFiles :: [FilePath]

16− , psciNodeFlags :: [String]

17 , psciEnvironment :: P.Environment

16 , psciEnvironment :: P.Environment

18 } deriving Show

17 } deriving Show

stack-ghc-8.0.yaml+2

@@ -3,3 +3,5 @@ packages:

3- '.'

4extra-deps:

5- pipes-http-1.0.2

6+- wai-websockets-3.0.0.9

7+- websockets-0.9.6.2