Pass stack ghc paths down to cabal-helper

Language/Haskell/GhcMod/CabalHelper.hs

@@ -34,10 +34,10 @@ import Data.Maybe
 import Data.Monoid
 import Data.Serialize (Serialize)
 import Data.Traversable
-import Distribution.Helper
+import Distribution.Helper hiding (Programs(..))
+import qualified Distribution.Helper as CH
 import qualified Language.Haskell.GhcMod.Types as T
-import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,
+import Language.Haskell.GhcMod.Types
-                                             cabalProgram)
 import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.PathsAndFiles
@@ -45,6 +45,8 @@ import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Output
 import System.FilePath
 import System.Directory (findExecutable)
+import System.Process
+import System.Exit
 import Prelude hiding ((.))
 
 import Paths_ghc_mod as GhcMod
@@ -145,6 +147,18 @@ getStackPackageDbStack = do
         localDb <- liftIO $ readProcess stack ["path", "--local-pkg-db"] ""
         return $ map (PackageDb . takeWhile (/='\n')) [snapshotDb, localDb]
 
+patchStackPrograms :: IOish m => Cradle -> Programs -> m Programs
+patchStackPrograms crdl progs
+    | cradleProjectType crdl /= StackProject = return progs
+patchStackPrograms crdl progs = do
+  let projdir = cradleRootDir crdl
+  Just ghc <- liftIO $ getStackGhcPath projdir
+  Just ghcPkg <- liftIO $ getStackGhcPkgPath projdir
+  return $ progs {
+      ghcProgram = ghc
+    , ghcPkgProgram = ghcPkg
+    }
+
 withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a
 withCabal action = do
     crdl <- cradle
@@ -163,7 +177,7 @@ withCabal action = do
     pkgDbStackOutOfSync <-
          case mCusPkgDbStack of
            Just cusPkgDbStack -> do
-             pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $
+             pkgDb <- runQuery'' readProc (helperProgs $ programs opts) projdir distdir $
                  map chPkgToGhcPkg <$> packageDbStack
              return $ pkgDb /= cusPkgDbStack
 
@@ -185,31 +199,54 @@ withCabal action = do
         || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $
           case projType of
             CabalProject ->
-                cabalReconfigure readProc opts crdl projdir distdir
+                cabalReconfigure readProc (programs opts) crdl projdir distdir
             StackProject ->
-                -- https://github.com/commercialhaskell/stack/issues/820
+
-                gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build'"
+                stackReconfigure crdl (programs opts)
             _ ->
                 error $ "withCabal: unsupported project type: " ++ show projType
 
     action
 
  where
-   cabalReconfigure readProc opts crdl projdir distdir = do
+   cabalReconfigure readProc progs crdl projdir distdir = do
      withDirectory_ (cradleRootDir crdl) $ do
         cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack
         let progOpts =
-                [ "--with-ghc=" ++ T.ghcProgram opts ]
+                [ "--with-ghc=" ++ T.ghcProgram progs ]
                 -- Only pass ghc-pkg if it was actually set otherwise we
                 -- might break cabal's guessing logic
-                ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions
+                ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (programs defaultOptions)
-                     then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
+                     then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]
                      else []
                 ++ map pkgDbArg cusPkgStack
-        liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) ""
+        liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""
         gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"
         liftIO $ writeAutogenFiles readProc projdir distdir
 
+   stackReconfigure crdl progs = do
+     withDirectory_ (cradleRootDir crdl) $ do
+       supported <- haveStackSupport
+       if supported
+          then do
+            spawn [T.stackProgram progs, "build", "--only-dependencies"]
+            spawn [T.stackProgram progs, "build", "--only-configure"]
+          else
+            gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 1.4.0.0)"
+
+   spawn [] = return ()
+   spawn (exe:args) = do
+     readProc <- gmReadProcess
+     liftIO $ void $ readProc exe args ""
+
+   haveStackSupport = do
+     (rv, _, _) <-
+         liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] ""
+     case rv of
+       ExitSuccess -> return True
+       ExitFailure _ -> return False
+
+
 
 pkgDbArg :: GhcPkgDb -> String
 pkgDbArg GlobalDb      = "--package-db=global"
