{-# 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

}