diff --git a/datadir/resources/hoogle.css b/datadir/resources/hoogle.css --- a/datadir/resources/hoogle.css +++ b/datadir/resources/hoogle.css @@ -29,20 +29,20 @@ margin-top: 5px; } -input { - font-size: 16px; - margin-top: 22px; - vertical-align: top; -} - form { margin-bottom: 0px; } -form a:hover { - background-color: white; +#logo img { + vertical-align: bottom; } +#hoogle, #submit { + font-size: 16px; + margin-bottom: 16px; + vertical-align: bottom; +} + #hoogle { width: 300px; margin-right: 5px; @@ -56,11 +56,56 @@ /******************************************************************** +* LEFT - EXTRA SUGGESTIONS +*/ + +#left { + float: left; + width: 140px; + margin-top: 7px; + margin-left: 10px; + font-size: 13px; +} + +#left ul { + padding: 0px; + margin: 0px; +} + +#left li { + list-style-type: none; + margin-bottom: 7px; + white-space: nowrap; + display: block; +} + +#left a { + text-decoration: none; + background-repeat: no-repeat; +} + +#left .plus { + color: #0E7700; + padding-right: 16px; + background-image: url(more_small.png); + background-position: center right; +} + +#left .minus { + color: #770E00; + padding-left: 16px; + background-image: url(less_small.png); + background-position: center left; +} + + +/******************************************************************** * BOTTOM - COPYRIGHT MESSAGE */ #footer { text-align: center; + font-size: 13px; } @@ -69,7 +114,6 @@ */ h1 { - font-size: 13px; padding: 5px; margin-top: 0px; font-weight: normal; @@ -77,11 +121,14 @@ to make type searching visisble */ background-color: #e4e4e4; border-top: 1px solid #999; + text-indent: 165px; + font-size: 16px; } p { - padding-left: 20px; - padding-right: 20px; + margin-left: 170px; + margin-right: 20px; + font-size: 16px; } @@ -102,10 +149,9 @@ margin-top: 20px; margin-bottom: 20px; padding: 3px; - width: 300px; + width: 400px; border: 2px solid #cc0; background-color: #ffc; - font-size: 10pt; text-align: left; } diff --git a/datadir/resources/hoogle.js b/datadir/resources/hoogle.js --- a/datadir/resources/hoogle.js +++ b/datadir/resources/hoogle.js @@ -1,43 +1,83 @@ +var instant = false; // should we search on key presses + + +///////////////////////////////////////////////////////////////////// +// SEARCHING + +var currentSearch; // String +var oldSearches = cache(100); + $(function(){ - if (window.external && ("AddSearchProvider" in window.external)) - document.getElementById("plugin").style.display = ""; + currentSearch = $("#hoogle").focus().keyup(searchBoxChange).val(); +}); - $("#hoogle").focus(); - if ($.getQueryString('ajax')) +function searchBoxChange() +{ + if (!instant) return; + var txt = $("#hoogle"); + var bod = $("#body"); + var now = txt.val(); + if (now == currentSearch) return; else currentSearch = now; + var old = oldSearches.ask(now); + if (old != undefined) + bod.html(old); + else { - var c = cache(100); - var last = $("#hoogle").val(); - - $("#hoogle").keyup(function(){ - var now = $("#hoogle").val(); - if (now == last) return; else last = now; - var old = c.ask(now); - if (old != undefined) - $("#body").html(old); - else - { - $.ajax({ - url: '?', - data: {mode:'ajax', hoogle:now}, - dataType: 'html', - complete: function(s){return function(e){ - c.add(s,e.responseText); - if ($("#hoogle").val() == s) - $("#body").html(e.responseText); - }}(now) - }); - } + $.ajax({ + url: '?', + data: {mode:'ajax', hoogle:now}, + dataType: 'html', + complete: function(s){return function(e){ + oldSearches.add(s,e.responseText); + if (txt.val() == s) + bod.html(e.responseText); + }}(now) }); } +} + + +///////////////////////////////////////////////////////////////////// +// INSTANT + +$(function(){ + setInstant($.getQueryString('ajax') == "1" || $.cookie("instant") == "1"); + $("#instant").css("display",""); }); +function setInstant(x) +{ + instant = x == undefined ? !instant : x ? true : false; + $("#instantVal").html(instant ? "on" : "off"); + if (instant) + { + $.cookie("instant","1",{expires:365}); + searchBoxChange(); + } + else + $.cookie("instant",null); +} + + +///////////////////////////////////////////////////////////////////// +// SEARCH PLUGIN + +$(function(){ + if (window.external && ("AddSearchProvider" in window.external)) + $("#plugin").css("display",""); +}); + function searchPlugin() { var l = document.location; var url = l.protocol + "//" + l.hostname + l.pathname + $("link[rel=search]").attr("href"); window.external.AddSearchProvider(url); } + + +///////////////////////////////////////////////////////////////////// +// DOCUMENTATION function docs(i) { diff --git a/datadir/resources/less_small.png b/datadir/resources/less_small.png new file mode 100644 Binary files /dev/null and b/datadir/resources/less_small.png differ diff --git a/datadir/resources/more_small.png b/datadir/resources/more_small.png new file mode 100644 Binary files /dev/null and b/datadir/resources/more_small.png differ 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.1.3 +version: 4.1.4 license: GPL license-file: docs/LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2004-2010 +copyright: Neil Mitchell 2004-2011 synopsis: Haskell API Search description: Hoogle is a Haskell API search engine, which allows you to @@ -37,7 +37,10 @@ parsec == 2.1.*, transformers == 0.2.*, uniplate == 1.6.*, - haskell-src-exts == 1.9.* + haskell-src-exts >= 1.9 && < 1.11 + + if !os(mingw32) + build-depends: unix exposed-modules: Hoogle diff --git a/src/CmdLine/Type.hs b/src/CmdLine/Type.hs --- a/src/CmdLine/Type.hs +++ b/src/CmdLine/Type.hs @@ -46,7 +46,7 @@ cmdLineMode = cmdArgsMode $ modes [search_ &= auto,test,server,dump,rank,combine,convert,dataa] &= verbosity &= program "hoogle" - &= summary ("Hoogle v" ++ showVersion version ++ ", (C) Neil Mitchell 2004-2010\nhttp://haskell.org/hoogle") + &= summary ("Hoogle v" ++ showVersion version ++ ", (C) Neil Mitchell 2004-2011\nhttp://haskell.org/hoogle") search_ = Search {web = def &= help "Operate as a web tool" diff --git a/src/General/System.hs b/src/General/System.hs --- a/src/General/System.hs +++ b/src/General/System.hs @@ -10,7 +10,6 @@ import System.IO as X import System.Mem as X (performGC) - import General.Base import qualified Control.Exception as E @@ -18,11 +17,26 @@ import GHC.IO.Handle(hDuplicate,hDuplicateTo) #endif +#ifndef mingw32_HOST_OS +import System.Posix(setFileCreationMask) +#else +setFileCreationMask :: Int -> IO Int +setFileCreationMask _ = return 0 +#endif + + withDirectory dir cmd = E.bracket (do x <- getCurrentDirectory; setCurrentDirectory dir; return x) setCurrentDirectory (const cmd) + + +withModeGlobalRead :: IO () -> IO () +withModeGlobalRead act = E.bracket + (setFileCreationMask 0o022) + (const act) + (\x -> setFileCreationMask x >> return ()) -- FIXME: This could use a lot more bracket calls! diff --git a/src/General/Web.hs b/src/General/Web.hs --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -6,10 +6,9 @@ module General.Web( responseOk, responseBadRequest, responseNotFound, responseError, - filePathToURL, combineURL, escapeURL, (++%), unescapeURL, + URL, filePathToURL, combineURL, escapeURL, (++%), unescapeURL, escapeHTML, (++&), htmlTag, - cgiArgs, - parseHttpQueryArgs + Args, cgiArgs, parseHttpQueryArgs ) where import General.System @@ -26,6 +25,9 @@ responseError x = Response (5,0,0) "Internal Server Error" [] $ "Internal server error: " ++ x +type Args = [(String, String)] + + --------------------------------------------------------------------- -- HTML STUFF @@ -100,7 +102,7 @@ envVariable x = catch (fmap Just $ getEnv x) (const $ return Nothing) -cgiArgs :: IO (Maybe [(String, String)]) +cgiArgs :: IO (Maybe Args) cgiArgs = do x <- cgiVariable return $ case x of @@ -111,7 +113,7 @@ --------------------------------------------------------------------- -- HTTP STUFF -parseHttpQueryArgs :: String -> [(String, String)] +parseHttpQueryArgs :: String -> Args parseHttpQueryArgs xs = mapMaybe (f . splitPair "=") $ splitList "&" xs where f Nothing = Nothing f (Just (a,b)) = Just (unescapeURL a, unescapeURL b) diff --git a/src/Hoogle.hs b/src/Hoogle.hs --- a/src/Hoogle.hs +++ b/src/Hoogle.hs @@ -11,7 +11,7 @@ -- * Database Database, loadDatabase, saveDatabase, createDatabase, showDatabase, -- * Query - Query, parseQuery, H.renderQuery, H.isBlankQuery, + Query(..), H.Scope(..), parseQuery, H.renderQuery, H.isBlankQuery, queryDatabases, querySuggestions, queryCompletions, -- * Score Score, H.scoring, diff --git a/src/Hoogle/DataBase/SubstrSearch.hs b/src/Hoogle/DataBase/SubstrSearch.hs --- a/src/Hoogle/DataBase/SubstrSearch.hs +++ b/src/Hoogle/DataBase/SubstrSearch.hs @@ -28,20 +28,13 @@ {- Description: -The substring search is an array of (key,value) pairs. The keys are sorted case -sensitively. - -To do a search we binary chop to find the range where the exact prefixes lie, -then we binary chop to find the range where the inexact prefixes lie, then we -scan linearly to find all substrings. - Data is stored flattened. For default we expect ~200Kb of disk usage. -} -- keys are sorted after being made lower case data SubstrSearch a = SubstrSearch - {text :: BS.ByteString -- all the bytestrings, lowercase, sorted - ,lens :: BS.ByteString -- a list of lengths, 0 means the string was identical to the previous one + {text :: BS.ByteString -- all the bytestrings, in preference order + ,lens :: BS.ByteString -- a list of lengths ,inds :: Int -> a -- a way of retrieving each index } @@ -53,18 +46,16 @@ (BS.pack $ map fromIntegral ls2) (is !!) where - (ts,is) = unzip $ sortBy (comparing fst) $ map (first $ map toLower) xs + (ts,is) = unzip $ map (first $ map toLower) xs (ts2,ls2) = f "" ts - f x (y:ys) | x == y = second (0:) $ f x ys - | otherwise = first (y:) $ second (length y:) $ f y ys + f x (y:ys) = first (y:) $ second (length y:) $ f y ys f x [] = ([],[]) data S a = S {sCount :: !Int -- which one are we on ,sFocus :: !BS.ByteString -- where we are in the string - ,sLast :: !(Maybe TextMatch) -- the last result ,sPrefix :: ![(a,EntryView,Score)] -- the prefixes ,sInfix :: ![(a,EntryView,Score)] -- the infixes } @@ -76,12 +67,9 @@ view = FocusOn y match = bsMatch (BSC.pack $ map toLower y) sN = BS.foldl f s0 $ lens x - s0 = S 0 (text x) Nothing [] [] + s0 = S 0 (text x) [] [] - f s 0 = addCount $ case sLast s of - Nothing -> s - Just x -> addMatch x s - f s ii = addCount $ moveFocus i $ maybe id addMatch t $ s{sLast=t} + f s ii = addCount $ moveFocus i $ maybe id addMatch t s where t = match i $ BS.unsafeTake i $ sFocus s i = fromIntegral ii diff --git a/src/Hoogle/Query/Suggest.hs b/src/Hoogle/Query/Suggest.hs --- a/src/Hoogle/Query/Suggest.hs +++ b/src/Hoogle/Query/Suggest.hs @@ -41,7 +41,7 @@ didYouMean :: Query -> TagStr -didYouMean q = Tags [TagBold $ Str "Did you mean: ", TagLink ("query:" ++ s) $ Str s] +didYouMean q = Tags [TagBold $ Str "Did you mean: ", TagLink "" $ Str s] where s = showTagText $ renderQuery q diff --git a/src/Hoogle/Type/TagStr.hs b/src/Hoogle/Type/TagStr.hs --- a/src/Hoogle/Type/TagStr.hs +++ b/src/Hoogle/Type/TagStr.hs @@ -120,11 +120,7 @@ g (Tags xs) = concatMap g xs g (TagBold x) = htmlTag "b" $ showTagHTML x g (TagEmph x) = htmlTag "i" $ showTagHTML x - -- FIXME: this is overly specific! - g (TagLink "" x) = g (TagLink url x) - where str = showTagText x - url = if "http:" `isPrefixOf` str then str else "?hoogle=" ++% str - g (TagLink url x) = "" ++ showTagHTML x ++ "" + g (TagLink url x) = "" ++ showTagHTML x ++ "" g (TagColor i x) = "" ++ showTagHTML x ++ "" nbsp (' ':' ':xs) = "  " ++ nbsp xs diff --git a/src/Recipe/All.hs b/src/Recipe/All.hs --- a/src/Recipe/All.hs +++ b/src/Recipe/All.hs @@ -16,7 +16,7 @@ -- CmdLine is guaranteed to be a constructor of type Data recipes :: CmdLine -> IO () -recipes opt = do +recipes opt = withModeGlobalRead $ do hSetBuffering stdout NoBuffering createDirectoryIfMissing True $ datadir opt withDirectory (datadir opt) $ do diff --git a/src/Web/All.hs b/src/Web/All.hs --- a/src/Web/All.hs +++ b/src/Web/All.hs @@ -10,7 +10,8 @@ action :: CmdLine -> IO () action q@Server{} = server q --- would like to use datadir, but not sure how +-- FIXME: Should use datadir, but not sure how +-- FIXME: Only server will preserve extra flags action q = do - res <- response "datadir/resources" q + res <- response "datadir/resources" [] q putStrLn $ intercalate "\n" $ map show (rspHeaders res) ++ ["",rspBody res] diff --git a/src/Web/Page.hs b/src/Web/Page.hs --- a/src/Web/Page.hs +++ b/src/Web/Page.hs @@ -1,10 +1,14 @@ -module Web.Page(header, footer, welcome) where +module Web.Page(searchLink, header, footer, welcome) where import General.Web import General.Util +searchLink :: Args -> String -> URL +searchLink extra x = "?" ++ concat [a ++ "=" ++% b ++ "&" | (a,b) <- extra, a /= "hoogle"] ++ "hoogle=" ++% x + + header resources query = ["" ,"" @@ -15,6 +19,7 @@ ," " ," " ," " + ," " ," " ," " ," " @@ -24,6 +29,8 @@ links = ["" - ," " + ," " ," " ,"" ] -welcome = +welcome extra = ["

Welcome to Hoogle

" ,"

" ," Hoogle is a Haskell API search engine, which allows you to search many standard Haskell libraries" @@ -77,4 +82,4 @@ ,"

" ] where - search x = "" ++& x ++ "
" + search x = "" ++& x ++ "
" diff --git a/src/Web/Response.hs b/src/Web/Response.hs --- a/src/Web/Response.hs +++ b/src/Web/Response.hs @@ -18,9 +18,9 @@ logFile = "log.txt" - -response :: FilePath -> CmdLine -> IO (Response String) -response resources q = do +-- extra is a hack, should be replaced with a local cookie, until it becomes the default +response :: FilePath -> Args -> CmdLine -> IO (Response String) +response resources extra q = do logMessage q let response x = responseOk [Header HdrContentType x] @@ -28,7 +28,7 @@ dbs <- if isRight $ queryParsed q then fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q) else return mempty - return $ runQuery ajax dbs q + return $ runQuery extra ajax dbs q case webmode q of Just "ajax" -> do @@ -60,8 +60,8 @@ runSuggest _ = return "" -runQuery :: Bool -> Database -> CmdLine -> [String] -runQuery ajax dbs Search{queryParsed = Left err} = +runQuery :: Args -> Bool -> Database -> CmdLine -> [String] +runQuery extra ajax dbs Search{queryParsed = Left err} = ["

Parse error in user query

" ,"

" ," Query: " ++ showTagHTMLWith f (parseInput err) ++ "" @@ -77,13 +77,14 @@ f _ = Nothing -runQuery ajax dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome +runQuery extra ajax dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome extra -runQuery ajax dbs cq@Search{queryParsed = Right q} = +runQuery extra ajax dbs cq@Search{queryParsed = Right q, queryText = qt} = (if prefix then - ["

Searching for " ++ qstr ++ "

"] ++ - ["

" ++ showTagHTML (transform qurl sug) ++ "

" | Just sug <- [querySuggestions dbs q]] ++ + ["

" ++ qstr ++ "

"] ++ + ["
" ++ also ++ "
" | not $ null pkgs] ++ + ["

" ++ showTag extra sug ++ "

" | Just sug <- [querySuggestions dbs q]] ++ if null res then ["

No results found

"] else @@ -96,18 +97,26 @@ start2 = maybe 0 (subtract 1 . max 0) $ start cq count2 = maybe 20 (max 1) $ count cq - res = [renderRes i (i /= 0 && i == start2 && prefix) x | (i,(_,x)) <- zip [0..] $ search dbs q] + src = search dbs q + res = [renderRes extra i (i /= 0 && i == start2 && prefix) x | (i,(_,x)) <- zip [0..] src] (pre,res2) = splitAt start2 res (now,post) = splitAt count2 res2 - urlMore = "?hoogle=" ++% queryText cq ++ "&start=" ++ show (start2+count2+1) ++ "#more" + also = "" + f x | PlusPackage x `elem` scope q = + let q2 = showTagText $ renderQuery $ q{scope = filter (/= PlusPackage x) $ scope q} in + "
  • " ++ x ++ "
    • " + | otherwise = + "
  • " ++ + "" ++ x ++ "
    • " + pkgs = nub [x | (_, (_,x):_) <- concatMap (locations . snd) $ take (start2+count2) src] + + urlMore = searchLink extra qt ++ "&start=" ++ show (start2+count2+1) ++ "#more" qstr = showTagHTML (renderQuery q) - qurl (TagLink url x) | "query:" `isPrefixOf` url = TagLink ("?hoogle=" ++% drop 6 url) x - qurl x = x -renderRes :: Int -> Bool -> Result -> [String] -renderRes i more Result{..} = +renderRes :: Args -> Int -> Bool -> Result -> [String] +renderRes extra i more Result{..} = ["" | more] ++ ["
    " ++ href selfUrl (showTagHTMLWith url self) ++ "
    "] ++ ["
    " ++ intercalate ", " [unwords $ zipWith (f u) [1..] ps | (u,ps) <- locations] ++ "
    " | not $ null locations] ++ @@ -119,7 +128,7 @@ docs2 = ("
    " ++ "") ++? - showTagHTML docs ++? + showTag extra docs ++? "
    " url (TagBold x) @@ -132,3 +141,11 @@ g x = x href url x = if null url then x else "" ++ x ++ "" + + +showTag :: Args -> TagStr -> String +showTag extra = showTagHTML . transform f + where + f (TagLink "" x) = TagLink (if "http:" `isPrefixOf` str then str else searchLink extra str) x + where str = showTagText x + f x = x diff --git a/src/Web/Server.hs b/src/Web/Server.hs --- a/src/Web/Server.hs +++ b/src/Web/Server.hs @@ -3,6 +3,7 @@ module Web.Server(server) where import General.Base +import General.Util import General.Web import CmdLine.All import Web.Response @@ -61,8 +62,9 @@ talk :: CmdLine -> Request String -> IO (Response String) talk Server{..} Request{rqURI=URI{uriPath=path,uriQuery=query}} | path `elem` ["/","/hoogle"] = do - args <- cmdLineWeb $ parseHttpQueryArgs $ drop 1 query - r <- response "/res" args{databases=databases} + let args = parseHttpQueryArgs $ drop 1 query + cmd <- cmdLineWeb args + r <- response "/res" (reps ("mode","ajax") ("ajax","1") args) cmd{databases=databases} return $ if local_ then fmap rewriteFileLinks r else r | takeDirectory path == "/res" = serveFile True $ resources takeFileName path | local_ && "/file/" `isPrefixOf` path = serveFile False $ drop 6 path