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.

Author: fgaz-scrive

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 diffent path without breaking the Haddock links.
+This mode only supports one `--local` directory.
 
 ## Searching a Hoogle database
 

src/Action/CmdLine.hs

@@ -44,6 +44,7 @@ data CmdLine
         ,haddock :: Maybe FilePath
         ,debug :: Bool
         ,language :: Language
+        ,relocatable :: Bool
         }
     | Server
         {port :: Int
@@ -132,6 +133,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

src/Action/Generate.hs

@@ -121,8 +121,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
+  -> [FilePath] -- ^ Prefix to remove from URLs to make the DB relocatable
+  -> 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
@@ -134,7 +139,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 ++ "/"
             yield (name, url, lbstrFromChunks [src])
     pure (Map.union
                 (Map.fromList cabals)
@@ -237,12 +244,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

src/General/Util.hs

@@ -112,7 +112,7 @@ getStatsDebug = do
 
 
 
-exitFail :: String -> IO ()
+exitFail :: String -> IO a
 exitFail msg = do
     hPutStrLn stderr msg
     exitFailure