diff --git a/IHaskell.cabal b/IHaskell.cabal index 5c7e7cad..129b135d 100644 --- a/IHaskell.cabal +++ b/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, diff --git a/profile/static/custom/custom.css b/profile/static/custom/custom.css index fb9814e2..7ef07b17 100644 --- a/profile/static/custom/custom.css +++ b/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; diff --git a/profile/static/custom/custom.js b/profile/static/custom/custom.js index 65bb10b9..f47ef711 100644 --- a/profile/static/custom/custom.js +++ b/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
+ IPython.Pager.prototype.append_text = function (text) { + this.pager_element.find(".container").append($('').html(text)); + }; }); $([IPython.events]).on('shell_reply.Kernel', function() { diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs index 3b40c9d0..f524ef6a 100644 --- a/src/IHaskell/Eval/Completion.hs +++ b/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. diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index c121beff..602e3d5c 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/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- enable a GHC extension." - ," :extension No - disable a GHC extension." + ," :extension - Enable a GHC extension." + ," :extension No - Disable a GHC extension." ," :type - Print expression type." ," :info - Print all info for a name." + ," :hoogle - Search for a query on Hoogle." + ," :doc - Get documentation for an identifier via Hogole." ," :set - Set an option." - ," :set no- - Unset an option." + ," :set no- - 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] diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs new file mode 100644 index 00000000..d1f8cdda --- /dev/null +++ b/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 "No result: %s" resp + +renderHtml (DocResult resp) = + printf "%s
...more...%s" + (renderSelf $ self resp) + (location resp) + (renderDocs $ docs resp) + +renderHtml (SearchResult resp) = + printf "%s
...more...%s" + (renderSelf $ self resp) + (location resp) + (renderDocs $ docs resp) + +renderSelf :: String -> String +renderSelf string + | startswith "package" string + = printf "%s %s" pkg $ replace "package" "" string + | otherwise + = printf "%s" $ strip string + where + pkg = "package" :: 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 "%s" $ unlines lines + else printf "%s" $ unlines lines + in + unlines $ map makeBlock groups + + diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs index 5f6fab4d..f4196501 100644 --- a/src/IHaskell/Eval/Parser.hs +++ b/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") diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs index 266fde84..320e794b 100644 --- a/src/IHaskell/Types.hs +++ b/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) diff --git a/src/Main.hs b/src/Main.hs index 83417dfa..4951e39e 100644 --- a/src/Main.hs +++ b/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