added shelling out directive

IHaskell.cabal

@@ -48,6 +48,7 @@ data-files:
 library
   hs-source-dirs:      src
   build-depends:       base ==4.6.*,
+                       process >= 1.1,
                        hlint,
                        cmdargs >= 0.10,
                        tar,
@@ -106,6 +107,7 @@ executable IHaskell
   
   -- Other library packages from which modules are imported.
   build-depends:       base ==4.6.*,
+                       process >= 1.1,
                        hlint,
                        cmdargs >= 0.10,
                        tar,
@@ -139,6 +141,7 @@ Test-Suite hspec
   Ghc-Options: -threaded
   Main-Is: Hspec.hs
   build-depends:       base ==4.6.*,
+                       process >= 1.1,
                        hlint,
                        cmdargs >= 0.10,
                        tar,

src/IHaskell/Eval/Evaluate.hs

@@ -25,6 +25,9 @@ import System.IO (hGetChar, hFlush)
 import System.Random (getStdGen, randomRs)
 import Unsafe.Coerce
 import Control.Monad (guard)
+import System.Process
+import System.Exit
+import Data.Maybe (fromJust)
 
 import NameSet
 import Name
@@ -394,6 +397,73 @@ evalCommand _ (Directive SetOpt option) state = do
 
     setOpt _ _ = Nothing
 
+evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $ 
+  case words cmd of 
+    "cd":dirs ->
+      let directory = unwords dirs in do
+        setCurrentDirectory directory
+        return []
+    cmd -> do
+      (readEnd, writeEnd) <- createPipe
+      handle <- fdToHandle writeEnd
+      pipe <- fdToHandle readEnd
+      let initProcSpec = shell $ unwords cmd
+          procSpec = initProcSpec {
+            std_in = Inherit,
+            std_out = UseHandle handle,
+            std_err = UseHandle handle
+          }
+      (_, _, _, process) <- createProcess procSpec
+          
+      -- Accumulate output from the process.
+      outputAccum <- liftIO $ newMVar ""
+
+      -- Start a loop to publish intermediate results.
+      let 
+        -- Compute how long to wait between reading pieces of the output. 
+        -- `threadDelay` takes an argument of microseconds.
+        ms = 1000
+        delay = 100 * ms
+
+        -- Maximum size of the output (after which we truncate).
+        maxSize = 100 * 1000
+        incSize = 200
+        output str = publish False [plain str]
+
+        loop = do
+          -- Wait and then check if the computation is done.
+          threadDelay delay
+
+          -- Read next chunk and append to accumulator.
+          nextChunk <- readChars pipe "\n" incSize
+          modifyMVar_ outputAccum (return . (++ nextChunk))
+
+          -- Check if we're done.
+          exitCode <- getProcessExitCode process
+          let computationDone = isJust exitCode
+
+          when computationDone $ do
+            nextChunk <- readChars pipe "" maxSize
+            modifyMVar_ outputAccum (return . (++ nextChunk))
+
+          if not computationDone
+          then do
+            -- Write to frontend and repeat.
+            readMVar outputAccum >>= output 
+            loop
+          else do
+            out <- readMVar outputAccum
+            case fromJust exitCode of
+              ExitSuccess -> return [plain out]
+              ExitFailure code -> do
+                let errMsg = "Process exited with error code " ++ show code
+                    htmlErr = printf "<span class='err-msg'>%s</span>" errMsg
+                return [plain $ out ++ "\n" ++ errMsg,
+                        html $ printf "<span class='mono'>%s</span>" out ++ htmlErr]
+
+      loop
+      
+
 -- This is taken largely from GHCi's info section in InteractiveUI.
 evalCommand _ (Directive GetHelp _) state = do
   write "Help via :help or :?."
@@ -626,6 +696,29 @@ evalCommand _ (ParseError loc err) state = do
     evalState = state
   }
 
