Merge pull request #17 from aavogt/master

a bunch of changes

IHaskell.cabal

@@ -50,7 +50,17 @@ executable IHaskell
   main-is:             Main.hs
   
   -- Modules included in this executable, other than Main.
-  -- other-modules:       
+  other-modules:       
+             IHaskell.Completion
+             IHaskell.Eval.Evaluate
+             IHaskell.IPython
+             IHaskell.Message.Parser
+             IHaskell.Message.UUID
+             IHaskell.Message.Writer
+             IHaskell.Types
+             IHaskell.ZeroMQ
+
+
   extensions: DoAndIfThenElse
               NoImplicitPrelude
               OverloadedStrings
@@ -70,6 +80,11 @@ executable IHaskell
                        ghc ==7.6.*,
                        ghc-paths ==0.1.*,
                        random ==1.0.*,
+                       split,
+                       utf8-string,
                        strict ==0.3.*,
                        shelly ==1.3.*,
+                       system-argv0,
+                       directory,
+                       system-filepath,
                        text ==0.11.*

IHaskell/Completion.hs

+{-# LANGUAGE PatternGuards #-}
+{- | very approximate completion. Seems to generate what is required by
+ <http://ipython.org/ipython-doc/dev/development/messaging.html#complete>,
+ but for whatever reason nothing gets added when the liftIO below prints
+ stuff like:
+
+ > {"status":"ok","text":"import Data hea","matches":["head"]}
+
+ When the cursor is after the hea, and you press tab.
+-}
+module IHaskell.Completion (makeCompletions) where
+
+import Prelude
+import Data.List
+import IHaskell.Types
+import GhcMonad(liftIO)
+import qualified GHC
+import Outputable (showPpr)
+import Data.Char
+import Data.ByteString.UTF8
+import Data.List.Split
+import Data.List.Split.Internals
+import Data.Aeson
+import IHaskell.Message.Writer
+import qualified Data.ByteString.Lazy as L
+
+makeCompletions replyHeader (CompleteRequest hdr code line pos) = do
+
+    ns <- GHC.getRdrNamesInScope
+    fs <- GHC.getProgramDynFlags
+
+    let candidate = getWordAt (toString line) pos
+        opts | Just cand <- candidate = filter (cand `isPrefixOf`) $ map (showPpr fs) ns
+            | otherwise = []
+
+    let reply = CompleteReply replyHeader (map fromString opts) line True
+    liftIO (L.putStrLn $ encode $ toJSON reply)
+    return reply
+
+
+-- there are better ways to accomplish this
+getWordAt :: String -> Int -> Maybe String
+getWordAt xs n =
+        fmap (map fst) $
+        find (any (== n) .  map snd) $
+        split (defaultSplitter{
+                        delimiter = Delimiter [ (==) ' ' . fst ],
+                        condensePolicy = Condense })
+                (zip xs [1 .. ])
+

IHaskell/Eval/Evaluate.hs

@@ -111,15 +111,18 @@ parseCommands code = concatMap makeCommands pieces
     pieces = trace (show $ makePieces $ lines code ) $ makePieces $ lines code
     makeCommands lines
       | isDirective lines = [createDirective lines]
-      | isDeclaration lines =
-          case parseDecl $ trace ("Decl<" ++ lines ++ "<>>>") lines of
-            ParseOk declaration -> [Declaration $ prettyPrint declaration]
-            ParseFailed srcLoc errMsg -> [ParseError (srcLine srcLoc) (srcColumn srcLoc) errMsg]
-      | otherwise = 
-          case parseStmts $ trace ("STMT<" ++ lines ++ "<s>>") lines of
-            Left (srcLine, srcColumn, errMsg) -> [ParseError srcLine srcColumn errMsg]
-            Right stmts -> map (Statement . prettyPrint) $ init stmts
-    isDeclaration line = any (`isInfixOf` line) ["type", "newtype", "data"]
+      | otherwise = case (parseDecl lines, parseStmts lines) of
+            (ParseOk declaration, _) -> trace ("Decl<" ++ lines ++ "<>>>")
+                        [Declaration $ prettyPrint declaration]
+            (ParseFailed {}, Right stmts) -> trace ("STMT<" ++ lines ++ "<s>>")
+                        $ map (Statement . prettyPrint) $ init stmts
+
+            -- show the parse error for the most likely type
+            (ParseFailed srcLoc errMsg, _)
+                | isDeclaration lines  -> [ParseError (srcLine srcLoc) (srcColumn srcLoc) errMsg]
+            (_, Left (lineNumber, colNumber,errMsg)) -> [ParseError lineNumber colNumber errMsg]
+
+    isDeclaration line = any (`isInfixOf` line) ["type", "newtype", "data", "instance", "class"]
     isDirective line = startswith [directiveChar] stripped || startswith "import" stripped
       where stripped = strip line
     createDirective line =

IHaskell/IPython.hs

@@ -6,6 +6,9 @@ module IHaskell.IPython (
 import ClassyPrelude
 import Shelly hiding (find, trace)
 import Text.Printf
+import System.Argv0
+import System.Directory
+import qualified Filesystem.Path.CurrentOS as FS
 
 -- | Run IPython with any arguments.
 ipython :: [Text] -> Sh ()
@@ -54,13 +57,8 @@ setupIPythonProfile profile = shelly $ do
 
   let profileDir = ipythonDir ++ "/profile_" ++ pack profile ++ "/"
 
-  -- Find out where IHaskell lives.
-  ihaskellPath <- which "IHaskell"
-  case ihaskellPath of
-    Nothing -> putStrLn "IHaskell not on $PATH."
-    Just path -> 
-      -- Finally, write configs!
-      writeConfigFilesTo profileDir (trace (unpack $ toTextIgnore path) $ unpack $ toTextIgnore path)
+  path <- liftIO $ fmap FS.encodeString getArgv0Absolute
+  writeConfigFilesTo profileDir (trace path $ path)
 
 -- | Write IPython configuration files to the profile directory.
 writeConfigFilesTo :: Text      -- ^ Profile directory to write to. Must have a trailing slash.
@@ -78,3 +76,14 @@ writeConfigFilesTo profileDir ihaskellPath = writeFile (fromText configFile) con
         , "c.Session.key = b''"
         , "c.Session.keyfile = b''"
         ]
+
+
+getArgv0Absolute :: IO FS.FilePath
+getArgv0Absolute = do
+    f <- getArgv0
+    f' <- if FS.absolute f then return f
+        else do
+            cd <- getCurrentDirectory
+            return $ FS.decodeString cd FS.</> f
+    print ("FS:" ++ FS.encodeString f')
+    return f'

IHaskell/Message/Parser.hs

@@ -72,6 +72,7 @@ parser :: MessageType            -- ^ The message type being parsed.
                                  -- header.
 parser KernelInfoRequestMessage  = kernelInfoRequestParser
 parser ExecuteRequestMessage     = executeRequestParser
+parser CompleteRequestMessage    = completeRequestParser
 parser other = error $ "Unknown message type " ++ show other
 
 -- | Parse a kernel info request.
@@ -105,3 +106,15 @@ executeRequestParser content =
       getUserVariables = [],
       getUserExpressions = []
     }
+
+completeRequestParser :: LByteString -> Message
+completeRequestParser content = parsed
+  where
+  Success parsed = flip parse decoded $ \ obj -> do
+        code     <- obj .: "block" <|> return ""
+        codeLine <- obj .: "line"
+        pos      <- obj .: "cursor_pos"
+        return $ CompleteRequest noHeader code codeLine pos
+
+  Just decoded = decode content
+

IHaskell/Message/Writer.hs

+{-# LANGUAGE CPP #-}
 -- | This module contains the @ToJSON@ instance for @Message@.
 module IHaskell.Message.Writer (
   ToJSON(..)
 )  where
 
+import Prelude (read)
 import ClassyPrelude
 import Data.Aeson
 
 import IHaskell.Types
 
+-- ghc (api) version number like ints [7,6,2]. Could be done at compile
+-- time, but for now there's no template haskell in IHaskell
+ghcVersionInts = ints $
+    map read $ words $
+    map (\x -> case x of '.' -> ' '; _ -> x)
+    (VERSION_ghc :: String)
+
 -- Convert message bodies into JSON.
 instance ToJSON Message where
   toJSON KernelInfoReply{} = object [
                              "protocol_version" .= ints [4, 0], -- current protocol version, major and minor
-                             "language_version" .= ints [7, 6, 2],
+                             "language_version" .= ghcVersionInts,
                              "language" .= string "haskell"
                            ]
 
@@ -45,6 +54,11 @@ instance ToJSON Message where
                              "execution_count" .= execCount,
                              "code" .= code
                            ]
+  toJSON (CompleteReply _ m t s) = object [
+                             "matches" .= m,
+                             "text" .= t,
+                             "status" .= if s then "ok" :: String else "error"
+                           ]
 
   toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body
 

IHaskell/Types.hs

@@ -96,6 +96,8 @@ data MessageType = KernelInfoReplyMessage
                  | DisplayDataMessage
                  | OutputMessage
                  | InputMessage
+                 | CompleteRequestMessage
+                 | CompleteReplyMessage
 
 instance Show MessageType where
   show KernelInfoReplyMessage     = "kernel_info_reply"
@@ -107,18 +109,23 @@ instance Show MessageType where
   show DisplayDataMessage         = "display_data"
   show OutputMessage              = "pyout"
   show InputMessage               = "pyin"
+  show CompleteRequestMessage     = "complete_request"
+  show CompleteReplyMessage       = "complete_reply"
 
 instance FromJSON MessageType where
-  parseJSON (String s) = return $ case s of
-    "kernel_info_reply"   -> KernelInfoReplyMessage
-    "kernel_info_request" -> KernelInfoRequestMessage
-    "execute_reply"       -> ExecuteReplyMessage
-    "execute_request"     -> ExecuteRequestMessage
-    "status"              -> StatusMessage
-    "stream"              -> StreamMessage
-    "display_data"        -> DisplayDataMessage
-    "pyout"               -> OutputMessage
-    "pyin"                -> InputMessage
+  parseJSON (String s) = case s of
+    "kernel_info_reply"   -> return KernelInfoReplyMessage
+    "kernel_info_request" -> return KernelInfoRequestMessage
+    "execute_reply"       -> return ExecuteReplyMessage
+    "execute_request"     -> return ExecuteRequestMessage
+    "status"              -> return StatusMessage
+    "stream"              -> return StreamMessage
+    "display_data"        -> return DisplayDataMessage
+    "pyout"               -> return OutputMessage
+    "pyin"                -> return InputMessage
+    "complete_request"    -> return CompleteRequestMessage
+    "complete_reply"      -> return CompleteReplyMessage
+    _                     -> fail ("Unknown message type: " ++ show s)
   parseJSON _ = fail "Must be a string."
 
 
@@ -176,6 +183,42 @@ data Message
       inCode :: String,                     -- ^ Submitted input code.
       executionCount :: Int                 -- ^ Which input this is.
     }
