{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}

{-|
Module      : Stack.Hoogle
Description : A wrapper around hoogle.
License     : BSD-3-Clause

A wrapper around hoogle.
-}

module Stack.Hoogle
  ( hoogleCmd
  ) where

import qualified Data.ByteString.Lazy.Char8 as BL8
import           Data.Char ( isSpace )
import           Data.Either.Extra ( eitherToMaybe )
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 ( createDirIfMissing, doesFileExist )
import qualified RIO.Map as Map
import           RIO.Process ( findExecutable, proc, readProcess_, runProcess_)
import qualified Stack.Build ( build )
import           Stack.Build.Target ( NeedTargets (..) )
import           Stack.Constants ( stackProgName' )
import           Stack.Prelude
import           Stack.Runners
                   ( ShouldReexec (..), withConfig, withDefaultEnvConfig
                   , withEnvConfig
                   )
import           Stack.Types.BuildOptsCLI
                   ( BuildOptsCLI (..), defaultBuildOptsCLI )
import           Stack.Types.BuildOptsMonoid ( buildOptsMonoidHaddockL )
import           Stack.Types.Config
                   ( Config (..), HasConfig (..) )
import           Stack.Types.EnvConfig
                   ( EnvConfig, HasSourceMap (..), hoogleDatabasePath
                   , hoogleRoot
                   )
import           Stack.Types.EnvSettings ( EnvSettings (..) )
import           Stack.Types.GlobalOpts
                   ( GlobalOpts (..), globalOptsBuildOptsMonoidL )
import           Stack.Types.Runner ( Runner, globalOptsL )
import           Stack.Types.SourceMap ( DepPackage (..), SourceMap (..) )

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.Hoogle" module.

data HoogleException
  = HoogleOnPathNotFoundBug
  deriving Int -> HoogleException -> ShowS
[HoogleException] -> ShowS
HoogleException -> [Char]
(Int -> HoogleException -> ShowS)
-> (HoogleException -> [Char])
-> ([HoogleException] -> ShowS)
-> Show HoogleException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HoogleException -> ShowS
showsPrec :: Int -> HoogleException -> ShowS
$cshow :: HoogleException -> [Char]
show :: HoogleException -> [Char]
$cshowList :: [HoogleException] -> ShowS
showList :: [HoogleException] -> ShowS
Show

instance Exception HoogleException where
  displayException :: HoogleException -> [Char]
displayException HoogleException
HoogleOnPathNotFoundBug = [Char] -> ShowS
bugReport [Char]
"[S-9669]"
    [Char]
"Cannot find Hoogle executable on PATH, after installing."

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Hoogle" module.

data HooglePrettyException
  = HoogleNotFound StyleDoc
  | HoogleDatabaseNotFound
  deriving Int -> HooglePrettyException -> ShowS
[HooglePrettyException] -> ShowS
HooglePrettyException -> [Char]
(Int -> HooglePrettyException -> ShowS)
-> (HooglePrettyException -> [Char])
-> ([HooglePrettyException] -> ShowS)
-> Show HooglePrettyException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HooglePrettyException -> ShowS
showsPrec :: Int -> HooglePrettyException -> ShowS
$cshow :: HooglePrettyException -> [Char]
show :: HooglePrettyException -> [Char]
$cshowList :: [HooglePrettyException] -> ShowS
showList :: [HooglePrettyException] -> ShowS
Show

instance Pretty HooglePrettyException where
  pretty :: HooglePrettyException -> StyleDoc
pretty (HoogleNotFound StyleDoc
e) =
    StyleDoc
"[S-1329]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
e
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Not installing Hoogle due to"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--no-setup" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
  pretty HooglePrettyException
HoogleDatabaseNotFound =
    StyleDoc
"[S-3025]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"No Hoogle database. Not building one due to"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--no-setup" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]

instance Exception HooglePrettyException

-- | Helper type to duplicate log messages

data Muted = Muted | NotMuted

-- | Hoogle command.

hoogleCmd :: ([String], Bool, Bool, Bool) -> RIO Runner ()
hoogleCmd :: ([[Char]], Bool, Bool, Bool) -> RIO Runner ()
hoogleCmd ([[Char]]
args, Bool
setup, Bool
rebuild, Bool
startServer) =
  (Runner -> Runner) -> RIO Runner () -> RIO Runner ()
