diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -1,13 +1,13 @@ cabal-version: >= 1.6 build-type: Simple name: hoogle -version: 4.2.14 +version: 4.2.15 license: BSD3 license-file: docs/LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2004-2012 +copyright: Neil Mitchell 2004-2013 synopsis: Haskell API Search description: Hoogle is a Haskell API search engine, which allows you to @@ -109,8 +109,8 @@ cmdargs >= 0.7 && < 0.11, tagsoup >= 0.11 && < 0.13, blaze-builder >= 0.2 && < 0.4, - http-types == 0.7.*, - case-insensitive >= 0.2 && < 0.5, + http-types >= 0.7 && < 0.9, + case-insensitive >= 0.2 && < 1.1, conduit >= 0.2 && < 0.6, wai >= 1.1 && < 1.4, warp >= 1.1 && < 1.4, diff --git a/src/Hoogle.hs b/src/Hoogle.hs --- a/src/Hoogle.hs +++ b/src/Hoogle.hs @@ -102,8 +102,8 @@ -- Invariant: locations will not be empty data Result = Result {locations :: [(URL, [(URL, String)])] -- your location, your parents - ,self :: TagStr - ,docs :: TagStr + ,self :: TagStr -- ^ Rendered view for the entry, including name/keywords/type as appropriate, colors matching 'renderQuery' + ,docs :: TagStr -- ^ Documentation for the entry } toResult :: H.Result -> (Score,Result) diff --git a/src/Hoogle/Query/Parser.hs b/src/Hoogle/Query/Parser.hs --- a/src/Hoogle/Query/Parser.hs +++ b/src/Hoogle/Query/Parser.hs @@ -75,7 +75,9 @@ pm <- fmap (== '+') $ oneOf "+-" modu <- keyword `sepBy1` (char '.') let typ = case modu of [x] | isLower (head x) -> Package; _ -> Module - return mempty{scope=[Scope pm typ $ intercalate "." modu]} + return $ if modu == ["exact"] + then mempty{exact=True} + else mempty{scope=[Scope pm typ $ intercalate "." modu]} keyword = do diff --git a/src/Hoogle/Query/Type.hs b/src/Hoogle/Query/Type.hs --- a/src/Hoogle/Query/Type.hs +++ b/src/Hoogle/Query/Type.hs @@ -11,13 +11,14 @@ {names :: [String] ,typeSig :: Maybe TypeSig ,scope :: [Scope] + ,exact :: Bool } deriving (Data,Typeable,Show,Eq) instance Monoid Query where - mempty = Query [] Nothing [] - mappend (Query x1 x2 x3) (Query y1 y2 y3) = - Query (x1++y1) (x2 `mplus` y2) (x3++y3) + mempty = Query [] Nothing [] False + mappend (Query x1 x2 x3 x4) (Query y1 y2 y3 y4) = + Query (x1++y1) (x2 `mplus` y2) (x3++y3) (x4||y4) data Scope = Scope Bool Category String deriving (Data,Typeable,Show,Eq) data Category = Module | Package deriving (Data,Typeable,Show,Eq) diff --git a/src/Hoogle/Score/All.hs b/src/Hoogle/Score/All.hs --- a/src/Hoogle/Score/All.hs +++ b/src/Hoogle/Score/All.hs @@ -1,7 +1,7 @@ module Hoogle.Score.All( module Hoogle.Score.Scoring, - Score, TypeCost(..), TextMatch(..), textScore, typeScore, scoreCosts, cost + Score, TypeCost(..), TextMatch(..), textScore, typeScore, scoreCosts, scoreExact, cost ) where import Hoogle.Score.Scoring diff --git a/src/Hoogle/Score/Type.hs b/src/Hoogle/Score/Type.hs --- a/src/Hoogle/Score/Type.hs +++ b/src/Hoogle/Score/Type.hs @@ -2,7 +2,7 @@ module Hoogle.Score.Type( Score, TypeCost(..), TextMatch(..), textScore, typeScore, - scoreCosts, cost + scoreCosts, scoreExact, cost ) where import Data.List @@ -61,6 +61,9 @@ scoreCosts :: Score -> [TypeCost] scoreCosts (Score _ x _) = x + +scoreExact :: Score -> Bool +scoreExact (Score _ ty txt) = null ty && null (filter (/= MatchExact) txt) instance Show Score where diff --git a/src/Hoogle/Search/All.hs b/src/Hoogle/Search/All.hs --- a/src/Hoogle/Search/All.hs +++ b/src/Hoogle/Search/All.hs @@ -6,11 +6,14 @@ import Hoogle.Search.Results import Hoogle.Type.All import Hoogle.Store.All +import Hoogle.Score.All -- return all the results, lazily search :: [DataBase] -> Query -> [Result] -search databases query = getResults query databases +search databases query = + (if exact query then takeWhile (scoreExact . resultScore) else id) $ + getResults query databases getResults :: Query -> [DataBase] -> [Result] diff --git a/src/Recipe/Hackage.hs b/src/Recipe/Hackage.hs --- a/src/Recipe/Hackage.hs +++ b/src/Recipe/Hackage.hs @@ -53,10 +53,9 @@ case had of Left e -> putWarning $ "Warning: Exception when reading haddock for ghc, " ++ show (e :: SomeException) Right had -> do - convertSrc make "ghc" $ unlines $ "@depends base" : concatMap f (haddockHacks $ lines had) - where - f x | "@package " `isPrefixOf` x = ["@url http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/",x] - | otherwise = [x] + loc <- findLocal local "ghc" + convertSrc make "ghc" $ unlines $ "@depends base" : (f loc) (haddockHacks $ lines had) + where f loc = haddockPackageUrl $ maybe "http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/" id loc makeDefault make local name = do let base = name == "base" diff --git a/src/Web/Server.hs b/src/Web/Server.hs --- a/src/Web/Server.hs +++ b/src/Web/Server.hs @@ -87,28 +87,30 @@ r <- response resp cmd{databases=databases} if local_ then rewriteFileLinks r else return r | path == "/res/search.xml" = serveSearch resources (fmap bsUnpack $ join $ lookup (fromString "domain") $ queryString r) - | takeDirectory path == "/res" = serveFile True $ resources takeFileName path + | takeDirectory path == "/res" = serveFile True (resources takeFileName path) False | local_, Just path <- stripPrefix "/file/" path = let hasDrive = "/" `isPrefixOf` path && ":" `isPrefixOf` (drop 2 path) - in serveFile False $ if hasDrive then drop 1 path else path + in serveFile False (if hasDrive then drop 1 path else path) local_ | otherwise = return $ responseNotFound $ show path where (path,query) = (bsUnpack path_, bsUnpack query_) serveSearch :: FilePath -> Maybe String -> IO Response serveSearch resources domain = do - r <- serveFile True $ resources "search.xml" + r <- serveFile True (resources "search.xml") False case domain of Nothing -> return r Just x -> responseRewrite (lbsReplace (fromString "http://haskell.org/hoogle/") (fromString x)) r -serveFile :: Bool -> FilePath -> IO Response -serveFile cache file = do +serveFile :: Bool -> FilePath -> Bool -> IO Response +serveFile cache file rewriteLinks = do b <- doesFileExist file - return $ if not b - then responseNotFound file - else ResponseFile ok200 hdr file Nothing + if not b + then return $ responseNotFound file + else (if rewriteLinks then rewriteHaddockFileLinks else return) $ ResponseFile ok200 hdr file Nothing + + where hdr = [(hContentType, fromString $ contentExt $ takeExtension file)] ++ [(hCacheControl, fromString "max-age=604800" {- 1 week -}) | cache] @@ -116,6 +118,17 @@ rewriteFileLinks :: Response -> IO Response rewriteFileLinks = responseRewrite $ lbsReplace (fromString "href='file://") (fromString "href='/file/") +replaceLetter :: LBString -> Char -> LBString +replaceLetter lbs letter = lbsReplace (fromString $ "href=\""++[letter]++":") (fromString $ "href=\"/file/"++[letter]++":") lbs + +replaceDriveLetters :: LBString -> LBString +replaceDriveLetters lbs = foldl replaceLetter lbs (['A' .. 'Z'] ++ ['a' .. 'z']) + +replaceLeadingSlash :: LBString -> LBString +replaceLeadingSlash = lbsReplace (fromString "href=\"/") (fromString "href=\"/file//") + +rewriteHaddockFileLinks :: Response -> IO Response +rewriteHaddockFileLinks = responseRewrite $ replaceDriveLetters . replaceLeadingSlash contentExt ".png" = "image/png" contentExt ".css" = "text/css"