{-# LANGUAGE OverloadedStrings #-}

module HsDev.Sandbox (
	Sandbox(..), sandboxType, sandbox,
	isSandbox, guessSandboxType, sandboxFromPath,
	findSandbox, searchSandbox, searchSandboxes,
	projectSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack,

	-- * package-db
	userPackageDb,

	-- * cabal-sandbox util
	cabalSandboxPackageDb,

	getModuleOpts, getProjectTargetOpts,

	getProjectSandbox,
	getProjectPackageDbStack
	) where

import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Except
import Control.Lens (view)
import Data.List (find, intercalate)
import Data.Maybe (isJust, fromMaybe, catMaybes)
import Data.Maybe.JustIf
import System.Directory (getAppUserDataDirectory, doesDirectoryExist)
import System.FilePath
import System.Log.Simple (MonadLog(..))
import Text.Format

import System.Directory.Paths
import HsDev.Error
import HsDev.PackageDb
import HsDev.Project.Types
import HsDev.Scan.Browse (browsePackages)
import HsDev.Stack hiding (path)
import HsDev.Symbols (moduleOpts, projectTargetOpts)
import HsDev.Symbols.Types (moduleId, Module(..), ModuleLocation(..), moduleLocation)
import HsDev.Tools.Ghc.Worker (GhcM)
import HsDev.Tools.Ghc.System (buildPath)
import HsDev.Util (searchPath, directoryContents, cabalFile)

isSandbox :: Path -> Bool
isSandbox :: Path -> Bool
isSandbox = Maybe BuildTool -> Bool
forall a. Maybe a -> Bool
isJust (Maybe BuildTool -> Bool)
-> (Path -> Maybe BuildTool) -> Path -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Maybe BuildTool
guessSandboxType

guessSandboxType :: Path -> Maybe BuildTool
guessSandboxType :: Path -> Maybe BuildTool
guessSandboxType Path
fpath
	| FilePath -> FilePath
takeFileName (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fpath) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal-sandbox" = BuildTool -> Maybe BuildTool
forall a. a -> Maybe a
Just BuildTool
CabalTool
	| FilePath -> FilePath
takeFileName (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fpath) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".stack-work" = BuildTool -> Maybe BuildTool
forall a. a -> Maybe a
Just BuildTool
StackTool
	| Bool
otherwise = Maybe BuildTool
forall a. Maybe a
Nothing

sandboxFromPath :: Path -> Maybe Sandbox
sandboxFromPath :: Path -> Maybe Sandbox
sandboxFromPath Path
fpath = BuildTool -> Path -> Sandbox
Sandbox (BuildTool -> Path -> Sandbox)
-> Maybe BuildTool -> Maybe (Path -> Sandbox)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> Maybe BuildTool
guessSandboxType Path
fpath Maybe (Path -> Sandbox) -> Maybe Path -> Maybe Sandbox
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Path -> Maybe Path
forall (f :: * -> *) a. Applicative f => a -> f a
pure Path
fpath

-- | Find sandbox in path
findSandbox :: Path -> IO (Maybe Sandbox)
findSandbox :: Path -> IO (Maybe Sandbox)
findSandbox Path
fpath = do
	Path
fpath' <- Path -> IO Path
forall a. Paths a => a -> IO a
canonicalize Path
fpath
	Bool
isDir <- Path -> IO Bool
dirExists Path
fpath'
	if Bool
isDir
		then do
			[Path]
dirs <- ([FilePath] -> [Path]) -> IO [FilePath] -> IO [Path]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((Path
fpath' Path -> [Path] -> [Path]
forall a. a -> [a] -> [a]
:) ([Path] -> [Path])
-> ([FilePath] -> [Path]) -> [FilePath] -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Path) -> [FilePath] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Path
fromFilePath) (IO [FilePath] -> IO [Path]) -> IO [FilePath] -> IO [Path]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
directoryContents (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fpath')
			Maybe Sandbox -> IO (Maybe Sandbox)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Sandbox -> IO (Maybe Sandbox))
-> Maybe Sandbox -> IO (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ [Maybe Sandbox] -> Maybe Sandbox
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Sandbox] -> Maybe Sandbox)
-> [Maybe Sandbox] -> Maybe Sandbox
forall a b. (a -> b) -> a -> b
$ (Path -> Maybe Sandbox) -> [Path] -> [Maybe Sandbox]
forall a b. (a -> b) -> [a] -> [b]
map Path -> Maybe Sandbox
sandboxFromDir [Path]
dirs
		else Maybe Sandbox -> IO (Maybe Sandbox)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Sandbox
