{-# LANGUAGE NoImplicitPrelude #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE ScopedTypeVariables #-}

-- | A wrapper around hoogle.

module Stack.Hoogle

( hoogleCmd

) where

import Stack.Prelude

import qualified Data.ByteString.Lazy.Char8 as BL8

import Data.Char (isSpace)

import qualified Data.Text as T

import Distribution.PackageDescription (packageDescription, package)

import Distribution.Types.PackageName (mkPackageName)

import Distribution.Version (mkVersion)

import Lens.Micro ((?~))

import Path (parseAbsFile)

import Path.IO hiding (findExecutable)

import qualified Stack.Build

import Stack.Build.Target (NeedTargets(NeedTargets))

import Stack.Runners

import Stack.Types.Config

import Stack.Types.SourceMap

import qualified RIO.Map as Map

import RIO.Process

-- | Helper type to duplicate log messages

data Muted = Muted | NotMuted

-- | Hoogle command.

hoogleCmd :: ([String],Bool,Bool,Bool) -> RIO Runner ()

hoogleCmd (args,setup,rebuild,startServer) =

local (over globalOptsL modifyGO) $

withConfig YesReexec $

withDefaultEnvConfig $ do

hooglePath <- ensureHoogleInPath

generateDbIfNeeded hooglePath

runHoogle hooglePath args'

where

modifyGO :: GlobalOpts -> GlobalOpts

modifyGO = globalOptsBuildOptsMonoidL . buildOptsMonoidHaddockL ?~ True

args' :: [String]

args' = if startServer

then ["server", "--local", "--port", "8080"]

else []

++ args

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 = do

config <- view configL

runRIO config $ -- a bit weird that we have to drop down like this

catch (withDefaultEnvConfig $ Stack.Build.build Nothing)

(\(_ :: ExitCode) -> return ())

hooglePackageName = mkPackageName "hoogle"

hoogleMinVersion = mkVersion [5, 0]

hoogleMinIdent =

PackageIdentifier hooglePackageName hoogleMinVersion

installHoogle :: RIO EnvConfig (Path Abs File)

installHoogle = requiringHoogle Muted $ do

Stack.Build.build Nothing

mhooglePath' <- findExecutable "hoogle"

case mhooglePath' of

Right hooglePath -> parseAbsFile hooglePath

Left _ -> do

logWarn "Couldn't find hoogle in path after installing. This shouldn't happen, may be a bug."

bail

requiringHoogle :: Muted -> RIO EnvConfig x -> RIO EnvConfig x

requiringHoogle muted f = do

hoogleTarget <- do

sourceMap <- view $ sourceMapL . to smDeps

case Map.lookup hooglePackageName sourceMap of

Just hoogleDep ->

case dpLocation hoogleDep of

PLImmutable pli ->

T.pack . packageIdentifierString <$>

restrictMinHoogleVersion muted (packageLocationIdent pli)

plm@(PLMutable _) -> do

T.pack . packageIdentifierString . package . packageDescription

<$> loadCabalFile plm

Nothing -> do

-- not muted because this should happen only once

logWarn "No hoogle version was found, trying to install the latest version"

mpir <- getLatestHackageVersion YesRequireHackageIndex hooglePackageName UsePreferredVersions

let hoogleIdent = case mpir of

Nothing -> hoogleMinIdent

Just (PackageIdentifierRevision _ ver _) ->

PackageIdentifier hooglePackageName ver

T.pack . packageIdentifierString <$>

restrictMinHoogleVersion muted hoogleIdent

config <- view configL

let boptsCLI = defaultBuildOptsCLI

{ boptsCLITargets = [hoogleTarget]

}

runRIO config $ withEnvConfig NeedTargets boptsCLI f

restrictMinHoogleVersion

:: HasLogFunc env

=> Muted -> PackageIdentifier -> RIO env PackageIdentifier

restrictMinHoogleVersion muted ident = do

if ident < hoogleMinIdent

then do

muteableLog LevelWarn muted $

"Minimum " <>

fromString (packageIdentifierString hoogleMinIdent) <>

" is not in your index. Installing the minimum version."

pure hoogleMinIdent

else do

muteableLog LevelInfo muted $

"Minimum version is " <>

fromString (packageIdentifierString hoogleMinIdent) <>

". Found acceptable " <>

fromString (packageIdentifierString ident) <>

" in your index, requiring its installation."

pure ident

muteableLog :: HasLogFunc env => LogLevel -> Muted -> Utf8Builder -> RIO env ()

muteableLog logLevel muted msg =

case muted of

Muted -> pure ()

NotMuted -> logGeneric "" logLevel msg

runHoogle :: Path Abs File -> [String] -> RIO EnvConfig ()

runHoogle hooglePath hoogleArgs = do

config <- view configL

menv <- liftIO $ configProcessContextSettings config envSettings

dbpath <- hoogleDatabasePath

let databaseArg = ["--database=" ++ toFilePath dbpath]

withProcessContext menv $ proc

(toFilePath hooglePath)

(hoogleArgs ++ databaseArg)

runProcess_

bail :: RIO EnvConfig a

bail = exitWith (ExitFailure (-1))

checkDatabaseExists = do

path <- hoogleDatabasePath

liftIO (doesFileExist path)

ensureHoogleInPath :: RIO EnvConfig (Path Abs File)

ensureHoogleInPath = do

config <- view configL

menv <- liftIO $ configProcessContextSettings config envSettings

mhooglePath <- runRIO menv (findExecutable "hoogle") <>

requiringHoogle NotMuted (findExecutable "hoogle")

eres <- case mhooglePath of

Left _ -> return $ Left "Hoogle isn't installed."

Right hooglePath -> do

result <- withProcessContext menv

$ proc hooglePath ["--numeric-version"]

$ tryAny . fmap fst . readProcess_

let unexpectedResult got = Left $ T.concat

[ "'"

, T.pack 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 parseVersion (takeWhile (not . isSpace) (BL8.unpack bs)) of

Nothing -> unexpectedResult $ T.pack (BL8.unpack bs)

Just ver

| ver >= hoogleMinVersion -> Right hooglePath

| otherwise -> Left $ T.concat

[ "Installed Hoogle is too old, "

, T.pack hooglePath

, " is version "

, T.pack $ versionString ver

, " but >= 5.0 is required."

]

case eres of

Right hooglePath -> parseAbsFile hooglePath

Left err

| setup -> do

logWarn $ display err <> " Automatically installing (use --no-setup to disable) ..."

installHoogle

| otherwise -> do

logWarn $ display err <> " Not installing it due to --no-setup."

bail

envSettings =

EnvSettings

{ esIncludeLocals = True

, esIncludeGhcPackagePath = True

, esStackExe = True

, esLocaleUtf8 = False

, esKeepGhcRts = False

}