forall a. (Runner -> Runner) -> RIO Runner a -> RIO Runner a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (ASetter Runner Runner GlobalOpts GlobalOpts
-> (GlobalOpts -> GlobalOpts) -> Runner -> Runner
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Runner Runner GlobalOpts GlobalOpts
forall env. HasRunner env => Lens' env GlobalOpts
Lens' Runner GlobalOpts
globalOptsL GlobalOpts -> GlobalOpts
modifyGO) (RIO Runner () -> RIO Runner ()) -> RIO Runner () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
    ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
YesReexec (RIO Config () -> RIO Runner ()) -> RIO Config () -> RIO Runner ()
forall a b. (a -> b) -> a -> b
$
      RIO EnvConfig () -> RIO Config ()
forall a. RIO EnvConfig a -> RIO Config a
withDefaultEnvConfig (RIO EnvConfig () -> RIO Config ())
-> RIO EnvConfig () -> RIO Config ()
forall a b. (a -> b) -> a -> b
$ do
        hooglePath <- RIO EnvConfig (Path Abs File)
ensureHoogleInPath
        generateDbIfNeeded hooglePath
        runHoogle hooglePath args'
 where
  modifyGO :: GlobalOpts -> GlobalOpts
  modifyGO :: GlobalOpts -> GlobalOpts
modifyGO = (BuildOptsMonoid -> Identity BuildOptsMonoid)
-> GlobalOpts -> Identity GlobalOpts
Lens' GlobalOpts BuildOptsMonoid
globalOptsBuildOptsMonoidL ((BuildOptsMonoid -> Identity BuildOptsMonoid)
 -> GlobalOpts -> Identity GlobalOpts)
-> ((Maybe Bool -> Identity (Maybe Bool))
    -> BuildOptsMonoid -> Identity BuildOptsMonoid)
-> (Maybe Bool -> Identity (Maybe Bool))
-> GlobalOpts
-> Identity GlobalOpts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Bool -> Identity (Maybe Bool))
-> BuildOptsMonoid -> Identity BuildOptsMonoid
Lens' BuildOptsMonoid (Maybe Bool)
buildOptsMonoidHaddockL ((Maybe Bool -> Identity (Maybe Bool))
 -> GlobalOpts -> Identity GlobalOpts)
-> Bool -> GlobalOpts -> GlobalOpts
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
True

  args' :: [String]
  args' :: [[Char]]
args' = if Bool
startServer
    then [[Char]
"server", [Char]
"--local", [Char]
"--port", [Char]
"8080"] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
args
    else [[Char]]
args

  generateDbIfNeeded :: Path Abs File -> RIO EnvConfig ()
  generateDbIfNeeded :: Path Abs File -> RIO EnvConfig ()
generateDbIfNeeded Path Abs File
hooglePath = do
    databaseExists <- RIO EnvConfig Bool
checkDatabaseExists
    unless (databaseExists && not rebuild) $
      if setup || rebuild
        then do
          prettyWarnL $
            if rebuild
              then
                [ flow "Rebuilding database ..." ]
              else
                [ flow "No Hoogle database yet. Automatically building \
                       \Haddock documentation and Hoogle database (use"
                , style Shell "--no-setup"
                , flow "to disable) ..."
                ]
          buildHaddocks
          prettyInfoS "Built Haddock documentation."
          generateDb hooglePath
          prettyInfoS "Generated Hoogle database."
        else prettyThrowIO HoogleDatabaseNotFound

  generateDb :: Path Abs File -> RIO EnvConfig ()
  generateDb :: Path Abs File -> RIO EnvConfig ()
