initial hoogling commit

IHaskell.cabal

@@ -48,6 +48,7 @@ data-files:
 library
   hs-source-dirs:      src
   build-depends:       base ==4.6.*,
+                       HTTP,
                        base64-bytestring >= 1.0,
                        process >= 1.1,
                        hlint,
@@ -88,6 +89,7 @@ library
                    IHaskell.Eval.Lint
                    IHaskell.Eval.Parser
                    IHaskell.Eval.Stdin
+                   IHaskell.Eval.Hoogle
                    IHaskell.IPython
                    IHaskell.Message.Parser
                    IHaskell.Message.UUID
@@ -111,6 +113,7 @@ executable IHaskell
              IHaskell.Eval.Evaluate
              IHaskell.Eval.Parser
              IHaskell.Eval.Stdin
+             IHaskell.Eval.Hoogle
              IHaskell.IPython
              IHaskell.Message.Parser
              IHaskell.Message.UUID
@@ -123,6 +126,7 @@ executable IHaskell
   
   -- Other library packages from which modules are imported.
   build-depends:       base ==4.6.*,
+                       HTTP,
                        base64-bytestring >= 1.0,
                        process >= 1.1,
                        hlint,
@@ -162,6 +166,7 @@ Test-Suite hspec
   Ghc-Options: -threaded
   Main-Is: Hspec.hs
   build-depends:       base ==4.6.*,
+                       HTTP,
                        base64-bytestring >= 1.0,
                        process >= 1.1,
                        hlint,

profile/static/custom/custom.css

@@ -2,6 +2,30 @@
 Custom IHaskell CSS.
 */
 
+/* Styles used for the Hoogle display in the pager */
+.hoogle-doc {
+    display: block;
+}
+.hoogle-code {
+    display: block;
+    font-family: monospace;
+    white-space: pre;
+}
+.hoogle-text {
+    display: block;
+}
+.hoogle-name {
+    color: green;
+    font-weight: bold;
+}
+.hoogle-package {
+    font-weight: bold;
+}
+.hoogle-package-name {
+    font-weight: bold;
+    font-style: italic;
+}
+
 /* Styles used for basic displays */
 .get-type {
     color: green;

profile/static/custom/custom.js

@@ -49,6 +49,11 @@ $([IPython.events]).on('app_initialized.NotebookApp', function(){
     });
 
     IPython.CodeCell.options_default['cm_config']['mode'] = 'haskell';
+
+    // Prevent the pager from surrounding everything with a <pre>
+    IPython.Pager.prototype.append_text = function (text) {
+        this.pager_element.find(".container").append($('<div/>').html(text));
+    };
 });
 
 $([IPython.events]).on('shell_reply.Kernel', function() {

src/IHaskell/Eval/Completion.hs

@@ -207,7 +207,8 @@ completePathWithExtensions extensions line =
   completePathFilter (extensionIsOneOf extensions) acceptAll line ""
   where
     acceptAll = const True
-    extensionIsOneOf exts str = any (\ext -> endswith ext str) exts
+    extensionIsOneOf exts str = any correctEnding exts
+      where correctEnding ext = endswith ext str
 
 completePathFilter :: (String -> Bool)      -- ^ File filter: test whether to include this file.
                    -> (String -> Bool)      -- ^ Directory filter: test whether to include this directory.

src/IHaskell/Eval/Evaluate.hs

@@ -64,6 +64,7 @@ import IHaskell.Types
 import IHaskell.Eval.Parser
 import IHaskell.Eval.Lint
 import IHaskell.Display
+import qualified IHaskell.Eval.Hoogle as Hoogle
 
 import Paths_ihaskell (version)
 import Data.Version (versionBranch)
@@ -549,19 +550,23 @@ evalCommand _ (Directive GetHelp _) state = do
   }
   where out = plain $ intercalate "\n"
           ["The following commands are available:"
-          ,"    :extension <Extension>    -  enable a GHC extension."
-          ,"    :extension No<Extension>  -  disable a GHC extension."
+          ,"    :extension <Extension>    -  Enable a GHC extension."
+          ,"    :extension No<Extension>  -  Disable a GHC extension."
           ,"    :type <expression>        -  Print expression type."
           ,"    :info <name>              -  Print all info for a name."
+          ,"    :hoogle <query>           -  Search for a query on Hoogle."
+          ,"    :doc <ident>              -  Get documentation for an identifier via Hogole."
           ,"    :set <opt>                -  Set an option."
-          ,"    :set no-<opt>              -  Unset an option."
+          ,"    :set no-<opt>             -  Unset an option."
           ,"    :?, :help                 -  Show this help text."
           ,""
           ,"Any prefix of the commands will also suffice, e.g. use :ty for :type."
           ,""
           ,"Options:"
-          ,"  lint       - enable or disable linting."
-          ,"  svg        - use svg output (cannot be resized)."
+          ,"  lint          - enable or disable linting."
+          ,"  svg           - use svg output (cannot be resized)."
+          ,"  show-types    - show types of all bound names"
+          ,"  show-errors   - display Show instance missing errors normally."
           ]
 
 -- This is taken largely from GHCi's info section in InteractiveUI.
@@ -603,6 +608,24 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
     evalPager = unlines strings
   }
 