forall a. Maybe a
Nothing
	where
		sandboxFromDir :: Path -> Maybe Sandbox
		sandboxFromDir :: Path -> Maybe Sandbox
sandboxFromDir Path
fdir
			| FilePath -> FilePath
takeFileName (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fdir) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"stack.yaml" = Path -> Maybe Sandbox
sandboxFromPath (FilePath -> Path
fromFilePath (FilePath -> FilePath
takeDirectory (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fdir) FilePath -> FilePath -> FilePath
</> FilePath
".stack-work"))
			| Bool
otherwise = Path -> Maybe Sandbox
sandboxFromPath Path
fdir

-- | Search sandbox by parent directory
searchSandbox :: Path -> IO (Maybe Sandbox)
searchSandbox :: Path -> IO (Maybe Sandbox)
searchSandbox Path
p = MaybeT IO Sandbox -> IO (Maybe Sandbox)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Sandbox -> IO (Maybe Sandbox))
-> MaybeT IO Sandbox -> IO (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ FilePath -> (FilePath -> MaybeT IO Sandbox) -> MaybeT IO Sandbox
forall (m :: * -> *) a.
(MonadIO m, MonadPlus m) =>
FilePath -> (FilePath -> m a) -> m a
searchPath (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
p) (IO (Maybe Sandbox) -> MaybeT IO Sandbox
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Sandbox) -> MaybeT IO Sandbox)
-> (FilePath -> IO (Maybe Sandbox))
-> FilePath
-> MaybeT IO Sandbox
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> IO (Maybe Sandbox)
findSandbox (Path -> IO (Maybe Sandbox))
-> (FilePath -> Path) -> FilePath -> IO (Maybe Sandbox)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Path
fromFilePath)

-- | Search sandboxes up from current directory
searchSandboxes :: Path -> IO [Sandbox]
searchSandboxes :: Path -> IO [Sandbox]
searchSandboxes Path
p = do
	Maybe Sandbox
mcabal <- BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox)
searchFor BuildTool
CabalTool FilePath
".cabal-sandbox" FilePath
".cabal-sandbox"
	Maybe Sandbox
mstack <- BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox)
searchFor BuildTool
StackTool FilePath
"stack.yaml" FilePath
".stack-work"
	[Sandbox] -> IO [Sandbox]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Sandbox] -> IO [Sandbox]) -> [Sandbox] -> IO [Sandbox]
forall a b. (a -> b) -> a -> b
$ [Maybe Sandbox] -> [Sandbox]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Sandbox
mcabal, Maybe Sandbox
mstack]
	where
		searchFor :: BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox)
		searchFor :: BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox)
searchFor BuildTool
tool FilePath
lookFor FilePath
sandboxDir = MaybeT IO Sandbox -> IO (Maybe Sandbox)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Sandbox -> IO (Maybe Sandbox))
-> MaybeT IO Sandbox -> IO (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ do
			FilePath
root <- FilePath -> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a.
(MonadIO m, MonadPlus m) =>
FilePath -> (FilePath -> m a) -> m a
searchPath (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
p) (IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> (FilePath -> IO (Maybe FilePath))
-> FilePath
-> MaybeT IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Maybe FilePath)
getRoot)
			Sandbox -> MaybeT IO Sandbox
forall (m :: * -> *) a. Monad m => a -> m a
return (Sandbox -> MaybeT IO Sandbox) -> Sandbox -> MaybeT IO Sandbox
forall a b. (a -> b) -> a -> b
$ BuildTool -> Path -> Sandbox
Sandbox BuildTool
tool (Path -> Sandbox) -> Path -> Sandbox
forall a b. (a -> b) -> a -> b
$ FilePath -> Path
fromFilePath (FilePath -> FilePath
takeDirectory FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
sandboxDir)
			where
				getRoot :: FilePath -> IO (Maybe FilePath)
getRoot = FilePath -> IO [FilePath]
directoryContents (FilePath -> IO [FilePath])
-> ([FilePath] -> IO (Maybe FilePath))
-> FilePath
-> IO (Maybe FilePath)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> ([FilePath] -> Maybe FilePath)
-> [FilePath]
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> Maybe FilePath
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
lookFor) (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeFileName)

