Merge branch 'master' into less-noisy-ghc-pkg

snoyberg · web-flow · commit e3b8d2cc5ee1 · 2018-05-20T20:34:05.000+03:00
diff --git a/ChangeLog.md b/ChangeLog.md
@@ -11,11 +11,20 @@ Behavior changes:
 
 Other enhancements:
 
+* On Windows, recognise a 'mintty' (false) terminal as a terminal, by default
+
 Bug fixes:
 
 * `~/.stack/config.yaml` and `stack.yaml` terminating by newline
 * The previous released caused a regression where some `stderr` from the
   `ghc-pkg` command showed up in the terminal. This output is now silenced.
+* A regression in recompilation checking introduced in v1.7.1 has been fixed.
+  See [#4001](https://github.com/commercialhaskell/stack/issues/4001)
+* `stack ghci` on a package with internal libraries was erroneously looking
+  for a wrong package corresponding to the internal library and failing to
+  load any module. This has been fixed now and changes to the code in the
+  library and the sublibrary are properly tracked. See
+  [#3926](https://github.com/commercialhaskell/stack/issues/3926).
 
 
 ## v1.7.1
diff --git a/package.yaml b/package.yaml
@@ -33,6 +33,7 @@ ghc-options:
 - -fwarn-tabs
 - -fwarn-incomplete-uni-patterns
 - -fwarn-incomplete-record-updates
+- -optP-Wno-nonportable-include-path # workaround [Filename case on macOS · Issue #4739 · haskell/cabal](https://github.com/haskell/cabal/issues/4739)
 dependencies:
 - Cabal
 - aeson
@@ -120,7 +121,7 @@ when:
   then:
     cpp-options: -DWINDOWS
     dependencies:
-    - Win32
+    - Win32 >= 2.5.3.0
   else:
     build-tools:
     - hsc2hs
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -1421,7 +1421,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap
                     unless (null warnings) $ prettyWarn $
                         "The following modules should be added to exposed-modules or other-modules in" <+>
                         display cabalfp <> ":" <> line <>
-                        indent 4 (mconcat $ map showModuleWarning warnings) <>
+                        indent 4 (mconcat $ intersperse line $ map showModuleWarning warnings) <>
                         line <> line <>
                         "Missing modules in the cabal file are likely to cause undefined reference errors from the linker, along with other problems."
 
diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs
@@ -437,7 +437,8 @@ getPackageFilesForTargets
 getPackageFilesForTargets pkg cabalFP nonLibComponents = do
     (components',compFiles,otherFiles,warnings) <-
         getPackageFiles (packageFiles pkg) cabalFP
-    let components = M.keysSet components' `Set.union` nonLibComponents
+    let necessaryComponents = Set.insert CLib $ Set.filter isCInternalLib (M.keysSet components')
+        components = necessaryComponents `Set.union` nonLibComponents
         componentsFiles =
             M.map (\files -> Set.union otherFiles (Set.map dotCabalGetPath files)) $
                 M.filterWithKey (\component _ -> component `Set.member` components) compFiles
diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs
@@ -243,8 +243,8 @@ runContainerAndExit getCmdArgs
      (env,isStdinTerminal,isStderrTerminal,homeDir) <- liftIO $
        (,,,)
        <$> getEnvironment
-       <*> hIsTerminalDevice stdin
-       <*> hIsTerminalDevice stderr
+       <*> hIsTerminalDeviceOrMinTTY stdin
+       <*> hIsTerminalDeviceOrMinTTY stderr
        <*> (parseAbsDir =<< getHomeDirectory)
      isStdoutTerminal <- view terminalL
      let dockerHost = lookup "DOCKER_HOST" env
diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs
@@ -35,7 +35,7 @@ fileWatchConf :: WatchConfig
               -> IO ()
 fileWatchConf cfg out inner = withManagerConf cfg $ \manager -> do
     let putLn = hPutStrLn out
-    outputIsTerminal <- hIsTerminalDevice out
+    outputIsTerminal <- hIsTerminalDeviceOrMinTTY out
     let withColor color str = putLn $ do
             if outputIsTerminal
             then concat [color, str, reset]
diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -661,8 +661,9 @@ wantedPackageComponents _ (TargetComps cs) _ = cs
 wantedPackageComponents bopts (TargetAll ProjectPackage) pkg = S.fromList $
     (case packageLibraries pkg of
        NoLibraries -> []
-       HasLibraries _names -> [CLib]) ++ -- FIXME. This ignores sub libraries and foreign libraries. Is that OK?
+       HasLibraries names -> CLib : map CInternalLib (S.toList names)) ++
     map CExe (S.toList (packageExes pkg)) <>
+    map CInternalLib (S.toList $ packageInternalLibraries pkg) <>
     (if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <>
     (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else [])
 wantedPackageComponents _ _ _ = S.empty
diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs
@@ -64,6 +64,7 @@ import qualified Distribution.Types.CondTree as Cabal
 import qualified Distribution.Types.ExeDependency as Cabal
 import           Distribution.Types.ForeignLib
 import qualified Distribution.Types.LegacyExeDependency as Cabal
+import           Distribution.Types.MungedPackageName
 import qualified Distribution.Types.UnqualComponentName as Cabal
 import qualified Distribution.Verbosity as D
 import           Lens.Micro (lens)
@@ -279,6 +280,7 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg
               | null extraLibNames -> NoLibraries
               | otherwise -> error "Package has buildable sublibraries but no buildable libraries, I'm giving up"
             Just _ -> HasLibraries foreignLibNames
+    , packageInternalLibraries = subLibNames
     , packageTests = M.fromList
       [(T.pack (Cabal.unUnqualComponentName $ testName t), testInterface t)
           | t <- testSuites pkgNoMod
@@ -299,8 +301,13 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg
     , packageOpts = GetPackageOpts $
       \sourceMap installedMap omitPkgs addPkgs cabalfp ->
            do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp
+              let internals = S.toList $ internalLibComponents $ M.keysSet componentsModules
+              excludedInternals <- mapM parsePackageName internals
+              mungedInternals <- mapM (parsePackageName . toInternalPackageMungedName) internals
               componentsOpts <-
-                  generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componentFiles
+                  generatePkgDescOpts sourceMap installedMap
+                  (excludedInternals ++ omitPkgs) (mungedInternals ++ addPkgs)
+                  cabalfp pkg componentFiles
               return (componentsModules,componentFiles,componentsOpts)
     , packageHasExposedModules = maybe
           False
@@ -325,6 +332,10 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg
       $ filter (buildable . foreignLibBuildInfo)
       $ foreignLibs pkg
 
+    toInternalPackageMungedName
+      = T.pack . unMungedPackageName . computeCompatPackageName (pkgName pkgId)
+      . Just . Cabal.mkUnqualComponentName . T.unpack
+
     -- Gets all of the modules, files, build files, and data files that
     -- constitute the package. This is primarily used for dirtiness
     -- checking during build, as well as use by "stack ghci"
@@ -411,6 +422,12 @@ generatePkgDescOpts sourceMap installedMap omitPkgs addPkgs cabalfp pkg componen
                          []
                          (return . generate CLib . libBuildInfo)
                          (library pkg)
+                   , mapMaybe
+                         (\sublib -> do
+                            let maybeLib = CInternalLib . T.pack . Cabal.unUnqualComponentName <$> libName sublib
+                            flip generate  (libBuildInfo sublib) <$> maybeLib
+                          )
+                         (subLibraries pkg)
                    , fmap
                          (\exe ->
                                generate
@@ -698,7 +715,7 @@ packageDescModulesAndFiles
     :: PackageDescription
     -> RIO Ctx (Map NamedComponent (Map ModuleName (Path Abs File)), Map NamedComponent (Set DotCabalPath), Set (Path Abs File), [PackageWarning])
 packageDescModulesAndFiles pkg = do
-    (libraryMods,libDotCabalFiles,libWarnings) <- -- FIXME add in sub libraries
+    (libraryMods,libDotCabalFiles,libWarnings) <-
         maybe
             (return (M.empty, M.empty, []))
             (asModuleAndFileMap libComponent libraryFiles)
diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
@@ -13,6 +14,7 @@ module Stack.Prelude
   , readProcessNull
   , withProcessContext
   , stripCR
+  , hIsTerminalDeviceOrMinTTY
   , module X
   ) where
 
@@ -30,6 +32,10 @@ import qualified System.Directory as Dir
 import qualified System.FilePath as FP
 import           System.IO.Error (isDoesNotExistError)
 
+#ifdef WINDOWS
+import           System.Win32 (isMinTTYHandle, withHandleToHANDLE)
+#endif
+
 import           Data.Conduit.Binary (sourceHandle, sinkHandle)
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.List as CL
@@ -151,3 +157,16 @@ withProcessContext pcNew inner = do
 -- | Remove a trailing carriage return if present
 stripCR :: Text -> Text
 stripCR = T.dropSuffix "\r"
+
+-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal
+-- devices, but isMinTTYHandle does.
+hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool
+#ifdef WINDOWS
+hIsTerminalDeviceOrMinTTY h = do
+  isTD <- hIsTerminalDevice h
+  if isTD
+    then return True
+    else liftIO $ withHandleToHANDLE h isMinTTYHandle
+#else
+hIsTerminalDeviceOrMinTTY = hIsTerminalDevice
+#endif
diff --git a/src/Stack/Types/NamedComponent.hs b/src/Stack/Types/NamedComponent.hs
@@ -8,7 +8,9 @@ module Stack.Types.NamedComponent
   , exeComponents
   , testComponents
   , benchComponents
+  , internalLibComponents
   , isCLib
+  , isCInternalLib
   , isCExe
   , isCTest
   , isCBench
@@ -59,10 +61,20 @@ benchComponents = Set.fromList . mapMaybe mBenchName . Set.toList
     mBenchName (CBench name) = Just name
     mBenchName _ = Nothing
 
+internalLibComponents :: Set NamedComponent -> Set Text
+internalLibComponents = Set.fromList . mapMaybe mInternalName . Set.toList
+  where
+    mInternalName (CInternalLib name) = Just name
+    mInternalName _ = Nothing
+
 isCLib :: NamedComponent -> Bool
 isCLib CLib{} = True
 isCLib _ = False
 
+isCInternalLib :: NamedComponent -> Bool
+isCInternalLib CInternalLib{} = True
+isCInternalLib _ = False
+
 isCExe :: NamedComponent -> Bool
 isCExe CExe{} = True
 isCExe _ = False
diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs
@@ -129,6 +129,7 @@ data Package =
           ,packageFlags :: !(Map FlagName Bool)           -- ^ Flags used on package.
           ,packageDefaultFlags :: !(Map FlagName Bool)    -- ^ Defaults for unspecified flags.
           ,packageLibraries :: !PackageLibraries          -- ^ does the package have a buildable library stanza?
+          ,packageInternalLibraries :: !(Set Text)        -- ^ names of internal libraries
           ,packageTests :: !(Map Text TestSuiteInterface) -- ^ names and interfaces of test suites
           ,packageBenchmarks :: !(Set Text)               -- ^ names of benchmarks
           ,packageExes :: !(Set Text)                     -- ^ names of executables
diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs
@@ -116,4 +116,4 @@ withRunner logLevel useTime terminal colorWhen widthOverride reExec inner = do
           | otherwise = w
 
 data ColorWhen = ColorNever | ColorAlways | ColorAuto
-    deriving (Show, Generic)
+    deriving (Eq, Show, Generic)
diff --git a/src/main/Main.hs b/src/main/Main.hs
@@ -98,12 +98,14 @@ import           Stack.Types.Version
 import           Stack.Types.Config
 import           Stack.Types.Compiler
 import           Stack.Types.Nix
+import           Stack.Types.Runner
 import           Stack.Upgrade
 import qualified Stack.Upload as Upload
 import qualified System.Directory as D
 import           System.Environment (getProgName, getArgs, withArgs)
 import           System.Exit
 import           System.FilePath (isValid, pathSeparator)
+import           System.Console.ANSI (SGR (Reset), hSupportsANSI, setSGR)
 import           System.IO (stderr, stdin, stdout, BufferMode(..), hPutStrLn, hPrint, hGetEncoding, hSetEncoding)
 
 -- | Change the character encoding of the given Handle to transliterate
@@ -167,7 +169,7 @@ main = do
   hSetTranslit stderr
   args <- getArgs
   progName <- getProgName
-  isTerminal <- hIsTerminalDevice stdout
+  isTerminal <- hIsTerminalDeviceOrMinTTY stdout
   execExtraHelp args
                 Docker.dockerHelpOptName
                 (dockerOptsParser False)
@@ -184,6 +186,15 @@ main = do
       throwIO exitCode
     Right (globalMonoid,run) -> do
       let global = globalOptsFromMonoid isTerminal globalMonoid
+      -- If stdout is (1) recognised as a terminal supporting ANSI (for the
+      -- purposes of the functions of the ansi-terminal package) and (2) a
+      -- native (ConHost) terminal on Windows 10, then the setSGR function will
+      -- enable the ANSI-capability for that terminal. Later uses of
+      -- hSupportsANSI with the functions of the RIO package that emit ANSI
+      -- codes will then have the intended outcome on native Windows 10
+      -- terminals.
+      when (globalColorWhen global /= ColorNever) $
+        hSupportsANSI stdout >>= flip when (setSGR [Reset])
       when (globalLogLevel global == LevelDebug) $ hPutStrLn stderr versionString'
       case globalReExecVersion global of
           Just expectVersion -> do
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/Main.hs b/test/integration/tests/3926-ghci-with-sublibraries/Main.hs
@@ -0,0 +1,44 @@
+import Control.Concurrent
+import Control.Monad.IO.Class
+import Control.Monad
+import Data.List
+import StackTest
+
+main :: IO ()
+main = do
+  stack ["clean"] -- to make sure we can load the code even after a clean
+  copy "src/Lib.v1" "src/Lib.hs"
+  copy "src-internal/Internal.v1" "src-internal/Internal.hs"
+  forkIO fileEditingThread
+  replThread
+
+replThread :: IO ()
+replThread = repl [] $ do
+  replCommand ":main"
+  line <- replGetLine
+  when (line /= "hello world") $ error "Main module didn't load correctly."
+  liftIO $ threadDelay 1000000 -- wait for an edit of the internal library
+  reloadAndTest "testInt" "42" "Internal library didn't reload."
+  liftIO $ threadDelay 1000000 -- wait for an edit of the internal library
+  reloadAndTest "testStr" "\"OK\"" "Main library didn't reload."
+
+fileEditingThread :: IO ()
+fileEditingThread = do
+  threadDelay 1000000
+  -- edit the internal library and return to ghci
+  copy "src-internal/Internal.v2" "src-internal/Internal.hs"
+  threadDelay 1000000
+  -- edit the internal library and end thread, returning to ghci
+  copy "src/Lib.v2" "src/Lib.hs"
+
+reloadAndTest :: String -> String -> String -> Repl ()
+reloadAndTest cmd exp err = do
+  reload
+  replCommand cmd
+  line <- replGetLine
+  unless (exp `isSuffixOf` line) $ error err
+
+reload :: Repl ()
+reload = replCommand ":reload" >> loop
+  where
+    loop = replGetLine >>= \line -> unless ("Ok" `isInfixOf` line) loop
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/Setup.hs b/test/integration/tests/3926-ghci-with-sublibraries/files/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/files.cabal b/test/integration/tests/3926-ghci-with-sublibraries/files/files.cabal
@@ -0,0 +1,22 @@
+name:           files
+version:        0.1.0.0
+build-type:     Simple
+cabal-version:  >= 2.0
+
+library
+  hs-source-dirs:   src
+  exposed-modules:  Lib
+  build-depends:    base, lib
+  default-language: Haskell2010
+
+library lib
+  hs-source-dirs:   src-internal
+  exposed-modules:  Internal
+  build-depends:    base
+  default-language: Haskell2010
+
+executable exe
+  hs-source-dirs:   src-exe
+  main-is:          Main.hs
+  build-depends:    base, files
+  default-language: Haskell2010
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/src-exe/Main.hs b/test/integration/tests/3926-ghci-with-sublibraries/files/src-exe/Main.hs
@@ -0,0 +1,7 @@
+module Main where
+
+import Lib
+
+main :: IO ()
+main = do
+  putStrLn "hello world"
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/src-internal/Internal.v1 b/test/integration/tests/3926-ghci-with-sublibraries/files/src-internal/Internal.v1
@@ -0,0 +1 @@
+module Internal where
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/src-internal/Internal.v2 b/test/integration/tests/3926-ghci-with-sublibraries/files/src-internal/Internal.v2
@@ -0,0 +1,4 @@
+module Internal where
+
+testInt :: Int
+testInt = 42
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/src/Lib.v1 b/test/integration/tests/3926-ghci-with-sublibraries/files/src/Lib.v1
@@ -0,0 +1,3 @@
+module Lib where
+
+import Internal
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/src/Lib.v2 b/test/integration/tests/3926-ghci-with-sublibraries/files/src/Lib.v2
@@ -0,0 +1,6 @@
+module Lib where
+
+import Internal
+
+testStr :: String
+testStr = "OK"
diff --git a/test/integration/tests/3926-ghci-with-sublibraries/files/stack.yaml b/test/integration/tests/3926-ghci-with-sublibraries/files/stack.yaml
@@ -0,0 +1,4 @@
+resolver: ghc-8.2.2
+extra-deps:
+- stm-2.4.4.1
+- mtl-2.2.1
diff --git a/test/integration/tests/4001-excess-recompilation/Main.hs b/test/integration/tests/4001-excess-recompilation/Main.hs
@@ -0,0 +1,19 @@
+import Control.Monad (unless)
+import Data.List (isInfixOf)
+import StackTest
+
+main :: IO ()
+main = do
+  copy "test/Main1.hs" "test/Main.hs"
+  copy "bench/Main1.hs" "bench/Main.hs"
+  stack ["build"]
+
+  copy "test/Main2.hs" "test/Main.hs"
+  copy "bench/Main2.hs" "bench/Main.hs"
+  res <- unregisteringLines . snd <$> stackStderr ["build"]
+  removeFileIgnore "test/Main.hs"
+  removeFileIgnore "bench/Main.hs"
+  unless (null res) $ fail "Stack recompiled when a test or benchmark file was changed, but only the library was targeted"
+
+unregisteringLines :: String -> [String]
+unregisteringLines = filter (isInfixOf " unregistering ") . lines
diff --git a/test/integration/tests/4001-excess-recompilation/files/Setup.hs b/test/integration/tests/4001-excess-recompilation/files/Setup.hs
diff --git a/test/integration/tests/4001-excess-recompilation/files/bench/Main1.hs b/test/integration/tests/4001-excess-recompilation/files/bench/Main1.hs
diff --git a/test/integration/tests/4001-excess-recompilation/files/bench/Main2.hs b/test/integration/tests/4001-excess-recompilation/files/bench/Main2.hs
diff --git a/test/integration/tests/4001-excess-recompilation/files/files.cabal b/test/integration/tests/4001-excess-recompilation/files/files.cabal
diff --git a/test/integration/tests/4001-excess-recompilation/files/src/Lib.hs b/test/integration/tests/4001-excess-recompilation/files/src/Lib.hs
diff --git a/test/integration/tests/4001-excess-recompilation/files/stack.yaml b/test/integration/tests/4001-excess-recompilation/files/stack.yaml
diff --git a/test/integration/tests/4001-excess-recompilation/files/test/Main1.hs b/test/integration/tests/4001-excess-recompilation/files/test/Main1.hs
diff --git a/test/integration/tests/4001-excess-recompilation/files/test/Main2.hs b/test/integration/tests/4001-excess-recompilation/files/test/Main2.hs
