Skip to content

Commit 3f86ca1

Browse files
chrisdonechrisdone
committed
Add stack hoogle command (hoogle-5.0)
Blocked on ndmitchell/hoogle#170 (comment)
1 parent f7d3124 commit 3f86ca1

3 files changed

Lines changed: 145 additions & 1 deletion

File tree

‎src/Stack/Types/Config.hs‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -119,6 +119,8 @@ module Stack.Types.Config
119119
,hpcReportDir
120120
,installationRootDeps
121121
,installationRootLocal
122+
,hoogleRoot
123+
,hoogleDatabasePath
122124
,packageDatabaseDeps
123125
,packageDatabaseExtra
124126
,packageDatabaseLocal
@@ -1304,6 +1306,19 @@ installationRootLocal = do
13041306
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
13051307
return $ getProjectWorkDir bc </> $(mkRelDir "install") </> psc
13061308

1309+
-- | Hoogle directory.
1310+
hoogleRoot :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs Dir)
1311+
hoogleRoot = do
1312+
bc <- asks getBuildConfig
1313+
psc <- useShaPathOnWindows =<< platformSnapAndCompilerRel
1314+
return $ getProjectWorkDir bc </> $(mkRelDir "hoogle") </> psc
1315+
1316+
-- | Get the hoogle database path.
1317+
hoogleDatabasePath :: (MonadThrow m, MonadReader env m, HasEnvConfig env) => m (Path Abs File)
1318+
hoogleDatabasePath = do
1319+
dir <- hoogleRoot
1320+
return (dir </> $(mkRelFile "database.hoo"))
1321+
13071322
-- | Path for platform followed by snapshot name followed by compiler
13081323
-- name.
13091324
platformSnapAndCompilerRel

‎src/System/Process/Read.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ module System.Process.Read
3333
,ReadProcessException (..)
3434
,augmentPath
3535
,augmentPathMap
36+
,resetExeCache
3637
)
3738
where
3839

@@ -378,6 +379,10 @@ findExecutable eo name = liftIO $ do
378379
return epath
379380
return $ either throwM return epath
380381

382+
-- | Reset the executable cache.
383+
resetExeCache :: MonadIO m => EnvOverride -> m ()
384+
resetExeCache eo = liftIO (atomicModifyIORef (eoExeCache eo) (const mempty))
385+
381386
-- | Load up an 'EnvOverride' from the standard environment.
382387
getEnvOverride :: MonadIO m => Platform -> m EnvOverride
383388
getEnvOverride platform =

‎src/main/Main.hs‎

Lines changed: 125 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,8 @@ import qualified Data.Text.IO as T
3535
import Data.Traversable
3636
import Data.Typeable (Typeable)
3737
import Data.Version (showVersion)
38+
import System.Process.Read
39+
import System.Process.Run
3840
#ifdef USE_GIT_INFO
3941
import Development.GitRev (gitCommitCount, gitHash)
4042
#endif
@@ -91,7 +93,6 @@ import System.Exit
9193
import System.FileLock (lockFile, tryLockFile, unlockFile, SharedExclusive(Exclusive), FileLock)
9294
import System.FilePath (pathSeparator, searchPathSeparator)
9395
import System.IO (hIsTerminalDevice, stderr, stdin, stdout, hSetBuffering, BufferMode(..), hPutStrLn, Handle, hGetEncoding, hSetEncoding)
94-
import System.Process.Read
9596

9697
-- | Change the character encoding of the given Handle to transliterate
9798
-- on unsupported characters instead of throwing an exception
@@ -325,6 +326,18 @@ commandLineHandler progName isInterpreter = complicatedOptions
325326
"Run ghci in the context of package(s) (experimental) (alias for 'ghci')"
326327
ghciCmd
327328
ghciOptsParser
329+
addCommand' "hoogle"
330+
"Run hoogle in the context of the current Stack config"
331+
hoogleCmd
332+
((,,) <$> many (strArgument (metavar "ARG"))
333+
<*> boolFlags
334+
True
335+
"setup"
336+
"If needed: Install hoogle, build haddocks, generate a hoogle database"
337+
idm
338+
<*> switch
339+
(long "rebuild" <>
340+
help "Rebuild the hoogle database"))
328341
)
329342

330343
-- These two are the only commands allowed in interpreter mode as well
@@ -1098,6 +1111,117 @@ evalCmd EvalOpts {..} go@GlobalOpts {..} = execCmd execOpts go
10981111
, eoExtra = evalExtra
10991112
}
11001113

