module Stack.Hoogle
( hoogleCmd
) where
import Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import Data.Char (isSpace)
import Data.List (find)
import qualified Data.Set as Set
import qualified Data.Text as T
import Lens.Micro
import Path.IO hiding (findExecutable)
import qualified Stack.Build
import Stack.Fetch
import Stack.Runners
import Stack.Types.Config
import Stack.Types.PackageIdentifier
import Stack.Types.PackageName
import Stack.Types.Version
import System.Exit
import System.Process.Read (resetExeCache, tryProcessStdout, findExecutable)
import System.Process.Run
hoogleCmd :: ([String],Bool,Bool) -> GlobalOpts -> IO ()
hoogleCmd (args,setup,rebuild) go = withBuildConfig go $ do
hooglePath <- ensureHoogleInPath
generateDbIfNeeded hooglePath
runHoogle hooglePath args
where
generateDbIfNeeded :: Path Abs File -> RIO EnvConfig ()
generateDbIfNeeded hooglePath = do
databaseExists <- checkDatabaseExists
if databaseExists && not rebuild
then return ()
else if setup || rebuild
then do
logWarn
(if rebuild
then "Rebuilding database ..."
else "No Hoogle database yet. Automatically building haddocks and hoogle database (use --no-setup to disable) ...")
buildHaddocks
logInfo "Built docs."
generateDb hooglePath
logInfo "Generated DB."
else do
logError
"No Hoogle database. Not building one due to --no-setup"
bail
generateDb :: Path Abs File -> RIO EnvConfig ()
generateDb hooglePath = do
do dir <- hoogleRoot
createDirIfMissing True dir
runHoogle hooglePath ["generate", "--local"]
buildHaddocks :: RIO EnvConfig ()
buildHaddocks =
liftIO
(catch
(withBuildConfigAndLock
(set
(globalOptsBuildOptsMonoidL . buildOptsMonoidHaddockL)
(Just True)
go)
(\lk ->
Stack.Build.build
(const (return ()))
lk
defaultBuildOptsCLI))
(\(_ :: ExitCode) ->
return ()))
hooglePackageName = $(mkPackageName "hoogle")
hoogleMinVersion = $(mkVersion "5.0")
hoogleMinIdent =
PackageIdentifier hooglePackageName hoogleMinVersion
installHoogle :: RIO EnvConfig ()
installHoogle = do
hooglePackageIdentifier <-
do (_,_,resolved) <-
resolvePackagesAllowMissing
Nothing
mempty
(Set.fromList [hooglePackageName])
return
(case find
((== hooglePackageName) . packageIdentifierName)
(map rpIdent resolved) of
Just ident@(PackageIdentifier _ ver)
| ver >= hoogleMinVersion -> Right ident
_ -> Left hoogleMinIdent)
case hooglePackageIdentifier of
Left{} ->
logInfo
("Minimum " <> packageIdentifierText hoogleMinIdent <>
" is not in your index. Installing the minimum version.")
Right ident ->
logInfo
("Minimum version is " <> packageIdentifierText hoogleMinIdent <>
". Found acceptable " <>
packageIdentifierText ident <>
" in your index, installing it.")
config <- view configL
menv <- liftIO $ configEnvOverride config envSettings
liftIO
(catch
(withBuildConfigAndLock
go
(\lk ->
Stack.Build.build
(const (return ()))
lk
defaultBuildOptsCLI
{ boptsCLITargets = [ packageIdentifierText
(either
id
id
hooglePackageIdentifier)]
}))
(\(e :: ExitCode) ->
case e of
ExitSuccess -> resetExeCache menv
_ -> throwIO e))
runHoogle :: Path Abs File -> [String] -> RIO EnvConfig ()
runHoogle hooglePath hoogleArgs = do
config <- view configL
menv <- liftIO $ configEnvOverride config envSettings
dbpath <- hoogleDatabasePath
let databaseArg = ["--database=" ++ toFilePath dbpath]
runCmd
Cmd
{ cmdDirectoryToRunIn = Nothing
, cmdCommandToRun = toFilePath hooglePath
, cmdEnvOverride = menv
, cmdCommandLineArguments = hoogleArgs ++ databaseArg
}
Nothing
bail :: RIO EnvConfig a
bail = liftIO (exitWith (ExitFailure (1)))
checkDatabaseExists = do
path <- hoogleDatabasePath
liftIO (doesFileExist path)
ensureHoogleInPath :: RIO EnvConfig (Path Abs File)
ensureHoogleInPath = do
config <- view configL
menv <- liftIO $ configEnvOverride config envSettings
mhooglePath <- findExecutable menv "hoogle"
eres <- case mhooglePath of
Nothing -> return $ Left "Hoogle isn't installed."
Just hooglePath -> do
result <- tryProcessStdout Nothing menv (toFilePath hooglePath) ["--numeric-version"]
let unexpectedResult got = Left $ T.concat
[ "'"
, T.pack (toFilePath hooglePath)
, " --numeric-version' did not respond with expected value. Got: "
, got
]
return $ case result of
Left err -> unexpectedResult $ T.pack (show err)
Right bs -> case parseVersionFromString (takeWhile (not . isSpace) (S8.unpack bs)) of
Nothing -> unexpectedResult $ T.pack (S8.unpack bs)
Just ver
| ver >= hoogleMinVersion -> Right hooglePath
| otherwise -> Left $ T.concat
[ "Installed Hoogle is too old, "
, T.pack (toFilePath hooglePath)
, " is version "
, versionText ver
, " but >= 5.0 is required."
]
case eres of
Right hooglePath -> return hooglePath
Left err
| setup -> do
logWarn $ err <> " Automatically installing (use --no-setup to disable) ..."
installHoogle
mhooglePath' <- findExecutable menv "hoogle"
case mhooglePath' of
Just hooglePath -> return hooglePath
Nothing -> do
logWarn "Couldn't find hoogle in path after installing. This shouldn't happen, may be a bug."
bail
| otherwise -> do
logWarn $ err <> " Not installing it due to --no-setup."
bail
envSettings =
EnvSettings
{ esIncludeLocals = True
, esIncludeGhcPackagePath = True
, esStackExe = True
, esLocaleUtf8 = False
, esKeepGhcRts = False
}