+-- Read from a file handle until we hit a delimiter or until we've read
+-- as many characters as requested
+readChars :: Handle -> String -> Int -> IO String
+
+-- If we're done reading, return nothing.
+readChars handle delims 0 = return []
+
+readChars handle delims nchars = do
+  -- Try reading a single character. It will throw an exception if the
+  -- handle is already closed.
+  tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
+  case tryRead of
+    Right char ->
+      -- If this is a delimiter, stop reading.
+      if char `elem` delims
+      then return [char]
+      else do
+        next <- readChars handle delims (nchars - 1)
+        return $ char:next
+    -- An error occurs at the end of the stream, so just stop reading.
+    Left _ -> return []
+
+
 doLoadModule :: String -> String -> Ghc [DisplayData]
 doLoadModule name modName = flip gcatch unload $ do
   -- Compile loaded modules. 
@@ -730,29 +823,6 @@ capturedStatement output stmt = do
     fd <- head <$> unsafeCoerce hValues
     fdToHandle fd
 
-  -- Read from a file handle until we hit a delimiter or until we've read
-  -- as many characters as requested
-  let 
-    readChars :: Handle -> String -> Int -> IO String
-
-    -- If we're done reading, return nothing.
-    readChars handle delims 0 = return []
-
-    readChars handle delims nchars = do
-      -- Try reading a single character. It will throw an exception if the
-      -- handle is already closed.
-      tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
-      case tryRead of
-        Right char ->
-          -- If this is a delimiter, stop reading.
-          if char `elem` delims
-          then return [char]
-          else do
-            next <- readChars handle delims (nchars - 1)
-            return $ char:next
-        -- An error occurs at the end of the stream, so just stop reading.
-        Left _ -> return []
-
   -- Keep track of whether execution has completed.
   completed <- liftIO $ newMVar False
   finishedReading <- liftIO newEmptyMVar

src/IHaskell/Eval/Parser.hs

@@ -62,6 +62,7 @@ data DirectiveType
   | SetExtension    -- ^ Enable or disable an extension via ':extension' (or prefixes)
   | LoadFile        -- ^ Load a Haskell module.
   | SetOpt          -- ^ Set various options.
+  | ShellCmd        -- ^ Execute a shell command.
   | GetHelp         -- ^ General help via ':?' or ':help'.
   deriving (Show, Eq)
 
@@ -219,6 +220,8 @@ joinFunctions [] = []
 parseDirective :: String       -- ^ Directive string.
                -> Int          -- ^ Line number at which the directive appears.
                -> CodeBlock    -- ^ Directive code block or a parse error.
+
+parseDirective (':':'!':directive) line = Directive ShellCmd $ '!':directive
 parseDirective (':':directive) line = case find rightDirective directives of
   Just (directiveType, _) -> Directive directiveType arg
     where arg = unwords restLine
@@ -292,6 +295,9 @@ joinLines = intercalate "\n"
 dropComments :: String -> String
 dropComments = removeOneLineComments . removeMultilineComments
   where
+    -- Don't remove comments after cmd directives
+    removeOneLineComments (':':'!':remaining) = ":!" ++ takeWhile (/= '\n') remaining ++ 
+      removeOneLineComments (dropWhile (/= '\n') remaining)
     removeOneLineComments ('-':'-':remaining) = removeOneLineComments (dropWhile (/= '\n') remaining)
     removeOneLineComments (x:xs) = x:removeOneLineComments xs
     removeOneLineComments x = x

src/IHaskell/Types.hs

@@ -74,7 +74,6 @@ instance ToJSON Profile where
 data KernelState = KernelState
   { getExecutionCounter :: Int,
     getLintStatus :: LintStatus,  -- Whether to use hlint, and what arguments to pass it. 
-    getCwd :: String,
     useSvg :: Bool,
     useShowErrors :: Bool,
     useShowTypes :: Bool
@@ -85,7 +84,6 @@ defaultKernelState :: KernelState
 defaultKernelState = KernelState
   { getExecutionCounter = 1,
     getLintStatus = LintOn,
-    getCwd = ".",
     useSvg = True,
     useShowErrors = False,
     useShowTypes = False

src/Main.hs

@@ -223,8 +223,6 @@ runKernel profileSrc initInfo = do
 
   -- Create initial state in the directory the kernel *should* be in.
   state <- initialKernelState
-  modifyMVar_ state $ \initState ->
-    return initState { getCwd = initDir initInfo }
 
   -- Receive and reply to all messages on the shell socket.
   interpret $ do