hoogle 4.1.2 → 4.1.3

raw patch · 32 files changed

+330/−262 lines, 32 filesdep +Cabaldep ~tagsoupPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: Cabal

Dependency ranges changed: tagsoup

API changes (from Hackage documentation)

Files

• datadir/resources/hoogle.css +21/−30
• hoogle.cabal +5/−3
• src/CmdLine/Load.hs +1/−1
• src/CmdLine/Type.hs +6/−4
• src/Console/All.hs +1/−1
• src/Console/Rank.hs +1/−1
• src/Console/Search.hs +20/−13
• src/Console/Test.hs +1/−1
• src/General/Base.hs +34/−0
• src/Hoogle.hs +52/−36
• src/Hoogle/DataBase/Items.hs +28/−11
• src/Hoogle/Language/Haskell.hs +4/−4
• src/Hoogle/Query/Render.hs +1/−0
• src/Hoogle/Query/Type.hs +3/−0
• src/Hoogle/Score/Scoring.hs +2/−2
• src/Hoogle/Score/Type.hs +1/−0
• src/Hoogle/Search/All.hs +4/−12
• src/Hoogle/Search/Results.hs +4/−2
• src/Hoogle/Type/Documentation.hs +1/−0
• src/Hoogle/Type/Item.hs +9/−14
• src/Hoogle/Type/ParseError.hs +5/−9
• src/Hoogle/Type/Result.hs +3/−4
• src/Hoogle/Type/TagStr.hs +1/−1
• src/Recipe/All.hs +2/−2
• src/Recipe/Cabal.hs +39/−0
• src/Recipe/Download.hs +1/−1
• src/Recipe/General.hs +4/−4
• src/Recipe/Hackage.hs +10/−6
• src/Recipe/Keyword.hs +1/−1
• src/Recipe/Type.hs +20/−48
• src/Web/Response.hs +39/−48
• src/Web/Server.hs +6/−3

@@ -30,6 +30,7 @@ }  input {+    font-size: 16px;     margin-top: 22px;     vertical-align: top; }@@ -68,7 +69,7 @@ */  h1 {-    font-size: 10pt;+    font-size: 13px;     padding: 5px;     margin-top: 0px;     font-weight: normal;@@ -78,7 +79,7 @@     border-top: 1px solid #999; } -p, table {+p {     padding-left: 20px;     padding-right: 20px; }@@ -117,9 +118,9 @@ *  RESULTS */ -td {-    padding-bottom: 0px;-    padding-top: 0px;+.ans, .doc, .from {+    margin-left: 170px;+    margin-right: 10px; }  a.dull, a.dull:hover {@@ -129,8 +130,18 @@  /** ANSWERS **/ +.ans i {+    font-weight: bold;+    font-style: normal;+}++.ans {+    font-size: 16px;+    margin-top: 15px;+}+ .ans .a {-    color: blue;+    color: #2200C1; }  .ans a.dull {@@ -152,32 +163,13 @@     color: blue; } -/** MODULES **/--.mod {-    vertical-align: bottom;-    text-align: right;-    font-size: 8pt;-}-.mod, .mod a {-    color: #080;-    text-decoration: none;-    background-color: white;-}--/** PACKAGES **/+/** PARENTS **/ -.pkg {-    text-align: right;-    vertical-align: top;-    font-size: 8pt;-    padding-bottom: 10px;+.p1, .p2 {+    font-size: 13px;     white-space: nowrap;-}-.pkg, .pkg a {-    color: #888;     text-decoration: none;-    background-color: white;+    color: #0E774A; }  /** DOCS **/@@ -185,7 +177,6 @@ .doc {     vertical-align: top;     font-size: 8pt;-    padding-bottom: 10px; } .doc, .doc a {     color: #888;

@@ -1,7 +1,7 @@ cabal-version:      >= 1.6 build-type:         Simple name:               hoogle-version:            4.1.2+version:            4.1.3 license:            GPL license-file:       docs/LICENSE category:           Development@@ -100,9 +100,10 @@     build-depends:         time,         cmdargs == 0.6.*,-        tagsoup >= 0.11 && < 0.12,+        tagsoup >= 0.11 && < 0.13,         network >= 2.2 && < 2.4,-        HTTP >= 4000.0 && < 4000.2+        HTTP >= 4000.0 && < 4000.2,+        Cabal >= 1.8 && < 1.11      other-modules:         CmdLine.All@@ -114,6 +115,7 @@         Console.Test         Paths_hoogle         Recipe.All+        Recipe.Cabal         Recipe.Download         Recipe.General         Recipe.Hackage

@@ -20,7 +20,7 @@                 case r of                     Nothing -> return $ Left x                     Just x -> do-                        src <- readFile x+                        src <- readFileUtf8 x                         return $ Right $ snd $ createDatabase Haskell [] src             Just x -> fmap Right $ loadDatabase x 

@@ -33,7 +33,7 @@         ,queryText :: String         }     | Test {testFiles :: [String], example :: Bool}-    | Server {port :: Int, databases :: [FilePath], resources :: FilePath, local_ :: Bool}+    | Server {port :: Int, databases :: [FilePath], resources :: FilePath, local_ :: Bool, nostdin :: Bool}     | Dump {database :: String, section :: [String]}     | Rank {srcfile :: FilePath}     | Combine {srcfiles :: [FilePath], outfile :: String}@@ -41,16 +41,17 @@     | Data {datadir :: FilePath, threads :: Int, haddock :: Bool, redownload :: Bool, actions :: [String], local :: [String]}       deriving (Data,Typeable,Show) +emptyParseError = ParseError 0 0 "" $ Str "" blankSearch = Search False Nothing Nothing Nothing False False False 1 [] [] (Left emptyParseError) "" -cmdLineMode = cmdArgsMode $ modes [search &= auto,test,server,dump,rank,combine,convert,dataa]+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") -search = Search+search_ = Search     {web = def &= help "Operate as a web tool"     ,start = def-    ,count = def+    ,count = def &= name "n" &= help "Return the first N results"     ,webmode = def     ,queryChunks = def &= args     ,info = def@@ -70,6 +71,7 @@ server = Server     {port = 80 &= typ "INT" &= help "Port number"     ,resources = ""+    ,nostdin = def &= help "Don't read from stdin"     ,local_ = def &= help "Rewrite file:/// links and serve them, can be a security hole"     } &= help "Start a Hoogle server" 

