diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 9ee6180..4cf0b38 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -3,7 +3,7 @@ module Language.Haskell.GhcMod ( -- * Cradle Cradle(..) - , ProjectType(..) + , Project(..) , findCradle -- * Options , Options(..) diff --git a/Language/Haskell/GhcMod/CabalHelper.hs b/Language/Haskell/GhcMod/CabalHelper.hs index af85eff..f9db18b 100644 --- a/Language/Haskell/GhcMod/CabalHelper.hs +++ b/Language/Haskell/GhcMod/CabalHelper.hs @@ -20,7 +20,6 @@ module Language.Haskell.GhcMod.CabalHelper ( getComponents , getGhcMergedPkgOptions , getCabalPackageDbStack - , getStackPackageDbStack , prepareCabalHelper ) #endif @@ -44,7 +43,6 @@ import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.CustomPackageDb import System.FilePath -import System.Directory (findExecutable) import System.Process import System.Exit import Prelude hiding ((.)) @@ -136,30 +134,18 @@ prepareCabalHelper = do let projdir = cradleRootDir crdl distdir = projdir cradleDistDir crdl readProc <- gmReadProcess - when (cradleProjectType crdl == CabalProject || cradleProjectType crdl == StackProject) $ + when (isCabalHelperProject $ cradleProject crdl) $ withCabal $ liftIO $ prepare readProc projdir distdir -getStackPackageDbStack :: IOish m => m [GhcPkgDb] -getStackPackageDbStack = do - mstack <- liftIO $ findExecutable "stack" - case mstack of - Nothing -> return [] - Just stack -> do - snapshotDb <- liftIO $ readProcess stack ["path", "--snapshot-pkg-db"] "" - localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] "" - return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb] - patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs -patchStackPrograms crdl progs - | cradleProjectType crdl /= StackProject = return progs -patchStackPrograms crdl progs = do - let projdir = cradleRootDir crdl - Just ghc <- getStackGhcPath projdir - Just ghcPkg <- getStackGhcPkgPath projdir +patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do + Just ghc <- getStackGhcPath senv + Just ghcPkg <- getStackGhcPkgPath senv return $ progs { ghcProgram = ghc , ghcPkgProgram = ghcPkg } +patchStackPrograms _crdl progs = return progs withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a withCabal action = do @@ -188,7 +174,7 @@ withCabal action = do Nothing -> return False - projType <- cradleProjectType <$> cradle + proj <- cradleProject <$> cradle when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." @@ -202,14 +188,14 @@ withCabal action = do when ( isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ - case projType of + case proj of CabalProject -> cabalReconfigure readProc (optPrograms opts) crdl projdir distdir - StackProject -> + StackProject {} -> stackReconfigure crdl (optPrograms opts) _ -> - error $ "withCabal: unsupported project type: " ++ show projType + error $ "withCabal: unsupported project type: " ++ show proj action diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index aa2d082..45ef00d 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -69,7 +69,7 @@ cabalCradle wdir = do let cabalDir = takeDirectory cabalFile return Cradle { - cradleProjectType = CabalProject + cradleProject = CabalProject , cradleCurrentDir = wdir , cradleRootDir = cabalDir , cradleTempDir = error "tmpDir" @@ -89,22 +89,22 @@ stackCradle wdir = do -- rather than stack, or maybe that's just me ;) whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero - distDir <- MaybeT $ getStackDistDir cabalDir + senv <- MaybeT $ getStackEnv cabalDir return Cradle { - cradleProjectType = StackProject + cradleProject = StackProject senv , cradleCurrentDir = wdir , cradleRootDir = cabalDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile - , cradleDistDir = distDir + , cradleDistDir = seDistDir senv } sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle sandboxCradle wdir = do sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir return Cradle { - cradleProjectType = SandboxProject + cradleProject = SandboxProject , cradleCurrentDir = wdir , cradleRootDir = sbDir , cradleTempDir = error "tmpDir" @@ -115,7 +115,7 @@ sandboxCradle wdir = do plainCradle :: IOish m => FilePath -> MaybeT m Cradle plainCradle wdir = do return $ Cradle { - cradleProjectType = PlainProject + cradleProject = PlainProject , cradleCurrentDir = wdir , cradleRootDir = wdir , cradleTempDir = error "tmpDir" diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 2d363a8..bb7b7ac 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -26,9 +26,9 @@ debugInfo = do Cradle {..} <- cradle cabal <- - case cradleProjectType of + case cradleProject of CabalProject -> cabalDebug - StackProject -> (++) <$> stackPaths <*> cabalDebug + StackProject {} -> (++) <$> stackPaths <*> cabalDebug _ -> return [] pkgOpts <- packageGhcOptions @@ -45,9 +45,9 @@ debugInfo = do stackPaths :: IOish m => GhcModT m [String] stackPaths = do - Cradle {..} <- cradle - Just ghc <- getStackGhcPath cradleRootDir - Just ghcPkg <- getStackGhcPkgPath cradleRootDir + Cradle { cradleProject = StackProject senv } <- cradle + ghc <- getStackGhcPath senv + ghcPkg <- getStackGhcPkgPath senv return $ [ "Stack ghc executable: " ++ show ghc , "Stack ghc-pkg executable:" ++ show ghcPkg @@ -64,7 +64,7 @@ cabalDebug = do return $ [ "Cabal file: " ++ show cradleCabalFile - , "Cabal Project Type: " ++ show cradleProjectType + , "Project: " ++ show cradleProject , "Cabal entrypoints:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc smpDoc entrypoints) , "Cabal components:\n" ++ render (nest 4 $ diff --git a/Language/Haskell/GhcMod/GhcPkg.hs b/Language/Haskell/GhcMod/GhcPkg.hs index ef06b09..9bff334 100644 --- a/Language/Haskell/GhcMod/GhcPkg.hs +++ b/Language/Haskell/GhcMod/GhcPkg.hs @@ -65,9 +65,9 @@ getGhcPkgProgram :: IOish m => GhcModT m FilePath getGhcPkgProgram = do crdl <- cradle progs <- optPrograms <$> options - case cradleProjectType crdl of - StackProject -> do - Just ghcPkg <- getStackGhcPkgPath (cradleRootDir crdl) + case cradleProject crdl of + (StackProject senv) -> do + Just ghcPkg <- getStackGhcPkgPath senv return ghcPkg _ -> return $ ghcPkgProgram progs @@ -77,7 +77,7 @@ getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb] getPackageDbStack = do crdl <- cradle mCusPkgStack <- getCustomPkgDbStack - stack <- case cradleProjectType crdl of + stack <- case cradleProject crdl of PlainProject -> return [GlobalDb, UserDb] SandboxProject -> do @@ -85,8 +85,8 @@ getPackageDbStack = do return $ [GlobalDb, db] CabalProject -> getCabalPackageDbStack - StackProject -> - getStackPackageDbStack + (StackProject StackEnv {..}) -> + return $ map PackageDb [seSnapshotPkgDb, seLocalPkgDb] return $ fromMaybe stack mCusPkgStack getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath] diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs index 228cc87..959e2b6 100644 --- a/Language/Haskell/GhcMod/PathsAndFiles.hs +++ b/Language/Haskell/GhcMod/PathsAndFiles.hs @@ -27,6 +27,7 @@ import Control.Monad import Control.Monad.Trans.Maybe import Control.Monad.Trans.Class import Data.List +import Data.List.Split import Data.Char import Data.Maybe import Data.Traversable hiding (mapM) @@ -85,22 +86,29 @@ findStackConfigFile dir = do Just (d, Just a) -> return $ Just $ d a Just (_, Nothing) -> error "findStackConfigFile" -getStackDistDir :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath) -getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do - takeWhile (/='\n') <$> readStack ["path", "--dist-dir"] +getStackEnv :: (IOish m, GmOut m) => FilePath -> m (Maybe StackEnv) +getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do + env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"] + let look k = fromJust $ lookup k env + return StackEnv { + seDistDir = look "dist-dir" + , seBinPath = splitSearchPath $ look "bin-path" + , seSnapshotPkgDb = look "snapshot-pkg-db" + , seLocalPkgDb = look "local-pkg-db" + } + where + liToTup [k,v] = (k,v) + liToTup _ = error "getStackEnv" -getStackGhcPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath) +getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath) getStackGhcPath = findExecutablesInStackBinPath "ghc" -getStackGhcPkgPath :: (IOish m, GmOut m) => FilePath -> m (Maybe FilePath) +getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath) getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg" -findExecutablesInStackBinPath :: (IOish m, GmOut m) => String -> FilePath -> m (Maybe FilePath) -findExecutablesInStackBinPath exe projdir = - U.withDirectory_ projdir $ runMaybeT $ do - path <- splitSearchPath . takeWhile (/='\n') - <$> readStack ["path", "--bin-path"] - MaybeT $ liftIO $ listToMaybe <$> findExecutablesInDirectories' path exe +findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath) +findExecutablesInStackBinPath exe StackEnv {..} = + liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories' path binary = diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 8fb0336..3906b0a 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -150,10 +150,10 @@ targetGhcOptions :: forall m. IOish m targetGhcOptions crdl sefnmn = do when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" - case cradleProjectType crdl of - CabalProject -> cabalOpts crdl - StackProject -> cabalOpts crdl - _ -> sandboxOpts crdl + case cradleProject crdl of + proj + | isCabalHelperProject proj -> cabalOpts crdl + | otherwise -> sandboxOpts crdl where zipMap f l = l `zip` (f `map` l) @@ -267,10 +267,10 @@ packageGhcOptions :: (Applicative m, IOish m, Gm m) => m [GHCOption] packageGhcOptions = do crdl <- cradle - case cradleProjectType crdl of - CabalProject -> getGhcMergedPkgOptions - StackProject -> getGhcMergedPkgOptions - _ -> sandboxOpts crdl + case cradleProject crdl of + proj + | isCabalHelperProject proj -> getGhcMergedPkgOptions + | otherwise -> sandboxOpts crdl -- also works for plain projects! sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String] diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index 3043011..473c56e 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -139,12 +139,27 @@ defaultOptions = Options { ---------------------------------------------------------------- -data ProjectType = CabalProject | SandboxProject | PlainProject | StackProject - deriving (Eq, Show) +data Project = CabalProject + | SandboxProject + | PlainProject + | StackProject StackEnv + deriving (Eq, Show) + +isCabalHelperProject :: Project -> Bool +isCabalHelperProject StackProject {} = True +isCabalHelperProject CabalProject {} = True +isCabalHelperProject _ = False + +data StackEnv = StackEnv { + seDistDir :: FilePath + , seBinPath :: [FilePath] + , seSnapshotPkgDb :: FilePath + , seLocalPkgDb :: FilePath + } deriving (Eq, Show) -- | The environment where this library is used. data Cradle = Cradle { - cradleProjectType:: ProjectType + cradleProject :: Project -- | The directory where this library is executed. , cradleCurrentDir :: FilePath -- | The project root directory. diff --git a/src/GHCMod.hs b/src/GHCMod.hs index 05961d6..ce8b75b 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -679,7 +679,7 @@ nukeCaches = do chdir <- liftIO $ ( "cabal-helper") <$> getAppUserDataDirectory "ghc-mod" c <- cradle - when (cradleProjectType c == CabalProject || cradleProjectType c == StackProject) $ do + when (isCabalHelperProject $ cradleProject c) $ do let root = cradleRootDir c let dist = cradleDistDir c liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root dist]