-
Notifications
You must be signed in to change notification settings - Fork 841
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
4 changed files
with
186 additions
and
2 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,163 @@ | ||
| {-# LANGUAGE ExtendedDefaultRules #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE TemplateHaskell #-} | ||
| {-# LANGUAGE TupleSections #-} | ||
| {-# OPTIONS_GHC -fno-warn-type-defaults #-} | ||
|
|
||
| -- | Run a IDE configured with the user's project(s). | ||
|
|
||
| module Stack.Ide (ide) where | ||
|
|
||
| import Control.Concurrent | ||
| import Control.Monad.Catch | ||
| import Control.Monad.IO.Class | ||
| import Control.Monad.Logger | ||
| import Control.Monad.Reader | ||
| import Data.Aeson | ||
| import qualified Data.ByteString as S | ||
| import qualified Data.ByteString.Char8 as S8 | ||
| import Data.ByteString.Lazy (ByteString) | ||
| import qualified Data.ByteString.Lazy as L | ||
| import Data.List | ||
| import qualified Data.Map.Strict as M | ||
| import Data.Maybe | ||
| import Data.Monoid | ||
| import qualified Data.Set as S | ||
| import Data.Text (Text) | ||
| import qualified Data.Text as T | ||
| import Path | ||
| import Path.IO | ||
| import Stack.Build.Source | ||
| import Stack.Constants | ||
| import Stack.Exec (defaultEnvSettings) | ||
| import Stack.Package | ||
| import Stack.Types | ||
| import System.Directory (doesFileExist) | ||
| import System.Exit | ||
| import System.IO | ||
| import qualified System.Process as P | ||
| import System.Process.Read | ||
|
|
||
| -- | Launch a GHCi IDE for the given local project targets with the | ||
| -- given options and configure it with the load paths and extensions | ||
| -- of those targets. | ||
| ide | ||
| :: (HasConfig r, HasBuildConfig r, HasEnvConfig r, MonadReader r m, MonadIO m, MonadThrow m, MonadLogger m, MonadCatch m) | ||
| => [Text] -- ^ Targets. | ||
| -> [String] -- ^ GHC options. | ||
| -> m () | ||
| ide targets useropts = do | ||
| econfig <- asks getEnvConfig | ||
| bconfig <- asks getBuildConfig | ||
| pwd <- getWorkingDir | ||
| pkgs <- | ||
| liftM catMaybes $ | ||
| forM (M.toList (bcPackages bconfig)) $ | ||
| \(dir,validWanted) -> | ||
| do cabalfp <- getCabalFileName dir | ||
| name <- parsePackageNameFromFilePath cabalfp | ||
| let config = | ||
| PackageConfig | ||
| { packageConfigEnableTests = True | ||
| , packageConfigEnableBenchmarks = True | ||
| , packageConfigFlags = localFlags mempty bconfig name | ||
| , packageConfigGhcVersion = envConfigGhcVersion econfig | ||
| , packageConfigPlatform = configPlatform | ||
| (getConfig bconfig) | ||
| } | ||
| pkg <- readPackage config cabalfp | ||
| if validWanted && wanted pwd cabalfp pkg | ||
| then do | ||
| pkgOpts <- getPackageOpts (packageOpts pkg) cabalfp | ||
| srcfiles <- | ||
| getPackageFiles (packageFiles pkg) Modules cabalfp | ||
| dist <- distDirFromDir dir | ||
| autogen <- return (autogenDir dist) | ||
| paths_foo <- | ||
| liftM | ||
| (autogen </>) | ||
| (parseRelFile | ||
| ("Paths_" ++ | ||
| packageNameString name ++ ".hs")) | ||
| paths_foo_exists <- fileExists paths_foo | ||
| return | ||
| (Just | ||
| ( packageName pkg | ||
| , ["--dist-dir=" <> toFilePath dist] ++ | ||
| map ("--ghc-option=" ++) (filter (not . badForGhci) pkgOpts) | ||
| , mapMaybe | ||
| (stripDir pwd) | ||
| (S.toList srcfiles <> | ||
| if paths_foo_exists | ||
| then [paths_foo] | ||
| else []))) | ||
| else return Nothing | ||
| localdb <- packageDatabaseLocal | ||
| depsdb <- packageDatabaseDeps | ||
| let pkgopts = concat (map _2 pkgs) | ||
| srcfiles = concatMap (map toFilePath . _3) pkgs | ||
| pkgdbs = | ||
| ["--package-db=" <> toFilePath depsdb <> ":" <> toFilePath localdb] | ||
| exec | ||
| "stack-ide" | ||
| (["--local-work-dir="++toFilePath pwd] ++ | ||
| map ("--ghc-option=" ++) (filter (not . badForGhci) useropts) <> pkgopts <> pkgdbs) | ||
| (encode (initialRequest srcfiles)) | ||
| where | ||
| wanted pwd cabalfp pkg = isInWantedList || targetsEmptyAndInDir | ||
| where | ||
| isInWantedList = elem (packageNameText (packageName pkg)) targets | ||
| targetsEmptyAndInDir = null targets || isParentOf (parent cabalfp) pwd | ||
| badForGhci x = | ||
| isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky") | ||
| _1 (x,_,_) = x | ||
| _2 (_,x,_) = x | ||
| _3 (_,_,x) = x | ||
|
|
||
| -- | Make the initial request. | ||
| initialRequest :: [FilePath] -> Value | ||
| initialRequest srcfiles = | ||
| object | ||
| [ "tag" .= "RequestUpdateSession" | ||
| , "contents" .= | ||
| [object ["tag" .= "TargetsInclude", "contents" .= srcfiles]]] | ||
|
|
||
| -- | Execute a process within the Stack configured environment. | ||
| exec :: (HasConfig r, MonadReader r m, MonadIO m, MonadLogger m, MonadThrow m) | ||
| => String -> [String] -> ByteString -> m b | ||
| exec cmd args input = do | ||
| config <- asks getConfig | ||
| menv <- | ||
| liftIO | ||
| (configEnvOverride | ||
| config | ||
| defaultEnvSettings | ||
| { esIncludeGhcPackagePath = False | ||
| }) | ||
| exists <- liftIO $ doesFileExist cmd | ||
| cmd' <- | ||
| if exists | ||
| then return cmd | ||
| else liftM toFilePath $ | ||
| join $ System.Process.Read.findExecutable menv cmd | ||
| let cp = | ||
| (P.proc cmd' args) | ||
| { P.env = envHelper menv | ||
| , P.delegate_ctlc = True | ||
| , P.std_in = P.CreatePipe | ||
| } | ||
| $logProcessRun cmd' args | ||
| (Just procin,Nothing,Nothing,ph) <- liftIO (P.createProcess cp) | ||
| liftIO | ||
| (do hSetBuffering stdin LineBuffering | ||
| hSetBuffering procin LineBuffering) | ||
| liftIO (do {-S8.hPutStrLn stdout (L.toStrict input)-} | ||
| S8.hPutStrLn procin (L.toStrict input)) | ||
| _tid <- | ||
| liftIO | ||
| (forkIO | ||
| (forever | ||
| (do bytes <- S.getLine | ||
| S.hPutStr procin bytes))) | ||
| ec <- liftIO (P.waitForProcess ph) | ||
| liftIO (exitWith ec) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters