From bc308f03da6bfb416152f858ab94c8d408282024 Mon Sep 17 00:00:00 2001 From: Andrew Gibiansky Date: Mon, 12 Sep 2016 00:44:27 -0700 Subject: [PATCH] add hoogle module and hoogle test suite --- ihaskell.cabal | 8 +- src/Jupyter/IHaskell/Hoogle.hs | 236 ++++++++++++++++++++++++++ tests/Jupyter/IHaskell/Test/Hoogle.hs | 94 ++++++++++ tests/Jupyter/IHaskell/Test/Lint.hs | 2 +- tests/Test.hs | 3 +- 5 files changed, 339 insertions(+), 4 deletions(-) create mode 100644 src/Jupyter/IHaskell/Hoogle.hs create mode 100644 tests/Jupyter/IHaskell/Test/Hoogle.hs diff --git a/ihaskell.cabal b/ihaskell.cabal index 2c26001d..8367dba4 100644 --- a/ihaskell.cabal +++ b/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: diff --git a/src/Jupyter/IHaskell/Hoogle.hs b/src/Jupyter/IHaskell/Hoogle.hs new file mode 100644 index 00000000..f04ec2d9 --- /dev/null +++ b/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" "∀" . + T.replace "=>" "⇒" . + T.replace "->" "→" . + T.replace "::" "∷" + + 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 ["
", content, "
"] + +mkSpan :: Text -> Text -> Text +mkSpan cls content = T.concat ["", content, ""] + +mkLink :: Text -> Text -> Text +mkLink href content = T.concat ["", content, ""] diff --git a/tests/Jupyter/IHaskell/Test/Hoogle.hs b/tests/Jupyter/IHaskell/Test/Hoogle.hs new file mode 100644 index 00000000..0c8824e0 --- /dev/null +++ b/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 diff --git a/tests/Jupyter/IHaskell/Test/Lint.hs b/tests/Jupyter/IHaskell/Test/Lint.hs index 132a40a1..2e4dda03 100644 --- a/tests/Jupyter/IHaskell/Test/Lint.hs +++ b/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 diff --git a/tests/Test.hs b/tests/Test.hs index 226c92da..d8b2eb40 100644 --- a/tests/Test.hs +++ b/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]