diff --git a/docs/Install.md b/docs/Install.md index 4413142c..e5a82755 100644 --- a/docs/Install.md +++ b/docs/Install.md @@ -25,9 +25,14 @@ Run `hoogle generate base filepath` to generate an index for only the `base` and Run `hoogle generate --local` to query `ghc-pkg` and generate links for all packages which have documentation and Hoogle input files generated. By editing your Cabal config file you can have Cabal automatically generate such files when packages are installed. Links to the results will point at your local file system. -### Index a directory +### Index one or more directories -Run `hoogle generate --local=mydir` to generate an index for the packages in `mydir`, which must contain `foo.txt` Hoogle input files. Links to the results will default to Hackage, but if `@url` directives are in the `.txt` files they can override the link destination. +Run `hoogle generate --local=mydir1 --local=mydir2` to generate an index for the packages in `mydir1` and `mydir2`, which must contain `foo.txt` Hoogle input files. Links to the results will default to Hackage, but if `@url` directives are in the `.txt` files they can override the link destination. + +### Index a directory, producing a relocatable database + +Run `hoogle generate --relocatable=mydir` to generate an index that supports moving the Haddock directory to a different path without breaking the Haddock links. +This mode acts like `--local` but only supports one directory. ## Searching a Hoogle database diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs index 3ba18e2e..270f979a 100644 --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -45,6 +45,7 @@ data CmdLine ,haddock :: Maybe FilePath ,debug :: Bool ,language :: Language + ,relocatable :: Maybe FilePath } | Server {port :: Int @@ -151,6 +152,7 @@ generate = Generate ,count = Nothing &= name "n" &= help "Maximum number of packages to index (defaults to all)" ,haddock = def &= help "Use local haddocks" ,debug = def &= help "Generate debug information" + ,relocatable = Nothing &= help "Index local packages and link to local haddock docs, producing a relocatable database" } &= help "Generate Hoogle databases" server = Server diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs index b5094dbe..bf6f975f 100644 --- a/src/Action/Generate.hs +++ b/src/Action/Generate.hs @@ -122,8 +122,13 @@ readHaskellOnline timing settings download = do pure (cbl, want, source) -readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) -readHaskellDirs timing settings dirs = do +readHaskellDirs + :: Timing + -> Settings + -> Maybe FilePath -- ^ Prefix to remove from URLs to make the DB relocatable + -> [FilePath] + -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) +readHaskellDirs timing settings prefixToRemove dirs = do files <- concatMapM listFilesRecursive dirs -- We reverse/sort the list because of #206 -- Two identical package names with different versions might be foo-2.0 and foo-1.0 @@ -135,7 +140,9 @@ readHaskellDirs timing settings dirs = do let source = forM_ packages $ \(name, file) -> do src <- liftIO $ bstrReadFile file dir <- liftIO $ canonicalizePath $ takeDirectory file - let url = "file://" ++ ['/' | not $ "/" `isPrefixOf` dir] ++ replace "\\" "/" dir ++ "/" + let url = case prefixToRemove of + Just prefix -> makeRelative prefix $ normalisePathSeparators dir ++ "/" + Nothing -> "file://" ++ ['/' | not $ "/" `isPrefixOf` dir] ++ normalisePathSeparators dir ++ "/" when (isJust $ bstrSplitInfix (bstrPack "@package " <> bstrPack (unPackageName name)) src) $ yield (name, url, lbstrFromChunks [src]) pure (Map.union @@ -173,7 +180,7 @@ readHaskellGhcpkg timing settings = do src <- liftIO $ bstrReadFile file docs <- liftIO $ canonicalizePath docs let url = "file://" ++ ['/' | not $ all isPathSeparator $ take 1 docs] ++ - replace "\\" "/" (addTrailingPathSeparator docs) + normalisePathSeparators (addTrailingPathSeparator docs) yield (name, url, lbstrFromChunks [src]) cbl <- pure $ let ts = map (both strPack) [("set","stackage"),("set","installed")] in Map.map (\p -> p{packageTags = ts ++ packageTags p}) cbl @@ -210,7 +217,7 @@ readHaskellHaddock timing settings docBaseDir = do whenM (liftIO $ doesFileExist file) $ do src <- liftIO $ bstrReadFile file let url = ['/' | not $ all isPathSeparator $ take 1 docs] ++ - replace "\\" "/" (addTrailingPathSeparator docs) + normalisePathSeparators (addTrailingPathSeparator docs) yield (name, url, lbstrFromChunks [src]) cbl <- pure $ let ts = map (both strPack) [("set","stackage"),("set","installed")] in Map.map (\p -> p{packageTags = ts ++ packageTags p}) cbl @@ -239,12 +246,18 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtensio Haskell | Just dir <- haddock -> do warnFlagIgnored "--haddock" "set" (local_ /= []) "--local" warnFlagIgnored "--haddock" "set" (isJust download) "--download" + warnFlagIgnored "--haddock" "set" (isJust relocatable) "--relocatable" readHaskellHaddock timing settings dir | [""] <- local_ -> do warnFlagIgnored "--local" "used as flag (no paths)" (isJust download) "--download" readHaskellGhcpkg timing settings + | Just _ <- relocatable, _:_ <- local_ -> + exitFail "Error: --relocatable and --local are mutually exclusive" + | Just relocatable' <- relocatable -> do + prefix <- canonicalizePath relocatable' + readHaskellDirs timing settings (Just prefix) [relocatable'] | [] <- local_ -> do readHaskellOnline timing settings doDownload - | otherwise -> readHaskellDirs timing settings local_ + | otherwise -> readHaskellDirs timing settings Nothing local_ Frege | [] <- local_ -> readFregeOnline timing doDownload | otherwise -> errorIO "No support for local Frege databases" (cblErrs, popularity) <- evaluate $ packagePopularity cbl diff --git a/src/General/Util.hs b/src/General/Util.hs index a6398993..28732229 100644 --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -24,6 +24,7 @@ module General.Util( getStatsPeakAllocBytes, getStatsCurrentLiveBytes, getStatsDebug, hackagePackageURL, hackageModuleURL, hackageDeclURL, ghcModuleURL, minimum', maximum', + normalisePathSeparators, general_util_test ) where @@ -50,6 +51,7 @@ import Data.Version import Data.Int import System.IO import System.Exit +import System.FilePath (isPathSeparator) import System.Mem import GHC.Stats import General.Str @@ -113,7 +115,7 @@ getStatsDebug = do -exitFail :: String -> IO () +exitFail :: String -> IO a exitFail msg = do hPutStrLn stderr msg exitFailure @@ -370,6 +372,11 @@ inRanges xs = \x -> maybe False (`inRange` x) $ Map.lookupLE x mp | otherwise = uncurry Map.insert x mp +-- | Turn platform-specific path separators into the canonical / used in URLs. +normalisePathSeparators :: FilePath -> FilePath +normalisePathSeparators = fmap $ \c -> if isPathSeparator c then '/' else c + + general_util_test :: IO () general_util_test = do testing "General.Util.splitPair" $ do