1114+
-- | Hoogle command.
1115+
hoogleCmd :: ([String],Bool,Bool) -> GlobalOpts -> IO ()
1116+
hoogleCmd (args,setup,rebuild) go = withBuildConfig go pathToHaddocks
1117+
where
1118+
pathToHaddocks :: StackT EnvConfig IO ()
1119+
pathToHaddocks = do
1120+
hoogleIsInPath <- checkHoogleInPath
1121+
if hoogleIsInPath
1122+
then haddocksToDb
1123+
else do
1124+
if setup
1125+
then do
1126+
$logWarn
1127+
"Hoogle isn't installed. Automatically installing (use --no-setup to disable) ..."
1128+
installHoogle
1129+
haddocksToDb
1130+
else do
1131+
$logError
1132+
"Hoogle isn't installed. Not installing it due to --no-setup."
1133+
bail
1134+
haddocksToDb :: StackT EnvConfig IO ()
1135+
haddocksToDb = do
1136+
databaseExists <- checkDatabaseExists
1137+
if databaseExists && not rebuild
1138+
then runHoogle args
1139+
else if setup || rebuild
1140+
then do
1141+
$logWarn
1142+
(if rebuild
1143+
then "Rebuilding database ..."
1144+
else "No Hoogle database yet. Automatically building haddocks and hoogle database (use --no-setup to disable) ...")
1145+
buildHaddocks
1146+
$logInfo "Built docs."
1147+
generateDb
1148+
$logInfo "Generated DB."
1149+
runHoogle args
1150+
else do
1151+
$logError
1152+
"No Hoogle database. Not building one due to --no-setup"
1153+
bail
1154+
generateDb :: StackT EnvConfig IO ()
1155+
generateDb = do
1156+
do dir <- hoogleRoot
1157+
createDirIfMissing True dir
1158+
runHoogle ["generate", "--local"]
1159+
buildHaddocks :: StackT EnvConfig IO ()
1160+
buildHaddocks =
1161+
liftIO
1162+
(catch
1163+
(withBuildConfigAndLock
1164+
(set
1165+
(globalOptsBuildOptsMonoid . buildOptsMonoidHaddock)
1166+
(Just True)
1167+
go)
1168+
(\lk ->
1169+
Stack.Build.build
1170+
(const (return ()))
1171+
lk
1172+
defaultBuildOptsCLI))
1173+
(\(_ :: ExitCode) ->
1174+
return ()))
1175+
installHoogle :: StackT EnvConfig IO ()
1176+
installHoogle =
1177+
do config <- asks getConfig
1178+
menv <- liftIO $ configEnvOverride config envSettings
1179+
liftIO
1180+
(catch
1181+
(withBuildConfigAndLock
1182+
go
1183+
(\lk ->
1184+
Stack.Build.build
1185+
(const (return ()))
1186+
lk
1187+
defaultBuildOptsCLI
1188+
{ boptsCLITargets = ["hoogle"]
1189+
}))
1190+
(\(e :: ExitCode) ->
1191+
case e of
1192+
ExitSuccess -> resetExeCache menv
1193+
_ -> throwIO e))
1194+
runHoogle :: [String] -> StackT EnvConfig IO ()
1195+
runHoogle hoogleArgs = do
1196+
config <- asks getConfig
1197+
menv <- liftIO $ configEnvOverride config envSettings
1198+
dbpath <- hoogleDatabasePath
1199+
let databaseArg = ["--database=" ++ toFilePath dbpath]
1200+
runCmd
1201+
(Cmd
1202+
{ cmdDirectoryToRunIn = Nothing
1203+
, cmdCommandToRun = "hoogle"
1204+
, cmdEnvOverride = menv
1205+
, cmdCommandLineArguments = hoogleArgs ++ databaseArg
1206+
})
1207+
Nothing
1208+
bail :: StackT EnvConfig IO ()
1209+
bail = liftIO (exitWith (ExitFailure (-1)))
1210+
checkDatabaseExists = do
1211+
path <- hoogleDatabasePath
1212+
liftIO (doesFileExist path)
1213+
checkHoogleInPath = do
1214+
config <- asks getConfig
1215+
menv <- liftIO $ configEnvOverride config envSettings
1216+
System.Process.Read.doesExecutableExist menv "hoogle"
1217+
envSettings =
1218+
EnvSettings
1219+
{ esIncludeLocals = True
1220+
, esIncludeGhcPackagePath = True
1221+
, esStackExe = True
1222+
, esLocaleUtf8 = False
1223+
}
1224+
11011225
-- | Run GHCi in the context of a project.
11021226
ghciCmd :: GhciOpts -> GlobalOpts -> IO ()
11031227
ghciCmd ghciOpts go@GlobalOpts{..} =

0 commit comments

Comments
 (0)