+evalCommand _ (Directive SearchHoogle query) state = safely state $ do
+  results <- liftIO $ Hoogle.search query
+  let output = unlines $ map (Hoogle.render Hoogle.HTML) results
+  return EvalOut {
+    evalStatus = Success,
+    evalResult = [],
+    evalState = state,
+    evalPager = output
+  }
+
+evalCommand _ (Directive GetDoc query) state = safely state $
+  return EvalOut {
+    evalStatus = Success,
+    evalResult = [],
+    evalState = state,
+    evalPager = "Hoogle documentation queries not implemented yet."
+  }
+
 evalCommand output (Statement stmt) state = wrapExecution state $ do
   write $ "Statement:\n" ++ stmt
   let outputter str = output $ IntermediateResult [plain str]

src/IHaskell/Eval/Hoogle.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
+module IHaskell.Eval.Hoogle ( 
+  search,
+  document,
+  render,
+  OutputFormat(..)
+  ) where
+
+import ClassyPrelude
+import Text.Printf
+import Network.HTTP
+import Data.Aeson
+import Data.String.Utils
+import qualified Data.ByteString.Lazy.Char8 as Char
+
+
+import IHaskell.IPython
+
+-- | Types of formats to render output to.
+data OutputFormat
+     = Plain      -- ^ Render to plain text.
+     | HTML       -- ^ Render to HTML.
+
+data HoogleResponse = HoogleResponse {
+    location :: String,
+    self :: String,
+    docs :: String
+  }
+  deriving (Eq, Show)
+
+data HoogleResult
+     = SearchResult HoogleResponse
+     | DocResult HoogleResponse
+     | NoResult String
+
+instance FromJSON [HoogleResponse] where
+  parseJSON (Object obj) = do
+    results <- obj .: "results"
+    mapM parseJSON results
+
+  parseJSON _ = fail "Expected object with 'results' field."
+
+instance FromJSON HoogleResponse where
+  parseJSON (Object obj) =
+    HoogleResponse      <$>
+    obj .: "location" <*>
+    obj .: "self"     <*>
+    obj .: "docs"
+
+  parseJSON _ = fail "Expected object with fields: location, self, docs"
+
+-- | Query Hoogle for the given string.
+-- This searches Hoogle using the internet. It returns either an error
+-- message or the successful JSON result.
+query :: String -> IO (Either String String)
+query str = do
+  let request = getRequest $ queryUrl str
+  response <- simpleHTTP request
+  return $ case response of
+    Left err -> Left $ show err
+    Right resp -> Right $ rspBody resp
+  where
+    queryUrl :: String -> String
+    queryUrl = printf "http://www.haskell.org/hoogle/?hoogle=%s&mode=json" . urlEncode
+
+-- | Search for a query on Hoogle.
+-- Return all search results.
+search :: String -> IO [HoogleResult]
+search string = do
+  response <- query string
+  return $ case response of
+    Left err -> [NoResult err]
+    Right json ->
+      case eitherDecode $ Char.pack json of
+        Left err -> [NoResult err]
+        Right results -> map SearchResult results
+
+-- | Look up an identifier on Hoogle.
+-- Return documentation for that identifier. If there are many
+-- identifiers, include documentation for all of them.
+document :: String -> IO [HoogleResult]
+document string = do
+  matchingResults <- filter matches <$> search string
+  return $ map toDocResult matchingResults
+  where
+    matches (SearchResult resp) = startswith "string" $ self resp
+    toDocResult (SearchResult resp) = DocResult resp
+
+-- | Render a Hoogle search result into an output format.
+render :: OutputFormat -> HoogleResult -> String
+render Plain = renderPlain
+render HTML  = renderHtml
+
+-- | Render a Hoogle result to plain text.
+renderPlain :: HoogleResult -> String
+
+renderPlain (NoResult res) = 
+  "No response available: " ++ res
+
+renderPlain (SearchResult resp) = 
+  printf "%s\nURL: %s\n%s" 
+  (self resp)
+  (location resp)
+  (docs resp)
+
+renderPlain (DocResult resp) = 
+  printf "%s\nURL: %s\n%s" 
+  (self resp)
+  (location resp)
+  (docs resp)
+
+-- | Render a Hoogle result to HTML.
+renderHtml :: HoogleResult -> String
+renderHtml (NoResult resp) = 
+  printf "<span class='err-msg'>No result: %s</span>" resp
+
+renderHtml (DocResult resp) = 
+  printf "%s<br/><a href='%s'>...more...</a><br/><div class='hoogle-doc'>%s</div>"
+  (renderSelf $ self resp)
+  (location resp)
+  (renderDocs $ docs resp)
+
+renderHtml (SearchResult resp) = 
+  printf "%s<br/><a href='%s'>...more...</a><br/><div class='hoogle-doc'>%s</div>"
+  (renderSelf $ self resp)
+  (location resp)
+  (renderDocs $ docs resp)
+
+renderSelf :: String -> String
+renderSelf string
+  | startswith "package" string
+    = printf "%s <span class='hoogle-package-name'>%s</span>" pkg $ replace "package" "" string
+  | otherwise
+    = printf "<span class='hoogle-name'>%s</span>" $ strip string
+  where 
+    pkg = "<span class='hoogle-package'>package</span>" :: String
+
+renderDocs :: String -> String
+renderDocs doc = 
+  let groups = groupBy bothAreCode $ lines doc
+      bothAreCode s1 s2 = 
+        startswith ">" (strip s1) &&
+        startswith ">" (strip s2)
+      isCode (s:_) = startswith ">" $ strip s
+      makeBlock lines =
+        if isCode lines
+        then printf "<div class='hoogle-code'>%s<div>" $ unlines lines
+        else printf "<div class='hoogle-text'>%s<div>" $ unlines lines
+      in
+    unlines $ map makeBlock groups
+
+

