hoogle 4.1.5 → 4.2

raw patch · 23 files changed

+674/−174 lines, 23 filesdep +old-localePVP ok

version bump matches the API change (PVP)

Dependencies added: old-locale

API changes (from Hackage documentation)

Files

• datadir/resources/hoogle.js +205/−62
• datadir/resources/jquery.cookie.js +96/−0
• hoogle.cabal +5/−2
• src/CmdLine/All.hs +1/−1
• src/CmdLine/Type.hs +7/−2
• src/Console/All.hs +4/−1
• src/Console/Log.hs +205/−0
• src/Console/Search.hs +1/−1
• src/General/Base.hs +7/−0
• src/General/System.hs +4/−0
• src/General/Web.hs +2/−6
• src/Hoogle.hs +14/−26
• src/Hoogle/Language/Haskell.hs +6/−8
• src/Hoogle/Query/Parser.hs +10/−14
• src/Hoogle/Query/Type.hs +28/−12
• src/Hoogle/Search/Results.hs +6/−2
• src/Hoogle/Type/All.hs +1/−0
• src/Hoogle/Type/Language.hs +11/−0
• src/Recipe/Keyword.hs +1/−1
• src/Test/Parse_Query.hs +2/−1
• src/Web/All.hs +1/−1
• src/Web/Page.hs +9/−4
• src/Web/Response.hs +48/−30

@@ -1,57 +1,181 @@ +var embed = false; // are we running as an embedded search box var instant = false; // should we search on key presses +var $hoogle; // $("#hoogle") after load + ///////////////////////////////////////////////////////////////////// // SEARCHING -var currentSearch; // String-var oldSearches = cache(100);-var timeoutId;- $(function(){-    currentSearch = $("#hoogle").focus().keyup(searchBoxChange).val();-});+    $hoogle = $("#hoogle");+    embed = !$hoogle.hasClass("HOOGLE_REAL");+    var self = embed ? newEmbed() : newReal();+    var $form = $hoogle.parents("form:first"); -function searchBoxChange()+    var ajaxUrl = !embed ? "?" : $form.attr("action") + "?";+    var ajaxMode = embed ? 'embed' : 'ajax';+    var ajaxPrefix = $form.find("input[name=prefix]").attr("value");+    var ajaxSuffix = $form.find("input[name=suffix]").attr("value");++    var active = $hoogle.val(); // What is currently being searched for (may not yet be displayed)+    var past = cache(100); // Cache of previous searches+    var watch = watchdog(500, function(){self.showWaiting();}); // Timeout of the "Waiting..." callback++    $hoogle.keyup(function(){+        if (!instant) return;++        var now = $hoogle.val();+        if (now == active) return;+        active = now;++        var old = past.ask(now);+        if (old != undefined){self.showResult(old); return;}++        watch.stop();+        if (embed && now == ""){self.hide(); return;}+        watch.start();++        try {+            $.ajax({+                url: ajaxUrl,+                data: {hoogle:now, mode:ajaxMode, prefix:ajaxPrefix, suffix:ajaxSuffix},+                dataType: 'html',+                complete: function(e){+                    watch.stop();+                    if (e.status == 200)+                    {+                        past.add(now,e.responseText);+                        if ($hoogle.val() == now)+                            self.showResult(e.responseText);+                    }+                    else+                        self.showError(e.status, e.responseText);+                }+            });+        } catch (err) {+            // Probably a permissions error from cross domain scripting...+            watch.stop();+        }+    });+})++function newReal() {-    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-    {-        if (timeoutId != undefined) window.clearTimeout(timeoutId);-        timeoutId = window.setTimeout(function(){timeoutId = undefined; $("h1").text("Still working...");}, 500);-        $.ajax({-            url: '?',-            data: {mode:'ajax', hoogle:now},-            dataType: 'html',-            complete: function(s){return function(e){-                window.clearTimeout(timeoutId);-                timeoutId = undefined;-                if (e.status == 200) {-                    oldSearches.add(s,e.responseText);-                    if (txt.val() == s)-                        bod.html(e.responseText);-                } else-                    bod.html("<h1><b>Error:</b> status " + e.status + "</h1><p>" + e.responseText + "</p>");-            }}(now)-        });+    $hoogle.focus();+    $hoogle.select();+    var $h1 = $("h1");+    var $body = $("#body");++    return {+        showWaiting: function(){$h1.text("Still working...");},+        showError: function(status,text){$body.html("<h1><b>Error:</b> status " + status + "</h1><p>" + text + "</p>")},+        showResult: function(text){$body.html(text);}     } } +function newEmbed()+{+    $hoogle.attr("autocomplete","off");+    // IE note: unless the div in the iframe contain any border it doesn't calculate the correct outerHeight()+    //          therefore we put 3 borders on the iframe, and leave one for the bottom div+    var $iframe = $("<iframe id='hoogle-output' scrolling='no' "++                    "style='position:absolute;border:1px solid rgb(127,157,185);border-bottom:0px;display:none;' />");+    var $body;+    $iframe.load(function(){+        var $contents = $iframe.contents();+        $contents.find("head").html(+            "<style type='text/css'>" ++            "html {border: 0px;}" ++            "body {font-family: sans-serif; font-size: 13px; background-color: white; padding: 0px; margin: 0px;}" ++            "a, i {display: block; color: black; padding: 1px 3px; text-decoration: none; white-space: nowrap; overflow: hidden; cursor: default;}" ++            "a.sel {background-color: rgb(10,36,106); color: white;}" ++            "div {border-bottom:1px solid rgb(127,157,185);}" ++            "</style>");+        $body = $("<div>").appendTo($contents.find("body"));+    });+    $iframe.insertBefore($hoogle); +    var finishOnBlur = true; // Should a blur hide the box++    function show(x){+        if (x == undefined)+            $iframe.css("display","none");+        else {+            $body.html(x).find("a").attr("target","_parent")+                .mousedown(function(){finishOnBlur = false;})+                .mouseup(function(){finishOnBlur = true;})+                .mouseenter(function(){+                    $body.find(".sel").removeClass("sel");+                    $(this).addClass("sel");+                });++            var pos = $hoogle.position();+            // need to display before using $body.outerHeight() on Firefox+            $iframe.css("display","").css(+                {top:px(pos.top + $hoogle.outerHeight() + unpx($hoogle.css("margin-top")))+                ,left:px(pos.left + unpx($hoogle.css("margin-left")))+                ,width:px($hoogle.outerWidth() - 2 /* iframe border */)+                ,height:$body.outerHeight()+                });+        }+    }++    $hoogle.blur(function(){if (finishOnBlur) show();});++    $hoogle.keydown(function(event){+        switch(event.which)+        {+        case Key.Return:+            var sel = $body.find(".sel:first");+            if (sel.size() == 0) return;+            event.preventDefault();+            document.location.href = sel.attr("href");+            break;++        case Key.Escape:+            $body.find(".sel").removeClass("sel");+            show();+            break;++        case Key.Down: case Key.Up:+            var i = event.which == Key.Down ? 1 : -1;+            var all = $body.find("a");+            var sel = all.filter(".sel");+            var now = all.index(sel);+            if (now == -1)+                all.filter(i == 1 ? ":first" : ":last").addClass("sel");+            else {+                sel.removeClass("sel");+                // IE treats :eq(-1) as :eq(0), so filter specifically+                if (now+i >= 0) all.filter(":eq(" + (now+i) + ")").addClass("sel");+            }+            event.preventDefault();+            break;+        }+    });++    return {+        showWaiting: function(){show("<i>Still working...</i>");},+        showError: function(status,text){show("<i>Error: status " + status + "</i>");},+        showResult : function(text){show(text);},+        hide: function(){show();}+    }+}++ /////////////////////////////////////////////////////////////////////-// INSTANT+// INSTANT BUTTON  $(function(){-    setInstant($.getQueryString('ajax') == "1" || $.cookie("instant") == "1");-    $("#instant").css("display","");+    if (embed)+        instant = true;+    else+    {+        setInstant($.getQueryString('ajax') == "1" || $.cookie("instant") == "1");+        $("#instant").css("display","");+    } });  function setInstant(x)@@ -61,7 +185,7 @@     if (instant)     {         $.cookie("instant","1",{expires:365});-        searchBoxChange();+        $hoogle.keyup();     }     else         $.cookie("instant",null);@@ -72,6 +196,7 @@ // SEARCH PLUGIN  $(function(){+    if (embed) return;     if (window.external && ("AddSearchProvider" in window.external))         $("#plugin").css("display",""); });@@ -96,31 +221,9 @@   /////////////////////////////////////////////////////////////////////-// CACHE--function cache(maxElems)-{-    // FIXME: Currently does not evict things-    var contents = {}; // what we have in the cache--    return {-        add: function(key,val)-        {-            contents[key] = val;-        },-        -        ask: function(key)-        {-            return contents[key];-        }-    };-}----/////////////////////////////////////////////////////////////////////-// EXTERNAL jQUERY BITS+// LIBRARY BITS +// Access the browser query string // From http://stackoverflow.com/questions/901115/get-querystring-values-with-jquery/3867610#3867610 ;(function ($) {     $.extend({      @@ -146,3 +249,43 @@         }     }); })(jQuery);+++var Key = {+    Up: 38,+    Down: 40,+    Return: 13,+    Escape: 27+};+++function unpx(x){var r = 1 * x.replace("px",""); return isNaN(r) ? 0 : r;}+function px(x){return x + "px";}+++function cache(maxElems)+{+    // FIXME: Currently does not evict things+    var contents = {}; // what we have in the cache++    return {+        add: function(key,val)+        {+            contents[key] = val;+        },+        +        ask: function(key)+        {+            return contents[key];+        }+    };+}+++function watchdog(time, fun)+{+    var id = undefined;+    function stop(){if (id == undefined) return; window.clearTimeout(id); id = undefined;}+    function start(){stop(); id = window.setTimeout(function(){id = undefined; fun();}, time);}+    return {start:start, stop:stop}+}

