From 782eda883d4f9399bf22034997c39d4bfb852bd2 Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Sat, 30 Jul 2016 18:51:59 -0500 Subject: [PATCH 01/13] Extracted renderLegacyGhciScriptFunction --- src/Stack/Ghci.hs | 52 ++++++++++++++++++++++++++++---------- src/test/Stack/GhciSpec.hs | 52 ++++++++++++++++++++++++++++++++++++++ stack.cabal | 1 + 3 files changed, 91 insertions(+), 14 deletions(-) create mode 100644 src/test/Stack/GhciSpec.hs diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index bb036524c3..6713761188 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -14,6 +14,9 @@ module Stack.Ghci , GhciException(..) , ghciSetup , ghci + + -- TODO: Address what should and should not be exported. + , renderLegacyGhciScript ) where import Control.Applicative @@ -171,20 +174,41 @@ ghci opts@GhciOpts{..} = do -- include CWD. "-i" : odir <> pkgopts <> ghciArgs <> extras) - withSystemTempDir "ghci" $ \tmpDir -> do - let macrosFile = tmpDir $(mkRelFile "cabal_macros.h") - macrosOpts <- preprocessCabalMacros pkgs macrosFile - if ghciNoLoadModules - then execGhci macrosOpts - else do - let scriptPath = tmpDir $(mkRelFile "ghci-script") - fp = toFilePath scriptPath - loadModules = ":add " <> unwords (map quoteFileName modulesToLoad) - addMainFile = maybe "" ((":add " <>) . quoteFileName . toFilePath) mainFile - bringIntoScope = ":module + " <> unwords modulesToLoad - liftIO (writeFile fp (unlines [loadModules,addMainFile,bringIntoScope])) - setScriptPerms fp - execGhci (macrosOpts ++ ["-ghci-script=" <> fp]) + + withSystemTempDir "ghci" $ \tmpDirectory -> do + macrosOptions <- writeMacrosFile tmpDirectory pkgs + if ghciNoLoadModules + then execGhci macrosOptions + else do + scriptPath <- writeGhciScript tmpDirectory (renderLegacyGhciScript modulesToLoad mainFile) + execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) + +writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String] +writeMacrosFile tmpDirectory packages = do + macrosOptions <- preprocessCabalMacros packages macrosFile + return macrosOptions + where + macrosFile = tmpDirectory $(mkRelFile "cabal_macros.h") + +writeGhciScript :: (MonadIO m) => Path Abs Dir -> String -> m (Path Abs File) +writeGhciScript tmpDirectory script = do + liftIO $ writeFile scriptFilePath script + setScriptPerms scriptFilePath + return scriptPath + where + scriptPath = tmpDirectory $(mkRelFile "ghci-script") + scriptFilePath = toFilePath scriptPath + +renderLegacyGhciScript :: [String] -> Maybe (Path b t) -> String +renderLegacyGhciScript modulesToLoad mainFile = + let loadModules = ":add" <> case unwords (map quoteFileName modulesToLoad) of + [] -> "" + xs -> " " <> xs + addMainFile = maybe "" ((":add " <>) . quoteFileName . toFilePath) mainFile + bringIntoScope = ":module +" <> case unwords modulesToLoad of + [] -> "" + xs -> " " <> xs + in unlines [loadModules,addMainFile,bringIntoScope] -- | Figure out the main-is file to load based on the targets. Sometimes there -- is none, sometimes it's unambiguous, sometimes it's diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs new file mode 100644 index 0000000000..035e6afb9d --- /dev/null +++ b/src/test/Stack/GhciSpec.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Test suite for GHCi like applications including both GHCi and Intero. +module Stack.GhciSpec where + +import Data.Text (Text) +import qualified Data.Text as T +import Test.Hspec +import NeatInterpolation +import Path + +import Stack.Ghci + +spec :: Spec +spec = do + describe "GHCi" $ do + describe "Script rendering" $ do + it "should render legacy script when given project:exe" $ do + renderLegacyGhciScript [] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + `shouldBe` T.unpack ghciScript_projectWithMain + + it "should render legacy script when given project" $ do + renderLegacyGhciScript ["Lib.A"] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + `shouldBe` T.unpack ghciScript_projectWithLibAndMain + + it "should render legacy script when given multiple project:lib" $ do + renderLegacyGhciScript ["Lib.A", "Lib.B"] Nothing + `shouldBe` T.unpack ghciScript_multipleProjectsWithLib + +-- Exptected GHCi scripts + +ghciScript_projectWithMain :: Text +ghciScript_projectWithMain = [text| +:add +:add /Users/someone/src/project-a/exe/Main.hs +:module + +|] + +ghciScript_projectWithLibAndMain :: Text +ghciScript_projectWithLibAndMain = [text| +:add Lib.A +:add /Users/someone/src/project-a/exe/Main.hs +:module + Lib.A +|] + +ghciScript_multipleProjectsWithLib :: Text +ghciScript_multipleProjectsWithLib = [text| +:add Lib.A Lib.B + +:module + Lib.A Lib.B +|] diff --git a/stack.cabal b/stack.cabal index c1c9539bbb..cb4c582ed0 100644 --- a/stack.cabal +++ b/stack.cabal @@ -306,6 +306,7 @@ test-suite stack-test , hspec <2.3 , http-conduit , monad-logger + , neat-interpolation , path >= 0.5.7 , path-io >= 1.1.0 && < 2.0.0 , resourcet From e979e91987d8349574e5c794c6028be5d9aa41cd Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Sat, 30 Jul 2016 18:53:06 -0500 Subject: [PATCH 02/13] Added DSL for describing GHCi scripts. --- src/Stack/Ghci/Script.hs | 70 +++++++++++++++++++++++++++++++ src/test/Stack/Ghci/ScriptSpec.hs | 40 ++++++++++++++++++ stack.cabal | 1 + 3 files changed, 111 insertions(+) create mode 100644 src/Stack/Ghci/Script.hs create mode 100644 src/test/Stack/Ghci/ScriptSpec.hs diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs new file mode 100644 index 0000000000..3461882855 --- /dev/null +++ b/src/Stack/Ghci/Script.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Ghci.Script + ( GhciScript + , GhciCommand (..) + , emptyScript + + , appendCommand + + , scriptToText + , scriptToLazyText + , scriptToBuilder + ) where + +import Data.Monoid +import Data.List +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import Data.Text.Lazy.Builder +import Data.Vector (Vector) +import qualified Data.Vector as V +import Path + +newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] } + +emptyScript :: GhciScript +emptyScript = GhciScript [] + +type ModuleName = Text + +data GhciCommand + = Add (Vector ModuleName) + | CdGhc (Path Abs Dir) + | Module (Vector ModuleName) + deriving (Show) + +appendCommand :: GhciCommand -> GhciScript -> GhciScript +appendCommand cmd (GhciScript backwardScript) = GhciScript (cmd:backwardScript) + +scriptToText :: GhciScript -> Text +scriptToText = LT.toStrict . scriptToLazyText + +scriptToLazyText :: GhciScript -> LT.Text +scriptToLazyText = toLazyText . scriptToBuilder + +scriptToBuilder :: GhciScript -> Builder +scriptToBuilder backwardScript = mconcat $ fmap commandToBuilder script + where + script = reverse $ unGhciScript backwardScript + +-- Command conversion + +commandToBuilder :: GhciCommand -> Builder + +commandToBuilder (Add modules) + | V.null modules = mempty + | otherwise = + fromText ":add " + <> (mconcat $ intersperse (singleton ' ') $ V.toList $ fmap fromText modules) + <> singleton '\n' + +commandToBuilder (CdGhc path) = + fromText ":cd-ghc " <> fromString (toFilePath path) + +commandToBuilder (Module modules) + | V.null modules = fromText ":module +" + | otherwise = + fromText ":module + " + <> (mconcat $ intersperse (singleton ' ') $ V.toList $ fmap fromText modules) + <> singleton '\n' diff --git a/src/test/Stack/Ghci/ScriptSpec.hs b/src/test/Stack/Ghci/ScriptSpec.hs new file mode 100644 index 0000000000..9f7fecdc78 --- /dev/null +++ b/src/test/Stack/Ghci/ScriptSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Test suite for the GhciScript DSL +module Stack.Ghci.ScriptSpec where + +import Test.Hspec +import Path + +import Stack.Ghci.Script + +spec :: Spec +spec = do + describe "GHCi" $ do + describe "Script DSL" $ do + + describe ":add" $ do + it "should not render empty add commands" $ do + let script = appendCommand (Add []) emptyScript + scriptToText script `shouldBe` "" + + it "should ensure that a space exists between each module in an add command" $ do + let script = appendCommand (Add ["Lib.A", "Lib.B"]) emptyScript + scriptToText script `shouldBe` ":add Lib.A Lib.B\n" + + describe ":cd-ghc" $ do + it "should render a full absolute path" $ do + let script = appendCommand (CdGhc $(mkAbsDir "/Users/someone/src/project/package-a")) emptyScript + scriptToText script `shouldBe` + ":cd-ghc /Users/someone/src/project/package-a/" + + describe ":module" $ do + it "should render empty module as ':module +'" $ do + let script = appendCommand (Module []) emptyScript + scriptToText script `shouldBe` ":module +" + + it "should ensure that a space exists between each module in a module command" $ do + let script = appendCommand (Module ["Lib.A", "Lib.B"]) emptyScript + scriptToText script `shouldBe` ":module + Lib.A Lib.B\n" diff --git a/stack.cabal b/stack.cabal index cb4c582ed0..b03d724149 100644 --- a/stack.cabal +++ b/stack.cabal @@ -96,6 +96,7 @@ library Stack.FileWatch Stack.GhcPkg Stack.Ghci + Stack.Ghci.Script Stack.Hoogle Stack.IDE Stack.Image From 047e336480961664bfb4660c3c5ef7fc892334bb Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Tue, 2 Aug 2016 14:52:13 -0500 Subject: [PATCH 03/13] Added function for rendering intero supported script. --- src/Stack/Ghci.hs | 12 ++++++ src/Stack/Ghci/Script.hs | 63 +++++++++++++++++++------------ src/test/Stack/Ghci/ScriptSpec.hs | 30 ++++++++++----- src/test/Stack/GhciSpec.hs | 42 +++++++++++++++++++++ 4 files changed, 112 insertions(+), 35 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 6713761188..36af0d020d 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -17,6 +17,7 @@ module Stack.Ghci -- TODO: Address what should and should not be exported. , renderLegacyGhciScript + , renderScriptIntero ) where import Control.Applicative @@ -45,6 +46,7 @@ import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) +import qualified Data.Vector as V import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription (updatePackageDescription) import Distribution.Text (display) @@ -59,6 +61,7 @@ import Stack.Build.Source import Stack.Build.Target import Stack.Constants import Stack.Exec +import Stack.Ghci.Script import Stack.Package import Stack.Types import Stack.Types.Internal @@ -210,6 +213,15 @@ renderLegacyGhciScript modulesToLoad mainFile = xs -> " " <> xs in unlines [loadModules,addMainFile,bringIntoScope] +renderScriptGhci :: [GhciPkgInfo] -> Text +renderScriptGhci = undefined + +renderScriptIntero :: [GhciPkgInfo] -> Text +renderScriptIntero = scriptToText . mconcat . fmap renderPkg + where + renderPkg pkg = cmdCdGhc (ghciPkgDir pkg) + <> cmdAdd (ghciPkgModules pkg) + -- | Figure out the main-is file to load based on the targets. Sometimes there -- is none, sometimes it's unambiguous, sometimes it's -- ambiguous. Warns and returns nothing if it's ambiguous. diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs index 3461882855..2b174b65da 100644 --- a/src/Stack/Ghci/Script.hs +++ b/src/Stack/Ghci/Script.hs @@ -2,10 +2,11 @@ module Stack.Ghci.Script ( GhciScript - , GhciCommand (..) - , emptyScript + , ModuleName - , appendCommand + , cmdAdd + , cmdCdGhc + , cmdModule , scriptToText , scriptToLazyText @@ -14,34 +15,42 @@ module Stack.Ghci.Script import Data.Monoid import Data.List +import Data.Set (Set) +import qualified Data.Set as S import Data.Text (Text) -import qualified Data.Text.Lazy as LT -import Data.Text.Lazy.Builder -import Data.Vector (Vector) -import qualified Data.Vector as V +import qualified Data.Text.Lazy as LT hiding (singleton) +import Data.Text.Lazy.Builder (Builder) +import qualified Data.Text.Lazy.Builder as LT import Path -newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] } +import Distribution.ModuleName hiding (toFilePath) -emptyScript :: GhciScript -emptyScript = GhciScript [] +newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] } -type ModuleName = Text +instance Monoid GhciScript where + mempty = GhciScript [] + (GhciScript xs) `mappend` (GhciScript ys) = GhciScript (ys <> xs) data GhciCommand - = Add (Vector ModuleName) + = Add (Set ModuleName) | CdGhc (Path Abs Dir) - | Module (Vector ModuleName) + | Module (Set ModuleName) deriving (Show) -appendCommand :: GhciCommand -> GhciScript -> GhciScript -appendCommand cmd (GhciScript backwardScript) = GhciScript (cmd:backwardScript) +cmdAdd :: Set ModuleName -> GhciScript +cmdAdd = GhciScript . (:[]) . Add + +cmdCdGhc :: Path Abs Dir -> GhciScript +cmdCdGhc = GhciScript . (:[]) . CdGhc + +cmdModule :: Set ModuleName -> GhciScript +cmdModule = GhciScript . (:[]) . Module scriptToText :: GhciScript -> Text scriptToText = LT.toStrict . scriptToLazyText scriptToLazyText :: GhciScript -> LT.Text -scriptToLazyText = toLazyText . scriptToBuilder +scriptToLazyText = LT.toLazyText . scriptToBuilder scriptToBuilder :: GhciScript -> Builder scriptToBuilder backwardScript = mconcat $ fmap commandToBuilder script @@ -53,18 +62,22 @@ scriptToBuilder backwardScript = mconcat $ fmap commandToBuilder script commandToBuilder :: GhciCommand -> Builder commandToBuilder (Add modules) - | V.null modules = mempty + | S.null modules = mempty | otherwise = - fromText ":add " - <> (mconcat $ intersperse (singleton ' ') $ V.toList $ fmap fromText modules) - <> singleton '\n' + LT.fromText ":add " + <> (mconcat $ intersperse (LT.singleton ' ') + $ fmap (LT.fromString . mconcat . intersperse "." . components) + $ S.toAscList modules) + <> LT.singleton '\n' commandToBuilder (CdGhc path) = - fromText ":cd-ghc " <> fromString (toFilePath path) + LT.fromText ":cd-ghc " <> LT.fromString (toFilePath path) <> LT.singleton '\n' commandToBuilder (Module modules) - | V.null modules = fromText ":module +" + | S.null modules = LT.fromText ":module +\n" | otherwise = - fromText ":module + " - <> (mconcat $ intersperse (singleton ' ') $ V.toList $ fmap fromText modules) - <> singleton '\n' + LT.fromText ":module + " + <> (mconcat $ intersperse (LT.singleton ' ') + $ fmap (LT.fromString . mconcat . intersperse "." . components) + $ S.toAscList modules) + <> LT.singleton '\n' diff --git a/src/test/Stack/Ghci/ScriptSpec.hs b/src/test/Stack/Ghci/ScriptSpec.hs index 9f7fecdc78..df3593c25c 100644 --- a/src/test/Stack/Ghci/ScriptSpec.hs +++ b/src/test/Stack/Ghci/ScriptSpec.hs @@ -5,36 +5,46 @@ -- | Test suite for the GhciScript DSL module Stack.Ghci.ScriptSpec where -import Test.Hspec -import Path +import Data.Monoid +import qualified Data.Set as S +import Distribution.ModuleName +import Test.Hspec +import Path -import Stack.Ghci.Script +import Stack.Ghci.Script spec :: Spec spec = do describe "GHCi" $ do describe "Script DSL" $ do + describe "script" $ do + it "should seperate commands with a newline" $ do + let script = cmdCdGhc $(mkAbsDir "/src/package-a") + <> cmdAdd [fromString "Lib.A"] + scriptToText script `shouldBe` + ":cd-ghc /src/package-a/\n:add Lib.A\n" + describe ":add" $ do it "should not render empty add commands" $ do - let script = appendCommand (Add []) emptyScript + let script = cmdAdd [] scriptToText script `shouldBe` "" it "should ensure that a space exists between each module in an add command" $ do - let script = appendCommand (Add ["Lib.A", "Lib.B"]) emptyScript + let script = cmdAdd (S.fromList [fromString "Lib.A", fromString "Lib.B"]) scriptToText script `shouldBe` ":add Lib.A Lib.B\n" describe ":cd-ghc" $ do it "should render a full absolute path" $ do - let script = appendCommand (CdGhc $(mkAbsDir "/Users/someone/src/project/package-a")) emptyScript + let script = cmdCdGhc $(mkAbsDir "/Users/someone/src/project/package-a") scriptToText script `shouldBe` - ":cd-ghc /Users/someone/src/project/package-a/" + ":cd-ghc /Users/someone/src/project/package-a/\n" describe ":module" $ do it "should render empty module as ':module +'" $ do - let script = appendCommand (Module []) emptyScript - scriptToText script `shouldBe` ":module +" + let script = cmdModule [] + scriptToText script `shouldBe` ":module +\n" it "should ensure that a space exists between each module in a module command" $ do - let script = appendCommand (Module ["Lib.A", "Lib.B"]) emptyScript + let script = cmdModule [fromString "Lib.A", fromString "Lib.B"] scriptToText script `shouldBe` ":module + Lib.A Lib.B\n" diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs index 035e6afb9d..6b7e75fe3f 100644 --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -- | Test suite for GHCi like applications including both GHCi and Intero. module Stack.GhciSpec where +import qualified Data.Map as M +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import Distribution.ModuleName +import Stack.Types.Package +import Stack.Types.PackageName +import Stack.Types.Version import Test.Hspec import NeatInterpolation import Path @@ -28,6 +35,41 @@ spec = do renderLegacyGhciScript ["Lib.A", "Lib.B"] Nothing `shouldBe` T.unpack ghciScript_multipleProjectsWithLib + + + it "should render intero scripts" $ do + let pkgs = + [ GhciPkgInfo + { ghciPkgModules = S.fromList [fromString "Lib.A"] + , ghciPkgDir = $(mkAbsDir "/src/package-a") + , ghciPkgName = $(mkPackageName "package-a") + , ghciPkgOpts = [] + , ghciPkgModFiles = S.empty + , ghciPkgCFiles = S.empty + , ghciPkgMainIs = M.empty + , ghciPkgPackage = Package + { packageName = $(mkPackageName "package-a") + , packageVersion = $(mkVersion "0.1.0.0") + , packageFiles = GetPackageFiles undefined + , packageDeps = M.empty + , packageTools = [] + , packageAllDeps = S.empty + , packageGhcOptions = [] + , packageFlags = M.empty + , packageDefaultFlags = M.empty + , packageHasLibrary = True + , packageTests = M.empty + , packageBenchmarks = S.empty + , packageExes = S.empty + , packageOpts = GetPackageOpts undefined + , packageHasExposedModules = True + , packageSimpleType = True + } + } + ] + res = renderScriptIntero pkgs + res `shouldBe` ":cd-ghc /src/package-a/\n:add Lib.A\n" + -- Exptected GHCi scripts ghciScript_projectWithMain :: Text From 9798336530245268557caa95576369227a9f1cbc Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Tue, 2 Aug 2016 17:32:58 -0500 Subject: [PATCH 04/13] Switched from Text Builder to ByteString Builder. --- src/Stack/Ghci.hs | 6 ++-- src/Stack/Ghci/Script.hs | 51 +++++++++++++++++++------------ src/test/Stack/Ghci/ScriptSpec.hs | 12 ++++---- src/test/Stack/GhciSpec.hs | 3 +- 4 files changed, 42 insertions(+), 30 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 36af0d020d..4521e25267 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -213,11 +213,11 @@ renderLegacyGhciScript modulesToLoad mainFile = xs -> " " <> xs in unlines [loadModules,addMainFile,bringIntoScope] -renderScriptGhci :: [GhciPkgInfo] -> Text +renderScriptGhci :: [GhciPkgInfo] -> GhciScript renderScriptGhci = undefined -renderScriptIntero :: [GhciPkgInfo] -> Text -renderScriptIntero = scriptToText . mconcat . fmap renderPkg +renderScriptIntero :: [GhciPkgInfo] -> GhciScript +renderScriptIntero = mconcat . fmap renderPkg where renderPkg pkg = cmdCdGhc (ghciPkgDir pkg) <> cmdAdd (ghciPkgModules pkg) diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs index 2b174b65da..570fc7dfdf 100644 --- a/src/Stack/Ghci/Script.hs +++ b/src/Stack/Ghci/Script.hs @@ -8,20 +8,22 @@ module Stack.Ghci.Script , cmdCdGhc , cmdModule - , scriptToText - , scriptToLazyText + , scriptToLazyByteString , scriptToBuilder + , scriptToFile ) where +import Control.Exception +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Builder import Data.Monoid import Data.List import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) -import qualified Data.Text.Lazy as LT hiding (singleton) -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as LT +import Data.Text.Encoding (encodeUtf8Builder) import Path +import System.IO import Distribution.ModuleName hiding (toFilePath) @@ -46,38 +48,47 @@ cmdCdGhc = GhciScript . (:[]) . CdGhc cmdModule :: Set ModuleName -> GhciScript cmdModule = GhciScript . (:[]) . Module -scriptToText :: GhciScript -> Text -scriptToText = LT.toStrict . scriptToLazyText - -scriptToLazyText :: GhciScript -> LT.Text -scriptToLazyText = LT.toLazyText . scriptToBuilder +scriptToLazyByteString :: GhciScript -> ByteString +scriptToLazyByteString = toLazyByteString . scriptToBuilder scriptToBuilder :: GhciScript -> Builder scriptToBuilder backwardScript = mconcat $ fmap commandToBuilder script where script = reverse $ unGhciScript backwardScript +scriptToFile :: Path Abs File -> GhciScript -> IO () +scriptToFile path script = + bracket (openFile filepath WriteMode) hClose + $ \hdl -> do hSetBuffering hdl (BlockBuffering Nothing) + hSetBinaryMode hdl True + hPutBuilder hdl (scriptToBuilder script) + where + filepath = toFilePath path + -- Command conversion +fromText :: Text -> Builder +fromText = encodeUtf8Builder + commandToBuilder :: GhciCommand -> Builder commandToBuilder (Add modules) | S.null modules = mempty | otherwise = - LT.fromText ":add " - <> (mconcat $ intersperse (LT.singleton ' ') - $ fmap (LT.fromString . mconcat . intersperse "." . components) + fromText ":add " + <> (mconcat $ intersperse (fromText " ") + $ fmap (stringUtf8 . mconcat . intersperse "." . components) $ S.toAscList modules) - <> LT.singleton '\n' + <> fromText "\n" commandToBuilder (CdGhc path) = - LT.fromText ":cd-ghc " <> LT.fromString (toFilePath path) <> LT.singleton '\n' + fromText ":cd-ghc " <> stringUtf8 (toFilePath path) <> fromText "\n" commandToBuilder (Module modules) - | S.null modules = LT.fromText ":module +\n" + | S.null modules = fromText ":module +\n" | otherwise = - LT.fromText ":module + " - <> (mconcat $ intersperse (LT.singleton ' ') - $ fmap (LT.fromString . mconcat . intersperse "." . components) + fromText ":module + " + <> (mconcat $ intersperse (fromText " ") + $ fmap (stringUtf8 . mconcat . intersperse "." . components) $ S.toAscList modules) - <> LT.singleton '\n' + <> fromText "\n" diff --git a/src/test/Stack/Ghci/ScriptSpec.hs b/src/test/Stack/Ghci/ScriptSpec.hs index df3593c25c..7e49c92558 100644 --- a/src/test/Stack/Ghci/ScriptSpec.hs +++ b/src/test/Stack/Ghci/ScriptSpec.hs @@ -22,29 +22,29 @@ spec = do it "should seperate commands with a newline" $ do let script = cmdCdGhc $(mkAbsDir "/src/package-a") <> cmdAdd [fromString "Lib.A"] - scriptToText script `shouldBe` + scriptToLazyByteString script `shouldBe` ":cd-ghc /src/package-a/\n:add Lib.A\n" describe ":add" $ do it "should not render empty add commands" $ do let script = cmdAdd [] - scriptToText script `shouldBe` "" + scriptToLazyByteString script `shouldBe` "" it "should ensure that a space exists between each module in an add command" $ do let script = cmdAdd (S.fromList [fromString "Lib.A", fromString "Lib.B"]) - scriptToText script `shouldBe` ":add Lib.A Lib.B\n" + scriptToLazyByteString script `shouldBe` ":add Lib.A Lib.B\n" describe ":cd-ghc" $ do it "should render a full absolute path" $ do let script = cmdCdGhc $(mkAbsDir "/Users/someone/src/project/package-a") - scriptToText script `shouldBe` + scriptToLazyByteString script `shouldBe` ":cd-ghc /Users/someone/src/project/package-a/\n" describe ":module" $ do it "should render empty module as ':module +'" $ do let script = cmdModule [] - scriptToText script `shouldBe` ":module +\n" + scriptToLazyByteString script `shouldBe` ":module +\n" it "should ensure that a space exists between each module in a module command" $ do let script = cmdModule [fromString "Lib.A", fromString "Lib.B"] - scriptToText script `shouldBe` ":module + Lib.A Lib.B\n" + scriptToLazyByteString script `shouldBe` ":module + Lib.A Lib.B\n" diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs index 6b7e75fe3f..1822511da1 100644 --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -18,6 +18,7 @@ import NeatInterpolation import Path import Stack.Ghci +import Stack.Ghci.Script (scriptToLazyByteString) spec :: Spec spec = do @@ -67,7 +68,7 @@ spec = do } } ] - res = renderScriptIntero pkgs + res = scriptToLazyByteString $ renderScriptIntero pkgs res `shouldBe` ":cd-ghc /src/package-a/\n:add Lib.A\n" -- Exptected GHCi scripts From 68112908e53e4f003f2869b3b22142c38e00c17d Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Tue, 2 Aug 2016 17:52:21 -0500 Subject: [PATCH 05/13] Added module phanse to intero script. --- src/Stack/Ghci.hs | 5 ++++- src/test/Stack/GhciSpec.hs | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 4521e25267..3245d90874 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -217,7 +217,10 @@ renderScriptGhci :: [GhciPkgInfo] -> GhciScript renderScriptGhci = undefined renderScriptIntero :: [GhciPkgInfo] -> GhciScript -renderScriptIntero = mconcat . fmap renderPkg +renderScriptIntero pkgs = + let addPhase = mconcat $ fmap renderPkg pkgs + modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) + in addPhase <> modulePhase where renderPkg pkg = cmdCdGhc (ghciPkgDir pkg) <> cmdAdd (ghciPkgModules pkg) diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs index 1822511da1..4ed3d167b2 100644 --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -69,7 +69,7 @@ spec = do } ] res = scriptToLazyByteString $ renderScriptIntero pkgs - res `shouldBe` ":cd-ghc /src/package-a/\n:add Lib.A\n" + res `shouldBe` ":cd-ghc /src/package-a/\n:add Lib.A\n:module + Lib.A\n" -- Exptected GHCi scripts From 0083d8fb717781d270dc84062d88e64df27c683a Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Tue, 2 Aug 2016 18:06:17 -0500 Subject: [PATCH 06/13] Added GHCi script rendering. --- src/Stack/Ghci.hs | 8 +++++++- src/test/Stack/GhciSpec.hs | 32 ++++++++++++++++++++++++++++++++ stack.cabal | 2 ++ 3 files changed, 41 insertions(+), 1 deletion(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 3245d90874..e825a89226 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -17,6 +17,7 @@ module Stack.Ghci -- TODO: Address what should and should not be exported. , renderLegacyGhciScript + , renderScriptGhci , renderScriptIntero ) where @@ -214,7 +215,12 @@ renderLegacyGhciScript modulesToLoad mainFile = in unlines [loadModules,addMainFile,bringIntoScope] renderScriptGhci :: [GhciPkgInfo] -> GhciScript -renderScriptGhci = undefined +renderScriptGhci pkgs = + let addPhase = mconcat $ fmap renderPkg pkgs + modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) + in addPhase <> modulePhase + where + renderPkg pkg = cmdAdd (ghciPkgModules pkg) renderScriptIntero :: [GhciPkgInfo] -> GhciScript renderScriptIntero pkgs = diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs index 4ed3d167b2..885d6deee8 100644 --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -36,6 +36,38 @@ spec = do renderLegacyGhciScript ["Lib.A", "Lib.B"] Nothing `shouldBe` T.unpack ghciScript_multipleProjectsWithLib + it "should render GHCi scripts" $ do + let pkgs = + [ GhciPkgInfo + { ghciPkgModules = S.fromList [fromString "Lib.A"] + , ghciPkgDir = $(mkAbsDir "/src/package-a") + , ghciPkgName = $(mkPackageName "package-a") + , ghciPkgOpts = [] + , ghciPkgModFiles = S.empty + , ghciPkgCFiles = S.empty + , ghciPkgMainIs = M.empty + , ghciPkgPackage = Package + { packageName = $(mkPackageName "package-a") + , packageVersion = $(mkVersion "0.1.0.0") + , packageFiles = GetPackageFiles undefined + , packageDeps = M.empty + , packageTools = [] + , packageAllDeps = S.empty + , packageGhcOptions = [] + , packageFlags = M.empty + , packageDefaultFlags = M.empty + , packageHasLibrary = True + , packageTests = M.empty + , packageBenchmarks = S.empty + , packageExes = S.empty + , packageOpts = GetPackageOpts undefined + , packageHasExposedModules = True + , packageSimpleType = True + } + } + ] + res = scriptToLazyByteString $ renderScriptGhci pkgs + res `shouldBe` ":add Lib.A\n:module + Lib.A\n" it "should render intero scripts" $ do diff --git a/stack.cabal b/stack.cabal index b03d724149..9c0080c16e 100644 --- a/stack.cabal +++ b/stack.cabal @@ -285,6 +285,8 @@ test-suite stack-test , Stack.Build.TargetSpec , Stack.ConfigSpec , Stack.DotSpec + , Stack.GhciSpec + , Stack.Ghci.ScriptSpec , Stack.PackageDumpSpec , Stack.ArgsSpec , Stack.NixSpec From 63818bcc01b7605284c9e359c8f5d0f72410ff39 Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Wed, 3 Aug 2016 13:11:41 -0500 Subject: [PATCH 07/13] Added support for adding a single file to a script. --- src/Stack/Ghci/Script.hs | 8 ++++++++ src/test/Stack/Ghci/ScriptSpec.hs | 6 ++++++ 2 files changed, 14 insertions(+) diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs index 570fc7dfdf..31db09f089 100644 --- a/src/Stack/Ghci/Script.hs +++ b/src/Stack/Ghci/Script.hs @@ -5,6 +5,7 @@ module Stack.Ghci.Script , ModuleName , cmdAdd + , cmdAddFile , cmdCdGhc , cmdModule @@ -35,6 +36,7 @@ instance Monoid GhciScript where data GhciCommand = Add (Set ModuleName) + | AddFile (Path Abs File) | CdGhc (Path Abs Dir) | Module (Set ModuleName) deriving (Show) @@ -42,6 +44,9 @@ data GhciCommand cmdAdd :: Set ModuleName -> GhciScript cmdAdd = GhciScript . (:[]) . Add +cmdAddFile :: Path Abs File -> GhciScript +cmdAddFile = GhciScript . (:[]) . AddFile + cmdCdGhc :: Path Abs Dir -> GhciScript cmdCdGhc = GhciScript . (:[]) . CdGhc @@ -81,6 +86,9 @@ commandToBuilder (Add modules) $ S.toAscList modules) <> fromText "\n" +commandToBuilder (AddFile path) = + fromText ":add " <> stringUtf8 (toFilePath path) <> fromText "\n" + commandToBuilder (CdGhc path) = fromText ":cd-ghc " <> stringUtf8 (toFilePath path) <> fromText "\n" diff --git a/src/test/Stack/Ghci/ScriptSpec.hs b/src/test/Stack/Ghci/ScriptSpec.hs index 7e49c92558..43b9fbad8a 100644 --- a/src/test/Stack/Ghci/ScriptSpec.hs +++ b/src/test/Stack/Ghci/ScriptSpec.hs @@ -34,6 +34,12 @@ spec = do let script = cmdAdd (S.fromList [fromString "Lib.A", fromString "Lib.B"]) scriptToLazyByteString script `shouldBe` ":add Lib.A Lib.B\n" + describe ":add (by file)" $ do + it "should render a full file path" $ do + let script = cmdAddFile $(mkAbsFile "/Users/someone/src/project/package-a/src/Main.hs") + scriptToLazyByteString script `shouldBe` + ":add /Users/someone/src/project/package-a/src/Main.hs\n" + describe ":cd-ghc" $ do it "should render a full absolute path" $ do let script = cmdCdGhc $(mkAbsDir "/Users/someone/src/project/package-a") From 7fc2c7995cf5d8edaffaf05f8560e2ec43ca08bd Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Wed, 3 Aug 2016 14:31:48 -0500 Subject: [PATCH 08/13] Added handling for main in scripts. --- src/Stack/Ghci.hs | 31 ++-- src/test/Stack/GhciSpec.hs | 302 +++++++++++++++++++++++++++---------- 2 files changed, 243 insertions(+), 90 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index e825a89226..41a2901788 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -184,7 +184,7 @@ ghci opts@GhciOpts{..} = do if ghciNoLoadModules then execGhci macrosOptions else do - scriptPath <- writeGhciScript tmpDirectory (renderLegacyGhciScript modulesToLoad mainFile) + scriptPath <- writeGhciScript tmpDirectory (renderScriptGhci pkgs mainFile) execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String] @@ -194,9 +194,9 @@ writeMacrosFile tmpDirectory packages = do where macrosFile = tmpDirectory $(mkRelFile "cabal_macros.h") -writeGhciScript :: (MonadIO m) => Path Abs Dir -> String -> m (Path Abs File) +writeGhciScript :: (MonadIO m) => Path Abs Dir -> GhciScript -> m (Path Abs File) writeGhciScript tmpDirectory script = do - liftIO $ writeFile scriptFilePath script + liftIO $ scriptToFile scriptPath script setScriptPerms scriptFilePath return scriptPath where @@ -214,19 +214,32 @@ renderLegacyGhciScript modulesToLoad mainFile = xs -> " " <> xs in unlines [loadModules,addMainFile,bringIntoScope] -renderScriptGhci :: [GhciPkgInfo] -> GhciScript -renderScriptGhci pkgs = +findOwningPackageForMain :: [GhciPkgInfo] -> Path Abs File -> Maybe GhciPkgInfo +findOwningPackageForMain pkgs mainFile = + find (\pkg -> toFilePath (ghciPkgDir pkg) `isPrefixOf` toFilePath mainFile) pkgs + +renderScriptGhci :: [GhciPkgInfo] -> Maybe (Path Abs File) -> GhciScript +renderScriptGhci pkgs mainFile = let addPhase = mconcat $ fmap renderPkg pkgs + mainPhase = case mainFile of + Just path -> cmdAddFile path + Nothing -> mempty modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) - in addPhase <> modulePhase + in addPhase <> mainPhase <> modulePhase where renderPkg pkg = cmdAdd (ghciPkgModules pkg) -renderScriptIntero :: [GhciPkgInfo] -> GhciScript -renderScriptIntero pkgs = +renderScriptIntero :: [GhciPkgInfo] -> Maybe (Path Abs File) -> GhciScript +renderScriptIntero pkgs mainFile = let addPhase = mconcat $ fmap renderPkg pkgs + mainPhase = case mainFile of + Just path -> + case findOwningPackageForMain pkgs path of + Just mainPkg -> cmdCdGhc (ghciPkgDir mainPkg) <> cmdAddFile path + Nothing -> cmdAddFile path + Nothing -> mempty modulePhase = cmdModule $ foldl' S.union S.empty (fmap ghciPkgModules pkgs) - in addPhase <> modulePhase + in addPhase <> mainPhase <> modulePhase where renderPkg pkg = cmdCdGhc (ghciPkgDir pkg) <> cmdAdd (ghciPkgModules pkg) diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs index 885d6deee8..2f2f38ce38 100644 --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -5,10 +5,12 @@ -- | Test suite for GHCi like applications including both GHCi and Intero. module Stack.GhciSpec where +import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Distribution.ModuleName import Stack.Types.Package import Stack.Types.PackageName @@ -24,92 +26,111 @@ spec :: Spec spec = do describe "GHCi" $ do describe "Script rendering" $ do - it "should render legacy script when given project:exe" $ do - renderLegacyGhciScript [] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) - `shouldBe` T.unpack ghciScript_projectWithMain - - it "should render legacy script when given project" $ do - renderLegacyGhciScript ["Lib.A"] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) - `shouldBe` T.unpack ghciScript_projectWithLibAndMain - - it "should render legacy script when given multiple project:lib" $ do - renderLegacyGhciScript ["Lib.A", "Lib.B"] Nothing - `shouldBe` T.unpack ghciScript_multipleProjectsWithLib - - it "should render GHCi scripts" $ do - let pkgs = - [ GhciPkgInfo - { ghciPkgModules = S.fromList [fromString "Lib.A"] - , ghciPkgDir = $(mkAbsDir "/src/package-a") - , ghciPkgName = $(mkPackageName "package-a") - , ghciPkgOpts = [] - , ghciPkgModFiles = S.empty - , ghciPkgCFiles = S.empty - , ghciPkgMainIs = M.empty - , ghciPkgPackage = Package - { packageName = $(mkPackageName "package-a") - , packageVersion = $(mkVersion "0.1.0.0") - , packageFiles = GetPackageFiles undefined - , packageDeps = M.empty - , packageTools = [] - , packageAllDeps = S.empty - , packageGhcOptions = [] - , packageFlags = M.empty - , packageDefaultFlags = M.empty - , packageHasLibrary = True - , packageTests = M.empty - , packageBenchmarks = S.empty - , packageExes = S.empty - , packageOpts = GetPackageOpts undefined - , packageHasExposedModules = True - , packageSimpleType = True - } - } - ] - res = scriptToLazyByteString $ renderScriptGhci pkgs - res `shouldBe` ":add Lib.A\n:module + Lib.A\n" - - - it "should render intero scripts" $ do - let pkgs = - [ GhciPkgInfo - { ghciPkgModules = S.fromList [fromString "Lib.A"] - , ghciPkgDir = $(mkAbsDir "/src/package-a") - , ghciPkgName = $(mkPackageName "package-a") - , ghciPkgOpts = [] - , ghciPkgModFiles = S.empty - , ghciPkgCFiles = S.empty - , ghciPkgMainIs = M.empty - , ghciPkgPackage = Package - { packageName = $(mkPackageName "package-a") - , packageVersion = $(mkVersion "0.1.0.0") - , packageFiles = GetPackageFiles undefined - , packageDeps = M.empty - , packageTools = [] - , packageAllDeps = S.empty - , packageGhcOptions = [] - , packageFlags = M.empty - , packageDefaultFlags = M.empty - , packageHasLibrary = True - , packageTests = M.empty - , packageBenchmarks = S.empty - , packageExes = S.empty - , packageOpts = GetPackageOpts undefined - , packageHasExposedModules = True - , packageSimpleType = True - } - } - ] - res = scriptToLazyByteString $ renderScriptIntero pkgs - res `shouldBe` ":cd-ghc /src/package-a/\n:add Lib.A\n:module + Lib.A\n" - --- Exptected GHCi scripts + describe "should render legacy GHCi scripts" $ do + it "should render legacy script when given project:exe" $ do + renderLegacyGhciScript [] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + `shouldBe` T.unpack ghciLegacyScript_projectWithMain + + it "should render legacy script when given project" $ do + renderLegacyGhciScript ["Lib.A"] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + `shouldBe` T.unpack ghciLegacyScript_projectWithLibAndMain + + it "should render legacy script when given multiple project:lib" $ do + renderLegacyGhciScript ["Lib.A", "Lib.B"] Nothing + `shouldBe` T.unpack ghciLegacyScript_multipleProjectsWithLib + + describe "should render GHCi scripts" $ do + it "with one library package" $ do + let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage Nothing + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 ghciScript_projectWithLib) + + it "with one main package" $ do + let res = scriptToLazyByteString $ renderScriptGhci [] + (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 ghciScript_projectWithMain) + + it "with one library and main package" $ do + let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage + (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 ghciScript_projectWithLibAndMain) + + it "with multiple library packages" $ do + let res = scriptToLazyByteString $ renderScriptGhci packages_multiplePackages Nothing + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 ghciScript_multipleProjectsWithLib) + + describe "should render intero scripts" $ do + it "with one library package" $ do + let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage Nothing + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 interoScript_projectWithLib) + + it "with one main package" $ do + let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage + (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 interoScript_projectWithMain) + + it "with one library and main package" $ do + let res = scriptToLazyByteString $ renderScriptIntero packages_singlePackage + (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 interoScript_projectWithLibAndMain) + + it "with multiple library packages" $ do + let res = scriptToLazyByteString $ renderScriptIntero packages_multiplePackages Nothing + res `shouldBe` (LBS.fromStrict $ T.encodeUtf8 interoScript_multipleProjectsWithLib) + +-- Exptected Intero scripts + +interoScript_projectWithLib :: Text +interoScript_projectWithLib = [text| +:cd-ghc /Users/someone/src/project-a/ +:add Lib.A +:module + Lib.A + +|] + +interoScript_projectWithMain :: Text +interoScript_projectWithMain = [text| +:cd-ghc /Users/someone/src/project-a/ +:add Lib.A +:cd-ghc /Users/someone/src/project-a/ +:add /Users/someone/src/project-a/exe/Main.hs +:module + Lib.A + +|] + +interoScript_projectWithLibAndMain :: Text +interoScript_projectWithLibAndMain = [text| +:cd-ghc /Users/someone/src/project-a/ +:add Lib.A +:cd-ghc /Users/someone/src/project-a/ +:add /Users/someone/src/project-a/exe/Main.hs +:module + Lib.A + +|] + +interoScript_multipleProjectsWithLib :: Text +interoScript_multipleProjectsWithLib = [text| +:cd-ghc /Users/someone/src/project-a/ +:add Lib.A +:cd-ghc /Users/someone/src/project-b/ +:add Lib.B +:module + Lib.A Lib.B + +|] + +-- Expected GHCi Scripts + +ghciScript_projectWithLib :: Text +ghciScript_projectWithLib = [text| +:add Lib.A +:module + Lib.A + +|] ghciScript_projectWithMain :: Text ghciScript_projectWithMain = [text| -:add :add /Users/someone/src/project-a/exe/Main.hs :module + + |] ghciScript_projectWithLibAndMain :: Text @@ -117,11 +138,130 @@ ghciScript_projectWithLibAndMain = [text| :add Lib.A :add /Users/someone/src/project-a/exe/Main.hs :module + Lib.A + |] ghciScript_multipleProjectsWithLib :: Text ghciScript_multipleProjectsWithLib = [text| +:add Lib.A +:add Lib.B +:module + Lib.A Lib.B + +|] + +-- Expected Legacy GHCi scripts + +ghciLegacyScript_projectWithMain :: Text +ghciLegacyScript_projectWithMain = [text| +:add +:add /Users/someone/src/project-a/exe/Main.hs +:module + +|] + +ghciLegacyScript_projectWithLibAndMain :: Text +ghciLegacyScript_projectWithLibAndMain = [text| +:add Lib.A +:add /Users/someone/src/project-a/exe/Main.hs +:module + Lib.A +|] + +ghciLegacyScript_multipleProjectsWithLib :: Text +ghciLegacyScript_multipleProjectsWithLib = [text| :add Lib.A Lib.B :module + Lib.A Lib.B |] + +-- Sample GHCi load configs + +packages_singlePackage :: [GhciPkgInfo] +packages_singlePackage = + [ GhciPkgInfo + { ghciPkgModules = S.fromList [fromString "Lib.A"] + , ghciPkgDir = $(mkAbsDir "/Users/someone/src/project-a") + , ghciPkgName = $(mkPackageName "package-a") + , ghciPkgOpts = [] + , ghciPkgModFiles = S.empty + , ghciPkgCFiles = S.empty + , ghciPkgMainIs = M.empty + , ghciPkgPackage = + Package + { packageName = $(mkPackageName "package-a") + , packageVersion = $(mkVersion "0.1.0.0") + , packageFiles = GetPackageFiles undefined + , packageDeps = M.empty + , packageTools = [] + , packageAllDeps = S.empty + , packageGhcOptions = [] + , packageFlags = M.empty + , packageDefaultFlags = M.empty + , packageHasLibrary = True + , packageTests = M.empty + , packageBenchmarks = S.empty + , packageExes = S.empty + , packageOpts = GetPackageOpts undefined + , packageHasExposedModules = True + , packageSimpleType = True + } + } + ] + +packages_multiplePackages :: [GhciPkgInfo] +packages_multiplePackages = + [ GhciPkgInfo + { ghciPkgModules = S.fromList [fromString "Lib.A"] + , ghciPkgDir = $(mkAbsDir "/Users/someone/src/project-a") + , ghciPkgName = $(mkPackageName "package-a") + , ghciPkgOpts = [] + , ghciPkgModFiles = S.empty + , ghciPkgCFiles = S.empty + , ghciPkgMainIs = M.empty + , ghciPkgPackage = + Package + { packageName = $(mkPackageName "package-a") + , packageVersion = $(mkVersion "0.1.0.0") + , packageFiles = GetPackageFiles undefined + , packageDeps = M.empty + , packageTools = [] + , packageAllDeps = S.empty + , packageGhcOptions = [] + , packageFlags = M.empty + , packageDefaultFlags = M.empty + , packageHasLibrary = True + , packageTests = M.empty + , packageBenchmarks = S.empty + , packageExes = S.empty + , packageOpts = GetPackageOpts undefined + , packageHasExposedModules = True + , packageSimpleType = True + } + } + , GhciPkgInfo + { ghciPkgModules = S.fromList [fromString "Lib.B"] + , ghciPkgDir = $(mkAbsDir "/Users/someone/src/project-b") + , ghciPkgName = $(mkPackageName "package-b") + , ghciPkgOpts = [] + , ghciPkgModFiles = S.empty + , ghciPkgCFiles = S.empty + , ghciPkgMainIs = M.empty + , ghciPkgPackage = + Package + { packageName = $(mkPackageName "package-b") + , packageVersion = $(mkVersion "0.1.0.0") + , packageFiles = GetPackageFiles undefined + , packageDeps = M.empty + , packageTools = [] + , packageAllDeps = S.empty + , packageGhcOptions = [] + , packageFlags = M.empty + , packageDefaultFlags = M.empty + , packageHasLibrary = True + , packageTests = M.empty + , packageBenchmarks = S.empty + , packageExes = S.empty + , packageOpts = GetPackageOpts undefined + , packageHasExposedModules = True + , packageSimpleType = True + } + } + ] From b5318547d5899476f19b2afa2c4fb114e1dd36c1 Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Wed, 3 Aug 2016 15:17:45 -0500 Subject: [PATCH 09/13] Removed dead imports. --- src/Stack/Ghci.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 41a2901788..71d1ce758f 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -47,8 +47,6 @@ import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) -import qualified Data.Vector as V -import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription (updatePackageDescription) import Distribution.Text (display) import Network.HTTP.Client.Conduit From 3aae8ed23acb871e540ce4d50f2926f46c04df4b Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Mon, 8 Aug 2016 08:42:49 -0500 Subject: [PATCH 10/13] Added repl testing facilities and test. Tests that a module can be added multiple times in a GHCi script. --- test/integration/lib/StackTest.hs | 64 +++++++++++++++++++ .../tests/module-added-multiple-times/Main.hs | 12 ++++ .../module-added-multiple-times/files/LICENSE | 30 +++++++++ .../files/Setup.hs | 2 + .../files/exe/Main.hs | 6 ++ .../files/project-a.cabal | 33 ++++++++++ .../files/src/Lib/A.hs | 4 ++ .../files/stack.yaml | 4 ++ 8 files changed, 155 insertions(+) create mode 100644 test/integration/tests/module-added-multiple-times/Main.hs create mode 100644 test/integration/tests/module-added-multiple-times/files/LICENSE create mode 100644 test/integration/tests/module-added-multiple-times/files/Setup.hs create mode 100644 test/integration/tests/module-added-multiple-times/files/exe/Main.hs create mode 100644 test/integration/tests/module-added-multiple-times/files/project-a.cabal create mode 100644 test/integration/tests/module-added-multiple-times/files/src/Lib/A.hs create mode 100644 test/integration/tests/module-added-multiple-times/files/stack.yaml diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs index 137ed4c90d..1940ecca42 100644 --- a/test/integration/lib/StackTest.hs +++ b/test/integration/lib/StackTest.hs @@ -1,11 +1,16 @@ module StackTest where +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Control.Concurrent import Control.Exception import Data.List (intercalate) import System.Environment import System.FilePath import System.Directory import System.IO +import System.IO.Error import System.Process import System.Exit import System.Info (os) @@ -42,6 +47,65 @@ stackErr args = do then error "stack was supposed to fail, but didn't" else return () +type Repl = ReaderT ReplConnection IO + +data ReplConnection + = ReplConnection + { replStdin :: Handle + , replStdout :: Handle + } + +nextPrompt :: Repl () +nextPrompt = do + (ReplConnection _ handle) <- ask + c <- liftIO $ hGetChar handle + if c == '>' + then do _ <- liftIO $ hGetChar handle + return () + else nextPrompt + +replCommand :: String -> Repl () +replCommand cmd = do + (ReplConnection input _) <- ask + liftIO $ hPutStrLn input cmd + +replGetLine :: Repl String +replGetLine = (fmap replStdout ask) >>= liftIO . hGetLine + +replGetChar :: Repl Char +replGetChar = (fmap replStdout ask) >>= liftIO . hGetChar + +runRepl :: FilePath -> [String] -> ReaderT ReplConnection IO () -> IO ExitCode +runRepl cmd args actions = do + logInfo $ "Running: " ++ cmd ++ " " ++ intercalate " " (map showProcessArgDebug args) + (Just rStdin, Just rStdout, Just rStderr, ph) <- + createProcess (proc cmd args) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + } + hSetBuffering rStdin NoBuffering + hSetBuffering rStdout NoBuffering + hSetBuffering rStderr NoBuffering + + forkIO $ bracket (openFile "/tmp/stderr" WriteMode) hClose + $ \err -> forever $ catch (hGetChar rStderr >>= hPutChar err) + $ \e -> if isEOFError e then return () else throw e + + runReaderT (nextPrompt >> actions) (ReplConnection rStdin rStdout) + waitForProcess ph + +repl :: [String] -> Repl () -> IO () +repl args action = do + stack <- getEnv "STACK_EXE" + ec <- runRepl stack ("repl":args) action + if ec == ExitSuccess + then return () + else return () + -- TODO: Understand why the exit code is 1 despite running GHCi tests + -- successfully. + -- else error $ "Exited with exit code: " ++ show ec + -- | Run stack with arguments and apply a check to the resulting -- stderr output if the process succeeded. stackCheckStderr :: [String] -> (String -> IO ()) -> IO () diff --git a/test/integration/tests/module-added-multiple-times/Main.hs b/test/integration/tests/module-added-multiple-times/Main.hs new file mode 100644 index 0000000000..abbfdf046a --- /dev/null +++ b/test/integration/tests/module-added-multiple-times/Main.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE BangPatterns #-} + +import Control.Monad +import Data.List +import StackTest + +main :: IO () +main = repl [] $ do + replCommand ":main" + line <- replGetLine + when (line /= "Hello World!") + $ error "Main module didn't load correctly." diff --git a/test/integration/tests/module-added-multiple-times/files/LICENSE b/test/integration/tests/module-added-multiple-times/files/LICENSE new file mode 100644 index 0000000000..c304a94836 --- /dev/null +++ b/test/integration/tests/module-added-multiple-times/files/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Your name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/test/integration/tests/module-added-multiple-times/files/Setup.hs b/test/integration/tests/module-added-multiple-times/files/Setup.hs new file mode 100644 index 0000000000..9a994af677 --- /dev/null +++ b/test/integration/tests/module-added-multiple-times/files/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/test/integration/tests/module-added-multiple-times/files/exe/Main.hs b/test/integration/tests/module-added-multiple-times/files/exe/Main.hs new file mode 100644 index 0000000000..504eb17dda --- /dev/null +++ b/test/integration/tests/module-added-multiple-times/files/exe/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Lib.A + +main :: IO () +main = putStrLn messageA diff --git a/test/integration/tests/module-added-multiple-times/files/project-a.cabal b/test/integration/tests/module-added-multiple-times/files/project-a.cabal new file mode 100644 index 0000000000..4e230ef90b --- /dev/null +++ b/test/integration/tests/module-added-multiple-times/files/project-a.cabal @@ -0,0 +1,33 @@ +name: project-a +version: 0.1.0.0 +synopsis: Simple project template from stack +description: Please see README.md +homepage: http://github.com/githubuser/project-a#readme +license: MIT +license-file: LICENSE +author: Author name here +maintainer: example@example.com +copyright: 2010 Author Here +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + default-language: Haskell2010 + + exposed-modules: Lib.A + + build-depends: base + + +executable project-a-exe + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 + + ghc-options: -rtsopts + + build-depends: base + + , project-a \ No newline at end of file diff --git a/test/integration/tests/module-added-multiple-times/files/src/Lib/A.hs b/test/integration/tests/module-added-multiple-times/files/src/Lib/A.hs new file mode 100644 index 0000000000..788d4e22d5 --- /dev/null +++ b/test/integration/tests/module-added-multiple-times/files/src/Lib/A.hs @@ -0,0 +1,4 @@ +module Lib.A where + +messageA :: String +messageA = "Hello World!" diff --git a/test/integration/tests/module-added-multiple-times/files/stack.yaml b/test/integration/tests/module-added-multiple-times/files/stack.yaml new file mode 100644 index 0000000000..91e9586879 --- /dev/null +++ b/test/integration/tests/module-added-multiple-times/files/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-6.0 +extra-deps: [] +flags: {} +extra-package-dbs: [] From 3fa15cd05f396e57cc00a4e8eda8d1153bc2a83c Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Mon, 8 Aug 2016 13:51:48 -0500 Subject: [PATCH 11/13] Removed legacy GHCi rendering functions. --- src/Stack/Ghci.hs | 55 ++++---------------------------------- src/Stack/Ghci/Script.hs | 15 ++++++++--- src/test/Stack/GhciSpec.hs | 14 ---------- 3 files changed, 16 insertions(+), 68 deletions(-) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 71d1ce758f..1f11f49465 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -16,7 +16,6 @@ module Stack.Ghci , ghci -- TODO: Address what should and should not be exported. - , renderLegacyGhciScript , renderScriptGhci , renderScriptIntero ) where @@ -35,7 +34,6 @@ import Data.Either import Data.Function import Data.List import Data.List.Extra (nubOrd) -import Data.List.Split (splitOn) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe @@ -64,7 +62,6 @@ import Stack.Ghci.Script import Stack.Package import Stack.Types import Stack.Types.Internal -import System.FilePath (takeBaseName) import Text.Read (readMaybe) #ifndef WINDOWS @@ -142,25 +139,8 @@ ghci opts@GhciOpts{..} = do $logWarn ("The following GHC options are incompatible with GHCi and have not been passed to it: " <> T.unwords (map T.pack (nubOrd omittedOpts))) - allModules <- checkForDuplicateModules ghciNoLoadModules pkgs + mainFile <- figureOutMainFile bopts mainIsTargets targets pkgs oiDir <- objectInterfaceDir bconfig - (modulesToLoad, mainFile) <- if ghciNoLoadModules then return ([], Nothing) else do - mmainFile <- figureOutMainFile bopts mainIsTargets targets pkgs - modulesToLoad <- case mmainFile of - Just mainFile -> do - let (_, mfDirs, mfName) = filePathPieces mainFile - mainPathPieces = map toFilePath mfDirs ++ [takeBaseName (toFilePath mfName)] - liftM catMaybes $ forM allModules $ \mn -> do - let matchesModule = splitOn "." mn `isSuffixOf` mainPathPieces - if matchesModule - then do - $logWarn $ "Warning: Omitting load of module " <> T.pack mn <> - ", because it matches the filepath of the Main target, " <> - T.pack (toFilePath mainFile) - return Nothing - else return (Just mn) - Nothing -> return allModules - return (modulesToLoad, mmainFile) let odir = [ "-odir=" <> toFilePathNoTrailingSep oiDir , "-hidir=" <> toFilePathNoTrailingSep oiDir ] @@ -182,6 +162,7 @@ ghci opts@GhciOpts{..} = do if ghciNoLoadModules then execGhci macrosOptions else do + checkForDuplicateModules pkgs scriptPath <- writeGhciScript tmpDirectory (renderScriptGhci pkgs mainFile) execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) @@ -201,17 +182,6 @@ writeGhciScript tmpDirectory script = do scriptPath = tmpDirectory $(mkRelFile "ghci-script") scriptFilePath = toFilePath scriptPath -renderLegacyGhciScript :: [String] -> Maybe (Path b t) -> String -renderLegacyGhciScript modulesToLoad mainFile = - let loadModules = ":add" <> case unwords (map quoteFileName modulesToLoad) of - [] -> "" - xs -> " " <> xs - addMainFile = maybe "" ((":add " <>) . quoteFileName . toFilePath) mainFile - bringIntoScope = ":module +" <> case unwords modulesToLoad of - [] -> "" - xs -> " " <> xs - in unlines [loadModules,addMainFile,bringIntoScope] - findOwningPackageForMain :: [GhciPkgInfo] -> Path Abs File -> Maybe GhciPkgInfo findOwningPackageForMain pkgs mainFile = find (\pkg -> toFilePath (ghciPkgDir pkg) `isPrefixOf` toFilePath mainFile) pkgs @@ -554,15 +524,14 @@ borderedWarning f = do $logWarn "" return x -checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => Bool -> [GhciPkgInfo] -> m [String] -checkForDuplicateModules noLoadModules pkgs = do +checkForDuplicateModules :: (MonadThrow m, MonadLogger m) => [GhciPkgInfo] -> m () +checkForDuplicateModules pkgs = do unless (null duplicates) $ do borderedWarning $ do $logWarn "The following modules are present in multiple packages:" forM_ duplicates $ \(mn, pns) -> do $logWarn (" * " <> T.pack mn <> " (in " <> T.intercalate ", " (map packageNameText pns) <> ")") - unless noLoadModules $ throwM LoadingDuplicateModules - return (map fst allModules) + throwM LoadingDuplicateModules where duplicates, allModules :: [(String, [PackageName])] duplicates = filter (not . null . tail . snd) allModules @@ -635,13 +604,6 @@ setScriptPerms fp = do ] #endif -filePathPieces :: Path Abs File -> (Path Abs Dir, [Path Rel Dir], Path Rel File) -filePathPieces x0 = go (parent x0, [], filename x0) - where - go (x, dirs, fp) - | parent x == x = (x, dirs, fp) - | otherwise = (parent x, dirname x : dirs, fp) - {- Copied from Stack.Ide, may be useful in the future -- | Get options and target files for the given package info. @@ -683,10 +645,3 @@ targetsCmd target go@GlobalOpts{..} = (mapM (getPackageOptsAndTargetFiles pwd) pkgs) forM_ targets (liftIO . putStrLn) -} - --- | Make sure that a filename with spaces in it gets the proper quotes. -quoteFileName :: String -> String -quoteFileName x = - if any (==' ') x - then show x - else x diff --git a/src/Stack/Ghci/Script.hs b/src/Stack/Ghci/Script.hs index 31db09f089..8c13d210ad 100644 --- a/src/Stack/Ghci/Script.hs +++ b/src/Stack/Ghci/Script.hs @@ -82,21 +82,28 @@ commandToBuilder (Add modules) | otherwise = fromText ":add " <> (mconcat $ intersperse (fromText " ") - $ fmap (stringUtf8 . mconcat . intersperse "." . components) + $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components) $ S.toAscList modules) <> fromText "\n" commandToBuilder (AddFile path) = - fromText ":add " <> stringUtf8 (toFilePath path) <> fromText "\n" + fromText ":add " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n" commandToBuilder (CdGhc path) = - fromText ":cd-ghc " <> stringUtf8 (toFilePath path) <> fromText "\n" + fromText ":cd-ghc " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n" commandToBuilder (Module modules) | S.null modules = fromText ":module +\n" | otherwise = fromText ":module + " <> (mconcat $ intersperse (fromText " ") - $ fmap (stringUtf8 . mconcat . intersperse "." . components) + $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components) $ S.toAscList modules) <> fromText "\n" + +-- | Make sure that a filename with spaces in it gets the proper quotes. +quoteFileName :: String -> String +quoteFileName x = + if any (==' ') x + then show x + else x diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs index 2f2f38ce38..773e9eea57 100644 --- a/src/test/Stack/GhciSpec.hs +++ b/src/test/Stack/GhciSpec.hs @@ -9,7 +9,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as M import qualified Data.Set as S import Data.Text (Text) -import qualified Data.Text as T import qualified Data.Text.Encoding as T import Distribution.ModuleName import Stack.Types.Package @@ -26,19 +25,6 @@ spec :: Spec spec = do describe "GHCi" $ do describe "Script rendering" $ do - describe "should render legacy GHCi scripts" $ do - it "should render legacy script when given project:exe" $ do - renderLegacyGhciScript [] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) - `shouldBe` T.unpack ghciLegacyScript_projectWithMain - - it "should render legacy script when given project" $ do - renderLegacyGhciScript ["Lib.A"] (Just $(mkAbsFile "/Users/someone/src/project-a/exe/Main.hs")) - `shouldBe` T.unpack ghciLegacyScript_projectWithLibAndMain - - it "should render legacy script when given multiple project:lib" $ do - renderLegacyGhciScript ["Lib.A", "Lib.B"] Nothing - `shouldBe` T.unpack ghciLegacyScript_multipleProjectsWithLib - describe "should render GHCi scripts" $ do it "with one library package" $ do let res = scriptToLazyByteString $ renderScriptGhci packages_singlePackage Nothing From 3a18b8e762217d91a48d5359cb60d8b44a38d189 Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Mon, 8 Aug 2016 15:22:55 -0500 Subject: [PATCH 12/13] Added process interrogation to determine rendering. --- src/Stack/Exec.hs | 11 ++++++++++- src/Stack/Ghci.hs | 9 ++++++++- src/System/Process/Run.hs | 15 +++++++++++++++ 3 files changed, 33 insertions(+), 2 deletions(-) diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index 437e1eb2c5..6e3e3fe056 100644 --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -21,7 +21,7 @@ import System.Process.Log import Control.Exception.Lifted import Data.Streaming.Process (ProcessExitedUnsuccessfully(..)) import System.Exit -import System.Process.Run (callProcess, Cmd(..)) +import System.Process.Run (callProcess, callProcessObserveStdout, Cmd(..)) #ifdef WINDOWS import System.Process.Read (EnvOverride) #else @@ -78,3 +78,12 @@ execSpawn menv cmd0 args = do liftIO $ case e of Left (ProcessExitedUnsuccessfully _ ec) -> exitWith ec Right () -> exitSuccess + +execObserve :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) + => EnvOverride -> String -> [String] -> m String +execObserve menv cmd0 args = do + $logProcessRun cmd0 args + e <- try (callProcessObserveStdout (Cmd Nothing cmd0 menv args)) + case e of + Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec + Right s -> return s diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 1f11f49465..bade9ff754 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -156,6 +156,12 @@ ghci opts@GhciOpts{..} = do -- include CWD. "-i" : odir <> pkgopts <> ghciArgs <> extras) + interrogateExeForRenderFunction = do + menv <- liftIO $ configEnvOverride config defaultEnvSettings + output <- execObserve menv (fromMaybe (compilerExeName wc) ghciGhcCommand) ["--version"] + if "Intero" `isPrefixOf` output + then return renderScriptIntero + else return renderScriptGhci withSystemTempDir "ghci" $ \tmpDirectory -> do macrosOptions <- writeMacrosFile tmpDirectory pkgs @@ -163,7 +169,8 @@ ghci opts@GhciOpts{..} = do then execGhci macrosOptions else do checkForDuplicateModules pkgs - scriptPath <- writeGhciScript tmpDirectory (renderScriptGhci pkgs mainFile) + renderFn <- interrogateExeForRenderFunction + scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs mainFile) execGhci (macrosOptions ++ ["-ghci-script=" <> toFilePath scriptPath]) writeMacrosFile :: (MonadIO m) => Path Abs Dir -> [GhciPkgInfo] -> m [String] diff --git a/src/System/Process/Run.hs b/src/System/Process/Run.hs index 84c9c4a1a2..da55223427 100644 --- a/src/System/Process/Run.hs +++ b/src/System/Process/Run.hs @@ -14,6 +14,7 @@ module System.Process.Run ,callProcess ,callProcess' ,callProcessInheritStderrStdout + ,callProcessObserveStdout ,createProcess' ,ProcessExitedUnsuccessfully ,Cmd(..) @@ -112,6 +113,20 @@ callProcessInheritStderrStdout cmd = do let inheritOutput cp = cp { std_in = CreatePipe, std_out = Inherit, std_err = Inherit } callProcess' inheritOutput cmd +callProcessObserveStdout :: (MonadIO m, MonadLogger m) => Cmd -> m String +callProcessObserveStdout cmd = do + c <- liftM modCP (cmdToCreateProcess cmd) + $logCreateProcess c + liftIO $ do + (_, Just hStdout, _, p) <- System.Process.createProcess c + hSetBuffering hStdout NoBuffering + exit_code <- waitForProcess p + case exit_code of + ExitSuccess -> hGetLine hStdout + ExitFailure _ -> throwIO (ProcessExitedUnsuccessfully c exit_code) + where + modCP c = c { std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit } + -- | Like 'System.Process.Internal.createProcess_', but taking a 'Cmd'. -- Note that the 'Handle's provided by 'UseHandle' are not closed -- automatically. From 25e89bb44c15e050ee2c597eab5c16a151380e32 Mon Sep 17 00:00:00 2001 From: AndrewRademacher Date: Mon, 8 Aug 2016 16:30:28 -0500 Subject: [PATCH 13/13] Fixed process log call. --- src/Stack/Exec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index d1642e0992..a01075a8bf 100644 --- a/src/Stack/Exec.hs +++ b/src/Stack/Exec.hs @@ -82,8 +82,8 @@ execSpawn menv cmd0 args = do execObserve :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => EnvOverride -> String -> [String] -> m String execObserve menv cmd0 args = do - $logProcessRun cmd0 args - e <- try (callProcessObserveStdout (Cmd Nothing cmd0 menv args)) + e <- $withProcessTimeLog cmd0 args $ + try (callProcessObserveStdout (Cmd Nothing cmd0 menv args)) case e of Left (ProcessExitedUnsuccessfully _ ec) -> liftIO $ exitWith ec Right s -> return s