diff --git a/src/Stack/Exec.hs b/src/Stack/Exec.hs index 7b0769d96d..a01075a8bf 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 + e <- $withProcessTimeLog cmd0 args $ + 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 75e3f5bc67..6cf809183d 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -14,6 +14,10 @@ module Stack.Ghci , GhciException(..) , ghciSetup , ghci + + -- TODO: Address what should and should not be exported. + , renderScriptGhci + , renderScriptIntero ) where import Control.Applicative @@ -30,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 @@ -42,7 +45,6 @@ import Data.Traversable (forM) import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) -import Distribution.ModuleName (ModuleName) import Distribution.PackageDescription (updatePackageDescription) import Distribution.Text (display) import Network.HTTP.Client.Conduit @@ -56,6 +58,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.PackageIdentifier import Stack.Types.PackageName @@ -64,7 +67,6 @@ import Stack.Types.Build import Stack.Types.Package import Stack.Types.Compiler import Stack.Types.Internal -import System.FilePath (takeBaseName) import Text.Read (readMaybe) #ifndef WINDOWS @@ -142,25 +144,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 ] @@ -176,20 +161,68 @@ 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]) + 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 + if ghciNoLoadModules + then execGhci macrosOptions + else do + checkForDuplicateModules pkgs + renderFn <- interrogateExeForRenderFunction + scriptPath <- writeGhciScript tmpDirectory (renderFn pkgs 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 -> GhciScript -> m (Path Abs File) +writeGhciScript tmpDirectory script = do + liftIO $ scriptToFile scriptPath script + setScriptPerms scriptFilePath + return scriptPath + where + scriptPath = tmpDirectory $(mkRelFile "ghci-script") + scriptFilePath = toFilePath scriptPath + +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 <> mainPhase <> modulePhase + where + renderPkg pkg = cmdAdd (ghciPkgModules pkg) + +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 <> mainPhase <> modulePhase + 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 @@ -503,15 +536,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 @@ -584,13 +616,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. @@ -632,10 +657,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 new file mode 100644 index 0000000000..8c13d210ad --- /dev/null +++ b/src/Stack/Ghci/Script.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Ghci.Script + ( GhciScript + , ModuleName + + , cmdAdd + , cmdAddFile + , cmdCdGhc + , cmdModule + + , 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 Data.Text.Encoding (encodeUtf8Builder) +import Path +import System.IO + +import Distribution.ModuleName hiding (toFilePath) + +newtype GhciScript = GhciScript { unGhciScript :: [GhciCommand] } + +instance Monoid GhciScript where + mempty = GhciScript [] + (GhciScript xs) `mappend` (GhciScript ys) = GhciScript (ys <> xs) + +data GhciCommand + = Add (Set ModuleName) + | AddFile (Path Abs File) + | CdGhc (Path Abs Dir) + | Module (Set ModuleName) + deriving (Show) + +cmdAdd :: Set ModuleName -> GhciScript +cmdAdd = GhciScript . (:[]) . Add + +cmdAddFile :: Path Abs File -> GhciScript +cmdAddFile = GhciScript . (:[]) . AddFile + +cmdCdGhc :: Path Abs Dir -> GhciScript +cmdCdGhc = GhciScript . (:[]) . CdGhc + +cmdModule :: Set ModuleName -> GhciScript +cmdModule = GhciScript . (:[]) . Module + +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 = + fromText ":add " + <> (mconcat $ intersperse (fromText " ") + $ fmap (stringUtf8 . quoteFileName . mconcat . intersperse "." . components) + $ S.toAscList modules) + <> fromText "\n" + +commandToBuilder (AddFile path) = + fromText ":add " <> stringUtf8 (quoteFileName (toFilePath path)) <> fromText "\n" + +commandToBuilder (CdGhc path) = + 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 . 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/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. diff --git a/src/test/Stack/Ghci/ScriptSpec.hs b/src/test/Stack/Ghci/ScriptSpec.hs new file mode 100644 index 0000000000..43b9fbad8a --- /dev/null +++ b/src/test/Stack/Ghci/ScriptSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Test suite for the GhciScript DSL +module Stack.Ghci.ScriptSpec where + +import Data.Monoid +import qualified Data.Set as S +import Distribution.ModuleName +import Test.Hspec +import Path + +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"] + 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 [] + 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"]) + 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") + 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 [] + 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"] + scriptToLazyByteString script `shouldBe` ":module + Lib.A Lib.B\n" diff --git a/src/test/Stack/GhciSpec.hs b/src/test/Stack/GhciSpec.hs new file mode 100644 index 0000000000..773e9eea57 --- /dev/null +++ b/src/test/Stack/GhciSpec.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | 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.Encoding as T +import Distribution.ModuleName +import Stack.Types.Package +import Stack.Types.PackageName +import Stack.Types.Version +import Test.Hspec +import NeatInterpolation +import Path + +import Stack.Ghci +import Stack.Ghci.Script (scriptToLazyByteString) + +spec :: Spec +spec = do + describe "GHCi" $ do + describe "Script rendering" $ do + 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 /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 +: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 + } + } + ] diff --git a/stack.cabal b/stack.cabal index 2afb30d483..9c98780d3f 100644 --- a/stack.cabal +++ b/stack.cabal @@ -101,6 +101,7 @@ library Stack.FileWatch Stack.GhcPkg Stack.Ghci + Stack.Ghci.Script Stack.Hoogle Stack.IDE Stack.Image @@ -296,6 +297,8 @@ test-suite stack-test , Stack.Build.TargetSpec , Stack.ConfigSpec , Stack.DotSpec + , Stack.GhciSpec + , Stack.Ghci.ScriptSpec , Stack.PackageDumpSpec , Stack.ArgsSpec , Stack.NixSpec @@ -318,6 +321,7 @@ test-suite stack-test , hspec >= 2.2 && <2.3 , http-conduit , monad-logger + , neat-interpolation , path >= 0.5.7 , path-io >= 1.1.0 && < 2.0.0 , resourcet diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs index eda29d15ae..b34659c5e9 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: []