generateDb Path Abs File
hooglePath = do
    dir <- RIO EnvConfig (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hoogleRoot
    createDirIfMissing True dir
    runHoogle hooglePath ["generate", "--local"]

  buildHaddocks :: RIO EnvConfig ()
  buildHaddocks :: RIO EnvConfig ()
buildHaddocks = do
    config <- Getting Config EnvConfig Config -> RIO EnvConfig Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config EnvConfig Config
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL
    runRIO config $ -- a bit weird that we have to drop down like this

      catch (withDefaultEnvConfig $ Stack.Build.build Nothing)
            (\(ExitCode
_ :: ExitCode) -> () -> RIO Config ()
forall a. a -> RIO Config a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

  hooglePackageName :: PackageName
hooglePackageName = [Char] -> PackageName
mkPackageName [Char]
"hoogle"
  hoogleMinVersion :: Version
hoogleMinVersion = [Int] -> Version
mkVersion [Int
5, Int
0]
  hoogleMinIdent :: PackageIdentifier
hoogleMinIdent =
    PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
hooglePackageName Version
hoogleMinVersion

  installHoogle :: RIO EnvConfig (Path Abs File)
  installHoogle :: RIO EnvConfig (Path Abs File)
installHoogle = Muted
-> RIO EnvConfig (Path Abs File) -> RIO EnvConfig (Path Abs File)
forall x. Muted -> RIO EnvConfig x -> RIO EnvConfig x
requiringHoogle Muted
Muted (RIO EnvConfig (Path Abs File) -> RIO EnvConfig (Path Abs File))
-> RIO EnvConfig (Path Abs File) -> RIO EnvConfig (Path Abs File)
forall a b. (a -> b) -> a -> b
$ do
    Maybe (Set (Path Abs File) -> IO ()) -> RIO EnvConfig ()
forall env.
HasEnvConfig env =>
Maybe (Set (Path Abs File) -> IO ()) -> RIO env ()
Stack.Build.build Maybe (Set (Path Abs File) -> IO ())
forall a. Maybe a
Nothing
    mhooglePath' <- [Char] -> RIO EnvConfig (Either ProcessException [Char])
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable [Char]
"hoogle"
    case mhooglePath' of
      Right [Char]
hooglePath -> [Char] -> RIO EnvConfig (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
hooglePath
      Left ProcessException
_ -> HoogleException -> RIO EnvConfig (Path Abs File)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HoogleException
HoogleOnPathNotFoundBug

  requiringHoogle :: Muted -> RIO EnvConfig x -> RIO EnvConfig x
  requiringHoogle :: forall x. Muted -> RIO EnvConfig x -> RIO EnvConfig x
requiringHoogle Muted
muted RIO EnvConfig x
f = do
    hoogleTarget <- do
      sourceMap <- Getting
  (Map PackageName DepPackage) EnvConfig (Map PackageName DepPackage)
-> RIO EnvConfig (Map PackageName DepPackage)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting
   (Map PackageName DepPackage) EnvConfig (Map PackageName DepPackage)
 -> RIO EnvConfig (Map PackageName DepPackage))
-> Getting
     (Map PackageName DepPackage) EnvConfig (Map PackageName DepPackage)
-> RIO EnvConfig (Map PackageName DepPackage)
forall a b. (a -> b) -> a -> b
$ (SourceMap -> Const (Map PackageName DepPackage) SourceMap)
-> EnvConfig -> Const (Map PackageName DepPackage) EnvConfig
forall env. HasSourceMap env => Lens' env SourceMap
Lens' EnvConfig SourceMap
sourceMapL ((SourceMap -> Const (Map PackageName DepPackage) SourceMap)
 -> EnvConfig -> Const (Map PackageName DepPackage) EnvConfig)
-> ((Map PackageName DepPackage
     -> Const (Map PackageName DepPackage) (Map PackageName DepPackage))
    -> SourceMap -> Const (Map PackageName DepPackage) SourceMap)
-> Getting
     (Map PackageName DepPackage) EnvConfig (Map PackageName DepPackage)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SourceMap -> Map PackageName DepPackage)
-> SimpleGetter SourceMap (Map PackageName DepPackage)
forall s a. (s -> a) -> SimpleGetter s a
to (.deps)
      case Map.lookup hooglePackageName sourceMap of
        Just DepPackage
hoogleDep ->
          case DepPackage
hoogleDep.location of
            PLImmutable PackageLocationImmutable
pli ->
              [Char] -> Text
T.pack ([Char] -> Text)
-> (PackageIdentifier -> [Char]) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString (PackageIdentifier -> Text)
-> RIO EnvConfig PackageIdentifier -> RIO EnvConfig Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                  Muted -> PackageIdentifier -> RIO EnvConfig PackageIdentifier
forall env.
HasLogFunc env =>
Muted -> PackageIdentifier -> RIO env PackageIdentifier
restrictMinHoogleVersion Muted
muted (PackageLocationImmutable -> PackageIdentifier
packageLocationIdent PackageLocationImmutable
pli)
            plm :: PackageLocation
plm@(PLMutable ResolvedPath Dir
_) ->
              [Char] -> Text
T.pack ([Char] -> Text)
-> (GenericPackageDescription -> [Char])
-> GenericPackageDescription
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> [Char]
packageIdentifierString (PackageIdentifier -> [Char])
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
packageDescription
                  (GenericPackageDescription -> Text)
-> RIO EnvConfig GenericPackageDescription -> RIO EnvConfig Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
-> PackageLocation -> RIO EnvConfig GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
Maybe Text -> PackageLocation -> RIO env GenericPackageDescription
loadCabalFile (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
stackProgName') PackageLocation
plm
        Maybe DepPackage
Nothing -> do
          -- not muted because this should happen only once

          [Char] -> RIO EnvConfig ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[Char] -> m ()
prettyWarnS
            [Char]
"No hoogle version was found, trying to install the latest version"
          mpir <- RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO EnvConfig (Maybe PackageIdentifierRevision)
forall env.
(HasPantryConfig env, HasLogFunc env) =>
RequireHackageIndex
-> PackageName
-> UsePreferredVersions
-> RIO env (Maybe PackageIdentifierRevision)
getLatestHackageVersion RequireHackageIndex
YesRequireHackageIndex PackageName
hooglePackageName UsePreferredVersions
UsePreferredVersions
          let hoogleIdent = case Maybe PackageIdentifierRevision
mpir of
                  Maybe PackageIdentifierRevision
Nothing -> PackageIdentifier
hoogleMinIdent
                  Just (PackageIdentifierRevision PackageName
_ Version
ver CabalFileInfo
_) ->
                      PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
hooglePackageName Version
ver
          T.pack . packageIdentifierString <$>
              restrictMinHoogleVersion muted hoogleIdent
    config <- view configL
    let boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
          { targetsCLI =  [hoogleTarget] }
    runRIO config $ withEnvConfig NeedTargets boptsCLI f

  restrictMinHoogleVersion ::
       HasLogFunc env
    => Muted
    -> PackageIdentifier
    -> RIO env PackageIdentifier
  restrictMinHoogleVersion :: forall env.
HasLogFunc env =>
Muted -> PackageIdentifier -> RIO env PackageIdentifier
restrictMinHoogleVersion Muted
muted PackageIdentifier
ident =
    if PackageIdentifier
ident PackageIdentifier -> PackageIdentifier -> Bool
forall a. Ord a => a -> a -> Bool
< PackageIdentifier
hoogleMinIdent
      then do
        LogLevel -> Muted -> Utf8Builder -> RIO env ()
forall env.
HasLogFunc env =>
LogLevel -> Muted -> Utf8Builder -> RIO env ()
muteableLog LogLevel
LevelWarn Muted
muted (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Minimum " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
hoogleMinIdent) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
" is not in your index. Installing the minimum version."
        PackageIdentifier -> RIO env PackageIdentifier
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifier
hoogleMinIdent
      else do
        LogLevel -> Muted -> Utf8Builder -> RIO env ()
forall env.
HasLogFunc env =>
LogLevel -> Muted -> Utf8Builder -> RIO env ()
muteableLog LogLevel
LevelInfo Muted
muted (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$
          Utf8Builder
"Minimum version is " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
hoogleMinIdent) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
". Found acceptable " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          [Char] -> Utf8Builder
forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident) Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<>
          Utf8Builder
" in your index, requiring its installation."
        PackageIdentifier -> RIO env PackageIdentifier
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifier
ident
  muteableLog ::
       HasLogFunc env
    => LogLevel
    -> Muted
    -> Utf8Builder
    -> RIO env ()
  muteableLog :: forall env.
HasLogFunc env =>
LogLevel -> Muted -> Utf8Builder -> RIO env ()
muteableLog LogLevel
logLevel Muted
muted Utf8Builder
msg =
    case Muted
muted of
      Muted
Muted -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Muted
NotMuted -> Text -> LogLevel -> Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Text -> LogLevel -> Utf8Builder -> m ()
logGeneric Text
"" LogLevel
logLevel Utf8Builder
msg

  runHoogle :: Path Abs File -> [String] -> RIO EnvConfig ()
  runHoogle :: Path Abs File -> [[Char]] -> RIO EnvConfig ()
runHoogle Path Abs File
hooglePath [[Char]]
hoogleArgs = do
    config <- Getting Config EnvConfig Config -> RIO EnvConfig Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config EnvConfig Config
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL
    menv <- liftIO $ config.processContextSettings envSettings
    dbpath <- hoogleDatabasePath
    let databaseArg = [[Char]
"--database=" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
dbpath]
    withProcessContext menv $ proc
      (toFilePath hooglePath)
      (hoogleArgs ++ databaseArg)
      runProcess_

  checkDatabaseExists :: RIO EnvConfig Bool
checkDatabaseExists = do
    path <- RIO EnvConfig (Path Abs File)
forall env. HasEnvConfig env => RIO env (Path Abs File)
hoogleDatabasePath
    liftIO (doesFileExist path)

  ensureHoogleInPath :: RIO EnvConfig (Path Abs File)
  ensureHoogleInPath :: RIO EnvConfig (Path Abs File)
ensureHoogleInPath = do
    config <- Getting Config EnvConfig Config -> RIO EnvConfig Config
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Config EnvConfig Config
forall env. HasConfig env => Lens' env Config
Lens' EnvConfig Config
configL
    menv <- liftIO $ config.processContextSettings envSettings
    mHooglePath <- eitherToMaybe <$> runRIO menv (findExecutable "hoogle")
    let mHooglePath' =
          Either ProcessException [Char] -> Maybe [Char]
forall a b. Either a b -> Maybe b
eitherToMaybe (Either ProcessException [Char] -> Maybe [Char])
-> RIO EnvConfig (Either ProcessException [Char])
-> RIO EnvConfig (Maybe [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Muted
-> RIO EnvConfig (Either ProcessException [Char])
-> RIO EnvConfig (Either ProcessException [Char])
forall x. Muted -> RIO EnvConfig x -> RIO EnvConfig x
requiringHoogle Muted
NotMuted ([Char] -> RIO EnvConfig (Either ProcessException [Char])
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
[Char] -> m (Either ProcessException [Char])
findExecutable [Char]
"hoogle")
    eres <- maybe mHooglePath' (pure . Just) mHooglePath >>= \case
      Maybe [Char]
Nothing -> Either StyleDoc [Char] -> RIO EnvConfig (Either StyleDoc [Char])
forall a. a -> RIO EnvConfig a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either StyleDoc [Char] -> RIO EnvConfig (Either StyleDoc [Char]))
-> Either StyleDoc [Char] -> RIO EnvConfig (Either StyleDoc [Char])
forall a b. (a -> b) -> a -> b
$ StyleDoc -> Either StyleDoc [Char]
forall a b. a -> Either a b
Left ([Char] -> StyleDoc
flow [Char]
"Hoogle isn't installed.")
      Just [Char]
hooglePath -> do
        result <- ProcessContext
-> RIO EnvConfig (Either SomeException ByteString)
-> RIO EnvConfig (Either SomeException ByteString)
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv
          (RIO EnvConfig (Either SomeException ByteString)
 -> RIO EnvConfig (Either SomeException ByteString))
-> RIO EnvConfig (Either SomeException ByteString)
-> RIO EnvConfig (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ [Char]
-> [[Char]]
-> (ProcessConfig () () ()
    -> RIO EnvConfig (Either SomeException ByteString))
-> RIO EnvConfig (Either SomeException ByteString)
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
 MonadIO m, HasCallStack) =>
[Char] -> [[Char]] -> (ProcessConfig () () () -> m a) -> m a
proc [Char]
hooglePath [[Char]
"--numeric-version"]
          ((ProcessConfig () () ()
  -> RIO EnvConfig (Either SomeException ByteString))
 -> RIO EnvConfig (Either SomeException ByteString))
-> (ProcessConfig () () ()
    -> RIO EnvConfig (Either SomeException ByteString))
-> RIO EnvConfig (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ RIO EnvConfig ByteString
-> RIO EnvConfig (Either SomeException ByteString)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (RIO EnvConfig ByteString
 -> RIO EnvConfig (Either SomeException ByteString))
-> (ProcessConfig () () () -> RIO EnvConfig ByteString)
-> ProcessConfig () () ()
-> RIO EnvConfig (Either SomeException ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> ByteString)
-> RIO EnvConfig (ByteString, ByteString)
-> RIO EnvConfig ByteString
forall a b. (a -> b) -> RIO EnvConfig a -> RIO EnvConfig b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst (RIO EnvConfig (ByteString, ByteString)
 -> RIO EnvConfig ByteString)
-> (ProcessConfig () () ()
    -> RIO EnvConfig (ByteString, ByteString))
-> ProcessConfig () () ()
-> RIO EnvConfig ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProcessConfig () () () -> RIO EnvConfig (ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ByteString, ByteString)
readProcess_
        let unexpectedResult StyleDoc
got = StyleDoc -> Either StyleDoc [Char]
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc [Char])
-> StyleDoc -> Either StyleDoc [Char]
forall a b. (a -> b) -> a -> b
$
                 [StyleDoc] -> StyleDoc
fillSep
                   [ Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
hooglePath)
                   , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--numeric-version"
                   , [Char] -> StyleDoc
flow [Char]
"did not respond with expected value. Got:"
                   ]
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
              StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
got
        pure $ case result of
          Left SomeException
err -> StyleDoc -> Either StyleDoc [Char]
unexpectedResult (StyleDoc -> Either StyleDoc [Char])
-> StyleDoc -> Either StyleDoc [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
string (SomeException -> [Char]
forall e. Exception e => e -> [Char]
displayException SomeException
err)
          Right ByteString
bs ->
            case [Char] -> Maybe Version
parseVersion ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) (ByteString -> [Char]
BL8.unpack ByteString
bs)) of
              Maybe Version
