hoogle 5.0.8 → 5.0.9
raw patch · 6 files changed
+50/−20 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES.txt +2/−0
- LICENSE +1/−1
- hoogle.cabal +2/−2
- src/Action/CmdLine.hs +4/−0
- src/Action/Generate.hs +19/−1
- src/Action/Server.hs +22/−16
CHANGES.txt view
@@ -1,5 +1,7 @@ Changelog for Hoogle +5.0.9+ #202, add --haddock functionality 5.0.8 #194, make --local work regardless of code page 5.0.7
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2004-2016.+Copyright Neil Mitchell 2004-2017. All rights reserved. Redistribution and use in source and binary forms, with or without
hoogle.cabal view
@@ -1,13 +1,13 @@ cabal-version: >= 1.18 build-type: Simple name: hoogle-version: 5.0.8+version: 5.0.9 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2004-2016+copyright: Neil Mitchell 2004-2017 synopsis: Haskell API Search description: Hoogle is a Haskell API search engine, which allows you to
src/Action/CmdLine.hs view
@@ -36,6 +36,7 @@ ,insecure :: Bool ,include :: [String] ,local_ :: [FilePath]+ ,haddock :: Maybe FilePath ,debug :: Bool ,language :: Language }@@ -45,6 +46,7 @@ ,cdn :: String ,logs :: FilePath ,local :: Bool+ ,haddock :: Maybe FilePath ,language :: Language ,scope :: String ,home :: String@@ -112,6 +114,7 @@ ,insecure = def &= help "Allow insecure HTTPS connections" ,include = def &= args &= typ "PACKAGE" ,local_ = def &= opt "" &= help "Index local packages"+ ,haddock = def &= help "Use local haddocks" ,debug = def &= help "Generate debug information" } &= help "Generate Hoogle databases" @@ -120,6 +123,7 @@ ,cdn = "" &= typ "URL" &= help "URL prefix to use" ,logs = "" &= opt "log.txt" &= typFile &= help "File to log requests to (defaults to stdout)" ,local = False &= help "Allow following file:// links, restricts to 127.0.0.1 Set --host explicitely (including to '*' for any host) to override the localhost-only behaviour"+ ,haddock = def &= help "Serve local haddocks from a specified directory" ,scope = def &= help "Default scope to start with" ,home = "http://hoogle.haskell.org" &= typ "URL" &= help "Set the URL linked to by the Hoogle logo." ,host = "" &= help "Set the host to bind on (e.g., an ip address; '!4' for ipv4-only; '!6' for ipv6-only; default: '*' for any host)."
src/Action/Generate.hs view
@@ -170,7 +170,24 @@ in Map.map (\p -> p{packageTags = ts ++ packageTags p}) cbl return (cbl, Map.keysSet cbl, source) +readHaskellHaddock :: Timing -> Settings -> FilePath -> IO (Map.Map String Package, Set.Set String, Source IO (String, URL, LStr))+readHaskellHaddock timing settings docBaseDir = do+ cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings+ let source =+ forM_ (Map.toList cbl) $ \(name, p@Package{..}) -> do+ let docs = docDir name p+ file = docBaseDir </> docs </> name <.> "txt"+ whenM (liftIO $ doesFileExist file) $ do+ src <- liftIO $ strReadFile file+ let url = ['/' | not $ all isPathSeparator $ take 1 docs] +++ replace "\\" "/" (addTrailingPathSeparator docs)+ yield (name, url, lstrFromChunks [src])+ cbl <- return $ let ts = map (both T.pack) [("set","stackage"),("set","installed")]+ in Map.map (\p -> p{packageTags = ts ++ packageTags p}) cbl+ return (cbl, Map.keysSet cbl, source) + where docDir name Package{..} = name ++ "-" ++ T.unpack packageVersion+ actionGenerate :: CmdLine -> IO () actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtension database "timing" else Nothing) $ \timing -> do putStrLn "Starting generate"@@ -180,7 +197,8 @@ download <- return $ downloadInput timing insecure download (takeDirectory database) settings <- loadSettings (cbl, want, source) <- case language of- Haskell | [""] <- local_ -> readHaskellGhcpkg timing settings+ Haskell | Just dir <- haddock -> readHaskellHaddock timing settings dir+ | [""] <- local_ -> readHaskellGhcpkg timing settings | [] <- local_ -> readHaskellOnline timing settings download | otherwise -> readHaskellDirs timing settings local_ Frege | [] <- local_ -> readFregeOnline timing download
src/Action/Server.hs view
@@ -6,6 +6,7 @@ import System.FilePath import Control.Exception import Control.DeepSeq+import System.Directory import Data.Tuple.Extra import qualified Language.Javascript.JQuery as JQuery import qualified Language.Javascript.Flot as Flot@@ -53,8 +54,9 @@ putStrLn . showDuration =<< time evaluate spawned dataDir <- getDataDir+ haddock <- maybe (return Nothing) (fmap Just . canonicalizePath) haddock withSearch database $ \store ->- server log cmd $ replyServer log local store cdn home (dataDir </> "html") scope+ server log cmd $ replyServer log local haddock store cdn home (dataDir </> "html") scope actionReplay :: CmdLine -> IO () actionReplay Replay{..} = withBuffering stdout NoBuffering $ do@@ -63,7 +65,7 @@ (t,_) <- duration $ withSearch database $ \store -> do log <- logNone dataDir <- getDataDir- let op = replyServer log False store "" "" (dataDir </> "html") scope+ let op = replyServer log False Nothing store "" "" (dataDir </> "html") scope replicateM_ repeat_ $ forM_ qs $ \x -> do res <- op x evaluate $ rnf res@@ -74,8 +76,8 @@ spawned :: UTCTime spawned = unsafePerformIO getCurrentTime -replyServer :: Log -> Bool -> StoreRead -> String -> String -> FilePath -> String -> Input -> IO Output-replyServer log local store cdn home htmlDir scope = \Input{..} -> case inputURL of+replyServer :: Log -> Bool -> Maybe FilePath -> StoreRead -> String -> String -> FilePath -> String -> Input -> IO Output+replyServer log local haddock store cdn home htmlDir scope Input{..} = case inputURL of -- without -fno-state-hack things can get folded under this lambda [] -> do let grab name = [x | (a,x) <- inputArgs, a == name, x /= ""]@@ -83,7 +85,7 @@ let qSource = grab "hoogle" ++ filter (/= "set:stackage") qScope let q = concatMap parseQuery qSource let (q2, results) = search store q- let body = showResults local inputArgs q2 $ dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results+ let body = showResults local haddock inputArgs q2 $ dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results case lookup "mode" $ reverse inputArgs of Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex $ map (second str) [("tags",tagOptions qScope)@@ -115,6 +117,9 @@ return $ OutputText $ lstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x else return $ OutputFail $ lstrPack "GHC Statistics is not enabled, restart with +RTS -T"+ "haddock":xs | Just x <- haddock -> do+ let file = intercalate "/" $ filter (not . (== "..")) (x:xs)+ return $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "") "file":xs | local -> do let x = ['/' | not isWindows] ++ intercalate "/" xs return $ OutputFile $ x ++ (if hasTrailingPathSeparator x then "index.html" else "")@@ -145,8 +150,8 @@ where k = key x -showResults :: Bool -> [(String, String)] -> [Query] -> [[Target]] -> String-showResults local args query results = unlines $+showResults :: Bool -> Maybe FilePath -> [(String, String)] -> [Query] -> [[Target]] -> String+showResults local haddock args query results = unlines $ ["<h1>" ++ renderQuery query ++ "</h1>" ,"<ul id=left>" ,"<li><b>Packages</b></li>"] ++@@ -154,8 +159,8 @@ ["</ul>"] ++ ["<p>No results found</p>" | null results] ++ ["<div class=result>" ++- "<div class=ans><a href=\"" ++ showURL local targetURL ++ "\">" ++ displayItem query targetItem ++ "</a></div>" ++- "<div class=from>" ++ showFroms local is ++ "</div>" +++ "<div class=ans><a href=\"" ++ showURL local haddock targetURL ++ "\">" ++ displayItem query targetItem ++ "</a></div>" +++ "<div class=from>" ++ showFroms local haddock is ++ "</div>" ++ "<div class=\"doc newline shut\">" ++ targetDocs ++ "</div>" ++ "</div>" | is@(Target{..}:_) <- results]@@ -177,17 +182,18 @@ [("is","module") | any ((==) "module" . targetType) xs] ++ nubOrd [("package",p) | Just (p,_) <- map targetPackage xs] -showFroms :: Bool -> [Target] -> String-showFroms local xs = intercalate ", " $ for pkgs $ \p ->+showFroms :: Bool -> Maybe FilePath -> [Target] -> String+showFroms local haddock xs = intercalate ", " $ for pkgs $ \p -> let ms = filter ((==) p . targetPackage) xs- in unwords ["<a href=\"" ++ showURL local b ++ "\">" ++ a ++ "</a>" | (a,b) <- catMaybes $ p : map remod ms]+ in unwords ["<a href=\"" ++ showURL local haddock b ++ "\">" ++ a ++ "</a>" | (a,b) <- catMaybes $ p : map remod ms] where remod Target{..} = do (a,_) <- targetModule; return (a,targetURL) pkgs = nubOrd $ map targetPackage xs -showURL :: Bool -> URL -> String-showURL True (stripPrefix "file:///" -> Just x) = "file/" ++ x-showURL _ x = x+showURL :: Bool -> Maybe FilePath -> URL -> String+showURL _ (Just _) x = "haddock" ++ x+showURL True _ (stripPrefix "file:///" -> Just x) = "file/" ++ x+showURL _ _ x = x -------------------------------------------------------------@@ -233,7 +239,7 @@ log <- logNone dataDir <- getDataDir let q === want = do- OutputHTML (lstrUnpack -> res) <- replyServer log False store "" "" (dataDir </> "html") "" (Input [] [("hoogle",q)])+ OutputHTML (lstrUnpack -> res) <- replyServer log False Nothing store "" "" (dataDir </> "html") "" (Input [] [("hoogle",q)]) if want `isInfixOf` res then putChar '.' else fail $ "Bad substring: " ++ res if sample then "Wife" === "<b>type family</b>"