add hoogle module and hoogle test suite

ihaskell.cabal

@@ -40,14 +40,17 @@ library
                        megaparsec,
                        semigroups,
                        haskell-src-exts,
+                       http-client-tls,
+                       http-client,
                        hlint,
                        extra
   exposed-modules:
                        Jupyter.IHaskell.Complete
                        Jupyter.IHaskell.Evaluate
+                       Jupyter.IHaskell.Hoogle
                        Jupyter.IHaskell.Interpreter
-                       Jupyter.IHaskell.Parser
                        Jupyter.IHaskell.Lint
+                       Jupyter.IHaskell.Parser
   
   if flag(binPkgDb)
     build-depends:       bin-package-db
@@ -72,8 +75,9 @@ Test-Suite test-ihaskell
     main-is:          Test.hs
     other-modules:
                       Jupyter.IHaskell.Test.Complete
-                      Jupyter.IHaskell.Test.Parser
+                      Jupyter.IHaskell.Test.Hoogle
                       Jupyter.IHaskell.Test.Lint
+                      Jupyter.IHaskell.Test.Parser
     hs-source-dirs:   tests
     default-language: Haskell2010
     build-depends:

src/Jupyter/IHaskell/Hoogle.hs

@@ -0,0 +1,236 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Jupyter.IHaskell.Hoogle (
+    hoogleSearch,
+    hoogleSearchExact,
+    HoogleResult(..),
+    renderHoogleResultHTML,
+    renderHoogleResultPlain,
+    ) where
+
+-- Imports from 'base'
+import           Control.Exception (catch, SomeException)
+import           Control.Monad (guard)
+import           Data.Bifunctor (second)
+import           Data.Char (isAscii, isAlphaNum)
+import           Data.Function ((&))
+import           Data.List (groupBy, elemIndex)
+import           Data.Monoid ((<>))
+
+-- Imports from 'aeson'
+import           Data.Aeson (FromJSON(..), (.:), eitherDecode, Value(..))
+
+-- Imports from 'text'
+import           Data.Text (Text)
+import qualified Data.Text as T
+
+-- Imports from 'bytestring'
+import           Data.ByteString.Lazy (ByteString)
+
+-- Imports from 'http-client'
+import           Network.HTTP.Client (withManager, parseUrl, httpLbs, responseBody, parseRequest)
+
+-- Imports from 'http-client-tls'
+import           Network.HTTP.Client.TLS (tlsManagerSettings)
+
+data HoogleResult =
+       HoogleResult
+         { hoogleResultLocation :: Text
+         , hoogleResultSelf :: Text
+         , hoogleResultDocs :: Text
+         }
+  deriving (Eq, Ord, Show)
+
+instance FromJSON HoogleResult where
+  parseJSON (Object obj) =
+    HoogleResult <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs"
+  parseJSON _ = fail "Expected object with fields: location, self, docs"
+
+newtype HoogleResults = HoogleResults { unHoogleResults :: [HoogleResult] }
+  deriving (Eq, Ord, Show)
+
+instance FromJSON HoogleResults where
+  parseJSON (Object obj) = do
+    results <- obj .: "results"
+    HoogleResults <$> mapM parseJSON results
+  parseJSON _ = fail "Expected object with 'results' field."
+
+-- | Look up an identifier on Hoogle. Return documentation for that identifier. If there are many
+-- identifiers, include documentation for all of them.
+hoogleSearchExact :: Text -> IO (Either String [HoogleResult])
+hoogleSearchExact string = second filterHoogleMatches <$> hoogleSearch string
+  where
+    filterHoogleMatches :: [HoogleResult] -> [HoogleResult]
+    filterHoogleMatches = filter (isExactMatch string)
+
+    isExactMatch :: Text -> HoogleResult -> Bool
+    isExactMatch name HoogleResult { .. } = T.strip hoogleResultSelf == T.strip name
+
+-- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either
+-- an error message or the successful JSON result.
+hoogleSearch :: Text -> IO (Either String [HoogleResult])
+hoogleSearch str = do
+  let url = T.concat ["https://www.haskell.org/hoogle/?hoogle=", T.pack $ urlEncode $ T.unpack str, "&mode=json"]
+  flip catch handleException $ do
+    request <- parseRequest (T.unpack url)
+    parseResponse <$> withManager tlsManagerSettings (httpLbs request)
+
+  where
+    handleException :: SomeException -> IO (Either String a)
+    handleException exception = return . Left . show $ exception
+
+    parseResponse = second unHoogleResults . eitherDecode . responseBody
+
+-- | Encode a string for use within a URL query parameter.
+--
+-- Copied directly from the HTTP package.
+urlEncode :: String -> String
+urlEncode [] = []
+urlEncode (ch:t)
+  | (isAscii ch && isAlphaNum ch) || ch `elem` ("-_.~" :: String) = ch : urlEncode t
+  | not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch))
+  | otherwise = escape (fromEnum ch) (urlEncode t)
+  where
+    escape :: Int -> String -> String
+    escape b rs = '%' : showH (b `div` 16) (showH (b `mod` 16) rs)
+
+    showH :: Int -> String -> String
+    showH x xs
+      | x <= 9 = toEnum (o_0 + x) : xs
+      | otherwise = toEnum (o_A + (x - 10)) : xs
+      where
+        o_0 = fromEnum '0'
+        o_A = fromEnum 'A'
+
+    eightBs :: [Int] -> Int -> [Int]
+    eightBs acc x
+      | x <= 255 = x : acc
+      | otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256)
+
+-- | Render a Hoogle result to plain text.
+renderHoogleResultPlain :: HoogleResult -> Text
+renderHoogleResultPlain HoogleResult { .. } =
+  T.concat [hoogleResultSelf, "\nURL: ", hoogleResultLocation, "\n", hoogleResultDocs]
+
+-- | Render a Hoogle result to HTML.
+renderHoogleResultHTML :: HoogleResult -> Text
+renderHoogleResultHTML HoogleResult { .. } =
+  renderSelf hoogleResultSelf hoogleResultLocation <> renderDocs hoogleResultDocs
+
+renderSelf :: Text -> Text -> Text
+renderSelf string loc
+  | "package" `T.isPrefixOf` string =
+      T.concat [pkg, " ", mkSpan "hoogle-package" (mkLink loc $ extractPackage string)]
+
+  | "module" `T.isPrefixOf` string =
+      T.concat
+        [ mod
+        , " "
+        , mkSpan "hoogle-module" (mkLink loc $ extractModule string)
+        , packageSub (extractPackageName loc)
+        ]
+
+  | "class" `T.isPrefixOf` string =
+      T.concat
+        [ cls
+        , " "
+        , mkSpan "hoogle-class" (mkLink loc $ extractClass string)
+        , packageSub (extractPackageName loc)
+        ]
+
+  | "data" `T.isPrefixOf` string =
+      T.concat
+        [ dat
+        , " "
+        , mkSpan "hoogle-class" (mkLink loc $ extractData string)
+        , packageSub (extractPackageName loc)
+        ]
+
+  | otherwise =
+      case T.splitOn "::" string of
+        [name, args] ->
+          mkSpan "hoogle-name"
+            (unicodeReplace $ mkLink loc (T.strip name) <> " :: " <> T.strip args)
+          <> packageAndModuleSub (extractPackageName loc) (extractModuleName loc)
+  where
+    extractPackage = T.strip . T.replace "package" ""
+    extractModule = T.strip . T.replace "module" ""
+    extractClass = T.strip . T.replace "class" ""
+    extractData = T.strip . T.replace "data" ""
+    pkg = mkSpan "hoogle-head" "package"
+    mod = mkSpan "hoogle-head" "module"
+    cls = mkSpan "hoogle-head" "class"
+    dat = mkSpan "hoogle-head" "data"
+
+    unicodeReplace :: Text -> Text
+    unicodeReplace =
+      T.replace "forall" "&#x2200;" .
+      T.replace "=>" "&#x21D2;" .
+      T.replace "->" "&#x2192;" .
+      T.replace "::" "&#x2237;"
+
+    packageSub Nothing = ""
+    packageSub (Just package) =
+      mkSpan "hoogle-sub" $
+        T.concat ["(", pkg, " ", mkSpan "hoogle-package" package, ")"]
+
+    packageAndModuleSub Nothing _ = ""
+    packageAndModuleSub (Just package) Nothing = packageSub (Just package)
+    packageAndModuleSub (Just package) (Just modname) =
+      mkSpan "hoogle-sub" $
+        T.concat
+          [ "("
+          , pkg
+          , " "
+          , mkSpan "hoogle-package" package
+          , ", "
+          , mod
+          , " "
+          , mkSpan "hoogle-module" modname
+          , ")"
+          ]
+
+renderDocs :: Text -> Text
+renderDocs docs =
+  docs &
+  T.lines &
+  groupBy bothAreCode &
+  map makeBlock &
+  T.unlines &
+  mkDiv "hoogle-doc"
+  where
+    bothAreCode x y = isCode [x] && isCode [y]
+    isCode ls =
+      case ls of
+        []  -> False
+        s:_ -> T.isPrefixOf ">" $ T.strip s
+    makeBlock ls =
+      mkDiv
+        (if isCode ls
+           then "hoogle-code"
+           else "hoogle-text")
+        (T.unlines $ filter (not . T.null . T.strip) ls)
+
+extractPackageName :: Text -> Maybe Text
+extractPackageName link = do
+  let pieces = T.splitOn "/" link
+  archiveLoc <- elemIndex "archive" pieces
+  latestLoc <- elemIndex "latest" pieces
+  guard $ latestLoc - archiveLoc == 2
+  return $ pieces !! (latestLoc - 1)
+
+extractModuleName :: Text -> Maybe Text
+extractModuleName link = do
+  case T.splitOn "/" link of
+    []     -> Nothing
+    pieces -> Just $ T.replace "-" "." $ T.takeWhile (/= '.') $ last pieces
+
+mkDiv :: Text -> Text -> Text
+mkDiv cls content = T.concat ["<div class='", cls, "'>", content, "</div>"]
+
+mkSpan :: Text -> Text -> Text
+mkSpan cls content = T.concat ["<span class='", cls, "'>", content, "</span>"]
+
+mkLink :: Text -> Text -> Text
+mkLink href content = T.concat  ["<a target='_blank' href='", href, "'>", content, "</a>"]