@@ -233,12 +270,12 @@ isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool
 isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do
   worldCabalConfig < worldCabalFile
 
-helperProgs :: Options -> Programs
+helperProgs :: Programs -> CH.Programs
-helperProgs opts = Programs {
+helperProgs progs = CH.Programs {
-                            cabalProgram  = T.cabalProgram opts,
+    cabalProgram  = T.cabalProgram progs,
-                            ghcProgram    = T.ghcProgram opts,
+    ghcProgram    = T.ghcProgram progs,
-                            ghcPkgProgram = T.ghcPkgProgram opts
+    ghcPkgProgram = T.ghcPkgProgram progs
-                          }
+  }
 
 chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a)
   => (FilePath -> Cached m GhcModState ChCacheData a) -> m a
@@ -252,7 +289,9 @@ chCached c = do
    -- changes the cache files will be gone anyways ;)
    cacheInputData root = do
                opt <- options
-               return $ ( helperProgs opt
+               crdl <- cradle
+               progs <- patchStackPrograms crdl (programs opt)
+               return $ ( helperProgs progs
                         , root
                         , (gmVer, chVer)
                         )

Language/Haskell/GhcMod/Debug.hs

@@ -53,6 +53,7 @@ cabalDebug = do
 
     return $
          [ "Cabal file:           " ++ show cradleCabalFile
+         , "Cabal Project Type:   " ++ show cradleProjectType
          , "Cabal entrypoints:\n"       ++ render (nest 4 $
               mapDoc gmComponentNameDoc smpDoc entrypoints)
          , "Cabal components:\n"        ++ render (nest 4 $

Language/Haskell/GhcMod/Error.hs

@@ -140,6 +140,9 @@ gmeDoc e = case e of
                ++ intercalate "\", \"" cfs ++"\"."
     GMECabalStateFile csfe ->
         gmCsfeDoc csfe
+    GMEStackBootrap rv stderr ->
+        (text $ "Boostrapping stack project failed (exited with "++show rv++")")
+          <+>: text stderr
 
 ghcExceptionDoc :: GhcException -> Doc
 ghcExceptionDoc e@(CmdLineError _) =

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -31,6 +31,8 @@ import Distribution.Helper (buildPlatform)
 import System.Directory
 import System.FilePath
 import System.Process
+import System.Info.Extra
+import System.Exit
 
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Error
@@ -76,9 +78,38 @@ findStackConfigFile :: FilePath -> IO (Maybe FilePath)
 findStackConfigFile dir = mightExist (dir </> "stack.yaml")
 
 getStackDistDir :: FilePath -> IO (Maybe FilePath)
-getStackDistDir dir = U.withDirectory_ dir $ runMaybeT $ do
+getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
-    stack <- MaybeT $ findExecutable "stack"
+    takeWhile (/='\n') <$> readStack ["path", "--dist-dir"]
-    liftIO $ takeWhile (/='\n') <$> readProcess stack ["path", "--dist-dir"] ""
+
+getStackGhcPath :: FilePath -> IO (Maybe FilePath)
+getStackGhcPath = findExecutablesInStackBinPath "ghc"
+
+getStackGhcPkgPath :: FilePath -> IO (Maybe FilePath)
+getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg"
+
+findExecutablesInStackBinPath :: String -> FilePath -> IO (Maybe FilePath)
+findExecutablesInStackBinPath exe projdir =
+    U.withDirectory_ projdir $ runMaybeT $ do
+      path <- splitSearchPath . takeWhile (/='\n')
+                <$> readStack ["path", "--bin-path"]
+      MaybeT $ listToMaybe <$> findExecutablesInDirectories' path exe
+
+findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
+findExecutablesInDirectories' path binary =
+    U.findFilesWith' isExecutable path (binary <.> exeExtension)
+   where isExecutable file = do
+             perms <- getPermissions file
+             return $ executable perms
+
+         exeExtension = if isWindows then "exe" else ""
+
+readStack :: [String] -> MaybeT IO String
+readStack args = do
+  stack <- MaybeT $ findExecutable "stack"
+  (e, out, err) <- liftIO $ readProcessWithExitCode stack args ""
+  case e of
+    ExitSuccess -> return out
+    (ExitFailure rv) -> throw $ GMEStackBootrap rv err
 
 -- | Get path to sandbox config file
 getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)

Language/Haskell/GhcMod/Types.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,
+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,
   StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
 module Language.Haskell.GhcMod.Types (
@@ -27,7 +27,8 @@ import Data.Maybe
 import Data.Typeable (Typeable)
 import Data.IORef
 import Data.Label.Derive
-import Distribution.Helper
+import Distribution.Helper hiding (Programs(..))
+import qualified Distribution.Helper as CabalHelper
 import Exception (ExceptionMonad)
 #if __GLASGOW_HASKELL__ < 708
 import qualified MonadUtils as GHC (MonadIO(..))
@@ -74,6 +75,19 @@ data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}
 
 type FileMappingMap = Map FilePath FileMapping
 
+data ProgramSource = ProgramSourceUser | ProgramSourceStack
+
+data Programs = Programs {
+  -- | @ghc@ program name.
+    ghcProgram    :: FilePath
+  -- | @ghc-pkg@ program name.
+  , ghcPkgProgram :: FilePath
+  -- | @cabal@ program name.
+  , cabalProgram  :: FilePath
+  -- | @stack@ program name.
+  , stackProgram   :: FilePath
+  } deriving (Show)
+
 data Options = Options {
     outputStyle   :: OutputStyle
   -- | Line separator string.
@@ -83,12 +97,7 @@ data Options = Options {
   , linePrefix :: Maybe (String, String)
   -- | Verbosity
   , logLevel      :: GmLogLevel
-  -- | @ghc@ program name.
+  , programs      :: Programs
-  , ghcProgram    :: FilePath
-  -- | @ghc-pkg@ program name.
-  , ghcPkgProgram :: FilePath
-  -- | @cabal@ program name.
-  , cabalProgram  :: FilePath
     -- | GHC command line options set on the @ghc-mod@ command line
   , ghcUserOptions:: [GHCOption]
   -- | If 'True', 'browse' also returns operators.
@@ -108,9 +117,12 @@ defaultOptions = Options {
   , lineSeparator  = LineSeparator "\0"
   , linePrefix     = Nothing
   , logLevel       = GmWarning
-  , ghcProgram     = "ghc"
+  , programs       = Programs {
-  , ghcPkgProgram  = "ghc-pkg"
+      ghcProgram     = "ghc"
-  , cabalProgram   = "cabal"
+    , ghcPkgProgram  = "ghc-pkg"
+    , cabalProgram   = "cabal"
+    , stackProgram   = "stack"
+    }
   , ghcUserOptions = []
   , operators      = False
   , detailed       = False
@@ -366,6 +378,9 @@ data GhcModError
 
   | GMECabalStateFile GMConfigStateFileError
     -- ^ Reading Cabal's state configuration file falied somehow.
+
+  | GMEStackBootrap Int String
+    -- ^ Bootstrapping @stack@ environment failed (process exited with failure)
     deriving (Eq,Show,Typeable)
 
 instance Error GhcModError where
@@ -386,10 +401,12 @@ data GMConfigStateFileError
 deriving instance Generic Version
 instance Serialize Version
 
-instance Serialize Programs
+instance Serialize CabalHelper.Programs
 instance Serialize ChModuleName
 instance Serialize ChComponentName
 instance Serialize ChEntrypoint
 
 mkLabel ''GhcModCaches
 mkLabel ''GhcModState
+mkLabel ''Options
+mkLabel ''Programs

Language/Haskell/GhcMod/Utils.hs

@@ -197,3 +197,14 @@ mkRevRedirMapFunc = do
   where
     mf :: FilePath -> FileMapping -> (FilePath, FilePath)
     mf from to = (fmPath to, from)
+
+findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]
+findFilesWith' _ [] _ = return []
+findFilesWith' f (d:ds) fileName = do
+    let file = d </> fileName
+    exist <- doesFileExist file
+    b <- if exist then f file else return False
+    if b then do
+               files <- findFilesWith' f ds fileName
+               return $ file : files
+        else findFilesWith' f ds fileName

ghc-mod.cabal

@@ -98,11 +98,9 @@ Library
   GHC-Options:          -Wall -fno-warn-deprecations
   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
                         ConstraintKinds, FlexibleContexts,
-                        DataKinds, KindSignatures, TypeOperators
+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns
   Exposed-Modules:      Language.Haskell.GhcMod
                         Language.Haskell.GhcMod.Internal
-  Other-Modules:        Paths_ghc_mod
-                        Utils
                         Language.Haskell.GhcMod.Boot
                         Language.Haskell.GhcMod.Browse
                         Language.Haskell.GhcMod.CabalHelper
@@ -142,6 +140,8 @@ Library
                         Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
+  Other-Modules:        Paths_ghc_mod
+                        Utils
   Build-Depends:        base >= 4.0 && < 5
                       , bytestring
                       , cereal >= 0.4
@@ -169,7 +169,8 @@ Library
                       , haskell-src-exts
                       , text
                       , djinn-ghc >= 0.0.2.2
-                      , fclabels
+                      , fclabels == 2.0.*
+                      , extra == 1.4.*
   if impl(ghc < 7.8)
     Build-Depends:      convertible
   if impl(ghc < 7.5)
@@ -181,7 +182,7 @@ Executable ghc-mod
   Default-Language:     Haskell2010
   Main-Is:              GHCMod.hs
   Other-Modules:        Paths_ghc_mod
-  GHC-Options:          -Wall -fno-warn-deprecations
+  GHC-Options:          -Wall -fno-warn-deprecations -threaded
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
@@ -194,6 +195,7 @@ Executable ghc-mod
                       , mtl >= 2.0
                       , ghc
                       , ghc-mod
+                      , fclabels == 2.0.*
 
 Executable ghc-modi
   Default-Language:     Haskell2010
@@ -229,7 +231,7 @@ Test-Suite spec
   Default-Language:     Haskell2010
   Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
                         ConstraintKinds, FlexibleContexts,
-                        DataKinds, KindSignatures, TypeOperators
+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns
   Main-Is:              Main.hs
   Hs-Source-Dirs:       test, .
   Ghc-Options:          -Wall -fno-warn-deprecations

src/GHCMod.hs

@@ -3,12 +3,13 @@
 module Main where
 
 import Config (cProjectVersion)
-import MonadUtils (liftIO)
+import Control.Category
 import Control.Applicative
 import Control.Arrow
 import Control.Monad
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
+import Data.Label
 import Data.List
 import Data.List.Split
 import Data.Char (isSpace)
@@ -16,6 +17,7 @@ import Data.Maybe
 import Exception
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
+import Language.Haskell.GhcMod.Types
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O
@@ -26,7 +28,7 @@ import System.Environment (getArgs)
 import System.IO (stdout, hSetEncoding, utf8, hFlush)
 import System.Exit
 import Text.PrettyPrint
-import Prelude
+import Prelude hiding ((.))
 
 import Misc
 
@@ -313,13 +315,16 @@ Exposed functions:
                   Right $ o { fileMappings = m : fileMappings o }
 
       , option "" ["with-ghc"] "GHC executable to use" $
-               reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p }
+               reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lPrograms) p o
 
       , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
-               reqArg "PROG" $ \p o -> Right $ o { ghcPkgProgram = p }
+               reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lPrograms) p o
 
       , option "" ["with-cabal"] "cabal-install executable to use" $
-               reqArg "PROG" $ \p o -> Right $ o { cabalProgram = p }
+               reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lPrograms) p o
+
+      , option "" ["with-stack"] "stack executable to use" $
+               reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lPrograms) p o
 
       , option "" ["version"] "print version information" $
                NoArg $ \_ -> Left ["version"]