+
+  | CompleteRequest {
+      header :: MessageHeader,
+      getCode :: ByteString, {- ^
+            The entire block of text where the line is.  This may be useful in the
+            case of multiline completions where more context may be needed.  Note: if
+            in practice this field proves unnecessary, remove it to lighten the
+            messages. json field @block@  -}
+      getCodeLine :: ByteString, -- ^ just the line with the cursor. json field @line@
+      getCursorPos :: Int -- ^ position of the cursor (index into the line?). json field @cursor_pos@
+
+    }
+
+  | CompleteReply {
+     header :: MessageHeader,
+     completionMatches :: [ByteString],
+     completionText :: ByteString,
+     completionStatus :: Bool
+  }
+      {- ^
+# The list of all matches to the completion request, such as
+# ['a.isalnum', 'a.isalpha'] for the above example.
+'matches' : list,
+
+# the substring of the matched text
+# this is typically the common prefix of the matches,
+# and the text that is already in the block that would be replaced by the full completion.
+# This would be 'a.is' in the above example.
+'text' : str,
+
+# status should be 'ok' unless an exception was raised during the request,
+# in which case it should be 'error', along with the usual error message content
+# in other messages.
+'status' : 'ok'
+} -}
+
     deriving Show
 
 -- | Possible statuses in the execution reply messages.
@@ -206,4 +249,5 @@ data StreamType = Stdin | Stdout deriving Show
 replyType :: MessageType -> MessageType
 replyType KernelInfoRequestMessage = KernelInfoReplyMessage
 replyType ExecuteRequestMessage = ExecuteReplyMessage
+replyType CompleteRequestMessage = CompleteReplyMessage
 replyType messageType = error $ "No reply for message type " ++ show messageType

Main.hs

@@ -12,6 +12,7 @@ import qualified IHaskell.Message.UUID as UUID
 import IHaskell.Eval.Evaluate
 import qualified Data.ByteString.Char8 as Chars
 import IHaskell.IPython
+import IHaskell.Completion (makeCompletions)
 
 data KernelState = KernelState
   { getExecutionCounter :: Int
@@ -145,3 +146,10 @@ replyTo interface ExecuteRequest{ getCode = code } replyHeader state = do
     executionCounter = execCount,
     status = Ok
   })
+
+
+replyTo _ creq@CompleteRequest{} replyHeader state = trace (show creq) $ do
+    cr <- makeCompletions replyHeader creq
+    return (state,  cr)
+
+