tests/Jupyter/IHaskell/Test/Hoogle.hs

@@ -0,0 +1,94 @@
+{-|
+Module      : Jupyter.IHaskell.Test.Hoogle
+Description : Tests for Jupyter.IHaskell.Hoogle
+Copyright   : (c) Andrew Gibiansky, 2016
+License     : MIT
+Maintainer  : andrew.gibiansky@gmail.com
+Stability   : stable
+Portability : POSIX
+-}
+
+{-# LANGUAGE OverloadedStrings #-}
+module Jupyter.IHaskell.Test.Hoogle (hoogleTests) where
+
+-- Imports from 'base'
+import           Control.Monad (unless)
+
+-- Imports from 'text'
+import           Data.Text (Text)
+import qualified Data.Text as T
+
+-- Imports from 'tasty'
+import           Test.Tasty (TestTree)
+
+-- Imports from 'tasty-hunit'
+import           Test.Tasty.HUnit (testCase, assertFailure)
+
+-- Imports from 'transformers'
+import           Control.Monad.IO.Class (MonadIO(..))
+
+-- Imports from 'ihaskell'
+import           Jupyter.IHaskell.Hoogle (hoogleSearch, hoogleSearchExact, HoogleResult(..))
+
+-- | Type of Hoogle query to issue.
+data Query = ExactMatch Text -- ^ Search for a string
+           | InexactMatch Text -- ^ Search for a precise identifier match
+  deriving (Eq, Ord, Show)
+
+-- | Test the IHaskell HLint integration.
+hoogleTests :: TestTree
+hoogleTests = testCase "Hoogle" $ do
+  -- Exact matches.
+  ExactMatch "map" --> [ hoogle "base" "Prelude.html#v:map" "map :: (a -> b) -> [a] -> [b]"
+                           "map f xs is the list obtained by applying f to each element"
+                       ]
+  ExactMatch "fmap" --> [HoogleResult "" "" ""]
+  ExactMatch "Data.Text" --> [HoogleResult "" "" ""]
+  ExactMatch "base" --> [HoogleResult "" "" ""]
+  ExactMatch "FromJSON" --> [HoogleResult "" "" ""]
+  ExactMatch "Monad" --> [HoogleResult "" "" ""]
+
+  -- Inexact matches.
+  InexactMatch "map" --> [HoogleResult "" "" ""]
+  InexactMatch "fmap" --> [HoogleResult "" "" ""]
+  InexactMatch "Data.Text" --> [HoogleResult "" "" ""]
+  InexactMatch "base" --> [HoogleResult "" "" ""]
+  InexactMatch "Monad" --> [HoogleResult "" "" ""]
+
+  -- Type signature searches.
+  InexactMatch ":: a -> a" --> [HoogleResult "" "" ""]
+  InexactMatch ":: Monoid w => w -> w -> w" --> [HoogleResult "" "" ""]
+
+hoogle :: Text -> Text -> Text -> Text -> HoogleResult
+hoogle pkg url =
+  HoogleResult
+    (T.concat ["http://hackage.haskell.org/packages/archive/", pkg, "/latest/doc/html/", url])
+
+
+-- | Run a single linter test. Lint the input and then compare output suggestions to generated
+-- suggestions.
+(-->) :: Query -> [HoogleResult] -> IO ()
+query --> expected = do
+  result <- case query of
+              ExactMatch txt   -> hoogleSearch txt
+              InexactMatch txt -> hoogleSearchExact txt
+  case result of
+    Left err -> assertFailure $ "Hoogle Error: " ++ err
+    Right observed ->
+      unless (and (zipWith sameResult expected observed) && length expected <= length observed) $
+        assertFailure $
+          concat
+            [ "Did not get expected Hoogle results for: "
+            , show query
+            , "\nExpected: "
+            , show expected
+            , "\nObserved: "
+            , show observed
+            ]
+
+  where
+    sameResult (HoogleResult url1 self1 doc1) (HoogleResult url2 self2 doc2) =
+      url1 == url2 &&
+      self1 == self2 &&
+      and (zipWith (==) (T.unpack doc1) (T.unpack doc2)) &&
+      T.length doc1 <= T.length doc2

tests/Jupyter/IHaskell/Test/Lint.hs

@@ -89,7 +89,7 @@ lintTests = testCase "Linting" $ do
 block --> expected = do
   observed <- lintCodeBlock (Loc 1 block)
   unless (and (zipWith (==) expected observed) && length expected == length observed) $
-    liftIO $ assertFailure $
+    assertFailure $
       concat
         [ "Did not get expected suggestions for: "
         , show block

tests/Test.hs

@@ -5,6 +5,7 @@ import           Test.Tasty (defaultMain, testGroup)
 
 -- Imports from 'ihaskell'
 import           Jupyter.IHaskell.Test.Complete (completionTests)
+import           Jupyter.IHaskell.Test.Hoogle (hoogleTests)
 import           Jupyter.IHaskell.Test.Lint (lintTests)
 import           Jupyter.IHaskell.Test.Parser (parserTests)
 
@@ -12,4 +13,4 @@ import           Jupyter.IHaskell.Test.Parser (parserTests)
 main :: IO ()
 main =
   defaultMain $
-    testGroup "Tests" [parserTests, completionTests, lintTests]
+    testGroup "Tests" [parserTests, completionTests, lintTests, hoogleTests]