-- | Get project sandbox: search up for .cabal, then search for stack.yaml in current directory and cabal sandbox in current + parents
projectSandbox :: BuildTool -> Path -> IO (Maybe Sandbox)
projectSandbox :: BuildTool -> Path -> IO (Maybe Sandbox)
projectSandbox BuildTool
tool Path
fpath = MaybeT IO Sandbox -> IO (Maybe Sandbox)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO Sandbox -> IO (Maybe Sandbox))
-> MaybeT IO Sandbox -> IO (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ do
	FilePath
p <- FilePath -> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a.
(MonadIO m, MonadPlus m) =>
FilePath -> (FilePath -> m a) -> m a
searchPath (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fpath) (IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> (FilePath -> IO (Maybe FilePath))
-> FilePath
-> MaybeT IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Maybe FilePath)
getCabalFile)
	[Sandbox]
sboxes <- IO [Sandbox] -> MaybeT IO [Sandbox]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Sandbox] -> MaybeT IO [Sandbox])
-> IO [Sandbox] -> MaybeT IO [Sandbox]
forall a b. (a -> b) -> a -> b
$ Path -> IO [Sandbox]
searchSandboxes (FilePath -> Path
fromFilePath (FilePath -> Path) -> FilePath -> Path
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
p)
	IO (Maybe Sandbox) -> MaybeT IO Sandbox
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Sandbox) -> MaybeT IO Sandbox)
-> IO (Maybe Sandbox) -> MaybeT IO Sandbox
forall a b. (a -> b) -> a -> b
$ Maybe Sandbox -> IO (Maybe Sandbox)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Sandbox -> IO (Maybe Sandbox))
-> Maybe Sandbox -> IO (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ (Sandbox -> Bool) -> [Sandbox] -> Maybe Sandbox
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((BuildTool -> BuildTool -> Bool
forall a. Eq a => a -> a -> Bool
== BuildTool
tool) (BuildTool -> Bool) -> (Sandbox -> BuildTool) -> Sandbox -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting BuildTool Sandbox BuildTool -> Sandbox -> BuildTool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildTool Sandbox BuildTool
Lens' Sandbox BuildTool
sandboxType) [Sandbox]
sboxes
	where
		getCabalFile :: FilePath -> IO (Maybe FilePath)
getCabalFile = FilePath -> IO [FilePath]
directoryContents (FilePath -> IO [FilePath])
-> ([FilePath] -> IO (Maybe FilePath))
-> FilePath
-> IO (Maybe FilePath)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Maybe FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> ([FilePath] -> Maybe FilePath)
-> [FilePath]
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> Maybe FilePath
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find FilePath -> Bool
cabalFile

-- | Get package-db stack for sandbox
sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack
sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack
sandboxPackageDbStack (Sandbox BuildTool
CabalTool Path
fpath) = do
	FilePath
dir <- FilePath -> GhcM FilePath
cabalSandboxPackageDb (FilePath -> GhcM FilePath) -> FilePath -> GhcM FilePath
forall a b. (a -> b) -> a -> b
$ Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fpath
	PackageDbStack -> GhcM PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDbStack -> GhcM PackageDbStack)
-> PackageDbStack -> GhcM PackageDbStack
forall a b. (a -> b) -> a -> b
$ [PackageDb] -> PackageDbStack
PackageDbStack [Path -> PackageDb
PackageDb (Path -> PackageDb) -> Path -> PackageDb
forall a b. (a -> b) -> a -> b
$ FilePath -> Path
fromFilePath FilePath
dir]
sandboxPackageDbStack (Sandbox BuildTool
StackTool Path
fpath) = (StackEnv -> PackageDbStack)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) StackEnv
-> GhcM PackageDbStack
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Getting PackageDbStack StackEnv PackageDbStack
-> StackEnv -> PackageDbStack
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting PackageDbStack StackEnv PackageDbStack
Lens' StackEnv PackageDbStack
stackPackageDbStack) (MGhcT SessionConfig (First DynFlags) (LogT IO) StackEnv
 -> GhcM PackageDbStack)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) StackEnv
-> GhcM PackageDbStack
forall a b. (a -> b) -> a -> b
$ FilePath -> MGhcT SessionConfig (First DynFlags) (LogT IO) StackEnv
projectEnv (FilePath
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) StackEnv)
-> FilePath
-> MGhcT SessionConfig (First DynFlags) (LogT IO) StackEnv
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory (Getting FilePath Path FilePath -> Path -> FilePath
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FilePath Path FilePath
Lens' Path FilePath
path Path
fpath)

