Merge pull request #30 from jetaggart/eval-in-haskell

Prototype for evaluation on the server.

Author: jetaggart

haskell.behaviors

@@ -11,7 +11,11 @@
                    :lt.plugins.haskell/editor-reformat-result
                    :lt.plugins.haskell/editor-syntax-result
                    :lt.plugins.haskell/editor-lint-result
+
                    :lt.plugins.haskell/on-eval-one
+                   :lt.plugins.haskell/haskell-success
+                   :lt.plugins.haskell/haskell-result
+                   :lt.plugins.haskell/haskell-exception
                    :lt.plugins.haskell/on-eval-type
 
                    [:lt.object/add-tag :docable]

haskell/LTHaskellClient.hs

@@ -9,11 +9,11 @@ import           System.Exit                (exitSuccess)
 import           System.IO                  (Handle, hClose, hFlush, hGetLine,
                                              hPutStrLn, stderr, stdout)
 
-import           Control.Applicative        ((<$>))
+import           Control.Applicative        ((<$>), (<*>))
 
 import           Data.Aeson                 (FromJSON (..), ToJSON (..),
                                              Value (..), eitherDecode, encode,
-                                             object, (.:), (.=))
+                                             object, (.:), (.:?), (.=), (.!=))
 import qualified Data.ByteString.Lazy.Char8 as BS
 
 import           GHC.Generics               (Generic)
