Merge branch 'master' of https://github.com/gibiansky/IHaskell

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,39 @@
 Custom IHaskell CSS.
 */
 
+/* Styles used for the Hoogle display in the pager */
+.hoogle-doc {
+    display: block;
+    padding-bottom: 1.3em;
+    padding-left: 0.4em;
+}
+.hoogle-code {
+    display: block;
+    font-family: monospace;
+    white-space: pre;
+}
+.hoogle-text {
+    display: block;
+}
+.hoogle-name {
+    color: green;
+    font-weight: bold;
+}
+.hoogle-head {
+    font-weight: bold;
+}
+.hoogle-sub {
+    display: block;
+    margin-left: 0.4em;
+}
+.hoogle-package {
+    font-weight: bold;
+    font-style: italic;
+}
+.hoogle-module {
+    font-weight: bold;
+}
+
 /* 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(IPython.utils.autoLinkUrls(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,14 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do
     evalPager = unlines strings
   }
 
+evalCommand _ (Directive SearchHoogle query) state = safely state $ do
+  results <- liftIO $ Hoogle.search query
+  return $ hoogleResults state results
+
+evalCommand _ (Directive GetDoc query) state = safely state $ do
+  results <- liftIO $ Hoogle.document query
+  return $ hoogleResults state results
+
 evalCommand output (Statement stmt) state = wrapExecution state $ do
   write $ "Statement:\n" ++ stmt
   let outputter str = output $ IntermediateResult [plain str]
@@ -790,6 +803,21 @@ evalCommand _ (ParseError loc err) state = do
     evalPager = ""
   }
 
+
+hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut
+hoogleResults state results = EvalOut {
+    evalStatus = Success,
+    evalResult = [],
+    evalState = state,
+    evalPager = output
+  }
+  where
+    fmt = 
+        case getFrontend state of
+          IPythonNotebook -> Hoogle.HTML
+          IPythonConsole -> Hoogle.Plain
+    output = unlines $ map (Hoogle.render fmt) results
+
 -- 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

src/IHaskell/Eval/Hoogle.hs

+{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
+module IHaskell.Eval.Hoogle ( 
+  search,
+  document,
+  render,
+  OutputFormat(..),
+  HoogleResult
+  ) where
+
+import ClassyPrelude hiding (span, div)
+import Text.Printf
+import Network.HTTP
+import Data.Aeson
+import Data.String.Utils
+import Data.List (elemIndex, (!!), last)
+import Control.Monad (guard)
+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
+     deriving Show
+
+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 ->
+          case map SearchResult results of
+            [] -> [NoResult "no matching identifiers found."]
+            res -> res
+
+-- | 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
+  let results = map toDocResult matchingResults
+  return $ case results of
+    [] -> [NoResult "no matching identifiers found."]
+    res -> res
+  where
+    matches (SearchResult resp) = 
+      case split " " $ self resp of
+        name:_ -> strip string == strip name
+        _ -> False
+    matches _ = False
+
+    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) = 
+  renderSelf (self resp) (location resp) 
+  ++
+  renderDocs (docs resp)
+
+renderHtml (SearchResult resp) =
+  renderSelf (self resp) (location resp) 
+  ++
+  renderDocs (docs resp)
+
+renderSelf :: String -> String -> String
+renderSelf string loc
+  | startswith "package" string
+    = pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
+
+  | startswith "module" string
+    = let package = extractPackageName loc in
+        mod ++ " " ++
+        span "hoogle-module" (link loc $ extractModule string) ++
+        packageSub package
+
+  | otherwise
+    = let [name, args] = split "::" string
+          package = extractPackageName loc
+          modname = extractModuleName loc in
+        span "hoogle-name" (unicodeReplace $ 
+          link loc (strip name) ++
+          " :: " ++
+          strip args)
+        ++ packageAndModuleSub package modname
+
+  where 
+    extractPackage = strip . replace "package" ""
+    extractModule = strip . replace "module" ""
+    pkg = span "hoogle-head" "package"
+    mod = span "hoogle-head" "module"
+
+    unicodeReplace :: String -> String
+    unicodeReplace =
+     replace "forall" "&#x2200;" . 
+     replace "=>"     "&#x21D2;" . 
+     replace "->"     "&#x2192;" . 
+     replace "::"     "&#x2237;"
+
+    packageSub Nothing = ""
+    packageSub (Just package) =
+      span "hoogle-sub" $ 
+        "(" ++ pkg ++ " " ++ span "hoogle-package" package ++ ")"
+
+    packageAndModuleSub Nothing _ = ""
+    packageAndModuleSub (Just package) Nothing = packageSub (Just package)
+    packageAndModuleSub (Just package) (Just modname) =
+        span "hoogle-sub" $ 
+          "(" ++ pkg ++ " " ++ span "hoogle-package" package ++ 
+           ", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")"
+
+renderDocs :: String -> String
+renderDocs doc = 
+  let groups = groupBy bothAreCode $ lines doc
+      nonull = filter (not . null . strip)
+      bothAreCode s1 s2 = 
+        startswith ">" (strip s1) &&
+        startswith ">" (strip s2)
+      isCode (s:_) = startswith ">" $ strip s
+      makeBlock lines =
+        if isCode lines
+        then div "hoogle-code" $ unlines $ nonull lines
+        else div "hoogle-text" $ unlines $ nonull lines
+      in
+    div "hoogle-doc" $ unlines $ map makeBlock groups
+
+extractPackageName :: String ->  Maybe String
+extractPackageName link = do
+  let pieces = split "/" link
+  archiveLoc <- elemIndex "archive" pieces
+  latestLoc <- elemIndex "latest" pieces
+  guard $ latestLoc - archiveLoc == 2
+  return $ pieces !! (latestLoc - 1)
+
+extractModuleName :: String ->  Maybe String
+extractModuleName link = do
+  let pieces = split "/" link
+  guard $ not $ null pieces
+  let html = last pieces
+      mod = replace "-" "." $ takeWhile (/= '.') html
+  return mod
+
+div :: String -> String -> String
+div = printf "<div class='%s'>%s</div>"
+
+span :: String -> String -> String
+span = printf "<span class='%s'>%s</span>"
+
+link :: String -> String -> String
+link = printf "<a target='_blank' href='%s'>%s</a>"

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/IPython.hs

@@ -205,10 +205,13 @@ installPipDependencies = withTmpDir $ \tmpDir ->
     mapM_ (installDependency tmpDir) 
       [
         ("pyzmq", "14.0.1")
-      , ("setuptools", "2.0.2") -- This cannot go first in the dependenc list, because its setup.py is broken.
-      , ("MarkupSafe", "0.18")  -- Neither can this
       , ("tornado","3.1.1")
       , ("jinja2","2.7.1")
+      -- The following cannot go first in the dependency list, because
+      -- their setup.py are broken and require the directory to exist
+      -- already.
+      , ("MarkupSafe", "0.18")
+      --, ("setuptools", "2.0.2")
       ]
   where
     installDependency :: FilePath -> (Text, Text) -> Sh ()

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