-- | Search package-db stack with user-db as default
searchPackageDbStack :: BuildTool -> Path -> GhcM PackageDbStack
searchPackageDbStack :: BuildTool -> Path -> GhcM PackageDbStack
searchPackageDbStack BuildTool
tool Path
p = do
	Maybe Sandbox
mbox <- IO (Maybe Sandbox)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Sandbox)
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox))
-> IO (Maybe Sandbox)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ BuildTool -> Path -> IO (Maybe Sandbox)
projectSandbox BuildTool
tool Path
p
	case Maybe Sandbox
mbox of
		Maybe Sandbox
Nothing -> PackageDbStack -> GhcM PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbStack
userDb
		Just Sandbox
sbox -> Sandbox -> GhcM PackageDbStack
sandboxPackageDbStack Sandbox
sbox

-- | Restore package-db stack by package-db
restorePackageDbStack :: PackageDb -> GhcM PackageDbStack
restorePackageDbStack :: PackageDb -> GhcM PackageDbStack
restorePackageDbStack PackageDb
GlobalDb = PackageDbStack -> GhcM PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbStack
globalDb
restorePackageDbStack PackageDb
UserDb = PackageDbStack -> GhcM PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbStack
userDb
restorePackageDbStack (PackageDb Path
p) = (Maybe PackageDbStack -> PackageDbStack)
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (Maybe PackageDbStack)
-> GhcM PackageDbStack
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PackageDbStack -> Maybe PackageDbStack -> PackageDbStack
forall a. a -> Maybe a -> a
fromMaybe (PackageDbStack -> Maybe PackageDbStack -> PackageDbStack)
-> PackageDbStack -> Maybe PackageDbStack -> PackageDbStack
forall a b. (a -> b) -> a -> b
$ [Path] -> PackageDbStack
fromPackageDbs [Path
p]) (MGhcT
   SessionConfig (First DynFlags) (LogT IO) (Maybe PackageDbStack)
 -> GhcM PackageDbStack)
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (Maybe PackageDbStack)
-> GhcM PackageDbStack
forall a b. (a -> b) -> a -> b
$ MaybeT
  (MGhcT SessionConfig (First DynFlags) (LogT IO)) PackageDbStack
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (Maybe PackageDbStack)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (MGhcT SessionConfig (First DynFlags) (LogT IO)) PackageDbStack
 -> MGhcT
      SessionConfig (First DynFlags) (LogT IO) (Maybe PackageDbStack))
-> MaybeT
     (MGhcT SessionConfig (First DynFlags) (LogT IO)) PackageDbStack
-> MGhcT
     SessionConfig (First DynFlags) (LogT IO) (Maybe PackageDbStack)
forall a b. (a -> b) -> a -> b
$ do
	Sandbox
sbox <- MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
-> MaybeT (MGhcT SessionConfig (First DynFlags) (LogT IO)) Sandbox
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
 -> MaybeT (MGhcT SessionConfig (First DynFlags) (LogT IO)) Sandbox)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
-> MaybeT (MGhcT SessionConfig (First DynFlags) (LogT IO)) Sandbox
forall a b. (a -> b) -> a -> b
$ IO (Maybe Sandbox)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Sandbox)
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox))
-> IO (Maybe Sandbox)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ Path -> IO (Maybe Sandbox)
searchSandbox Path
p
	GhcM PackageDbStack
-> MaybeT
     (MGhcT SessionConfig (First DynFlags) (LogT IO)) PackageDbStack
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GhcM PackageDbStack
 -> MaybeT
      (MGhcT SessionConfig (First DynFlags) (LogT IO)) PackageDbStack)
-> GhcM PackageDbStack
-> MaybeT
     (MGhcT SessionConfig (First DynFlags) (LogT IO)) PackageDbStack
forall a b. (a -> b) -> a -> b
$ Sandbox -> GhcM PackageDbStack
sandboxPackageDbStack Sandbox
sbox

-- | User package-db: <arch>-<os>-<version>
userPackageDb :: GhcM FilePath
userPackageDb :: GhcM FilePath
userPackageDb = do
	FilePath
root <- IO FilePath -> GhcM FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> GhcM FilePath) -> IO FilePath -> GhcM FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getAppUserDataDirectory FilePath
"ghc"
	FilePath
