Pass stack ghc paths down to cabal-helper

2015-08-28 09:44:20 +02:00 · 2015-08-28 09:44:20 +02:00 · 2a0414f368
parent 85722ab6f2
commit 2a0414f368
8 changed files with 154 additions and 45 deletions
--- a/Language/Haskell/GhcMod/CabalHelper.hs
+++ b/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,
-                                             cabalProgram)
+import Language.Haskell.GhcMod.Types
 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
-                     then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]
+                ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (programs defaultOptions)
+                     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 opts = Programs {
-                            cabalProgram  = T.cabalProgram opts,
-                            ghcProgram    = T.ghcProgram opts,
-                            ghcPkgProgram = T.ghcPkgProgram opts
-                          }
+helperProgs :: Programs -> CH.Programs
+helperProgs progs = CH.Programs {
+    cabalProgram  = T.cabalProgram progs,
+    ghcProgram    = T.ghcProgram progs,
+    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)
                        )
--- a/Language/Haskell/GhcMod/Debug.hs
+++ b/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 $
--- a/Language/Haskell/GhcMod/Error.hs
+++ b/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 _) =
--- a/Language/Haskell/GhcMod/PathsAndFiles.hs
+++ b/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
-    stack <- MaybeT $ findExecutable "stack"
-    liftIO $ takeWhile (/='\n') <$> readProcess stack ["path", "--dist-dir"] ""
+getStackDistDir projdir = U.withDirectory_ projdir $ runMaybeT $ do
+    takeWhile (/='\n') <$> readStack ["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)
--- a/Language/Haskell/GhcMod/Types.hs
+++ b/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.
-  , ghcProgram    :: FilePath
-  -- | @ghc-pkg@ program name.
-  , ghcPkgProgram :: FilePath
-  -- | @cabal@ program name.
-  , cabalProgram  :: FilePath
+  , programs      :: Programs
    -- | 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"
-  , ghcPkgProgram  = "ghc-pkg"
-  , cabalProgram   = "cabal"
+  , programs       = Programs {
+      ghcProgram     = "ghc"
+    , 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
--- a/Language/Haskell/GhcMod/Utils.hs
+++ b/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
--- a/ghc-mod.cabal
+++ b/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
--- a/src/GHCMod.hs
+++ b/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"]