From ecb4b9fa74a80947a516151fdb7eb35e85e59e1e Mon Sep 17 00:00:00 2001 From: Francesco Gazzetta Date: Fri, 11 Jul 2025 15:57:31 +0200 Subject: [PATCH 1/2] Action/Generate: Add relocatable option This is useful for example if you generate the haddocks and the index in CI and deploy them to another machine at a different path. --- docs/Install.md | 9 +++++++-- src/Action/CmdLine.hs | 2 ++ src/Action/Generate.hs | 21 +++++++++++++++++---- src/General/Util.hs | 2 +- 4 files changed, 27 insertions(+), 7 deletions(-) diff --git a/docs/Install.md b/docs/Install.md index 4413142c..5f9877d3 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 --local=mydir` to generate an index that supports moving the Haddock directory to a different path without breaking the Haddock links. +This mode only supports one `--local` directory. ## Searching a Hoogle database diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs index 3ba18e2e..c25c2c8d 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 :: Bool } | 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 = False &= help "Generate a relocatable database" } &= help "Generate Hoogle databases" server = Server diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs index b5094dbe..eb10e7fa 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 $ replace "\\" "/" dir ++ "/" + Nothing -> "file://" ++ ['/' | not $ "/" `isPrefixOf` dir] ++ replace "\\" "/" dir ++ "/" when (isJust $ bstrSplitInfix (bstrPack "@package " <> bstrPack (unPackageName name)) src) $ yield (name, url, lbstrFromChunks [src]) pure (Map.union @@ -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" relocatable "--relocatable" readHaskellHaddock timing settings dir | [""] <- local_ -> do warnFlagIgnored "--local" "used as flag (no paths)" (isJust download) "--download" readHaskellGhcpkg timing settings | [] <- local_ -> do readHaskellOnline timing settings doDownload - | otherwise -> readHaskellDirs timing settings local_ + | relocatable, _:_:_ <- local_ -> + exitFail "Error: --relocatable needs exactly one --local, or the paths will be ambiguous" + | relocatable -> do + prefix <- traverse canonicalizePath $ listToMaybe local_ + readHaskellDirs timing settings prefix 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..82030818 100644 --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -113,7 +113,7 @@ getStatsDebug = do -exitFail :: String -> IO () +exitFail :: String -> IO a exitFail msg = do hPutStrLn stderr msg exitFailure From 2104dc52ef6a67d5b87f71f52856ae131d5fb71a Mon Sep 17 00:00:00 2001 From: Francesco Gazzetta Date: Fri, 12 Dec 2025 11:03:39 +0100 Subject: [PATCH 2/2] Make --relocatable accept a path --- docs/Install.md | 4 ++-- src/Action/CmdLine.hs | 4 ++-- src/Action/Generate.hs | 12 ++++++------ 3 files changed, 10 insertions(+), 10 deletions(-) diff --git a/docs/Install.md b/docs/Install.md index 5f9877d3..e5a82755 100644 --- a/docs/Install.md +++ b/docs/Install.md @@ -31,8 +31,8 @@ Run `hoogle generate --local=mydir1 --local=mydir2` to generate an index for the ### Index a directory, producing a relocatable database -Run `hoogle generate --relocatable --local=mydir` to generate an index that supports moving the Haddock directory to a different path without breaking the Haddock links. -This mode only supports one `--local` directory. +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 c25c2c8d..270f979a 100644 --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -45,7 +45,7 @@ data CmdLine ,haddock :: Maybe FilePath ,debug :: Bool ,language :: Language - ,relocatable :: Bool + ,relocatable :: Maybe FilePath } | Server {port :: Int @@ -152,7 +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 = False &= help "Generate a relocatable database" + ,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 eb10e7fa..ee8fd9a7 100644 --- a/src/Action/Generate.hs +++ b/src/Action/Generate.hs @@ -246,17 +246,17 @@ 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" relocatable "--relocatable" + 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 <- traverse canonicalizePath relocatable + readHaskellDirs timing settings prefix [relocatable'] | [] <- local_ -> do readHaskellOnline timing settings doDownload - | relocatable, _:_:_ <- local_ -> - exitFail "Error: --relocatable needs exactly one --local, or the paths will be ambiguous" - | relocatable -> do - prefix <- traverse canonicalizePath $ listToMaybe local_ - readHaskellDirs timing settings prefix local_ | otherwise -> readHaskellDirs timing settings Nothing local_ Frege | [] <- local_ -> readFregeOnline timing doDownload | otherwise -> errorIO "No support for local Frege databases"