dir <- FilePath -> GhcM FilePath
buildPath FilePath
"{arch}-{os}-{version}"
	FilePath -> GhcM FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> GhcM FilePath) -> FilePath -> GhcM FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
root FilePath -> FilePath -> FilePath
</> FilePath
dir

-- | Get sandbox package-db: <arch>-<os>-<compiler>-<version>-packages.conf.d
cabalSandboxPackageDb :: FilePath -> GhcM FilePath
cabalSandboxPackageDb :: FilePath -> GhcM FilePath
cabalSandboxPackageDb FilePath
root = do
	[FilePath]
dirs <- (FilePath -> GhcM FilePath)
-> [FilePath]
-> MGhcT SessionConfig (First DynFlags) (LogT IO) [FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((FilePath -> FilePath) -> GhcM FilePath -> GhcM FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
root FilePath -> FilePath -> FilePath
</>) (GhcM FilePath -> GhcM FilePath)
-> (FilePath -> GhcM FilePath) -> FilePath -> GhcM FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> GhcM FilePath
buildPath) [
		FilePath
"{arch}-{os}-{compiler}-{version}-packages.conf.d",
		FilePath
"{arch}-{os/cabal}-{compiler}-{version}-packages.conf.d"]
	Maybe FilePath
mdir <- ([Maybe FilePath] -> Maybe FilePath)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) [Maybe FilePath]
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe FilePath)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe FilePath] -> Maybe FilePath
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum (MGhcT SessionConfig (First DynFlags) (LogT IO) [Maybe FilePath]
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe FilePath))
-> MGhcT SessionConfig (First DynFlags) (LogT IO) [Maybe FilePath]
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ [FilePath]
-> (FilePath
    -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe FilePath))
-> MGhcT SessionConfig (First DynFlags) (LogT IO) [Maybe FilePath]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
dirs ((FilePath
  -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe FilePath))
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) [Maybe FilePath])
-> (FilePath
    -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe FilePath))
-> MGhcT SessionConfig (First DynFlags) (LogT IO) [Maybe FilePath]
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
		FilePath -> Bool -> Maybe FilePath
forall a. a -> Bool -> Maybe a
justIf FilePath
dir (Bool -> Maybe FilePath)
-> MGhcT SessionConfig (First DynFlags) (LogT IO) Bool
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> MGhcT SessionConfig (First DynFlags) (LogT IO) Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesDirectoryExist FilePath
dir)
	case Maybe FilePath
mdir of
		Maybe FilePath
Nothing -> HsDevError -> GhcM FilePath
forall (m :: * -> *) a. MonadThrow m => HsDevError -> m a
hsdevError (HsDevError -> GhcM FilePath) -> HsDevError -> GhcM FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> HsDevError
OtherError (FilePath -> HsDevError) -> FilePath -> HsDevError
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [
			FilePath
"No suitable package-db found in sandbox, is it configured?",
			Format
"Searched in: {}" Format -> FilePath -> FilePath
forall a r. (Hole a, FormatResult r) => Format -> a -> r
~~ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [FilePath]
dirs]
		Just FilePath
dir -> FilePath -> GhcM FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir

-- | Options for GHC for module and project
getModuleOpts :: [String] -> Module -> GhcM (PackageDbStack, [String])
getModuleOpts :: [FilePath] -> Module -> GhcM (PackageDbStack, [FilePath])
getModuleOpts [FilePath]
opts Module
m = do
	PackageDbStack
pdbs <- case Getting ModuleLocation Module ModuleLocation
-> Module -> ModuleLocation
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ModuleId -> Const ModuleLocation ModuleId)
-> Module -> Const ModuleLocation Module
Lens' Module ModuleId
moduleId ((ModuleId -> Const ModuleLocation ModuleId)
 -> Module -> Const ModuleLocation Module)
-> ((ModuleLocation -> Const ModuleLocation ModuleLocation)
    -> ModuleId -> Const ModuleLocation ModuleId)
-> Getting ModuleLocation Module ModuleLocation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleLocation -> Const ModuleLocation ModuleLocation)
-> ModuleId -> Const ModuleLocation ModuleId
Lens' ModuleId ModuleLocation
moduleLocation) Module
m of
		FileModule Path
fpath Maybe Project
mproj -> BuildTool -> Path -> GhcM PackageDbStack
searchPackageDbStack (BuildTool -> (Project -> BuildTool) -> Maybe Project -> BuildTool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe BuildTool
CabalTool (Getting BuildTool Project BuildTool -> Project -> BuildTool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildTool Project BuildTool
Lens' Project BuildTool
projectBuildTool) Maybe Project
mproj) Path
fpath
		InstalledModule{} -> PackageDbStack -> GhcM PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbStack
