stack-1.6.1: src/Stack/Hoogle.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
-- | A wrapper around hoogle.
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
-- | Hoogle command.
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
-- FIXME this Nothing means "do not follow any
-- specific snapshot", which matches old
-- behavior. However, since introducing the
-- logic to pin a name to a package in a
-- snapshot, we may arguably want to ensure
-- that we're grabbing the version of Hoogle
-- present in the snapshot currently being
-- used.
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
}