packages feed

hoogle 4.0.0.1 → 4.0.0.2

raw patch · 13 files changed

+188/−138 lines, 13 files

Files

hoogle.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.1.4 build-type:         Simple name:               hoogle-version:            4.0.0.1+version:            4.0.0.2 license:            GPL license-file:       LICENSE category:           Development@@ -89,7 +89,6 @@     Hoogle.TypeSig.All     Hoogle.TypeSig.Parser     Hoogle.TypeSig.Type-    Main     Test.All     Test.General     Test.Parse_Query@@ -97,3 +96,4 @@     Test.Parse_TypeSig     Web.Action     Web.All+    Web.Page
src/CmdLine/All.hs view
@@ -1,8 +1,10 @@  module CmdLine.All(     module CmdLine.Query,+    module CmdLine.Flag,     module CmdLine.Action     ) where  import CmdLine.Query+import CmdLine.Flag import CmdLine.Action
src/CmdLine/Flag.hs view
@@ -34,7 +34,7 @@              | Include FilePath  -- ^ Include directory              | TestFile FilePath -- ^ Run tests in a file              | Rank FilePath     -- ^ Generate rankings-               deriving (Eq {-! Enum !-} )+               deriving (Show,Eq {-! Enum !-} )   -- | In which circumstances are you allowed to pass this command
src/CmdLine/Query.hs view
@@ -3,9 +3,9 @@     or the command line arguments.      Need to return the following pieces of information:-    +     * Was there a query, or was nothing entered-    +     * Are you wanting to operate in Web mode or Command Line mode. Adding a     Web parameter to Command Line gives you Web mode. @@ -24,11 +24,11 @@  data CmdQuery = CmdQuery {     queryWeb :: Bool, -- ^ Are you operating from the web (via CGI)-    queryText :: String, -- ^ The string the user entered, @""@ for no string+    queryText :: String, -- ^ The string the user entered, @\"\"@ for no string     query :: Either ParseError Query, -- ^ The actual query     queryFlags :: [CmdFlag], -- ^ The flags from the query     queryBadFlags :: [String] -- ^ The bad flags-    }+    } deriving Show   -- | Left (query text, error message), null query text = no query given@@ -57,11 +57,12 @@  cmdQueryArgs :: [String] -> IO CmdQuery cmdQueryArgs xs = case parseCmdLineQuery xs of-    Left err -> return $ CmdQuery False orig (Left err) [] []+    Left err -> return $ CmdQuery (hasFlag ["w","web"]) orig (Left err) [Debug | hasFlag ["debug"]] []     Right res -> do         (flags,bad) <- flagsCmdLine $ queryArgs res         return $ CmdQuery (Web `elem` flags) orig (Right res) flags bad     where orig = unwords $ map quote xs+          hasFlag names = or [(a++b) `elem` xs | a <- ["/","--"], b <- names]   quote :: String -> String
src/CmdLine/Search.hs view
@@ -48,7 +48,7 @@          verbose = Verbose `elem` flags         color = Color True `elem` flags-        showTag = if color then showTagConsole else show+        showTag = if color then showTagConsole else showTagText          f (m,r,v) = maybe "" (\m -> showModule m ++ " ") m ++                     showTag r ++ (if verbose then "  -- " ++ v else "")
src/CmdLine/Test.hs view
@@ -21,7 +21,7 @@   -- LineNo Query Results-data Test = Test Int String Query [String]+data Test = Test Int String Query [[String]]             deriving Show  @@ -29,7 +29,7 @@ parseTest line str | "@test " `isPrefixOf` str =     case reads $ drop 5 str of         [(x,rest)] -> case parseQuery x of-            Right q -> Just $ Test line x q (words rest)+            Right q -> Just $ Test line x q (map (split ',') $ words rest)             _ -> err         _ -> err     where err = error $ "Couldn't parse @test on line " ++ show line@@ -37,15 +37,16 @@   runTest :: DataBase -> Test -> Bool-runTest db (Test _ _ q ans) = f ans $ searchAll [db] q+runTest db (Test _ _ q ans) =+        ordered (group $ map resultScore res) &&       -- all results are in order+        all (`elem` map fst items) (concat ans) &&     -- all items are present+        ordered (map (map (`lookupJust` items)) ans)   -- all items are in order     where-        f ["*"] _ = True-        f ("*":x:xs) (m:ms) = f (if g x m then xs else "*":x:xs) ms-        f (x:xs) (m:ms) = g x m && f xs ms-        f [] [] = True-        f _ _ = False+        res = searchAll [db] q+        items = map (entryName . fromLink . resultEntry &&& resultScore) res -        g name m = name == entryName (fromLink $ resultEntry m)+        ordered ((x:xs):(y:ys):zs) = x < y && all (== x) xs && ordered ((y:ys):zs)+        ordered [x:xs] = all (== x) xs   failedTest :: Test -> String
src/Data/TagStr.hs view
@@ -3,6 +3,7 @@  import Data.Char import Data.List+import Data.Generics.Uniplate   data TagStr = Str String@@ -11,46 +12,38 @@             | TagUnderline TagStr             | TagHyperlink String TagStr             | TagColor Int TagStr+              deriving Show  -tagInner (TagBold x) = x-tagInner (TagUnderline x) = x-tagInner (TagHyperlink _ x) = x-tagInner (TagColor _ x) = x+instance Uniplate TagStr where+    uniplate (Tags xs) = (xs, Tags)+    uniplate (TagBold x) = ([x], \[x] -> TagBold x)+    uniplate (TagUnderline x) = ([x], \[x] -> TagUnderline x)+    uniplate (TagHyperlink i x) = ([x], \[x] -> TagHyperlink i x)+    uniplate (TagColor i x) = ([x], \[x] -> TagColor i x)+    uniplate x = ([], const x)  -showTag :: TagStr -> String-showTag x = f x-    where-        f (Str x) = x-        f (Tags x) = concatMap f x-        f x = f $ tagInner x+showTagText :: TagStr -> String+showTagText x = concat [y | Str y <- universe x]   showTagConsole :: TagStr -> String showTagConsole x = f [] x     where         f a (Str x) = x-        f a (Tags xs) = concatMap (f a) xs          f a t =             case getCode t of-                Nothing -> f a x-                Just val -> tag (val:a) ++ f (val:a) x ++ tag a-            where x = tagInner t+                Nothing -> g a+                Just val -> tag (val:a) ++ g (val:a) ++ tag a+            where g a = concatMap (f a) (children t)                  getCode (TagBold _) = Just "1"-        getCode (TagHyperlink _ _) = Just "4"+        getCode (TagHyperlink url _) = if null url then Nothing else Just "4"         getCode (TagUnderline _) = Just "4"         getCode (TagColor n _) | n <= 5 && n >= 0 = Just ['3', intToDigit (n + 1)]         getCode _ = Nothing-        -        tag stack = chr 27 : '[' : (concat $ intersperse ";" $ ("0":reverse stack)) ++ "m" --+        tag stack = chr 27 : '[' : (concat $ intersperse ";" $ ("0":reverse stack)) ++ "m" -instance Show TagStr where-    show (Str x) = x-    show (Tags x) = concatMap show x-    show x = show $ tagInner x
src/Hoogle/DataBase/TypeSearch/Result.hs view
@@ -84,4 +84,6 @@     b <- mergeBindings $ map resultArgBind $ args ++ [res]     let s = newTypeScore is query (fromLink e) b         view = zipWith ArgPosNum [0..] $ map resultArgPos args-    return (e, view, s)+        -- need to fake at least one ArgPosNum, so we know we have some highlight info+        view2 = [ArgPosNum (-1) (-1) | null view] ++ view+    return (e, view2, s)
src/Hoogle/DataBase/TypeSearch/TypeScore.hs view
@@ -52,7 +52,7 @@             (entryInfoAlias query `diff` entryInfoAlias result)          diff a b = (a \\ b, b \\ a)-        ctx = nub $ concat [f c b | (c,v) <- entryInfoContext result, (TVar a, b) <- bindings bs, a == v]+        ctx = nub $ concat [f c b | (c,v) <- entryInfoContext result, (b, TVar a) <- bindings bs, a == v]         f c (TVar v) = [(c,v)]         f c (TLit l) = [(c,l) | not $ hasInstance is c l]
src/Hoogle/Item/Item.hs view
@@ -85,7 +85,7 @@         f (ArgPos i s) = (if null res then id else TagColor (head res)) $ Str s             where res = [k+1 | ArgPosNum k j <- view, j == i]         f (ArgRes s) = (if args then TagColor 0 else id) $ Str s-        f (Focus x) = renderFocus [i | FocusOn i <- view] x+        f (Focus x) = TagHyperlink "" $ renderFocus [i | FocusOn i <- view] x   renderFocus :: [Range] -> String -> TagStr
src/Main.hs view
@@ -11,96 +11,3 @@     if queryWeb q         then actionWeb q         else actionCmdLine q---{-----exec :: Origin -> Query -> IO ()--exec CmdLine q | not $ usefulQuery q = putStr $ "No query given\n" ++ helpMsg--exec CmdLine q = do-    checkFlags q (fColor ++ fDatabase ++ fStart ++ fCount ++ fDocs ++ fInfo)-    databases <- collectDataBases q-    res <- searcher databases-    if null res then putStrLn "No results found" else do-    -        when showInfo $ do-            putStrLn $ showTags $ renderResult $ head res-            putStrLn ""-            docs <- loadDocs $ itemResult $ head res-            case docs of-                Nothing -> putStrLn "No info on this item"-                Just x -> putStr $ showTags $ renderDocs x-        -        when (showInfo && showDocs) $ putStrLn ""-        when showDocs $ putStrLn $ fromMaybe "No documentation" $ locateWebDocs $ itemResult $ head res-        -        when (not (showDocs || showInfo)) $-            putStr $ unlines $ map (showTags . renderResult) res-    where-        showDocs = hasFlag q fDocs-        showInfo = hasFlag q fInfo-    -        showTags = if hasFlag q fColor then showTagConsole else showTag-        -        searcher dbs | isJust start || isJust count-                     = searchRange dbs q (fromMaybe 1 start - 1) (fromMaybe 25 count)-                     | otherwise = searchAll dbs q-        -        start = getPosIntFlag fStart-        count = getPosIntFlag fCount-        -        getPosIntFlag flags =-            case getFlag q flags of-                Nothing -> Nothing-                Just x ->-                    case (reads x :: [(Int,String)]) of-                        [(n,"")] | n > 0 -> Just n-                        _ -> Nothing-- }--{ - RULES-For each /db=... flag, it must be either a file (load it) or a folder (look for +packages in it)-If always check the current directory if all /db directives fail-If no /db files and no +packages then default to +base-- }-collectDataBases :: Query -> IO [DataBase]-collectDataBases q =  do-    (files,dirs) <- f (getFlags q fDatabase)-    let packs = [x | PlusPackage x <- scope q]-    files2 <- mapM (g (dirs++[""])) (if null packs && null files then ["base"] else packs)-    res <- mapM h (files ++ catMaybes files2)-    return $ catMaybes res-    where-        f :: [FilePath] -> IO ([FilePath],[FilePath])-        f [] = return ([], [])-        f (x:xs) = do-            bfile <- doesFileExist x-            bdir <- doesDirectoryExist x-            if not (bfile || bdir)-                then do-                    putStrLn $ "Warning, database not found: " ++ x-                    f xs-                else do-                    (a,b) <- f xs-                    return ([x|bfile]++a, [x|not bfile]++b)--        -- maybe return an item-        g :: [FilePath] -> String -> IO (Maybe FilePath)-        g (x:xs) y = do-            let file = x </> y <.> "hoo"-            b <- doesFileExist file-            if b then return $ Just file-                 else g xs y-        g [] y = do-            putStrLn $ "Warning, failed to find package " ++ y-            return Nothing--        h file = do-            db <- loadDataBase file-            when (isNothing db) $ putStrLn $ "Failed to load database, " ++ file-            return db--}
src/Web/Action.hs view
@@ -1,5 +1,105 @@  module Web.Action(actionWeb) where +import CmdLine.All+import Hoogle.All+import Hoogle.Query.All+import Hoogle.Item.All+import Hoogle.Search.All+import General.Code+import System.IO.Unsafe(unsafeInterleaveIO)+import Web.Page+import Text.ParserCombinators.Parsec+import Data.TagStr+import Data.Range+import Data.Binary.Defer.Index -actionWeb = undefined++actionWeb :: CmdQuery -> IO ()+actionWeb q = do+    (skipped,dbs) <- loadDataBases q+    let res = unlines $ header (escapeHTML $ queryText q) ++ runQuery dbs q ++ footer+    when (Debug `elem` queryFlags q) $+        writeFile "temp.htm" res+    putStrLn res+++-- is the package not something that might go wrong+safePackage :: String -> Bool+safePackage = all $ \x -> isAlphaNum x || x `elem` "-_"+++-- return the databases you loaded, and those you can't+-- guarantees not to actually load the databases unless necessary+-- TODO: Should say which databases are ignored+loadDataBases :: CmdQuery -> IO ([String], [DataBase])+loadDataBases CmdQuery{query=Right q} = do+    let pkgs = nub [x | PlusPackage x <- scope q, safePackage x]+        files = if null pkgs then ["default"] else pkgs+    files <- filterM doesFileExist $ map (\x -> "res" </> x <.> "hoo") files+    dbs <- unsafeInterleaveIO $ mapM loadDataBase files+    return ([], dbs)+loadDataBases _ = return ([], [])+++-- TODO: Should escape the query text+runQuery :: [DataBase] -> CmdQuery -> [String]+runQuery dbs CmdQuery{queryText = text, query = Left err} =+    ["<h1><b>Parse error in user query</b></h1>"+    ,"<p>"+    ,"  Query: <tt>" +? pre ++ "<span id='error'>" +? post2 ++ "</span></tt><br/>"+    ,"</p><p>"+    ,"  Error: " +? drop 1 (dropWhile (/= ':') $ show err) ++ "<br/>"+    ,"</p><p>"+    ,"  For information on what queries should look like, see the user manual."+    ,"</p>"+    ]+    where+        (pre,post) = splitAt (sourceColumn (errorPos err) - 1) text+        post2 = if null post then concat (replicate 3 "&nbsp;") else post+++runQuery dbs q | not $ usefulQuery $ fromRight $ query q =+    ["<h1><b>Welcome to Hoogle</b></h1>"+    ,"<p>"+    ,"  Hoogle is a Haskell API search engine, have fun!"+    ,"</p>"+    ]+++runQuery dbs CmdQuery{query = Right q} =+    ["<h1>Searching for " ++ qstr ++ "</h1>"] +++    ["<p>" ++ showTagHTML sug ++ "</p>" | Just sug <- [suggestQuery dbs q]] +++    if null res then+        ["<p>No results found</p>"]+    else+        ["<table>"] ++ map (f . renderResult) res ++ ["</table>"]+    where+        res = searchRange (rangeStartCount 0 25) dbs q+        f (m,r,v) = "<tr><td class='mod'>" ++ maybe "" showModule m +++                    "</td><td>" ++ showTagHTML r ++ "</td></tr>"++        qstr = unwords $ ["<b>" ++ n ++ "</b>" | n <- names q] +++               ["::" | names q /= [] && isJust (typeSig q)] +++               [showTagHTML (renderEntryText view $ renderTypeSig t) | Just t <- [typeSig q]]+        view = [ArgPosNum i i | i <- [0..10]]++++a +? b = a ++ escapeHTML b+++escapeHTML = concatMap f+    where+        f '\"' = "&quot;"+        f '<' = "&lt;"+        f '>' = "&gt;"+        f x = [x]+++showTagHTML (Str x) = escapeHTML x+showTagHTML (Tags xs) = concatMap showTagHTML xs+showTagHTML (TagBold x) = "<b>" ++ showTagHTML x ++ "</b>"+showTagHTML (TagUnderline x) = "<i>" ++ showTagHTML x ++ "</i>"+showTagHTML (TagHyperlink url x) = "<a href=\"" +? url ++ "\">" ++ showTagHTML x ++ "</a>"+showTagHTML (TagColor i x) = "<span class='c" ++ show i ++ "'>" ++ showTagHTML x ++ "</span>"
+ src/Web/Page.hs view
@@ -0,0 +1,44 @@++module Web.Page(header, footer) where+++header query =+    ["<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"+    ,"<html>"+    ,"  <head>"+    ,"     <meta http-equiv='Content-Type' content='text/html; charset=iso-8859-1' />"+    ,"     <title>" ++ query ++ " - Hoogle</title>"+    ,"     <link type='text/css' rel='stylesheet' href='res/hoogle.css'>"+    ,"     <link type='image/png' rel='icon' href='res/favicon.png'>"+    ,"     <script type='text/javascript' src='res/hoogle.js'> </script>"+    ,"  </head>"+    ,"  <body onload='on_load()'>"+    ] ++ links ++ search query+++links =+    ["<div id='links'>"+    ,"  <!--[if IE]><span style='display:none;'><![endif]-->"+    ,"    <a href='javascript:addHoogle()'>Firefox plugin</a> |"+    ,"  <!--[if IE]></span><![endif]-->"+    ,"  <a href='http://www.haskell.org/haskellwiki/Hoogle'>Manual</a> |"+    ,"  <a href='http://www.haskell.org/'>haskell.org</a>"+    ,"</div>"+    ]++search query =+    ["<form action='?' method='get' id='search'>"+    ,"  <a id='logo' href='http://haskell.org/hoogle/'>" +++         "<img src='res/hoogle.png' alt='Hoogle' />" +++       "</a>"+    ,"  <input name='q' id='text' type='text' value=\"" ++ query ++ "\" />"+    ,"  <input id='submit' type='submit' value='Search' />"+    ,"</form>"+    ]+++footer =+    ["    <p id='footer'>&copy; <a href='http://www.cs.york.ac.uk/~ndm/'>Neil Mitchell</a> 2004-2008</p>"+    ,"  </body>"+    ,"</html>"+    ]