{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
data Muted = Muted | NotMuted
hoogleCmd :: ([String],Bool,Bool,Bool) -> RIO Runner ()
hoogleCmd :: ([String], Bool, Bool, Bool) -> RIO Runner ()
hoogleCmd ([String]
args,Bool
setup,Bool
rebuild,Bool
startServer) =
(Runner -> Runner) -> RIO Runner () -> RIO Runner ()
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
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
Path Abs File
hooglePath <- RIO EnvConfig (Path Abs File)
ensureHoogleInPath
Path Abs File -> RIO EnvConfig ()
generateDbIfNeeded Path Abs File
hooglePath
Path Abs File -> [String] -> RIO EnvConfig ()
runHoogle Path Abs File
hooglePath [String]
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' :: [String]
args' = if Bool
startServer
then [String
"server", String
"--local", String
"--port", String
"8080"]
else []
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
args
generateDbIfNeeded :: Path Abs File -> RIO EnvConfig ()
generateDbIfNeeded :: Path Abs File -> RIO EnvConfig ()
generateDbIfNeeded Path Abs File
hooglePath = do
Bool
databaseExists <- RIO EnvConfig Bool
checkDatabaseExists
if Bool
databaseExists Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
rebuild
then () -> RIO EnvConfig ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else if Bool
setup Bool -> Bool -> Bool
|| Bool
rebuild
then do
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn
(if Bool
rebuild
then Utf8Builder
"Rebuilding database ..."
else Utf8Builder
"No Hoogle database yet. Automatically building haddocks and hoogle database (use --no-setup to disable) ...")
RIO EnvConfig ()
buildHaddocks
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Built docs."
Path Abs File -> RIO EnvConfig ()
generateDb Path Abs File
hooglePath
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
"Generated DB."
else do
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logError
Utf8Builder
"No Hoogle database. Not building one due to --no-setup"
RIO EnvConfig ()
forall a. RIO EnvConfig a
bail
generateDb :: Path Abs File -> RIO EnvConfig ()
generateDb :: Path Abs File -> RIO EnvConfig ()
generateDb Path Abs File
hooglePath = do
do Path Abs Dir
dir <- RIO EnvConfig (Path Abs Dir)
forall env. HasEnvConfig env => RIO env (Path Abs Dir)
hoogleRoot
Bool -> Path Abs Dir -> RIO EnvConfig ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True Path Abs Dir
dir
Path Abs File -> [String] -> RIO EnvConfig ()
runHoogle Path Abs File
hooglePath [String
"generate", String
"--local"]
buildHaddocks :: RIO EnvConfig ()
buildHaddocks :: RIO EnvConfig ()
buildHaddocks = do
Config
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
configL
Config -> RIO Config () -> RIO EnvConfig ()
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Config
config (RIO Config () -> RIO EnvConfig ())
-> RIO Config () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$
RIO Config () -> (ExitCode -> RIO Config ()) -> RIO Config ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (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
$ 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)
(\(ExitCode
_ :: ExitCode) -> () -> RIO Config ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
hooglePackageName :: PackageName
hooglePackageName = String -> PackageName
mkPackageName String
"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
Either ProcessException String
mhooglePath' <- String -> RIO EnvConfig (Either ProcessException String)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m (Either ProcessException String)
findExecutable String
"hoogle"
case Either ProcessException String
mhooglePath' of
Right String
hooglePath -> String -> RIO EnvConfig (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
hooglePath
Left ProcessException
_ -> do
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"Couldn't find hoogle in path after installing. This shouldn't happen, may be a bug."
RIO EnvConfig (Path Abs File)
forall a. RIO EnvConfig a
bail
requiringHoogle :: Muted -> RIO EnvConfig x -> RIO EnvConfig x
requiringHoogle :: Muted -> RIO EnvConfig x -> RIO EnvConfig x
requiringHoogle Muted
muted RIO EnvConfig x
f = do
Text
hoogleTarget <- do
Map PackageName DepPackage
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
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 SourceMap -> Map PackageName DepPackage
smDeps
case PackageName -> Map PackageName DepPackage -> Maybe DepPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
hooglePackageName Map PackageName DepPackage
sourceMap of
Just DepPackage
hoogleDep ->
case DepPackage -> PackageLocation
dpLocation DepPackage
hoogleDep of
PLImmutable PackageLocationImmutable
pli ->
String -> Text
T.pack (String -> Text)
-> (PackageIdentifier -> String) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
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
_) -> do
String -> Text
T.pack (String -> Text)
-> (GenericPackageDescription -> String)
-> GenericPackageDescription
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
packageIdentifierString (PackageIdentifier -> String)
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> String
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
<$> PackageLocation -> RIO EnvConfig GenericPackageDescription
forall env.
(HasPantryConfig env, HasLogFunc env, HasProcessContext env) =>
PackageLocation -> RIO env GenericPackageDescription
loadCabalFile PackageLocation
plm
Maybe DepPackage
Nothing -> do
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn Utf8Builder
"No hoogle version was found, trying to install the latest version"
Maybe PackageIdentifierRevision
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 :: PackageIdentifier
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
String -> Text
T.pack (String -> Text)
-> (PackageIdentifier -> String) -> PackageIdentifier -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> String
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 PackageIdentifier
hoogleIdent
Config
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
configL
let boptsCLI :: BuildOptsCLI
boptsCLI = BuildOptsCLI
defaultBuildOptsCLI
{ boptsCLITargets :: [Text]
boptsCLITargets = [Text
hoogleTarget]
}
Config -> RIO Config x -> RIO EnvConfig x
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO Config
config (RIO Config x -> RIO EnvConfig x)
-> RIO Config x -> RIO EnvConfig x
forall a b. (a -> b) -> a -> b
$ NeedTargets -> BuildOptsCLI -> RIO EnvConfig x -> RIO Config x
forall a.
NeedTargets -> BuildOptsCLI -> RIO EnvConfig a -> RIO Config a
withEnvConfig NeedTargets
NeedTargets BuildOptsCLI
boptsCLI RIO EnvConfig x
f
restrictMinHoogleVersion
:: HasLogFunc env
=> Muted -> PackageIdentifier -> RIO env PackageIdentifier
restrictMinHoogleVersion :: Muted -> PackageIdentifier -> RIO env PackageIdentifier
restrictMinHoogleVersion Muted
muted PackageIdentifier
ident = do
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
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageIdentifier -> String
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 (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
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageIdentifier -> String
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
<>
String -> Utf8Builder
forall a. IsString a => String -> a
fromString (PackageIdentifier -> String
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 (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifier
ident
muteableLog :: HasLogFunc env => LogLevel -> Muted -> Utf8Builder -> RIO env ()
muteableLog :: LogLevel -> Muted -> Utf8Builder -> RIO env ()
muteableLog LogLevel
logLevel Muted
muted Utf8Builder
msg =
case Muted
muted of
Muted
Muted -> () -> RIO env ()
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 -> [String] -> RIO EnvConfig ()
runHoogle Path Abs File
hooglePath [String]
hoogleArgs = do
Config
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
configL
ProcessContext
menv <- IO ProcessContext -> RIO EnvConfig ProcessContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO EnvConfig ProcessContext)
-> IO ProcessContext -> RIO EnvConfig ProcessContext
forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
envSettings
Path Abs File
dbpath <- RIO EnvConfig (Path Abs File)
forall env. HasEnvConfig env => RIO env (Path Abs File)
hoogleDatabasePath
let databaseArg :: [String]
databaseArg = [String
"--database=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
dbpath]
ProcessContext -> RIO EnvConfig () -> RIO EnvConfig ()
forall env a.
HasProcessContext env =>
ProcessContext -> RIO env a -> RIO env a
withProcessContext ProcessContext
menv (RIO EnvConfig () -> RIO EnvConfig ())
-> RIO EnvConfig () -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> (ProcessConfig () () () -> RIO EnvConfig ())
-> RIO EnvConfig ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc
(Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
hooglePath)
([String]
hoogleArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
databaseArg)
ProcessConfig () () () -> RIO EnvConfig ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_
bail :: RIO EnvConfig a
bail :: RIO EnvConfig a
bail = ExitCode -> RIO EnvConfig a
forall (m :: * -> *) a. MonadIO m => ExitCode -> m a
exitWith (Int -> ExitCode
ExitFailure (-Int
1))
checkDatabaseExists :: RIO EnvConfig Bool
checkDatabaseExists = do
Path Abs File
path <- RIO EnvConfig (Path Abs File)
forall env. HasEnvConfig env => RIO env (Path Abs File)
hoogleDatabasePath
IO Bool -> RIO EnvConfig Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path)
ensureHoogleInPath :: RIO EnvConfig (Path Abs File)
ensureHoogleInPath :: RIO EnvConfig (Path Abs File)
ensureHoogleInPath = do
Config
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
configL
ProcessContext
menv <- IO ProcessContext -> RIO EnvConfig ProcessContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ProcessContext -> RIO EnvConfig ProcessContext)
-> IO ProcessContext -> RIO EnvConfig ProcessContext
forall a b. (a -> b) -> a -> b
$ Config -> EnvSettings -> IO ProcessContext
configProcessContextSettings Config
config EnvSettings
envSettings
Either ProcessException String
mhooglePath <- ProcessContext
-> RIO ProcessContext (Either ProcessException String)
-> RIO EnvConfig (Either ProcessException String)
forall (m :: * -> *) env a. MonadIO m => env -> RIO env a -> m a
runRIO ProcessContext
menv (String -> RIO ProcessContext (Either ProcessException String)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m (Either ProcessException String)
findExecutable String
"hoogle") RIO EnvConfig (Either ProcessException String)
-> RIO EnvConfig (Either ProcessException String)
-> RIO EnvConfig (Either ProcessException String)
forall a. Semigroup a => a -> a -> a
<>
Muted
-> RIO EnvConfig (Either ProcessException String)
-> RIO EnvConfig (Either ProcessException String)
forall x. Muted -> RIO EnvConfig x -> RIO EnvConfig x
requiringHoogle Muted
NotMuted (String -> RIO EnvConfig (Either ProcessException String)
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasProcessContext env) =>
String -> m (Either ProcessException String)
findExecutable String
"hoogle")
Either Text String
eres <- case Either ProcessException String
mhooglePath of
Left ProcessException
_ -> Either Text String -> RIO EnvConfig (Either Text String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text String -> RIO EnvConfig (Either Text String))
-> Either Text String -> RIO EnvConfig (Either Text String)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text String
forall a b. a -> Either a b
Left Text
"Hoogle isn't installed."
Right String
hooglePath -> do
Either SomeException ByteString
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
$ String
-> [String]
-> (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) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
hooglePath [String
"--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 (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 :: Text -> Either Text b
unexpectedResult Text
got = Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b) -> Text -> Either Text b
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"'"
, String -> Text
T.pack String
hooglePath
, Text
" --numeric-version' did not respond with expected value. Got: "
, Text
got
]
Either Text String -> RIO EnvConfig (Either Text String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text String -> RIO EnvConfig (Either Text String))
-> Either Text String -> RIO EnvConfig (Either Text String)
forall a b. (a -> b) -> a -> b
$ case Either SomeException ByteString
result of
Left SomeException
err -> Text -> Either Text String
forall b. Text -> Either Text b
unexpectedResult (Text -> Either Text String) -> Text -> Either Text String
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (SomeException -> String
forall a. Show a => a -> String
show SomeException
err)
Right ByteString
bs -> case String -> Maybe Version
parseVersion ((Char -> Bool) -> String -> String
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 -> String
BL8.unpack ByteString
bs)) of
Maybe Version
Nothing -> Text -> Either Text String
forall b. Text -> Either Text b
unexpectedResult (Text -> Either Text String) -> Text -> Either Text String
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (ByteString -> String
BL8.unpack ByteString
bs)
Just Version
ver
| Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
hoogleMinVersion -> String -> Either Text String
forall a b. b -> Either a b
Right String
hooglePath
| Bool
otherwise -> Text -> Either Text String
forall a b. a -> Either a b
Left (Text -> Either Text String) -> Text -> Either Text String
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
[ Text
"Installed Hoogle is too old, "
, String -> Text
T.pack String
hooglePath
, Text
" is version "
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
ver
, Text
" but >= 5.0 is required."
]
case Either Text String
eres of
Right String
hooglePath -> String -> RIO EnvConfig (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile String
hooglePath
Left Text
err
| Bool
setup -> do
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO EnvConfig ())
-> Utf8Builder -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
err Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" Automatically installing (use --no-setup to disable) ..."
RIO EnvConfig (Path Abs File)
installHoogle
| Bool
otherwise -> do
Utf8Builder -> RIO EnvConfig ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> RIO EnvConfig ())
-> Utf8Builder -> RIO EnvConfig ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Text
err Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" Not installing it due to --no-setup."
RIO EnvConfig (Path Abs File)
forall a. RIO EnvConfig a
bail
envSettings :: EnvSettings
envSettings =
EnvSettings :: Bool -> Bool -> Bool -> Bool -> Bool -> EnvSettings
EnvSettings
{ esIncludeLocals :: Bool
esIncludeLocals = Bool
True
, esIncludeGhcPackagePath :: Bool
esIncludeGhcPackagePath = Bool
True
, esStackExe :: Bool
esStackExe = Bool
True
, esLocaleUtf8 :: Bool
esLocaleUtf8 = Bool
False
, esKeepGhcRts :: Bool
esKeepGhcRts = Bool
False
}