diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -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 maintainer: Neil Mitchell -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 diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -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)." diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs --- a/src/Action/Generate.hs +++ b/src/Action/Generate.hs @@ -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 diff --git a/src/Action/Server.hs b/src/Action/Server.hs --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -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 $ ["

" ++ renderQuery query ++ "

" ,""] ++ ["

No results found

" | null results] ++ ["
" ++ - "
" ++ displayItem query targetItem ++ "
" ++ - "
" ++ showFroms local is ++ "
" ++ + "
" ++ displayItem query targetItem ++ "
" ++ + "
" ++ showFroms local haddock is ++ "
" ++ "
" ++ targetDocs ++ "
" ++ "
" | 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 ++ "" | (a,b) <- catMaybes $ p : map remod ms] + in unwords ["" ++ 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" === "type family"