userDb
		ModuleLocation
_ -> PackageDbStack -> GhcM PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbStack
userDb
	[PackageConfig]
pkgs <- [FilePath] -> PackageDbStack -> GhcM [PackageConfig]
browsePackages [FilePath]
opts PackageDbStack
pdbs
	(PackageDbStack, [FilePath]) -> GhcM (PackageDbStack, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return ((PackageDbStack, [FilePath]) -> GhcM (PackageDbStack, [FilePath]))
-> (PackageDbStack, [FilePath])
-> GhcM (PackageDbStack, [FilePath])
forall a b. (a -> b) -> a -> b
$ (PackageDbStack
pdbs, [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
		[PackageConfig] -> Module -> [FilePath]
moduleOpts [PackageConfig]
pkgs Module
m,
		[FilePath]
opts])

-- | Options for GHC for project target
getProjectTargetOpts :: [String] -> Project -> Info -> GhcM (PackageDbStack, [String])
getProjectTargetOpts :: [FilePath] -> Project -> Info -> GhcM (PackageDbStack, [FilePath])
getProjectTargetOpts [FilePath]
opts Project
proj Info
t = do
	PackageDbStack
pdbs <- BuildTool -> Path -> GhcM PackageDbStack
searchPackageDbStack (Getting BuildTool Project BuildTool -> Project -> BuildTool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildTool Project BuildTool
Lens' Project BuildTool
projectBuildTool Project
proj) (Getting Path Project Path -> Project -> Path
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Path Project Path
Lens' Project Path
projectPath Project
proj)
	[PackageConfig]
pkgs <- [FilePath] -> PackageDbStack -> GhcM [PackageConfig]
browsePackages [FilePath]
opts PackageDbStack
pdbs
	(PackageDbStack, [FilePath]) -> GhcM (PackageDbStack, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return ((PackageDbStack, [FilePath]) -> GhcM (PackageDbStack, [FilePath]))
-> (PackageDbStack, [FilePath])
-> GhcM (PackageDbStack, [FilePath])
forall a b. (a -> b) -> a -> b
$ (PackageDbStack
pdbs, [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
		[PackageConfig] -> Project -> Info -> [FilePath]
projectTargetOpts [PackageConfig]
pkgs Project
proj Info
t,
		[FilePath]
opts])

-- | Get sandbox of project (if any)
getProjectSandbox :: MonadLog m => Project -> m (Maybe Sandbox)
getProjectSandbox :: Project -> m (Maybe Sandbox)
getProjectSandbox Project
p = IO (Maybe Sandbox) -> m (Maybe Sandbox)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Sandbox) -> m (Maybe Sandbox))
-> (Project -> IO (Maybe Sandbox)) -> Project -> m (Maybe Sandbox)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildTool -> Path -> IO (Maybe Sandbox)
projectSandbox (Getting BuildTool Project BuildTool -> Project -> BuildTool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting BuildTool Project BuildTool
Lens' Project BuildTool
projectBuildTool Project
p) (Path -> IO (Maybe Sandbox))
-> (Project -> Path) -> Project -> IO (Maybe Sandbox)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Path Project Path -> Project -> Path
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Path Project Path
Lens' Project Path
projectPath (Project -> m (Maybe Sandbox)) -> Project -> m (Maybe Sandbox)
forall a b. (a -> b) -> a -> b
$ Project
p

-- | Get project package-db stack
getProjectPackageDbStack :: Project -> GhcM PackageDbStack
getProjectPackageDbStack :: Project -> GhcM PackageDbStack
getProjectPackageDbStack = Project
-> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox)
forall (m :: * -> *). MonadLog m => Project -> m (Maybe Sandbox)
getProjectSandbox (Project
 -> MGhcT SessionConfig (First DynFlags) (LogT IO) (Maybe Sandbox))
-> (Maybe Sandbox -> GhcM PackageDbStack)
-> Project
-> GhcM PackageDbStack
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GhcM PackageDbStack
-> (Sandbox -> GhcM PackageDbStack)
-> Maybe Sandbox
-> GhcM PackageDbStack
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PackageDbStack -> GhcM PackageDbStack
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDbStack
userDb) Sandbox -> GhcM PackageDbStack
sandboxPackageDbStack