Merge pull request #34 from edechter/tooltip

Added basic tooltip functionality. 

IHaskell/Config.hs

 {-# LANGUAGE QuasiQuotes #-}
 -- | Description : IPython configuration files are compiled-into IHaskell
-module IHaskell.Config (ipython, notebook, console, qtconsole, customjs) where
+module IHaskell.Config (ipython, notebook, console, qtconsole, customjs, tooltipjs) where
 
 import Data.String.Here
 import ClassyPrelude
@@ -19,3 +19,6 @@ qtconsole = [template|config/ipython_qtconsole_config.py|]
 
 customjs :: String
 customjs = [template|config/custom.js|]
+
+tooltipjs :: String
+tooltipjs = [template|deps/tooltip.js|]

IHaskell/Eval/Evaluate.hs

@@ -24,6 +24,7 @@ import InteractiveEval
 import HscTypes
 import GhcMonad (liftIO)
 import GHC hiding (Stmt)
+import GHC (exprType)
 import GHC.Paths
 import Exception hiding (evaluate)
 
@@ -61,8 +62,11 @@ write x = when debug $ liftIO $ hPutStrLn stderr x
 type LineNumber = Int
 type ColumnNumber = Int
 type Interpreter = Ghc
+data DirectiveType 
+  = GetType String
+  deriving Show
 data Command
-  = Directive String
+  = Directive DirectiveType
   | Import String
   | Declaration String
   | Statement String
@@ -114,6 +118,7 @@ joinDisplays displays =
       0 -> other
       _ -> joinedPlains : other
 
+
 parseCommands :: String     -- ^ Code containing commands.
               -> [Command]  -- ^ Commands contained in code string.
 parseCommands code = concatMap makeCommands pieces
@@ -129,6 +134,7 @@ parseCommands code = concatMap makeCommands pieces
     makePieces [] = []
     makePieces (first:rest)
       | isDirective first = first : makePieces rest
+      | isImport first = first : makePieces rest
       | otherwise = unlines (first:take endOfBlock rest) : makePieces (drop endOfBlock rest)
           where
             endOfBlock = fromMaybe (length rest) $ findIndex (\x -> indentLevel x <= indentLevel first) rest
@@ -137,6 +143,7 @@ parseCommands code = concatMap makeCommands pieces
     pieces = trace (show $ makePieces $ lines code ) $ makePieces $ lines code
     makeCommands lines
       | isDirective lines = [createDirective lines]
+      | isImport lines    = [Import $ strip lines]
       | otherwise = case (parseDecl lines, parseStmts lines) of
             (ParseOk declaration, _) -> [Declaration $ prettyPrint declaration]
             (ParseFailed {}, Right stmts) -> map (Statement . prettyPrint) $ init stmts
@@ -147,12 +154,12 @@ parseCommands code = concatMap makeCommands pieces
             (_, 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 =
-      case strip line of
-        ':':_ -> Directive $ strip line
-        _ -> Import $ strip line
+    isDirective line = startswith [directiveChar] (strip line) 
+    isImport line = startswith "import" (strip line)
+
+    createDirective line = case strip line of
+      ':':'t':' ':expr -> Directive (GetType expr)
+      other            -> ParseError 0 0 $ "Unknown command: " ++ other ++ "."
 
 evalCommand :: Command -> Interpreter [DisplayData]
 evalCommand (Import importStr) = do
@@ -162,9 +169,18 @@ evalCommand (Import importStr) = do
   setContext $ IIDecl importDecl : context
   return []
 
-evalCommand (Directive directive) = do
-  write $ "Directive: " ++ directive
-  return [Display MimeHtml $ printf "<span style='font-weight: bold; color: green;'>%s</span>" directive]
+evalCommand (Directive (GetType expr)) 
+  = ghandle handler 
+    $ do result <- exprType expr
+         dflags <- getSessionDynFlags
+         return [Display MimeHtml 
+          $ printf "<span style='font-weight: bold; color: green;'>%s</span>" 
+          $ showSDocUnqual dflags $ ppr result]
+  where 
+    handler :: SomeException -> Interpreter [DisplayData]
+    handler exception = do
+      write $ concat ["BreakCom: ", show exception]
+      return [Display MimeHtml $ makeError $ show exception]
 
 evalCommand (Statement stmt) = do
   write $ "Statement: " ++ stmt

IHaskell/IPython.hs

@@ -97,6 +97,12 @@ writeConfigFilesTo profileDir ihaskellPath = do
     -- The custom directory many not exist, in which case we'll create it.
     mkdir_p (conf "static/custom/")
     writeFile (conf "static/custom/custom.js")      Config.customjs
+
+    -- The notebook/js directory many not exist, in which case we'll create it.
+    mkdir_p (conf "static/notebook/")
+    mkdir_p (conf "static/notebook/js")
+    writeFile (conf "static/notebook/js/tooltip.js") Config.tooltipjs
+
   where
     conf filename = fromText $ profileDir ++ filename
 

IHaskell/Message/Parser.hs

@@ -75,6 +75,7 @@ parser :: MessageType            -- ^ The message type being parsed.
 parser KernelInfoRequestMessage  = kernelInfoRequestParser
 parser ExecuteRequestMessage     = executeRequestParser
 parser CompleteRequestMessage    = completeRequestParser
+parser ObjectInfoRequestMessage  = objectInfoRequestParser
 parser other = error $ "Unknown message type " ++ show other
 
 -- | Parse a kernel info request.
@@ -120,3 +121,14 @@ completeRequestParser content = parsed
 
   Just decoded = decode content
 
+objectInfoRequestParser :: LByteString -> Message
+objectInfoRequestParser content = parsed
+  where
+    Success parsed = flip parse decoded $ \obj -> do
+      oname <- obj .: "oname"
+      dlevel <- obj .: "detail_level"
+      return $ ObjectInfoRequest noHeader oname dlevel
+
+    Just decoded = decode content
+
+

IHaskell/Message/Writer.hs

@@ -62,6 +62,14 @@ instance ToJSON Message where
                              "text" .= t,
                              "status" .= if s then "ok" :: String else "error"
                            ]
+  toJSON o@ObjectInfoReply{} = object [
+                            "oname" .= objectName o,
+                            "found" .= objectFound o,
+                            "ismagic" .= False,
+                            "isalias" .= False,
+                            "type_name" .= objectTypeString o,
+                            "docstring" .= objectDocString o
+                           ]
 
   toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body
 

IHaskell/Types.hs

@@ -99,6 +99,8 @@ data MessageType = KernelInfoReplyMessage
                  | InputMessage
                  | CompleteRequestMessage
                  | CompleteReplyMessage
+                 | ObjectInfoRequestMessage
+                 | ObjectInfoReplyMessage
 
 instance Show MessageType where
   show KernelInfoReplyMessage     = "kernel_info_reply"
@@ -112,6 +114,8 @@ instance Show MessageType where
   show InputMessage               = "pyin"
   show CompleteRequestMessage     = "complete_request"
   show CompleteReplyMessage       = "complete_reply"
+  show ObjectInfoRequestMessage   = "object_info_request"
+  show ObjectInfoReplyMessage     = "object_info_reply"
 
 instance FromJSON MessageType where
   parseJSON (String s) = case s of
@@ -126,6 +130,8 @@ instance FromJSON MessageType where
     "pyin"                -> return InputMessage
     "complete_request"    -> return CompleteRequestMessage
     "complete_reply"      -> return CompleteReplyMessage
+    "object_info_request" -> return ObjectInfoRequestMessage
+    "object_info_reply"   -> return ObjectInfoReplyMessage
     _                     -> fail ("Unknown message type: " ++ show s)
   parseJSON _ = fail "Must be a string."
 
@@ -220,6 +226,19 @@ data Message
 # in other messages.
 'status' : 'ok'
 } -}
