module HsDev.Stack (
stack, yaml,
path, pathOf,
build, buildDeps, configure,
StackEnv(..), stackRoot, stackProject, stackConfig, stackGhc, stackSnapshot, stackLocal,
getStackEnv, projectEnv,
stackPackageDbStack,
stackCompiler, stackArch,
MaybeT(..)
) where
import Control.Arrow
import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.))
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.IO.Class
import Data.Char
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as M
import Distribution.Compiler
import Distribution.System
import qualified Distribution.Text as T (display)
import System.Directory
import System.Environment
import System.FilePath
import System.Process
import System.Log.Simple (MonadLog(..))
import qualified Packages as GHC
import HsDev.Error
import HsDev.PackageDb
import qualified HsDev.Tools.Ghc.Compat as Compat
import HsDev.Scan.Browse (withPackages)
import HsDev.Util as Util
stackCompiler :: MonadLog m => m String
stackCompiler = do
res <- withPackages ["-no-user-package-db"] $
return .
map (GHC.packageNameString &&& GHC.packageVersion) .
fromMaybe [] .
Compat.pkgDatabase
let
compiler = T.display buildCompilerFlavor
CompilerId _ version' = buildCompilerId
ver = maybe (T.display version') T.display $ lookup compiler res
return $ compiler ++ "-" ++ ver
stackArch :: String
stackArch = T.display buildArch
stack :: MonadLog m => [String] -> m String
stack cmd' = hsdevLiftIO $ do
curExe <- liftIO getExecutablePath
stackExe <- Util.withCurrentDirectory (takeDirectory curExe) $
liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return
comp <- stackCompiler
liftIO $ readProcess stackExe (cmd' ++ ["--compiler", comp, "--arch", stackArch]) ""
yaml :: Maybe FilePath -> [String]
yaml Nothing = []
yaml (Just y) = ["--stack-yaml", y]
type Paths = Map String FilePath
path :: MonadLog m => Maybe FilePath -> m Paths
path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where
breakPath :: String -> (String, FilePath)
breakPath = second (dropWhile isSpace . drop 1) . break (== ':')
pathOf :: String -> Lens' Paths (Maybe FilePath)
pathOf = at
build :: MonadLog m => [String] -> Maybe FilePath -> m ()
build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg)
buildDeps :: MonadLog m => Maybe FilePath -> m ()
buildDeps = build ["--only-dependencies"]
configure :: MonadLog m => Maybe FilePath -> m ()
configure = build ["--only-configure"]
data StackEnv = StackEnv {
_stackRoot :: FilePath,
_stackProject :: FilePath,
_stackConfig :: FilePath,
_stackGhc :: FilePath,
_stackSnapshot :: FilePath,
_stackLocal :: FilePath }
makeLenses ''StackEnv
getStackEnv :: Paths -> Maybe StackEnv
getStackEnv p = StackEnv <$>
(p ^. pathOf "stack-root") <*>
(p ^. pathOf "project-root") <*>
(p ^. pathOf "config-location") <*>
(p ^. pathOf "ghc-paths") <*>
(p ^. pathOf "snapshot-pkg-db") <*>
(p ^. pathOf "local-pkg-db")
projectEnv :: MonadLog m => FilePath -> m StackEnv
projectEnv p = hsdevLiftIO $ Util.withCurrentDirectory p $ do
paths' <- path Nothing
maybe (hsdevError $ ToolError "stack" ("can't get paths for " ++ p)) return $ getStackEnv paths'
stackPackageDbStack :: Lens' StackEnv PackageDbStack
stackPackageDbStack = lens g s where
g :: StackEnv -> PackageDbStack
g env' = PackageDbStack $ map PackageDb [_stackLocal env', _stackSnapshot env']
s :: StackEnv -> PackageDbStack -> StackEnv
s env' pdbs = env' {
_stackSnapshot = fromMaybe (_stackSnapshot env') $ pdbs ^? packageDbStack . ix 1 . packageDb,
_stackLocal = fromMaybe (_stackLocal env') $ pdbs ^? packageDbStack . ix 0 . packageDb }