src/IHaskell/Eval/Parser.hs

@@ -64,6 +64,8 @@ data DirectiveType
   | SetOpt          -- ^ Set various options.
   | ShellCmd        -- ^ Execute a shell command.
   | GetHelp         -- ^ General help via ':?' or ':help'.
+  | SearchHoogle    -- ^ Search for something via Hoogle.
+  | GetDoc          -- ^ Get documentation for an identifier via Hoogle.
   deriving (Show, Eq)
 
 -- | Unlocate something - drop the position.
@@ -238,6 +240,8 @@ parseDirective (':':directive) line = case find rightDirective directives of
     directives =
       [(GetType,      "type")
       ,(GetInfo,      "info")
+      ,(SearchHoogle, "hoogle")
+      ,(GetDoc,       "documentation")
       ,(SetExtension, "extension")
       ,(LoadFile,     "load")
       ,(SetOpt,       "set")

src/IHaskell/Types.hs

@@ -20,6 +20,7 @@ module IHaskell.Types (
   KernelState(..),
   LintStatus(..),
   Width, Height,
+  FrontendType(..),
   defaultKernelState,
   extractPlain
   ) where
@@ -76,6 +77,7 @@ instance ToJSON Profile where
 data KernelState = KernelState
   { getExecutionCounter :: Int,
     getLintStatus :: LintStatus,  -- Whether to use hlint, and what arguments to pass it. 
+    getFrontend :: FrontendType,
     useSvg :: Bool,
     useShowErrors :: Bool,
     useShowTypes :: Bool
@@ -86,16 +88,23 @@ defaultKernelState :: KernelState
 defaultKernelState = KernelState
   { getExecutionCounter = 1,
     getLintStatus = LintOn,
+    getFrontend = IPythonConsole,
     useSvg = True,
     useShowErrors = False,
     useShowTypes = False
   }
 
+data FrontendType
+     = IPythonConsole
+     | IPythonNotebook
+     deriving (Show, Eq, Read)
+
 -- | Initialization information for the kernel.
 data InitInfo = InitInfo {
   extensions :: [String],   -- ^ Extensions to enable at start.
   initCells :: [String],    -- ^ Code blocks to run before start.
-  initDir :: String         -- ^ Which directory this kernel should pretend to operate in.
+  initDir :: String,        -- ^ Which directory this kernel should pretend to operate in.
+  frontend :: FrontendType  -- ^ What frontend this serves.
   }
   deriving (Show, Read)
 

src/Main.hs

@@ -145,7 +145,7 @@ ihaskell (Args Console flags) = showingHelp Console flags $ do
   setupIPython
 
   flags <- addDefaultConfFile flags
-  info <- initInfo flags
+  info <- initInfo IPythonConsole flags
   runConsole info
 
 ihaskell (Args (View (Just fmt) (Just name)) []) =
@@ -160,7 +160,7 @@ ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do
 
   flags <- addDefaultConfFile flags
 
-  undirInfo <- initInfo flags
+  undirInfo <- initInfo IPythonNotebook flags
   curdir <- getCurrentDirectory
   let info = undirInfo { initDir = curdir }
 
@@ -198,10 +198,10 @@ showingHelp mode flags act =
     chooseMode UpdateIPython = update
  
 -- | Parse initialization information from the flags.
-initInfo :: [Argument] -> IO InitInfo
-initInfo [] = return InitInfo { extensions = [], initCells = [], initDir = "."}
-initInfo (flag:flags) = do
-  info <- initInfo flags
+initInfo :: FrontendType -> [Argument] -> IO InitInfo
+initInfo front [] = return InitInfo { extensions = [], initCells = [], initDir = ".", frontend = front }
+initInfo front (flag:flags) = do
+  info <- initInfo front flags
   case flag of
     Extension ext -> return info { extensions = ext:extensions info }
     ConfFile filename -> do
@@ -227,6 +227,8 @@ runKernel profileSrc initInfo = do
 
   -- Create initial state in the directory the kernel *should* be in.
   state <- initialKernelState
+  modifyMVar_ state $ \kernelState -> return $
+    kernelState { getFrontend = frontend initInfo }
 
   -- Receive and reply to all messages on the shell socket.
   interpret True $ do