Action/Generate: Add relocatable option

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
 

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

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" (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
-                | 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

src/General/Util.hs

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