@@ -0,0 +1,96 @@+/**+ * Cookie plugin+ *+ * Copyright (c) 2006 Klaus Hartl (stilbuero.de)+ * Dual licensed under the MIT and GPL licenses:+ * http://www.opensource.org/licenses/mit-license.php+ * http://www.gnu.org/licenses/gpl.html+ *+ */++/**+ * Create a cookie with the given name and value and other optional parameters.+ *+ * @example $.cookie('the_cookie', 'the_value');+ * @desc Set the value of a cookie.+ * @example $.cookie('the_cookie', 'the_value', { expires: 7, path: '/', domain: 'jquery.com', secure: true });+ * @desc Create a cookie with all available options.+ * @example $.cookie('the_cookie', 'the_value');+ * @desc Create a session cookie.+ * @example $.cookie('the_cookie', null);+ * @desc Delete a cookie by passing null as value. Keep in mind that you have to use the same path and domain+ *       used when the cookie was set.+ *+ * @param String name The name of the cookie.+ * @param String value The value of the cookie.+ * @param Object options An object literal containing key/value pairs to provide optional cookie attributes.+ * @option Number|Date expires Either an integer specifying the expiration date from now on in days or a Date object.+ *                             If a negative value is specified (e.g. a date in the past), the cookie will be deleted.+ *                             If set to null or omitted, the cookie will be a session cookie and will not be retained+ *                             when the the browser exits.+ * @option String path The value of the path atribute of the cookie (default: path of page that created the cookie).+ * @option String domain The value of the domain attribute of the cookie (default: domain of page that created the cookie).+ * @option Boolean secure If true, the secure attribute of the cookie will be set and the cookie transmission will+ *                        require a secure protocol (like HTTPS).+ * @type undefined+ *+ * @name $.cookie+ * @cat Plugins/Cookie+ * @author Klaus Hartl/klaus.hartl@stilbuero.de+ */++/**+ * Get the value of a cookie with the given name.+ *+ * @example $.cookie('the_cookie');+ * @desc Get the value of a cookie.+ *+ * @param String name The name of the cookie.+ * @return The value of the cookie.+ * @type String+ *+ * @name $.cookie+ * @cat Plugins/Cookie+ * @author Klaus Hartl/klaus.hartl@stilbuero.de+ */+jQuery.cookie = function(name, value, options) {+    if (typeof value != 'undefined') { // name and value given, set cookie+        options = options || {};+        if (value === null) {+            value = '';+            options.expires = -1;+        }+        var expires = '';+        if (options.expires && (typeof options.expires == 'number' || options.expires.toUTCString)) {+            var date;+            if (typeof options.expires == 'number') {+                date = new Date();+                date.setTime(date.getTime() + (options.expires * 24 * 60 * 60 * 1000));+            } else {+                date = options.expires;+            }+            expires = '; expires=' + date.toUTCString(); // use expires attribute, max-age is not supported by IE+        }+        // CAUTION: Needed to parenthesize options.path and options.domain+        // in the following expressions, otherwise they evaluate to undefined+        // in the packed version for some reason...+        var path = options.path ? '; path=' + (options.path) : '';+        var domain = options.domain ? '; domain=' + (options.domain) : '';+        var secure = options.secure ? '; secure' : '';+        document.cookie = [name, '=', encodeURIComponent(value), expires, path, domain, secure].join('');+    } else { // only name given, get cookie+        var cookieValue = null;+        if (document.cookie && document.cookie != '') {+            var cookies = document.cookie.split(';');+            for (var i = 0; i < cookies.length; i++) {+                var cookie = jQuery.trim(cookies[i]);+                // Does this cookie string begin with the name we want?+                if (cookie.substring(0, name.length + 1) == (name + '=')) {+                    cookieValue = decodeURIComponent(cookie.substring(name.length + 1));+                    break;+                }+            }+        }+        return cookieValue;+    }+};

@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hoogle-version:            4.1.5+version:            4.2 license:            GPL license-file:       docs/LICENSE category:           Development@@ -26,6 +26,7 @@     resources/*.png     -- surely a Cabal bug that this isn't picked up by *.js     resources/jquery-1.4.2.js+    resources/jquery.cookie.js  library     hs-source-dirs:     src@@ -84,6 +85,7 @@         Hoogle.DataBase.TypeSearch.All         Hoogle.Type.Documentation         Hoogle.Type.Item+        Hoogle.Type.Language         Hoogle.Type.TagStr         Hoogle.Type.TypeSig         Hoogle.Type.ParseError@@ -101,7 +103,7 @@     hs-source-dirs:     src      build-depends:-        time,+        time, old-locale,         cmdargs == 0.6.*,         tagsoup >= 0.11 && < 0.13,         network >= 2.2 && < 2.4,@@ -113,6 +115,7 @@         CmdLine.Load         CmdLine.Type         Console.All+        Console.Log         Console.Rank         Console.Search         Console.Test

@@ -95,6 +95,6 @@ cmdLineWeb args = cmdLineExpand $ blankSearch         {web=Just $ fromMaybe "web" $ ask ["mode"]         ,start=askInt ["start"], count=askInt ["count"]-        ,queryChunks = maybeToList $ ask ["q","hoogle"]}+        ,queryChunks = mapMaybe ask [["prefix"],["q","hoogle"],["suffix"]]}     where ask x = listToMaybe [b | (a,b) <- args, a `elem` x]           askInt x = readMay =<< ask x

@@ -35,6 +35,7 @@     | Server {port :: Int, local_ :: Bool, databases :: [FilePath], resources :: FilePath, nostdin :: Bool}     | Combine {srcfiles :: [FilePath], outfile :: String}     | Convert {srcfile :: String, outfile :: String}+    | Log {logfiles :: [FilePath]}     | Test {testFiles :: [String], example :: Bool}     | Dump {database :: String, section :: [String]}     | Rank {srcfile :: FilePath}@@ -43,7 +44,7 @@ emptyParseError = ParseError 0 0 "" $ Str "" blankSearch = Search False False False [] Nothing Nothing Nothing 1 [] (Left emptyParseError) "" -cmdLineMode = cmdArgsMode $ modes [search_ &= auto,dataa,server,combine,convert,test,dump,rank]+cmdLineMode = cmdArgsMode $ modes [search_ &= auto,data_,server,combine,convert,test,dump,rank,log_]     &= verbosity &= program "hoogle"     &= summary ("Hoogle v" ++ showVersion version ++ ", (C) Neil Mitchell 2004-2011\nhttp://haskell.org/hoogle") @@ -92,7 +93,7 @@     ,outfile = def &= argPos 1 &= typ "DATABASE" &= opt ""     } &= help "Convert an input file to a database" -dataa = Data+data_ = Data     {datadir = def &= typDir &= help "Database directory"     ,redownload = def &= help "Redownload all files from the web"     ,threads = def &= typ "INT" &= name "j" &= help "Number of threads to use" &= ignore -- ignore until it works@@ -105,3 +106,7 @@                  ,"  data default -- equialent to no arguments"                  ,"  data all"                  ]++log_ = Log+    {logfiles = def &= args &= typ "LOGFILE"+    } &= help "Analyse log files"

@@ -3,6 +3,7 @@  import CmdLine.All import Recipe.All+import Console.Log import Console.Search import Console.Test import Console.Rank@@ -33,6 +34,8 @@  action x@Data{} = recipes x +action (Log files) = logFiles files+ action (Convert from to) = do     to <- return $ if null to then replaceExtension from "hoo" else to     when (any isUpper $ takeBaseName to) $ putStrLn $ "Warning: Hoogle databases should be all lower case, " ++ takeBaseName to@@ -53,7 +56,7 @@     putStrLn $ "File: " ++ file     putStr $ showDatabase d $ if null sections then Nothing else Just sections -action q@Search{} | isBlankQuery $ fromRight $ queryParsed q =+action q@Search{} | fromRight (queryParsed q) == mempty =     exitMessage ["No query entered"                 ,"Try --help for command line options"] 

@@ -0,0 +1,205 @@+{-# LANGUAGE PatternGuards, RecordWildCards, ScopedTypeVariables #-}++-- | Analyse the log files. It's a three stage process.+--   1, parse each line separately.+--   2, collapse searches done between lines (instant, ajax, suggest)+--   3, draw overall statistics+module Console.Log(logFiles) where++import General.Base+import qualified Data.ByteString.Lazy.Char8 as BS+import qualified Data.Map as Map++type BString = BS.ByteString++logFiles :: [FilePath] -> IO ()+logFiles xs = do+    es <- mapM readEntries xs+    print $ mconcat $ map (stats . groupEntries) es++---------------------------------------------------------------------+-- STATISTICS++data Stats = Stats+    {hits :: !Int+    ,searches :: !Int+    ,common :: !(Map.Map BString Int)+    }++instance Show Stats where+    show Stats{..} = unlines+        ["Hits:      " ++ show hits+        ,"Searches:  " ++ show searches+        ,"Unique:    " ++ show (Map.size common)+        ,"Top:       " ++ fromList "" (map (BS.unpack . fst) top)+        ]+        where+            top = take 20 $ sortBy (comparing $ negate . snd) $ Map.toList common+++instance Monoid Stats where+    mempty = Stats 0 0 Map.empty+    mappend (Stats x1 x2 x3) (Stats y1 y2 y3) = Stats (x1+y1) (x2+y2) (Map.unionWith (+) x3 y3)++stats :: [Entry] -> Stats+stats = foldl' f mempty+    where+        f s@Stats{..} Entry{..} = s+            {hits = 1 + hits+            ,searches = (if BS.null search then 0 else 1) + searches+            ,common = if BS.null search then common else Map.insertWith' (+) search 1 common+            }+++---------------------------------------------------------------------+-- GROUP ENTRIES++groupEntries :: [Entry] -> [Entry]+groupEntries = id+++---------------------------------------------------------------------+-- READ ENTRIES++data Entry = Entry+    {search :: BString -- the search performed, "" for blank+    ,extra :: [(BString,BString)] -- extra parameters+    ,date :: Maybe (Int,Int,Int) -- date the search was performed+    ,time :: Maybe (Int,Int,Int) -- time the search was performed+    ,unique :: Maybe String -- maybe a uniquely identifying string+    ,instant :: Maybe Int -- number of times you hit with instant for this query+    ,suggest :: Maybe Int -- number of times you hit with suggest for this query+    } deriving Show++entry = Entry BS.empty [] Nothing Nothing Nothing Nothing Nothing+++readEntries :: FilePath -> IO [Entry]+readEntries x = do+    src <- BS.readFile x+    return $ mapMaybe readEntry $ BS.lines src+++qstr = map BS.pack ["","q","hoogle"]++readEntry :: BString -> Maybe Entry++-- log format v1+readEntry x+    | Just ('[',x) <- BS.uncons x+    = do y <- readList x+         let (a,b) = partition (flip elem qstr . fst) y+         return entry{search=fromList BS.empty $ map snd a, extra = b}+    where+        readList x = do+            ('(',x) <- BS.uncons x+            (a,x) <- readShowString x+            (',',x) <- BS.uncons x+            (b,x) <- readShowString x+            (')',x) <- BS.uncons x+            case BS.uncons x of+                Just (',',x) -> do+                    ys <- readList x+                    return $ (a,b):ys+                Just (']',x) -> do+                    return [(a,b)]+                _ -> Nothing++-- log format v2+readEntry o@x+    | BS.length x > 10 && BS.index x 10 == ' '+    = do (d,x) <- readDate x+         (' ',x) <- BS.uncons x+         (s,x) <- readShowString x+         args <- readArgs $ BS.dropWhile isSpace x+         return entry{search = s, date = Just d,+                extra = filter (flip notElem qstr . fst) args}+    where+        readArgs x+            | Just ('?',x) <- BS.uncons x = do+              (a,x) <- return $ BS.break (== '=') x+              ('=',x) <- BS.uncons x+              (b,x) <- readQuoteString x+              x <- return $ BS.dropWhile isSpace x+              ys <- readArgs x+              return $ (a,b) : ys+            | otherwise = Just []+    ++-- log format v3+readEntry x+    | BS.length x > 10 && BS.index x 10 == 'T'+    = do ((d,t),x) <- readDateTime x+         (' ',x) <- BS.uncons x+         (u,x) <- return $ first BS.unpack $ BS.break (== ' ') x+         args <- readArgs $ BS.dropWhile isSpace x+         let (a,b) = partition (flip elem qstr . fst) args+         return entry{date = Just d, time = Just t, extra = b,+            search=fromList BS.empty $ map snd a,+            unique = if u == "0" then Nothing else Just u}+    where+        readArgs x+            | BS.null x = Just []+            | otherwise = do+                (a,x) <- readShortString x+                ('=',x) <- BS.uncons x+                (b,x) <- readShortString x+                ys <- readArgs $ BS.dropWhile isSpace x+                return $ (a,b):ys++readEntry _ = Nothing+++---------------------------------------------------------------------+-- READ UTILITIES++readDate :: BString -> Maybe ((Int,Int,Int), BString)+readDate x = do+    (d1,x) <- BS.readInt x+    ('-',x) <- BS.uncons x+    (d2,x) <- BS.readInt x+    ('-',x) <- BS.uncons x+    (d3,x) <- BS.readInt x+    return ((d1,d2,d2),x)++readDateTime :: BString -> Maybe (((Int,Int,Int),(Int,Int,Int)), BString)+readDateTime x = do+    (d,x) <- readDate x+    ('T',x) <- BS.uncons x+    (t1,x) <- BS.readInt x+    (':',x) <- BS.uncons x+    (t2,x) <- BS.readInt x+    (':',x) <- BS.uncons x+    (t3,x) <- BS.readInt x+    return ((d,(t1,t2,t3)),x)+++-- | String, as produced by show+readShowString :: BString -> Maybe (BString, BString)+readShowString o@x = do+    ('\"',x) <- BS.uncons x+    (a,x) <- return $ BS.break (== '\"') x+    if '\\' `BS.elem` a then do+        [(a,x)] <- return $ reads $ BS.unpack o+        return (BS.pack a, BS.pack x)+     else do+        ('\"',x) <- BS.uncons x+        return (a, x)+++-- | Either a string produced by show, or a isAlphaNum terminated chunk+readShortString :: BString -> Maybe (BString, BString)+readShortString x | Just ('\"',_) <- BS.uncons x = readShowString x+                  | otherwise = Just $ BS.span isAlphaNum x+++-- | Either a space terminated chunk, or a quote terminated chunk+readQuoteString :: BString -> Maybe (BString, BString)+readQuoteString x | Just ('\"',x) <- BS.uncons x = do+    (a,x) <- return $ BS.break (== '\"') x+    ('\"',x) <- BS.uncons x+    return (a, BS.dropWhile isSpace x)+readQuoteString x = do+    (a,x) <- return $ BS.break (== ' ') x+    return (a, BS.dropWhile isSpace x)+

@@ -22,7 +22,7 @@                   ["Generate more databases with: hoogle data all" | length n < 100] ++                   ["Found " ++ show (length n) ++ " databases, including: " ++ unwords (take 5 n) | not $ null n]) -    let sug = querySuggestions dbs q+    let sug = suggestions dbs q     when (isJust sug) $         putStrLn $ showTag $ fromJust sug     verbose <- isLoud

@@ -31,6 +31,8 @@ thd3 (a,b,c) = c  +swap (a,b) = (b,a)+ fromLeft (Left x) = x fromRight (Right x) = x @@ -101,3 +103,8 @@ chop _ [] = [] chop f as = b : chop f as'     where (b, as') = f as+++fromList :: a -> [a] -> a+fromList x [] = x+fromList x (y:ys) = y

@@ -69,3 +69,7 @@  exitMessage :: [String] -> IO a exitMessage msg = putStr (unlines msg) >> exitFailure+++getEnvVar :: String -> IO (Maybe String)+getEnvVar x = catch (fmap Just $ getEnv x) (const $ return Nothing)

@@ -92,14 +92,10 @@ -- However, it does always set REQUEST_URI. cgiVariable :: IO (Maybe String) cgiVariable = do-    str <- envVariable "QUERY_STRING"+    str <- getEnvVar "QUERY_STRING"     if isJust str         then return str-        else fmap (fmap $ const "") $ envVariable "REQUEST_URI"---envVariable :: String -> IO (Maybe String)-envVariable x = catch (fmap Just $ getEnv x) (const $ return Nothing)+        else fmap (fmap $ const "") $ getEnvVar "REQUEST_URI"   cgiArgs :: IO (Maybe Args)

@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}  -- | The Hoogle API. To perform a search you call 'search' with a 'Database' (obtained by 'loadDatabase') and a --   'Query' (obtained by 'parseQuery').@@ -7,20 +6,19 @@     TagStr(..), showTagText, showTagANSI, showTagHTML, showTagHTMLWith,     H.ParseError(..),     URL,-    Language(..),+    H.Language(..),     -- * Database     Database, loadDatabase, saveDatabase, createDatabase, showDatabase,     -- * Query-    Query(..), H.Scope(..), parseQuery, H.renderQuery, H.isBlankQuery,-    queryDatabases, querySuggestions, queryCompletions,+    Query, parseQuery, H.renderQuery,+    H.queryDatabases, H.queryPackages, H.querySetPackage,     -- * Score     Score, H.scoring,     -- * Search-    Result(..), search+    Result(..), search, suggestions, completions     ) where  import Data.Binary.Defer.Index-import Data.Data import General.Base import General.System @@ -36,10 +34,6 @@ import Hoogle.Score.All(Score)  --- | The languages supported by Hoogle.-data Language = Haskell -- ^ The Haskell language (<http://haskell.org/>), along with many GHC specific extensions.-    deriving (Enum,Read,Show,Eq,Ord,Bounded,Data,Typeable)- -- * Database  -- | A Hoogle database, containing a set of functions/items which can be searched. The 'Database' type is used@@ -80,7 +74,7 @@ -- | Create a database from an input definition. Source files for Hoogle databases are usually --   stored in UTF8 format, and should be read using 'hSetEncoding' and 'utf8'. createDatabase-    :: Language -- ^ Which format the input definition is in.+    :: H.Language -- ^ Which format the input definition is in.     -> [Database] -- ^ A list of databases which contain definitions this input definition relies upon (e.g. types, aliases, instances).     -> String -- ^ The input definitions, usually with one definition per line, in a format specified by the 'Language'.     -> ([H.ParseError], Database) -- ^ A pair containing any parse errors present in the input definition, and the database ignoring any parse errors.@@ -99,24 +93,10 @@ -- Hoogle.Query  -- | Parse a query for a given language, returning either a parse error, or a query.-parseQuery :: Language -> String -> Either H.ParseError Query+parseQuery :: H.Language -> String -> Either H.ParseError Query parseQuery _ = H.parseQuery --- | Given a query, return the list of packages that should be searched. Each package will be---   the name of a database, without any file path or extension included.-queryDatabases :: Query -> [String]-queryDatabases x = if null ps then ["default"] else ps-    where ps = [p | H.PlusPackage p <- H.scope x] --- | Given a query and a database optionally give a list of what the user might have meant.-querySuggestions :: Database -> Query -> Maybe TagStr-querySuggestions (Database dbs) q = H.suggestQuery dbs q---- | Given a query data a database return a list of the possible completions for the search.-queryCompletions :: Database -> String -> [String]-queryCompletions x = H.completions (toDataBase x)-- -- Hoogle.Search  -- Invariant: locations will not be empty@@ -140,3 +120,11 @@ -- | Perform a search. The results are returned lazily. search :: Database -> Query -> [(Score,Result)] search (Database xs) q = map toResult $ H.search xs q++-- | Given a query and a database optionally give a list of what the user might have meant.+suggestions :: Database -> Query -> Maybe TagStr+suggestions (Database dbs) q = H.suggestQuery dbs q++-- | Given a query string and a database return a list of the possible completions for the search.+completions :: Database -> String -> [String]+completions x = H.completions (toDataBase x)

@@ -35,12 +35,11 @@ parseLine :: Int -> String -> Either ParseError ([Fact],[TextItem]) parseLine line x | "(##)" `isPrefixOf` x = Left $ parseErrorWith line 1 "Skipping due to HSE bug #206" "(##)" parseLine line ('@':str) = case a of-        "entry" -> Right $ itemEntry $ dropWhile isSpace b-        "package" -> Right $ itemPackage $ dropWhile isSpace b+        "entry" | b <- words b, b /= [] -> Right $ itemEntry b+        "package" | [b] <- words b, b /= "" -> Right $ itemPackage b         _ -> Left $ parseErrorWith line 2 ("Unknown attribute: " ++ a) $ '@':str     where (a,b) = break isSpace str-parseLine line x | a == "module" = Right $ itemModule $ split '.' $ dropWhile isSpace b-    where (a,b) = break isSpace x+parseLine line x | ["module",a] <- words x = Right $ itemModule $ split '.' a parseLine line x     | not continue = res     | otherwise = fromMaybe res $ fmap Right $ parseTuple x `mappend` parseCtor x@@ -80,10 +79,9 @@     itemURL="http://hackage.haskell.org/package/" ++ x ++ "/",     itemDisp=Tags [emph "package",space,bold x]} -itemEntry x = fact [] $ textItem{itemName=ab, itemKey=ab,-    itemDisp= if null b then bold a else Tags [emph a,space,bold b]}-    where (a,b) = second (dropWhile isSpace) $ break isSpace x-          ab = if null b then a else b+itemEntry (x:xs) = fact [] $ textItem{itemName=y, itemKey=y,+    itemDisp= if null xs then bold x else Tags [emph x,space,bold y]}+    where y = if null xs then x else unwords xs  itemModule xs = fact [] $ textItem{itemLevel=1, itemKey=last xs, itemName=intercalate "." xs,     itemURL="",

@@ -28,10 +28,6 @@ optionBool p = (p >> return True) <|> return False  -joinQuery (Query a1 b1 c1) (Query a2 b2 c2) = Query (a1++a2) (b1 `mplus` b2) (c1++c2)-joinQueries = foldr joinQuery blankQuery-- --------------------------------------------------------------------- -- QUERY PARSEC @@ -41,19 +37,19 @@         end f = do x <- f; eof; return x              names = do a <- many (flag <|> name)-                   b <- option blankQuery (string "::" >> spaces >> types)-                   let res@Query{names=names} = joinQuery (joinQueries a) b+                   b <- option mempty (string "::" >> spaces >> types)+                   let res@Query{names=names} = mappend (mconcat a) b                        (op,nop) = partition ((`elem` ascSymbols) . head) names                    if op /= [] && nop /= []                        then fail "Combination of operators and names"                        else return res         -        name = (do x <- operator ; spaces ; return blankQuery{names=[x]})+        name = (do x <- operator ; spaces ; return mempty{names=[x]})                <|>                (do xs <- keyword `sepBy1` (char '.') ; spaces                    return $ case xs of-                       [x] -> blankQuery{names=[x]}-                       xs -> blankQuery{names=[last xs],scope=[PlusModule (init xs)]}+                       [x] -> mempty{names=[x]}+                       xs -> mempty{names=[last xs],scope=[PlusModule (init xs)]}                )                  operator = between (char '(') (char ')') op <|> op@@ -65,10 +61,10 @@         types = do a <- flags                    b <- parsecTypeSig                    c <- flags-                   return $ joinQueries [a,blankQuery{typeSig=Just b},c]+                   return $ mconcat [a,mempty{typeSig=Just b},c] -        flag = try $ do x <- parseFlagScope ; spaces ; return x-        flags = fmap joinQueries $ many flag+        flag = try $ do x <- parseFlagScope; spaces; return x+        flags = fmap mconcat $ many flag   -- deal with the parsing of:@@ -82,8 +78,8 @@         modname  = keyword `sepBy1` (char '.')     modu <- modname     case modu of-        [x] -> return $ blankQuery{scope=[if isLower (head x) then aPackage x else aModule [x]]}-        xs -> return $ blankQuery{scope=[aModule xs]}+        [x] -> return $ mempty{scope=[if isLower (head x) then aPackage x else aModule [x]]}+        xs -> return $ mempty{scope=[aModule xs]}   keyword = do

@@ -2,8 +2,7 @@  module Hoogle.Query.Type where -import Data.Maybe-import Data.Data+import General.Base import Hoogle.Type.All  @@ -15,14 +14,10 @@     }     deriving (Data,Typeable,Show,Eq) ---- | Test if a query will result in a search being performed. A query which lists only scopes---   (e.g. @+base@) will still be reported is blank.-isBlankQuery :: Query -> Bool-isBlankQuery query = null (names query) && isNothing (typeSig query)--blankQuery :: Query-blankQuery = Query [] Nothing []+instance Monoid Query where+    mempty = Query [] Nothing []+    mappend (Query x1 x2 x3) (Query y1 y2 y3) =+        Query (x1++y1) (x2 `mplus` y2) (x3++y3)   data Scope = PlusPackage  String@@ -31,5 +26,26 @@            | MinusModule [String]            deriving (Eq, Show, Read, Data, Typeable) -isPlusModule  (PlusModule  _) = True; isPlusModule  _ = False-isMinusModule (MinusModule _) = True; isMinusModule _ = False++-- | Given a query, return the list of packages that should be searched. Each package will be+--   the name of a database, without any file path or extension included.+queryDatabases :: Query -> [String]+queryDatabases x = if null ps then ["default"] else ps+    where ps = [p | PlusPackage p <- scope x]+++-- | Return those packages which are explicitly excluded (paired with 'False')+--   or included (paired with 'True') in the query.+queryPackages :: Query -> [(Bool, String)]+queryPackages = concatMap f . scope+    where f (MinusPackage x) = [(False,x)]+          f (PlusPackage  x) = [(True ,x)]+          f _ = []++-- | Set the state of a package within a query. 'Nothing' means delete the package,+--   'Just' 'True' for add it, and 'Just' 'False' for remove it.+querySetPackage :: Maybe Bool -> String -> Query -> Query+querySetPackage b x q = q{scope= filter f (scope q) ++ [if b then PlusPackage x else MinusPackage x | Just b <- [b]]}+    where f (MinusPackage y) = x /= y+          f (PlusPackage  y) = x /= y+          f _ = True

@@ -70,10 +70,14 @@         f [] act = id         f xs act = filter (act xs . fromLink . resultEntry) -        mods = filter (\x -> isPlusModule x || isMinusModule x) $ scope q+        mods = filter isMod $ scope q         pkgs = [x | MinusPackage x <- scope q] +        isMod PlusModule{}  = True+        isMod MinusModule{} = True+        isMod _ = False + -- pkgs is a non-empty list of MinusPackage values correctPackage :: [String] -> Entry -> Bool correctPackage pkgs x = null myPkgs || any (maybe True (`notElem` pkgs)) myPkgs@@ -85,7 +89,7 @@ correctModule mods x = null myMods || any (maybe True (f base mods . split '.')) myMods     where         myMods = map (fmap (entryName . fromLink) . listToMaybe . drop 1 . snd) $ entryLocations x-        base = isMinusModule $ head mods+        base = case head mods of MinusModule{} -> True; _ -> False          f z [] y = z         f z (PlusModule  x:xs) y | doesMatch x y = f True  xs y

@@ -3,6 +3,7 @@  import Hoogle.Type.Documentation  as X import Hoogle.Type.Item           as X+import Hoogle.Type.Language       as X import Hoogle.Type.ParseError     as X import Hoogle.Type.Result         as X import Hoogle.Type.TagStr         as X

@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Hoogle.Type.Language where++import General.Base+++-- | The languages supported by Hoogle.+data Language+    = Haskell -- ^ The Haskell language (<http://haskell.org/>), along with many GHC specific extensions.+    deriving (Enum,Read,Show,Eq,Ord,Bounded,Data,Typeable)

@@ -14,7 +14,7 @@  translate :: String -> String translate src = unlines $ keywordPrefix ++ items-    where items = concatMap keywordFormat $ partitions (~== "<a name>") $+    where items = concatMap keywordFormat $ drop 1 $ partitions (~== "<a name>") $                   takeWhile (~/= "<div class=printfooter>") $ parseTags src  

@@ -1,13 +1,14 @@  module Test.Parse_Query(parse_Query) where +import General.Base import Test.General import Hoogle.Query.All import Hoogle.Type.All  parse_Query = do     let (===) = parseTest parseQuery-        q = blankQuery+        q = mempty      "map" === q{names = ["map"]}     "#" === q{names = ["#"]}

@@ -13,4 +13,4 @@ -- FIXME: Should use datadir, but not sure how action q = do     res <- response "datadir/resources" q-    putStrLn $ intercalate "\n" $ map show (rspHeaders res) ++ ["",rspBody res]+    putStrLn $ intercalate "\n" $ map (takeWhile (`notElem` "\r\n") . show) (rspHeaders res) ++ ["",rspBody res]

@@ -3,8 +3,13 @@  import General.Web import General.Util+import qualified Paths_hoogle(version)+import Data.Version(showVersion)  +version = showVersion Paths_hoogle.version++ searchLink :: String -> URL searchLink x = "?hoogle=" ++% x @@ -15,12 +20,12 @@     ,"  <head profile='http://a9.com/-/spec/opensearch/1.1/'>"     ,"     <meta http-equiv='Content-Type' content='text/html; charset=iso-8859-1' />"     ,"     <title>" ++ (query ++? " - ") ++ "Hoogle</title>"-    ,"     <link type='text/css' rel='stylesheet' href='" ++ resources ++ "/hoogle.css' />"+    ,"     <link type='text/css' rel='stylesheet' href='" ++ resources ++ "/hoogle.css?version=" ++% version ++ "' />"     ,"     <link type='image/png' rel='icon' href='" ++ resources ++ "/favicon.png' />"     ,"     <link type='application/opensearchdescription+xml' rel='search' href='" ++ resources ++ "/search.xml' title='Hoogle' />"     ,"     <script type='text/javascript' src='" ++ resources ++ "/jquery-1.4.2.js'> </script>"     ,"     <script type='text/javascript' src='" ++ resources ++ "/jquery.cookie.js'> </script>"-    ,"     <script type='text/javascript' src='" ++ resources ++ "/hoogle.js'> </script>"+    ,"     <script type='text/javascript' src='" ++ resources ++ "/hoogle.js?version=" ++% version ++ "'> </script>"     ,"  </head>"     ,"  <body>"     ] ++ links ++ search resources query ++@@ -42,7 +47,7 @@     ,"  <a id='logo' href='http://haskell.org/hoogle/'>" ++          "<img src='" ++ resources ++ "/hoogle.png' width='160' height='58' alt='Hoogle' />" ++        "</a>"-    ,"  <input name='hoogle' id='hoogle' type='text' autocomplete='off' value=\"" ++ query ++ "\" />"+    ,"  <input name='hoogle' id='hoogle' class='HOOGLE_REAL' type='text' autocomplete='off' value=\"" ++ query ++ "\" />"     ,"  <input id='submit' type='submit' value='Search' />"     ,"</form>"     ]@@ -50,7 +55,7 @@  footer =     ["</div>"-    ,"    <p id='footer'>&copy; <a href='http://community.haskell.org/~ndm/'>Neil Mitchell</a> 2004-2011</p>"+    ,"    <p id='footer'>&copy; <a href='http://community.haskell.org/~ndm/'>Neil Mitchell</a> 2004-2011, version " ++& version ++ "</p>"     ,"  </body>"     ,"</html>"     ]

@@ -5,14 +5,17 @@ import CmdLine.All import Hoogle import General.Base+import General.System import General.Util import General.Web import Web.Page import Data.Generics.Uniplate  import Data.Time.Clock-import Data.Time.Calendar+import Data.Time.Format+import System.Locale import Network.HTTP+import System.IO.Unsafe(unsafeInterleaveIO)   logFile = "log.txt"@@ -21,43 +24,57 @@ response :: FilePath -> CmdLine -> IO (Response String) response resources q = do     logMessage q-    let response x = responseOk [Header HdrContentType x]+    let response x ys = responseOk $ [Header HdrContentType x] ++ ys -    let res ajax = do-            dbs <- if isRight $ queryParsed q-                   then fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q)-                   else return mempty-            return $ runQuery ajax dbs q+    dbs <- unsafeInterleaveIO $ case queryParsed q of+        Left _ -> return mempty+        Right x -> fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q)      case web q of-        Just "ajax" -> do-            res <- res True-            return $ response "text/html" $ unlines res-        Just "web" -> do-            res <- res False-            return $ response "text/html" $ unlines $ header resources (escapeHTML $ queryText q) ++ res ++ footer-        Just "suggest" -> fmap (response "application/json") $ runSuggest q-        Just e -> return $ response "text/html" $ "Unknown webmode: " ++ e+        Just "suggest" -> fmap (response "application/json" []) $ runSuggest q+        Just "embed" -> return $ response "text/html" [hdr] $ unlines $ runEmbed dbs q+            where hdr = Header (HdrCustom "Access-Control-Allow-Origin") "*"+        Just "ajax" -> return $ response "text/html" [] $ unlines $ runQuery True dbs q+        Just "web" -> return $ response "text/html" [] $ unlines $+            header resources (escapeHTML $ queryText q) +++            runQuery False dbs q ++ footer+        mode -> return $ response "text/html" [] $ "Unknown webmode: " ++ fromMaybe "none" mode   logMessage :: CmdLine -> IO () logMessage q = do     time <- getCurrentTime-    cgi <- fmap (fromMaybe []) cgiArgs+    args <- fmap (fromMaybe [("hoogle",queryText q)]) cgiArgs+    ip <- fmap (fromMaybe "0") $ getEnvVar "REMOTE_ADDR"+    let shw x = if all isAlphaNum x then x else show x     appendFile logFile $ (++ "\n") $ unwords $-        [showGregorian (utctDay time)-        ,show (queryText q)] ++-        ["?" ++ a ++ "=" ++ c ++ b ++ c | (a,b) <- cgi, let c = ['\"' | any isSpace b]]+        [formatTime defaultTimeLocale "%FT%T" time+        ,ip] +++        [shw a ++ "=" ++ shw b | (a,b) <- args]   runSuggest :: CmdLine -> IO String runSuggest cq@Search{queryText=q} = do-    (_, db) <- loadQueryDatabases (databases cq) (Query [] Nothing [])-    let res = queryCompletions db q+    (_, db) <- loadQueryDatabases (databases cq) mempty+    let res = completions db q     return $ "[" ++ show q ++ "," ++ show res ++ "]" runSuggest _ = return ""  +runEmbed :: Database -> CmdLine -> [String]+runEmbed dbs Search{queryParsed = Left err} = ["<i>Parse error: " ++& errorMessage err ++ "</i>"]+runEmbed dbs cq@Search{queryParsed = Right q}+    | null now = ["<i>No results found</i>"]+    | otherwise =+        ["<a href='" ++ url ++ "'>" ++ showTagHTML (transform f $ self $ snd x) ++ "</a>"+        | x <- now, let url = fromList "" $ map fst $ locations $ snd x]+    where+        now = take (maybe 10 (max 1) $ count cq) $ search dbs q+        f (TagEmph x) = TagBold x+        f (TagBold x) = x+        f x = x++ runQuery :: Bool -> Database -> CmdLine -> [String] runQuery ajax dbs Search{queryParsed = Left err} =     ["<h1>" ++ showTagHTMLWith f (parseInput err) ++ "</h1>"@@ -73,14 +90,14 @@         f _ = Nothing  -runQuery ajax dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome+runQuery ajax dbs q | fromRight (queryParsed q) == mempty = welcome   runQuery ajax dbs cq@Search{queryParsed = Right q, queryText = qt} =     (if prefix then         ["<h1>" ++ qstr ++ "</h1>"] ++         ["<div id='left'>" ++ also ++ "</div>" | not $ null pkgs] ++-        ["<p>" ++ showTag sug ++ "</p>" | Just sug <- [querySuggestions dbs q]] +++        ["<p>" ++ showTag sug ++ "</p>" | Just sug <- [suggestions dbs q]] ++         if null res then             ["<p>No results found</p>"]         else@@ -99,16 +116,17 @@         (now,post) = splitAt count2 res2          also = "<ul><li><b>Packages</b></li>" ++ concatMap f (take (5 + length minus) $ nub $ minus ++ pkgs) ++ "</ul>"-            where minus = [x | MinusPackage x <- scope q]-        f x | PlusPackage lx `elem` scope q =-                let q2 = showTagText $ renderQuery $ q{scope = filter (/= PlusPackage lx) $ scope q} in+            where minus = [x | (False,x) <- queryPackages q]+        f x | (True,lx) `elem` queryPackages q =+                let q2 = showTagText $ renderQuery $ querySetPackage Nothing lx q in                 "<li><a class='minus' href='" ++ searchLink q2 ++ "'>" ++ x ++ "</a></li>"-            | MinusPackage lx `elem` scope q =-                let q2 = showTagText $ renderQuery $ q{scope = filter (/= MinusPackage lx) $ scope q} in+            | (False,lx) `elem` queryPackages q =+                let q2 = showTagText $ renderQuery $ querySetPackage Nothing lx q in                 "<li><a class='plus pad' href='" ++ searchLink q2 ++ "'>" ++ x ++ "</a></li>"             | otherwise =-                "<li><a class='minus' href='" ++ searchLink (qt ++ " -" ++ lx) ++ "'></a>" ++-                "<a class='plus' href='" ++ searchLink (qt ++ " +" ++ lx) ++ "'>" ++ x ++ "</a></li>"+                let link b = searchLink $ showTagText $ renderQuery $ querySetPackage (Just b) lx q in+                "<li><a class='minus' href='" ++ link False ++ "'></a>" +++                "<a class='plus' href='" ++ link True ++ "'>" ++ x ++ "</a></li>"             where lx = map toLower x         pkgs = [x | (_, (_,x):_)  <- concatMap (locations . snd) $ take (start2+count2) src]