Nothing -> StyleDoc -> Either StyleDoc [Char]
unexpectedResult (StyleDoc -> Either StyleDoc [Char])
-> StyleDoc -> Either StyleDoc [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (ByteString -> [Char]
BL8.unpack ByteString
bs)
              Just Version
ver
                | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
hoogleMinVersion -> [Char] -> Either StyleDoc [Char]
forall a b. b -> Either a b
Right [Char]
hooglePath
                | Bool
otherwise -> StyleDoc -> Either StyleDoc [Char]
forall a b. a -> Either a b
Left (StyleDoc -> Either StyleDoc [Char])
-> StyleDoc -> Either StyleDoc [Char]
forall a b. (a -> b) -> a -> b
$
                    [StyleDoc] -> StyleDoc
fillSep
                      [ [Char] -> StyleDoc
flow [Char]
"Installed Hoogle is too old, "
                      , Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
hooglePath)
                      , [Char] -> StyleDoc
flow [Char]
"is version"
                      , [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
ver)
                      , [Char] -> StyleDoc
flow [Char]
"but >= 5.0 is required."
                      ]
    case eres of
      Right [Char]
hooglePath -> [Char] -> RIO EnvConfig (Path Abs File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Abs File)
parseAbsFile [Char]
hooglePath
      Left StyleDoc
err
        | Bool
setup -> do
            [StyleDoc] -> RIO EnvConfig ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
              [ StyleDoc
err
              , [Char] -> StyleDoc
flow [Char]
"Automatically installing (use"
              , Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"--no-setup"
              , [Char] -> StyleDoc
flow [Char]
"to disable) ..."
              ]
            RIO EnvConfig (Path Abs File)
installHoogle
        | Bool
otherwise -> HooglePrettyException -> RIO EnvConfig (Path Abs File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (HooglePrettyException -> RIO EnvConfig (Path Abs File))
-> HooglePrettyException -> RIO EnvConfig (Path Abs File)
forall a b. (a -> b) -> a -> b
$ StyleDoc -> HooglePrettyException
HoogleNotFound StyleDoc
err

  envSettings :: EnvSettings
envSettings = EnvSettings
    { includeLocals :: Bool
includeLocals = Bool
True
    , includeGhcPackagePath :: Bool
includeGhcPackagePath = Bool
True
    , stackExe :: Bool
stackExe = Bool
True
    , localeUtf8 :: Bool
localeUtf8 = Bool
False
    , keepGhcRts :: Bool
keepGhcRts = Bool
False
    }