+  | ObjectInfoRequest {
+      header :: MessageHeader, 
+      objectName :: ByteString, -- ^ name of object to be searched for
+      detailLevel :: Int       -- ^ level of detail desired. default (0) 
+                                --  is equivalent to typing foo?, (1) is foo?? (don't know yet what this means for haskell)
+    }
+  | ObjectInfoReply {
+      header :: MessageHeader, 
+      objectName :: ByteString, 
+      objectFound :: Bool, -- ^ was the object found? 
+      objectTypeString :: ByteString, -- ^ type info string
+      objectDocString  :: ByteString
+    }
 
     deriving Show
 
@@ -252,4 +271,5 @@ replyType :: MessageType -> MessageType
 replyType KernelInfoRequestMessage = KernelInfoReplyMessage
 replyType ExecuteRequestMessage = ExecuteReplyMessage
 replyType CompleteRequestMessage = CompleteReplyMessage
+replyType ObjectInfoRequestMessage = ObjectInfoReplyMessage
 replyType messageType = error $ "No reply for message type " ++ show messageType

Main.hs

 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- | Description : Argument parsing and basic messaging loop, using Haskell
 --                 Chans to communicate with the ZeroMQ sockets. 
 module Main where
@@ -18,6 +19,10 @@ import qualified Data.ByteString.Char8 as Chars
 import IHaskell.IPython
 import IHaskell.Completion (makeCompletions)
 
+import GHC
+import Exception (ghandle, gcatch)
+import Outputable (showSDoc, ppr)
+
 data KernelState = KernelState
   { getExecutionCounter :: Int
   }
@@ -162,4 +167,23 @@ replyTo _ creq@CompleteRequest{} replyHeader state = trace (show creq) $ do
     cr <- makeCompletions replyHeader creq
     return (state,  cr)
 
+-- | Reply to the object_info_request message. Given an object name, return
+-- | the associated type calculated by GHC.
+replyTo _ ObjectInfoRequest{objectName=oname} replyHeader state = do
+         dflags <- getSessionDynFlags
+         maybeDocs  <- flip gcatch (\(e::SomeException) -> return Nothing) $ do
+                          result <- exprType . Chars.unpack $ oname
+                          let docs = (showSDoc dflags) . ppr $ result
+                          return (Just docs)
+         let docs = maybe "" id maybeDocs
+         let reply = ObjectInfoReply {
+                        header = replyHeader,
+                        objectName = oname, 
+                        objectFound = if isNothing maybeDocs then False else True,
+                        objectTypeString = Chars.pack docs,
+                        objectDocString  = Chars.pack docs                    
+                      }
+         return (state, reply)
+
+