Sandbox.hs

{-# 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 = isJust . guessSandboxType

guessSandboxType :: Path -> Maybe BuildTool
guessSandboxType fpath
	| takeFileName (view path fpath) == ".cabal-sandbox" = Just CabalTool
	| takeFileName (view path fpath) == ".stack-work" = Just StackTool
	| otherwise = Nothing

sandboxFromPath :: Path -> Maybe Sandbox
sandboxFromPath fpath = Sandbox <$> guessSandboxType fpath <*> pure fpath

-- | Find sandbox in path
findSandbox :: Path -> IO (Maybe Sandbox)
findSandbox fpath = do
	fpath' <- canonicalize fpath
	isDir <- dirExists fpath'
	if isDir
		then do
			dirs <- liftM ((fpath' :) . map fromFilePath) $ directoryContents (view path fpath')
			return $ msum $ map sandboxFromDir dirs
		else return Nothing
	where
		sandboxFromDir :: Path -> Maybe Sandbox
		sandboxFromDir fdir
			| takeFileName (view path fdir) == "stack.yaml" = sandboxFromPath (fromFilePath (takeDirectory (view path fdir) </> ".stack-work"))
			| otherwise = sandboxFromPath fdir

-- | Search sandbox by parent directory
searchSandbox :: Path -> IO (Maybe Sandbox)
searchSandbox p = runMaybeT $ searchPath (view path p) (MaybeT . findSandbox . fromFilePath)

-- | Search sandboxes up from current directory
searchSandboxes :: Path -> IO [Sandbox]
searchSandboxes p = do
	mcabal <- searchFor CabalTool ".cabal-sandbox" ".cabal-sandbox"
	mstack <- searchFor StackTool "stack.yaml" ".stack-work"
	return $ catMaybes [mcabal, mstack]
	where
		searchFor :: BuildTool -> FilePath -> FilePath -> IO (Maybe Sandbox)
		searchFor tool lookFor sandboxDir = runMaybeT $ do
			root <- searchPath (view path p) (MaybeT . getRoot)
			return $ Sandbox tool $ fromFilePath (takeDirectory root </> sandboxDir)
			where
				getRoot = directoryContents >=> return . find ((== lookFor) . 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 tool fpath = runMaybeT $ do
	p <- searchPath (view path fpath) (MaybeT . getCabalFile)
	sboxes <- liftIO $ searchSandboxes (fromFilePath $ takeDirectory p)
	MaybeT $ return $ find ((== tool) . view sandboxType) sboxes
	where
		getCabalFile = directoryContents >=> return . find cabalFile

-- | Get package-db stack for sandbox
sandboxPackageDbStack :: Sandbox -> GhcM PackageDbStack
sandboxPackageDbStack (Sandbox CabalTool fpath) = do
	dir <- cabalSandboxPackageDb $ view path fpath
	return $ PackageDbStack [PackageDb $ fromFilePath dir]
sandboxPackageDbStack (Sandbox StackTool fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory (view path fpath)

-- | Search package-db stack with user-db as default
searchPackageDbStack :: BuildTool -> Path -> GhcM PackageDbStack
searchPackageDbStack tool p = do
	mbox <- liftIO $ projectSandbox tool p
	case mbox of
		Nothing -> return userDb
		Just sbox -> sandboxPackageDbStack sbox

-- | Restore package-db stack by package-db
restorePackageDbStack :: PackageDb -> GhcM PackageDbStack
restorePackageDbStack GlobalDb = return globalDb
restorePackageDbStack UserDb = return userDb
restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDbs [p]) $ runMaybeT $ do
	sbox <- MaybeT $ liftIO $ searchSandbox p
	lift $ sandboxPackageDbStack sbox

-- | User package-db: <arch>-<os>-<version>
userPackageDb :: GhcM FilePath
userPackageDb = do
	root <- liftIO $ getAppUserDataDirectory "ghc"
	dir <- buildPath "{arch}-{os}-{version}"
	return $ root </> dir

-- | Get sandbox package-db: <arch>-<os>-<compiler>-<version>-packages.conf.d
cabalSandboxPackageDb :: FilePath -> GhcM FilePath
cabalSandboxPackageDb root = do
	dirs <- mapM (fmap (root </>) . buildPath) [
		"{arch}-{os}-{compiler}-{version}-packages.conf.d",
		"{arch}-{os/cabal}-{compiler}-{version}-packages.conf.d"]
	mdir <- liftM msum $ forM dirs $ \dir -> do
		justIf dir <$> liftIO (doesDirectoryExist dir)
	case mdir of
		Nothing -> hsdevError $ OtherError $ unlines [
			"No suitable package-db found in sandbox, is it configured?",
			"Searched in: {}" ~~ intercalate ", " dirs]
		Just dir -> return dir

-- | Options for GHC for module and project
getModuleOpts :: [String] -> Module -> GhcM (PackageDbStack, [String])
getModuleOpts opts m = do
	pdbs <- case view (moduleId . moduleLocation) m of
		FileModule fpath mproj -> searchPackageDbStack (maybe CabalTool (view projectBuildTool) mproj) fpath
		InstalledModule{} -> return userDb
		_ -> return userDb
	pkgs <- browsePackages opts pdbs
	return $ (pdbs, concat [
		moduleOpts pkgs m,
		opts])

-- | Options for GHC for project target
getProjectTargetOpts :: [String] -> Project -> Info -> GhcM (PackageDbStack, [String])
getProjectTargetOpts opts proj t = do
	pdbs <- searchPackageDbStack (view projectBuildTool proj) (view projectPath proj)
	pkgs <- browsePackages opts pdbs
	return $ (pdbs, concat [
		projectTargetOpts pkgs proj t,
		opts])

-- | Get sandbox of project (if any)
getProjectSandbox :: MonadLog m => Project -> m (Maybe Sandbox)
getProjectSandbox p = liftIO . projectSandbox (view projectBuildTool p) . view projectPath $ p

-- | Get project package-db stack
getProjectPackageDbStack :: Project -> GhcM PackageDbStack
getProjectPackageDbStack = getProjectSandbox >=> maybe (return userDb) sandboxPackageDbStack