@@ -22,29 +22,32 @@ import           Language.Haskell.GhcMod    (check, defaultOptions, findCradle,
 
 import           Language.Haskell.Stylish
 
+import           Data.Char                  (isSpace)
+import           ReplSession
+
 main :: IO ()
 main = withSocketsDo $ do
-    [portStr, clientIdStr] <- getArgs
+    [portStr, clientIdStr, projectDir] <- getArgs
     let port = fromIntegral (read portStr :: Int)
         clientId = read clientIdStr
     handle <- connectTo "localhost" (PortNumber port)
-    cwd <- getCurrentDirectory
+    client <- startSession projectDir
 
-    putStrLn $ "Connected: " ++ cwd
+    putStrLn $ "Connected: " ++ projectDir
     hFlush stdout
 
-    sendResponse handle $ LTConnection "Haskell" "haskell" clientId cwd ["haskell.api.reformat", "haskell.api.syntax"]
-    processCommands handle
+    sendResponse handle $ LTConnection "Haskell" "haskell" clientId projectDir ["haskell.api.reformat", "haskell.api.syntax"]
 
+    processCommands $ LTClientState handle client
 
-processCommands :: Handle -> IO ()
-processCommands handle = do
+processCommands :: LTClientState -> IO ()
+processCommands state@(LTClientState handle _) = do
   line <- hGetLine handle
   case parseCommand line of
     Left e -> hPutStrLn stderr ("Error processing command: " ++ e)
-    Right ltCommand -> execCommand handle ltCommand
+    Right ltCommand -> execCommand state ltCommand
 
-  processCommands handle
+  processCommands state
 
   where
     parseCommand :: String -> Either String (LTCommand (Maybe LTPayload))
@@ -55,19 +58,22 @@ sendResponse handle = hPutStrLn handle . BS.unpack . encode
 
 -- API
 
-execCommand :: Handle -> LTCommand (Maybe LTPayload) -> IO ()
+data LTClientState = LTClientState { ltHandle :: Handle, ltReplSession :: ReplSession }
+
+execCommand :: LTClientState -> LTCommand (Maybe LTPayload) -> IO ()
 
-execCommand handle (LTCommand (_, "client.close", Nothing)) = do
-  hClose handle
+execCommand state (LTCommand (_, "client.close", Nothing)) = do
+  hClose $ ltHandle state
+  endSession $ ltReplSession state
   exitSuccess
 
-execCommand handle (LTCommand (cId, command, Just ltPayload)) =
+execCommand state (LTCommand (cId, command, Just ltPayload)) =
   go command $ ltData ltPayload
 
   where
     go "haskell.api.reformat" payloadData = do
       reformattedCode <- format payloadData
-      respond "editor.haskell.reformat.result" $ LTPayload reformattedCode
+      respond "editor.haskell.reformat.result" $ LTPayload reformattedCode 0
 
     go "haskell.api.syntax" payloadData = do
       syntaxIssues <- getSyntaxIssues payloadData
@@ -77,8 +83,26 @@ execCommand handle (LTCommand (cId, command, Just ltPayload)) =
       lintIssues <- getLintIssues payloadData
       respond "editor.haskell.lint.result" $ LTArrayPayload lintIssues
 
+    go "haskell.api.eval" payloadData = do
+      result <- evalInSession payloadData $ ltReplSession state
+      let line = ltLine ltPayload
+      case result of
+        Left msg -> respond "editor.eval.haskell.exception" $ LTPayload msg line
+        Right msg | isBlank msg -> respond "editor.eval.haskell.success" $ LTPayload "" line
+        Right msg -> respond "editor.eval.haskell.result" $ LTPayload msg line
+
+    go "haskell.api.type" payloadData = do
+      result <- evalInSession (":type " ++ payloadData) $ ltReplSession state
+      let line = ltLine ltPayload
+      case result of
+        Left msg -> respond "editor.eval.haskell.exception" $ LTPayload msg line
+        Right msg -> respond "editor.eval.haskell.result" $ LTPayload msg line
+
     respond :: (ToJSON a) => Command -> a -> IO ()
-    respond respCommand respPayload = sendResponse handle $ LTCommand (cId, respCommand, respPayload)
+    respond respCommand respPayload = sendResponse (ltHandle state) $ LTCommand (cId, respCommand, respPayload)
+
+isBlank :: String -> Bool
+isBlank = all isSpace
 
 -- API types
 
@@ -89,12 +113,12 @@ data LTCommand a = LTCommand (Client, Command, a)  deriving (Show, Generic)
 instance (FromJSON a) => FromJSON (LTCommand a)
 instance (ToJSON a) => ToJSON (LTCommand a)
 
-data LTPayload = LTPayload { ltData :: String } deriving (Show)
+data LTPayload = LTPayload { ltData :: String, ltLine :: Int } deriving (Show)
 instance FromJSON LTPayload where
-  parseJSON (Object v) = LTPayload <$> v .: "data"
+  parseJSON (Object v) = LTPayload <$> v .: "data" <*> (v .:? "line" .!= 0)
 
 instance ToJSON LTPayload where
-  toJSON payload = object [ "data" .= ltData payload ]
+  toJSON payload = object [ "data" .= ltData payload, "line" .= ltLine payload ]
 
 data LTArrayPayload = LTArrayPayload { ltDataArray :: [String] } deriving (Show)
 instance FromJSON LTArrayPayload where

haskell/ReplSession.hs

@@ -0,0 +1,97 @@
+module ReplSession (
+  ReplSession,
+  evalInSession,
+  startSession,
+  endSession
+) where
+
+import System.IO
+import System.Process
+import System.Directory (getDirectoryContents)
+import Data.List (isSuffixOf)
+import Control.Monad (liftM)
+
+data ReplSession = ReplSession {
+  replIn :: Handle,
+  replOut :: Handle,
+  replError :: Handle,
+  replProcess :: ProcessHandle
+}
+
+evalInSession :: String -> ReplSession -> IO (Either String String)
+evalInSession cmd session@(ReplSession input out err _) = do
+  clearHandle out 0
+  clearHandle err 0
+  sendCommand (cmd ++ "\n") session
+  readEvalOutput session
+
+readEvalOutput :: ReplSession -> IO (Either String String)
+readEvalOutput (ReplSession _ out err _) = do
+  output <- readUntil out ("--EvalFinished\n" `isSuffixOf`)
+  let onlyOutput = take (length output - length "--EvalFinished\n") output
+  hasErrorOutput <- hReady err
+  if hasErrorOutput
+    then readAll err >>= \errorOutput -> return . Left $ errorOutput
+    else return . Right $ onlyOutput
+
+readUntil :: Handle -> (String -> Bool) -> IO String
+readUntil handle predicate = readUntil' handle "" predicate
+
+readUntil' :: Handle -> String -> (String -> Bool) -> IO String
+readUntil' handle output predicate = do
+  char <- hGetChar handle
+  let newOutput = output ++ [char]
+  if predicate $ newOutput
+    then return newOutput
+    else readUntil' handle newOutput predicate
+
+readAll :: Handle -> IO String
+readAll handle = untilM' (liftM not $ hReady handle) (hGetChar handle)
+
+startSession :: FilePath -> IO ReplSession
+startSession path = do
+  cabalProject <- isCabalProject path
+  let (cmd, args) = if cabalProject then ("cabal", ["repl"]) else ("ghci", [])
+  (input, out, err, process) <- runInteractiveProcess cmd args (Just path) Nothing
+  let session = ReplSession input out err process
+  prepareSession session
+  return session
+
+isCabalProject :: FilePath -> IO Bool
+isCabalProject dir = do
+  files <- getDirectoryContents dir
+  return $ any (".cabal" `isSuffixOf`) files
+
+prepareSession :: ReplSession -> IO ()
+prepareSession session@(ReplSession _ out _ _) = do
+  sendCommand ":set prompt \"--EvalFinished\\n\"\n" session
+  clearHandle out 1000
+
+sendCommand :: String -> ReplSession -> IO ()
+sendCommand cmd (ReplSession input _ _ _) = do
+  hPutStrLn input cmd
+  hFlush input
+
+clearHandle :: Handle -> Int -> IO ()
+clearHandle handle wait =
+  untilM (liftM not $ hWaitForInput handle wait) $ do
+    hGetChar handle
+
+untilM :: (Monad m) => m Bool -> m a -> m ()
+untilM predicate action = untilM' predicate action >> return ()
+
+untilM' :: (Monad m) => m Bool -> m a -> m [a]
+untilM' predicate action = do
+  isFinished <- predicate
+  if isFinished
+    then return []
+    else do
+      res <- action
+      others <- untilM' predicate action
+      return $ res : others
+
+endSession :: ReplSession -> IO ()
+endSession session = do
+  sendCommand ":quit\n" session
+  waitForProcess $ replProcess session
+  return ()