@@ -36,7 +36,7 @@ action (Convert from to) = do     to <- return $ if null to then replaceExtension from "hoo" else to     putStrLn $ "Converting " ++ from-    src <- readFile from+    src <- readFileUtf8 from     let (err,db) = createDatabase Haskell [] src     unless (null err) $ putStr $ unlines $ "Warning: parse errors" : map show err     saveDatabase to db

@@ -15,7 +15,7 @@ scores :: ([String], [(String,[String])]) -> [(Score,Score)] scores (pre,xs) = concatMap trans     [-        [ fst $ head $ searchAll db q ++ [error $ "Did not find in " ++ query ++ ", " ++ y]+        [ fst $ head $ search db q ++ [error $ "Did not find in " ++ query ++ ", " ++ y]         | y <- ys , let (err,db) = createDatabase Haskell [] $ unlines $ pre ++ ["a::" ++ y]         , null err || error "Errors while converting rank database"         ]

@@ -5,6 +5,7 @@ import CmdLine.All import General.Base import General.System+import System.Console.CmdArgs import Hoogle  @@ -24,35 +25,41 @@     let sug = querySuggestions dbs q     when (isJust sug) $         putStrLn $ showTag $ fromJust sug+    verbose <- isLoud     when verbose $ putStrLn "= ANSWERS ="      when (color flags) $         putStrLn $ "Searching for: " ++ showTag (renderQuery q) -    let res = search dbs q+    let res = restrict $ concatMap expand $ search dbs q     if null res then         putStrLn "No results found"      else if info flags then do-        let Result{self=self,docs=docs,package=package} = snd $ head res-        putStrLns 2 $ f $ head res+        let Result{..} = snd $ head res+        putStrLns 2 $ disp verbose $ head res         putStrLns 2 $ showTag docs-        when (isJust package) $ putStrLn $ "From package " ++ snd (fromJust package)-        putStrLns 1 $ showTag $ snd self+        case locations of+            (_,(_,p):_):_ -> putStrLn $ "From package " ++ p+            _ -> return ()+        putStrLns 1 $ showTag self      else-        putStr $ unlines $ map f res+        putStr $ unlines $ map (disp verbose) res     where-        search | start2 == 0 && count2 == maxBound = searchAll-               | otherwise = searchRange (start2,start2+count2-1)+        restrict | start2 == 0 && count2 == maxBound = id+                 | otherwise = take count2 . drop start2             where start2 = maybe 0 (subtract 1) $ start flags                   count2 = fromMaybe maxBound $ count flags          showTag = if color flags then showTagANSI else showTagText-        verbose = False -        f (s,Result{..}) = maybe "" (\m -> snd m ++ " ") modul ++-                           showTag (snd self) ++-                           (if verbose then "  -- " ++ show s else "") ++-                           (if link flags then " -- " ++ fst self else "")+        expand (s,r) | null $ locations r = [(s,r)]+                     | otherwise = [(s,r{locations=[p]}) | p <- locations r]++        disp verbose (s,Result{..}) =+            (case locations of (_,_:(_,m):_):_ -> m ++ " "; _ -> "") +++            showTag self +++            (if verbose then "  -- " ++ show s else "") +++            (if link flags then " -- " ++ head (map fst locations ++ [""]) else "")   -- Put out a string with some blank links following

@@ -22,7 +22,7 @@     putStrLn "Converting testdata"     performGC -- clean up the databases     dat <- getDataDir-    src <- readFile $ dat </> "testdata.txt"+    src <- readFileUtf8 $ dat </> "testdata.txt"     let (errs, dbOld) = createDatabase Haskell [] src     unless (null errs) $ error $ unlines $ "Couldn't convert testdata database:" : map show errs     let dbfile = dat </> "databases/testdata.hoo"

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | Module for "pure" things in the base, and things I think should --   have been in base, or could plausibly be added. module General.Base(module General.Base, module X) where@@ -16,7 +18,12 @@ import Numeric as X (readHex,showHex) import System.FilePath as X hiding (combine) +import Control.Exception(bracket)+import System.IO ++-- | A URL, or internet address. These addresses will usually start with either+--   @http:\/\/@ or @file:\/\/@. type URL = String  fst3 (a,b,c) = a@@ -56,6 +63,33 @@ readFile' x = do     src <- readFile x     length src `seq` return src+++readFileUtf8' :: FilePath -> IO String+readFileUtf8' x = do+    src <- readFileUtf8 x+    length src `seq` return src+++readFileUtf8 :: FilePath -> IO String+#if __GLASGOW_HASKELL__ < 612+readFileUtf8 x = readFile x+#else+readFileUtf8 x = do+    h <- openFile x ReadMode+    hSetEncoding h utf8+    hGetContents h+#endif+++writeFileUtf8 :: FilePath -> String -> IO ()+#if __GLASGOW_HASKELL__ < 612+writeFileUtf8 x y = writeFile x y+#else+writeFileUtf8 x y = bracket (openFile x WriteMode) hClose $ \h -> do+    hSetEncoding h utf8+    hPutStr h y+#endif   ltrim = dropWhile isSpace

@@ -1,13 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} --- The plan, over time, is to make this module simply reexport things, integrating the wrapper--- layer back into Hoogle proper---- | The Hoogle API.+-- | The Hoogle API. To perform a search you call 'search' with a 'Database' (obtained by 'loadDatabase') and a+--   'Query' (obtained by 'parseQuery'). module Hoogle(     -- * Utility types-    module Hoogle.Type.TagStr,-    H.ParseError(..), H.emptyParseError,+    TagStr(..), showTagText, showTagANSI, showTagHTML, showTagHTMLWith,+    H.ParseError(..),     URL,     Language(..),     -- * Database@@ -18,7 +16,7 @@     -- * Score     Score, H.scoring,     -- * Search-    Result(..), searchAll, searchRange+    Result(..), search     ) where  import Data.Binary.Defer.Index@@ -38,13 +36,21 @@ import Hoogle.Score.All(Score)  --- * Utility types--data Language = Haskell+-- | 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+--   for a variety of purposes:+--+--   [Creation] A database is created by merging existing databases with the 'Monoid' instance and 'mappend',+--   or by creating a new 'Database' from an input file with 'createDatabase'.+--+--   [Serialization] A database is saved to disk with 'saveDatabase' and loaded from disk with 'loadDatabase'.+--+--   [Searching] A database is searched using 'search'. newtype Database = Database [H.DataBase]  toDataBase (Database x) = H.combineDataBase x@@ -58,69 +64,79 @@     show = show . toDataBase  -loadDatabase :: FilePath -> IO Database-loadDatabase = fmap fromDataBase . H.loadDataBase+-- | Save a database to a file.+saveDatabase :: FilePath -> Database -> IO ()+saveDatabase file x = do+    performGC+    H.saveDataBase file $ toDataBase x  -showDatabase :: Database -> Maybe [String] -> String-showDatabase x sects = concatMap (`H.showDataBase` toDataBase x) $ fromMaybe [""] sects+-- | Load a database from a file. If the database was not saved with the same version of Hoogle,+--   it will probably throw an error.+loadDatabase :: FilePath -> IO Database+loadDatabase = fmap fromDataBase . H.loadDataBase  --- | From a textbase lines we have currently-createDatabase :: Language -> [Database] -> String -> ([H.ParseError], Database)+-- | 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.+    -> [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. createDatabase _ dbs src = (err, fromDataBase $ H.createDataBase xs res)     where         (err,res) = H.parseInputHaskell src         xs = concat [x | Database x <- dbs]  -saveDatabase :: FilePath -> Database -> IO ()-saveDatabase file x = do-    performGC-    H.saveDataBase file $ toDataBase x+-- | Show debugging information on some parts of the database. If the second argument+--   is 'Nothing' the whole database will be shown. Otherwise, the listed parts will be shown.+showDatabase :: Database -> Maybe [String] -> String+showDatabase x sects = concatMap (`H.showDataBase` toDataBase x) $ fromMaybe [""] sects   -- 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.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 data Result = Result-    {package :: Maybe (URL, String)-    ,modul :: Maybe (URL, String)-    ,self :: (URL, TagStr)+    {locations :: [(URL, [(URL, String)])] -- your location, your parents+    ,self :: TagStr     ,docs :: TagStr     }  toResult :: H.Result -> (Score,Result)-toResult r@(H.Result entry view score) = (score, Result package modul self docs)+toResult r@(H.Result entry view score) = (score, Result parents self docs)     where         ent = fromLink entry-        (text,_) = H.renderResult r+        self = H.renderResult r -        package = fmap ((H.entryURL &&& H.entryName) . fromLink) $ H.entryPackage ent-        modul = fmap ((H.entryURL &&& H.entryName) . fromLink) $ H.entryModule ent-        self = (H.entryURL ent, text)+        parents = map (second $ map f) $  H.entryLocations ent+        f = (H.entryURL &&& H.entryName) . fromLink         docs = H.renderDocumentation $ H.entryDocs ent  -searchAll :: Database -> Query -> [(Score,Result)]-searchAll (Database xs) q = map toResult $ H.searchAll xs q----- | A pair of bounds. These bounds are the lowest and highest indices in the array, in that order.---   For example, the first 10 elements are (0,9) and the next 10 are (10,19)-searchRange :: (Int,Int) -> Database -> Query -> [(Score,Result)]-searchRange (a,b) (Database xs) q = map toResult $ H.searchRange (a,b) xs q+-- | Perform a search. The results are returned lazily.+search :: Database -> Query -> [(Score,Result)]+search (Database xs) q = map toResult $ H.search xs q

@@ -12,7 +12,7 @@ import qualified Data.Binary.Defer as D  -- Invariant: Index Entry is by order of EntryScore-newtype Items = Items (Index Entry)+newtype Items = Items {fromItems :: Index Entry}  entriesItems :: Items -> [Link Entry] entriesItems (Items x) = indexLinks x@@ -42,22 +42,39 @@                   pkg2 = if itemLevel x == 0 then Just $ newLink i r else pkg                   mod2 = if itemLevel x == 1 then Just $ newLink i r else mod -        f pkg mod TextItem{..} = Entry pkg mod itemName itemDisp-            (htmlDocumentation itemDocs) url itemPriority itemKey itemType+        f pkg mod TextItem{..} = Entry [(url, catMaybes [pkg,mod])] itemName itemDisp+            (htmlDocumentation itemDocs) itemPriority itemKey itemType             where url | Just pkg <- pkg, itemLevel == 1 || (itemLevel > 1 && isNothing mod) = entryURL (fromLink pkg) `combineURL` itemURL                       | Just mod <- mod, itemLevel > 1 = entryURL (fromLink mod) `combineURL` itemURL                       | otherwise = itemURL   -- | Given a set of items, which may or may not individually satisfy the entryScore invariant,---   make it so they _do_ satisfy the invariant+--   make it so they _do_ satisfy the invariant.+--   Also merge any pair of items which are similar enough. mergeItems :: [Items] -> Items-mergeItems xs = Items $ newIndex $ map ren ijv+mergeItems xs = Items $ newIndex $ map (reindex (mp Map.!) . snd) ys     where-        -- xs are sets of items, vs are sets of values, is index xs, js index vs-        mp = Map.fromList [(ij, newLink n v) | (n,(ij,v)) <- zip [0..] ijv]-        ijv = sortOn (entryScore . snd) [((i,linkKey jv),fromLink jv) | (i,Items vs) <- zip [0..] xs, jv <- indexLinks vs]+        mp = Map.fromList [(i, newLink n y) | (n,(is, y)) <- zip [0..] ys, i <- is]+        ys = reorder $ flatten $ map (map (linkKey &&& fromLink) . indexLinks . fromItems) xs -        ren (ij,v) = v{entryPackage = f ij $ entryPackage v, entryModule = f ij $ entryModule v}-        f _ Nothing = Nothing-        f (i,j) (Just e) = Just $ mp Map.! (i,linkKey e) ++reorder :: [(a,Entry)] -> [([a],Entry)]+reorder = sortOn (entryScore . snd) . Map.elems . foldl' f Map.empty+    where+        f mp (i,e@Entry{..}) = Map.insertWith g key ([i],e) mp+            where key = (entryName, entryText, entryDocs, entryKey, entryType)+        g (i1,e1) (i2,e2) = (i1++i2, e1+            {entryPriority=min (entryPriority e1) (entryPriority e2)+            ,entryLocations=nub $ concatMap entryLocations $ if entryScore e1 < entryScore e2 then [e1,e2] else [e2,e1]})+++flatten :: [[(Int,Entry)]] -> [(Int,Entry)]+flatten xs = concat $ zipWith f ns xs+    where+        ns = 0 : scanl1 (+) (map length xs)+        f n x = [(i+n, reindex (\j -> newLink (j+n) (snd $ x!!j)) y) | (i,y) <- x]+++reindex :: (Int -> Link Entry) -> Entry -> Entry+reindex op x = x{entryLocations = map (second $ map $ op . linkKey) $ entryLocations x}

@@ -99,12 +99,12 @@   -- base::Prelude is priority 0--- base is priority 1+-- base, but not inside GHC is priority 1 -- Everything else is priority 2 setPriority pkg mod x = x{itemPriority = pri}-    where pri = if base then (if prelude then 0 else 1) else 2-          prelude = maybe [] itemName mod == "Prelude"-          base = maybe [] itemName pkg == "base"+    where pri = if pkg2 == "base" && not ("GHC." `isPrefixOf` mod2) then (if mod2 == "Prelude" then 0 else 1) else 2+          mod2 = maybe "" itemName mod+          pkg2 = maybe "" itemName pkg   setModuleURL pkg _ x

@@ -7,6 +7,7 @@ import Hoogle.Type.All  +-- | Render a query, in particular using 'TagColor' for any type signature argument positions. renderQuery :: Query -> TagStr renderQuery x = Tags $ namesig ++ [Str " " | namesig /= [] && scp /= []] ++ scp     where

@@ -7,6 +7,7 @@ import Hoogle.Type.All  +-- | A query, representing a user input. data Query = Query     {names :: [String]     ,typeSig :: Maybe TypeSig@@ -15,6 +16,8 @@     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) 

@@ -10,8 +10,8 @@ import System.Random  --- | A list of scores where one is lower than the other, returns the score result.---   In the 'IO' monad since it may require randomness, and it may output status messages while solving,+-- | Given a set of scores, where the first is lower than the second, returns details for how to rank scores.+--   This function is in the 'IO' monad since it may require randomness, and it may output status messages while solving, --   particularly if in Verbose mode. scoring :: [(Score,Score)] -> IO String scoring xs = do

@@ -46,6 +46,7 @@       deriving (Show,Eq,Ord,Enum,Bounded)  +-- | A score, representing how close a match is. Lower scores are better. data Score = Score Int [TypeCost] [TextMatch]  instance Monoid Score where

@@ -1,7 +1,5 @@ -module Hoogle.Search.All(-    searchAll, searchRange-    ) where+module Hoogle.Search.All(search) where  import Hoogle.DataBase.All import Hoogle.Query.All@@ -9,15 +7,9 @@ import Hoogle.Type.All  --- return all the results-searchAll :: [DataBase] -> Query -> [Result]-searchAll databases query = getResults query databases----- should be possible to fast-path certain searches, currently not done--- start index, end index-searchRange :: (Int,Int) -> [DataBase] -> Query -> [Result]-searchRange (from,to) databases query = take (to - from + 1) $ drop from $ getResults query databases+-- return all the results, lazily+search :: [DataBase] -> Query -> [Result]+search databases query = getResults query databases   getResults :: Query -> [DataBase] -> [Result]

@@ -76,13 +76,15 @@  -- pkgs is a non-empty list of MinusPackage values correctPackage :: [String] -> Entry -> Bool-correctPackage pkgs = maybe True ((`notElem` pkgs) . entryName . fromLink) . entryPackage+correctPackage pkgs x = null myPkgs || any (maybe True (`notElem` pkgs)) myPkgs+    where myPkgs = map (fmap (entryName . fromLink) . listToMaybe . snd) $ entryLocations x   -- mods is a non-empty list of PlusModule/MinusModule correctModule :: [Scope] -> Entry -> Bool-correctModule mods = maybe True (f base mods . split '.' . entryName . fromLink) . entryModule+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          f z [] y = z

@@ -10,6 +10,7 @@   newtype Documentation = Documentation ByteString+    deriving (Eq,Ord)   instance BinaryDefer Documentation where

@@ -35,20 +35,21 @@       deriving Show  +-- Invariant: locations will not be empty data Entry = Entry-    {entryPackage :: Maybe (Link Entry)-    ,entryModule :: Maybe (Link Entry)+    {entryLocations :: [(URL, [Link Entry])]     ,entryName :: String     ,entryText :: TagStr     ,entryDocs :: Documentation-    ,entryURL :: URL     ,entryPriority :: Int     ,entryKey :: String -- used only for rebuilding combined databases     ,entryType :: Maybe TypeSig -- used only for rebuilding combined databases     }     deriving (Typeable) +entryURL e = head $ map fst (entryLocations e) ++ [""] + data EntryView = FocusOn String -- characters in the range should be focused                | ArgPosNum Int Int -- argument a b, a is remapped to b                  deriving Show@@ -77,22 +78,16 @@ -- the entry priority -- the name of the entry, in lower case -- the name of the entry--- the module-data EntryScore = EntryScore Int String String String+data EntryScore = EntryScore Int String String                   deriving (Eq,Ord)   entryScore :: Entry -> EntryScore-entryScore e = EntryScore (entryPriority e) (map toLower $ entryName e) (entryName e) m-    where m = maybe [] (entryName . fromLink) $ entryModule e+entryScore e = EntryScore (entryPriority e) (map toLower $ entryName e) (entryName e)  instance Show Entry where-    show e = unwords [showTagText $ entryText e, m]-        where-            m = case entryModule e of-                    Nothing -> ""-                    Just y -> "{#" ++ show (linkKey y) ++ "}"+    show = showTagText . entryText  instance BinaryDefer Entry where-    put (Entry a b c d e f g h i) = put9 a b c d e f g h i-    get = get9 Entry+    put (Entry a b c d e f g) = put7 a b c d e f g+    get = get7 Entry

@@ -5,20 +5,16 @@ import Hoogle.Type.TagStr import Data.Data --- | 1 based+-- | Data type representing a parse error. All indecies are 1-based. data ParseError = ParseError-    {lineNo :: Int-    ,columnNo :: Int-    ,errorMessage :: String-    ,parseInput :: TagStr+    {lineNo :: Int -- ^ Line number on which the error occured, 1 for the first line of a file.+    ,columnNo :: Int -- ^ Column number on which the error occured, 1 for the first character of a line.+    ,errorMessage :: String -- ^ Error message caused by the parse error.+    ,parseInput :: TagStr -- ^ Input string which caused the error - sometimes with a 'TagEmph' to indicate which part was incorrect.     } deriving (Ord,Eq,Data,Typeable)  instance Show ParseError where     show (ParseError line col err _) = "Parse error " ++ show line ++ ":" ++ show col ++ ": " ++ err---emptyParseError :: ParseError-emptyParseError = ParseError 0 0 "" $ Str ""   parseErrorWith :: Int -> Int -> String -> String -> ParseError

@@ -15,8 +15,7 @@     deriving Show  --- return (module it is in, the text to go beside it, verbose scoring info)-renderResult :: Result -> (TagStr, String)-renderResult r = (renderEntryText (resultView r) $ entryText e-                 ,show $ resultScore r)+-- return the entry rendered with respect to the EntryView+renderResult :: Result -> TagStr+renderResult r = renderEntryText (resultView r) $ entryText e     where e = fromLink $ resultEntry r

@@ -20,7 +20,7 @@     | TagBold TagStr -- ^ Bold text.     | TagEmph TagStr -- ^ Underlined/italic text.     | TagLink String TagStr -- ^ A hyperlink to a URL.-    | TagColor Int TagStr -- ^ Colored text. Index into a 0-based palette.+    | TagColor Int TagStr -- ^ Colored text. Index into a 0-based palette. Text without any 'TagColor' should be black.       deriving (Data,Typeable,Ord,Show,Eq)  

@@ -20,11 +20,11 @@     hSetBuffering stdout NoBuffering     createDirectoryIfMissing True $ datadir opt     withDirectory (datadir opt) $ do-        resetErrors+        resetWarnings         download opt         let ys = parseRules $ actions opt         make opt (filter (not . null . snd) ys) (map fst ys)-        recapErrors+        recapWarnings         putStrLn "Data generation complete"  

@@ -0,0 +1,39 @@++module Recipe.Cabal(+    Cabal(..), readCabal+    ) where++import Distribution.Compiler+import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.PackageDescription.Parse+import Distribution.System+import Distribution.Text+import Distribution.Verbosity+import Distribution.Version+++ghcVersion = [7,0,1]++data Cabal = Cabal+    {cabalName :: String+    ,cabalVersion :: String+    ,cabalDescription :: [String]+    ,cabalDepends :: [String]+    } deriving Show+++readCabal :: FilePath -> IO Cabal+readCabal file = do+    pkg <- readPackageDescription silent file+    let plat = Platform I386 Linux+        comp = CompilerId GHC (Version ghcVersion [])+    pkg <- return $ case finalizePackageDescription [] (const True) plat comp [] pkg of+        Left _ -> flattenPackageDescription pkg+        Right (pkg,_) -> pkg+    return $ Cabal+        (display $ pkgName $ package pkg)+        (display $ pkgVersion $ package pkg)+        (lines $ description pkg)+        [display x | Just l <- [library pkg], Dependency x _ <- targetBuildDepends $ libBuildInfo l]

@@ -40,7 +40,7 @@         wget opt (out <.> "tar.gz") url         createDirectoryIfMissing True out         withDirectory out $-            system_ $ "tar -xf .." </> takeFileName out <.> "tar.gz"+            system_ $ "tar -xzf .." </> takeFileName out <.> "tar.gz"         writeFile (out <.> "txt") ""  

@@ -13,16 +13,16 @@ convert make x = do     b <- doesFileExist $ x <.> "txt"     if not b then-        putError $ "Error: " ++ x ++ " couldn't be converted, no input file found"+        putWarning $ "Warning: " ++ x ++ " couldn't be converted, no input file found"      else do         (deps,src) <- readInput x         make deps         let deps2 = map hoo deps         deps3 <- filterM doesFileExist deps2-        when (deps2 /= deps3) $ putError $ "Error: " ++ x ++ " doesn't know about dependencies on " ++ unwords (deps2 \\ deps3)+        when (deps2 /= deps3) $ putWarning $ "Warning: " ++ x ++ " doesn't know about dependencies on " ++ unwords (deps2 \\ deps3)         dbs <- mapM loadDatabase deps3         let (err,db) = createDatabase Haskell dbs src-        unless (null err) $ outStrLn $ "Skipped " ++ show (length err) ++ " errors in " ++ x+        unless (null err) $ outStrLn $ "Skipped " ++ show (length err) ++ " warnings in " ++ x         whenLoud $ outStr $ unlines $ map show err         outStr $ "Converting " ++ x ++ "... "         performGC@@ -32,7 +32,7 @@  readInput :: Name -> IO ([Name], String) readInput x = do-    src <- readFile $ x <.> "txt"+    src <- readFileUtf8 $ x <.> "txt"     let (a,b) = span ("@depends " `isPrefixOf`) $ lines src     return (map (drop 9) a, unlines b) 

@@ -2,6 +2,7 @@ module Recipe.Hackage(makePlatform, makeDefault, makePackage, makeAll) where  import Recipe.Type+import Recipe.Cabal import Recipe.General import General.Base import General.System@@ -38,7 +39,7 @@         src <- readCabal file         return $ [""] ++ zipWith (++) ("-- | " : repeat "--   ") (cabalDescription src) ++                  ["--","-- Version " ++ ver, "@package " ++ name]-    writeFile "package.txt" $ unlines $ concat xs+    writeFile "package.txt" $ safeEncoding $ unlines $ concat xs     convert noDeps "package"  @@ -47,7 +48,7 @@     b1 <- doesDirectoryExist $ cabals </> name     b2 <- doesDirectoryExist $ haddocks </> name     if not b1 || not b2 then-        putError $ "Error: " ++ name ++ " couldn't find both Cabal and Haddock inputs"+        putWarning $ "Warning: " ++ name ++ " couldn't find both Cabal and Haddock inputs"      else do         vc <- version cabals name         vh <- version haddocks name@@ -58,12 +59,12 @@         sz <- hFileSize h         hClose h         if sz == 0 then-            putError $ "Error: " ++ name ++ " has no haddock output"+            putWarning $ "Warning: " ++ name ++ " has no haddock output"          else do-            had <- readFile' had+            had <- readFileUtf8' had             cab <- readCabal cab             loc <- findLocal local name-            writeFile (name <.> "txt") $ unlines $+            writeFileUtf8 (name <.> "txt") $ unlines $                 ["@depends " ++ a | a <- cabalDepends cab \\ (name:avoid)] ++                 (maybe id haddockPackageUrl loc) (haddockHacks $ lines had)             convert make name@@ -92,7 +93,10 @@              lines src     return [(name, takeWhile (\x -> x == '.' || isDigit x) $ drop 1 b)            | x <- xs, (a,_:b) <- [break (== '=') x], let name = trim $ dropWhile (== '-') $ trim a-           , name `notElem` words "Cabal hpc Win32"]+           , not $ avoid name]+    where+        avoid x = ("haskell" `isPrefixOf` x && all isDigit (drop 7 x)) ||+                  (x `elem` words "Cabal hpc Win32")   ---------------------------------------------------------------------

@@ -9,7 +9,7 @@  makeKeyword :: IO () makeKeyword = do-    writeFile "keyword.txt" . translate =<< readFile' keywords+    writeFileUtf8 "keyword.txt" . translate =<< readFile' keywords     convert noDeps "keyword"  

@@ -1,17 +1,15 @@  module Recipe.Type(-    CmdLine(..), Name, hoo, noDeps,+    CmdLine(..), Name, hoo, noDeps, safeEncoding,     keywords, platform, cabals, haddocks, listing, version,-    resetErrors, putError, recapErrors,-    outStr, outStrLn,-    Cabal(..), readCabal, readCabalDepends, readCabalField+    resetWarnings, putWarning, recapWarnings,+    outStr, outStrLn     ) where  import CmdLine.All import Control.Concurrent import System.IO.Unsafe import General.Base-import General.Util import General.System  @@ -26,6 +24,11 @@ noDeps xs = error "Internal error: package with no dependencies had dependencies"  +-- | Lots of things go slightly wrong if you use characters > 127 in places, this just replaces them with ?+safeEncoding :: String -> String+safeEncoding = map (\x -> if x <= '\0' || x > '\127' then '?' else x)++ --------------------------------------------------------------------- -- DOWNLOADED INFORMATION @@ -48,24 +51,24 @@   ------------------------------------------------------------------------ ERROR MESSAGES+-- WARNING MESSAGES -{-# NOINLINE errors #-}-errors :: MVar [String]-errors = unsafePerformIO $ newMVar []+{-# NOINLINE warnings #-}+warnings :: MVar [String]+warnings = unsafePerformIO $ newMVar [] -putError :: String -> IO ()-putError x = do+putWarning :: String -> IO ()+putWarning x = do     outStrLn x-    modifyMVar_ errors $ return . (x:)+    modifyMVar_ warnings $ return . (x:) -recapErrors :: IO ()-recapErrors = do-    xs <- readMVar errors+recapWarnings :: IO ()+recapWarnings = do+    xs <- readMVar warnings     mapM_ outStrLn $ reverse xs -resetErrors :: IO ()-resetErrors = modifyMVar_ errors $ const $ return []+resetWarnings :: IO ()+resetWarnings = modifyMVar_ warnings $ const $ return []   outputLock :: MVar ()@@ -74,34 +77,3 @@ outStr, outStrLn :: String -> IO () outStr x = withMVar outputLock $ \_ -> do putStr x; hFlush stdout outStrLn x = outStr $ x ++ "\n"--------------------------------------------------------------------------- CABAL--data Cabal = Cabal {cabalDepends :: [String], cabalDescription :: [String]}--readCabal :: FilePath -> IO Cabal-readCabal file = do-    src <- fmap lines $ readFile' file-    return $ Cabal (readCabalDepends src) (readCabalField src True "description")---readCabalDepends :: [String] -> [String]-readCabalDepends xs = nub $ map (takeWhile g) $ filter f $ words $ map (rep ',' ' ') $ unwords $ readCabalField xs False "build-depends"-    where f x = x /= "" && isAlpha (head x)-          g x = isAlphaNum x || x `elem` "-_"---readCabalField :: [String] -> Bool -> String -> [String]-readCabalField xs root name = f xs-    where-        f (x:xs) | (name ++ ":") `isPrefixOf` map toLower x2 && (null spc || not root) =-                [x4 | x4 /= []] ++ map (rep "." "" . trim) ys ++ f zs-            where-                x4 = trim x3-                x3 = drop (length name + 1) x2-                (spc,x2) = span isSpace x-                (ys,zs) = span ((> length spc) . length . takeWhile isSpace) xs-        f (x:xs) = f xs-        f [] = []

@@ -23,18 +23,21 @@ response resources q = do     logMessage q     let response x = responseOk [Header HdrContentType x]-    case webmode q of-        Just "suggest" -> fmap (response "application/json") $ runSuggest q-        Just "ajax" -> do++    let res ajax = do             dbs <- if isRight $ queryParsed q                    then fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q)                    else return mempty-            return $ response "text/html" $ unlines $ runQuery dbs q+            return $ runQuery ajax dbs q++    case webmode q of+        Just "ajax" -> do+            res <- res True+            return $ response "text/html" $ unlines res         Nothing -> do-            dbs <- if isRight $ queryParsed q-                   then fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q)-                   else return mempty-            return $ response "text/html" $ unlines $ header resources (escapeHTML $ queryText q) ++ runQuery dbs q ++ footer+            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: " ++ show e  @@ -57,14 +60,13 @@ runSuggest _ = return ""  --runQuery :: Database -> CmdLine -> [String]-runQuery dbs Search{queryParsed = Left err} =+runQuery :: Bool -> Database -> CmdLine -> [String]+runQuery ajax dbs Search{queryParsed = Left err} =     ["<h1><b>Parse error in user query</b></h1>"     ,"<p>"-    ,"  Query: <span id='error'>" ++ showTagHTMLWith f (parseInput err) ++ "</span><br/>"+    ,"  Query: <span id='error'>" ++ showTagHTMLWith f (parseInput err) ++ "</span>"     ,"</p><p>"-    ,"  Error: " ++& errorMessage err ++ "<br/>"+    ,"  Error: " ++& errorMessage err     ,"</p><p>"     ,"  For information on what queries should look like, see the"     ,"  <a href='http://www.haskell.org/haskellwiki/Hoogle'>user manual</a>."@@ -75,53 +77,45 @@         f _ = Nothing  -runQuery dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome+runQuery ajax dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome  -runQuery dbs cq@Search{queryParsed = Right q} =-    ["<h1>Searching for " ++ qstr ++ "</h1>"] ++-    ["<p>" ++ showTagHTML (transform qurl sug) ++ "</p>" | Just sug <- [querySuggestions dbs q]] ++-    if null res then-        ["<p>No results found</p>"]+runQuery ajax dbs cq@Search{queryParsed = Right q} =+    (if prefix then+        ["<h1>Searching for " ++ qstr ++ "</h1>"] +++        ["<p>" ++ showTagHTML (transform qurl sug) ++ "</p>" | Just sug <- [querySuggestions dbs q]] +++        if null res then+            ["<p>No results found</p>"]+        else+            concat (pre ++ now)     else-        ["<table>"] ++-        concatMap (uncurry renderRes) pre ++-        insertMore (concatMap (uncurry renderRes) now) ++-        [moreResults | not $ null post] ++-        ["</table>"]+        concat now) +++    ["<p><a href=\"" ++& urlMore ++ "\" class='more'>Show more results</a></p>" | not $ null post]     where+        prefix = not $ ajax && start2 /= 0 -- show from the start, with header         start2 = maybe 0 (subtract 1 . max 0) $ start cq         count2 = maybe 20 (max 1) $ count cq-        res = zip [0..] $ map snd $ searchRange (start2,start2+count2) dbs q++        res = [renderRes i (i /= 0 && i == start2 && prefix) x | (i,(_,x)) <- zip [0..] $ search dbs q]         (pre,res2) = splitAt start2 res         (now,post) = splitAt count2 res2 -        moreResults = "<tr><td></td><td><a href=\"" ++& urlMore ++ "\" class='more'>Show more results</a></td></tr>"         urlMore = "?hoogle=" ++% queryText cq ++ "&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  ---- insert <a name=more> where you can-insertMore :: [String] -> [String]-insertMore [] = []-insertMore (x:xs) = f x : xs-    where-        f ('>':xs) | not $ "<td" `isPrefixOf` xs = "><a name='more'></a>" ++ xs-        f (x:xs) = x : f xs-        f [] = []---renderRes :: Int -> Result -> [String]-renderRes i Result{..} =-        [tr $ td "mod" (f modul) ++ td "ans" (href selfUrl $ showTagHTMLWith url selfText)-        ,tr $ td "pkg" (f package) ++ td "doc" docs2]+renderRes :: Int -> Bool -> Result -> [String]+renderRes i more Result{..} =+        ["<a name='more'></a>" | more] +++        ["<div class='ans'>" ++ href selfUrl (showTagHTMLWith url self) ++ "</div>"] +++        ["<div class='from'>" ++ intercalate ", " [unwords $ zipWith (f u) [1..] ps | (u,ps) <- locations] ++ "</div>" | not $ null locations] +++        ["<div class='doc'>" ++ docs2 ++ "</div>" | showTagText docs /= ""]     where-        (selfUrl,selfText) = self-        f = maybe "" (uncurry href)+        selfUrl = head $ map fst locations ++ [""]+        f u cls (url,text) = "<a class='p" ++ show cls ++ "' href='" ++  url2 ++ "'>" ++ text ++ "</a>"+            where url2 = if url == takeWhile (/= '#') u then u else url          docs2 = ("<div id='d" ++ show i ++ "' class='shut'>" ++                    "<a class='docs' onclick='return docs(" ++ show i ++ ")' href='" ++& selfUrl ++ "'></a>") ++?@@ -137,7 +131,4 @@         g (TagEmph x) = TagBold x         g x = x --tr x = "<tr>" ++ x ++ "</tr>"-td c x = "<td" ++ (if null c then "" else " class='" ++ c ++ "'") ++ ">" ++ x ++ "</td>"-href url x = if null url then x else "<a class='dull' href='" ++& url ++ "'>" ++ x ++ "</a>"+        href url x = if null url then x else "<a class='dull' href='" ++& url ++ "'>" ++ x ++ "</a>"

@@ -19,9 +19,12 @@ server :: CmdLine -> IO () server q@Server{..} = withSocketsDo $ do     stop <- httpServer port (talk q)-    putStrLn $ "Started Hoogle Server on port " ++ show port-    b <- hIsClosed stdin-    (if b then forever $ threadDelay maxBound else getChar >> return ()) `finally` stop+    flip finally stop $ do+        putStrLn $ "Started Hoogle Server on port " ++ show port+        -- must run under nohup, and with input from /dev/null+        shut <- if nostdin then return True else hIsClosed stdin+        eof <- if shut then return True else isEOF+        when eof $ forever $ threadDelay maxBound   -- | Given a port and a handler, return an action to shutdown the server