Merge pull request #4273 from commercialhaskell/reduce-template-haskell

Avoid unnecessary recompilations

Author: snoyberg

package.yaml

@@ -93,7 +93,7 @@ dependencies:
 - project-template
 - regex-applicative-text
 - resourcet
-- retry
+- retry >= 0.7
 - rio
 - semigroups
 - split
@@ -231,6 +231,7 @@ library:
   - Stack.Sig.Sign
   - Stack.Snapshot
   - Stack.Solver
+  - Stack.StoreTH
   - Stack.Types.Build
   - Stack.Types.BuildPlan
   - Stack.Types.CompilerBuild
@@ -258,6 +259,7 @@ library:
   - Stack.Upgrade
   - Stack.Upload
   - Text.PrettyPrint.Leijen.Extended
+  - System.Permissions
   - System.Process.PagerEditor
   - System.Terminal
   when:

src/Data/Attoparsec/Interpreter.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP #-}
 {- |  This module implements parsing of additional arguments embedded in a
       comment when stack is invoked as a script interpreter
 
@@ -62,7 +61,6 @@ import           Conduit
 import           Data.Conduit.Attoparsec
 import           Data.List (intercalate)
 import           Data.Text (pack)
-import           Stack.Constants
 import           Stack.Prelude
 import           System.FilePath (takeExtension)
 import           System.IO (stderr, hPutStrLn)
@@ -146,11 +144,7 @@ getInterpreterArgs file = do
 
     decodeError e =
       case e of
-#if MIN_VERSION_conduit_extra(1,2,0)
         ParseError ctxs _ (Position line col _) ->
-#else
-        ParseError ctxs _ (Position line col) ->
-#endif
           if null ctxs
           then "Parse error"
           else ("Expecting " ++ intercalate " or " ctxs)

src/Network/HTTP/Download/Verified.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DeriveDataTypeable    #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -192,11 +191,7 @@ hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
 -- 'Control.Retry.recovering' customized for HTTP failures
 recoveringHttp :: forall env a. HasRunner env => RetryPolicy -> RIO env a -> RIO env a
 recoveringHttp retryPolicy =
-#if MIN_VERSION_retry(0,7,0)
     helper $ \run -> recovering retryPolicy (handlers run) . const
-#else
-    helper $ \run -> recovering retryPolicy (handlers run)
-#endif
   where
     helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a
     helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action)

src/Stack/Build.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -46,16 +45,9 @@ import           Stack.Types.Config
 import           Stack.Types.NamedComponent
 import           Stack.Types.Package
 
-import           Stack.Types.Compiler (compilerVersionText
-#ifdef WINDOWS
-                                      ,getGhcVersion
-#endif
-                                      )
+import           Stack.Types.Compiler (compilerVersionText, getGhcVersion)
 import           System.FileLock (FileLock, unlockFile)
-
-#ifdef WINDOWS
-import           System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP)
-#endif
+import           System.Terminal (fixCodePage)
 
 -- | Build.
 --
@@ -67,7 +59,10 @@ build :: HasEnvConfig env
       -> Maybe FileLock
       -> BuildOptsCLI
       -> RIO env ()
-build msetLocalFiles mbuildLk boptsCli = fixCodePage $ do
+build msetLocalFiles mbuildLk boptsCli = do
+  mcp <- view $ configL.to configModifyCodePage
+  ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion
+  fixCodePage mcp ghcVersion $ do
     bopts <- view buildOptsL
     let profiling = boptsLibProfile bopts || boptsExeProfile bopts
     let symbols = not (boptsLibStrip bopts || boptsExeStrip bopts)
@@ -282,53 +277,6 @@ loadPackage loc flags ghcOptions = do
         }
   resolvePackage pkgConfig <$> loadCabalFileImmutable loc
 
--- | Set the code page for this process as necessary. Only applies to Windows.
--- See: https://github.com/commercialhaskell/stack/issues/738
-fixCodePage :: HasEnvConfig env => RIO env a -> RIO env a
-#ifdef WINDOWS
-fixCodePage inner = do
-    mcp <- view $ configL.to configModifyCodePage
-    ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion
-    if mcp && ghcVersion < mkVersion [7, 10, 3]
-        then fixCodePage'
-        -- GHC >=7.10.3 doesn't need this code page hack.
-        else inner
-  where
-    fixCodePage' = do
-        origCPI <- liftIO getConsoleCP
-        origCPO <- liftIO getConsoleOutputCP
-
-        let setInput = origCPI /= expected
-            setOutput = origCPO /= expected
-            fixInput
-                | setInput = bracket_
-                    (liftIO $ do
-                        setConsoleCP expected)
-                    (liftIO $ setConsoleCP origCPI)
-                | otherwise = id
-            fixOutput
-                | setOutput = bracket_
-                    (liftIO $ do
-                        setConsoleOutputCP expected)
-                    (liftIO $ setConsoleOutputCP origCPO)
-                | otherwise = id
-
-        case (setInput, setOutput) of
-            (False, False) -> return ()
-            (True, True) -> warn ""
-            (True, False) -> warn " input"
-            (False, True) -> warn " output"
-
-        fixInput $ fixOutput inner
-    expected = 65001 -- UTF-8
-    warn typ = logInfo $
-        "Setting" <>
-        typ <>
-        " codepage to UTF-8 (65001) to ensure correct output from GHC"
-#else
-fixCodePage = id
-#endif
-
 -- | Query information about the build and print the result to stdout in YAML format.
 queryBuildInfo :: HasEnvConfig env
                => [Text] -- ^ selectors

src/Stack/Build/Cache.hs

@@ -1,9 +1,5 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE DataKinds             #-}
@@ -39,30 +35,28 @@ import qualified Data.ByteArray as Mem (convert)
 import qualified Data.ByteString.Base64.URL as B64URL
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as S8
-#ifdef mingw32_HOST_OS
 import           Data.Char (ord)
-#endif
 import qualified Data.Map as M
 import qualified Data.Set as Set
 import qualified Data.Store as Store
-import           Data.Store.VersionTagged
 import qualified Data.Text as T
 import           Path
 import           Path.IO
+import           Stack.Constants
 import           Stack.Constants.Config
+import           Stack.StoreTH
 import           Stack.Types.Build
 import           Stack.Types.Compiler
 import           Stack.Types.Config
 import           Stack.Types.GhcPkgId
 import           Stack.Types.NamedComponent
-import           Stack.Types.Package
 import qualified System.FilePath as FP
 
 -- | Directory containing files to mark an executable as installed
 exeInstalledDir :: (MonadReader env m, HasEnvConfig env, MonadThrow m)
                 => InstallLocation -> m (Path Abs Dir)
-exeInstalledDir Snap = (</> $(mkRelDir "installed-packages")) `liftM` installationRootDeps
-exeInstalledDir Local = (</> $(mkRelDir "installed-packages")) `liftM` installationRootLocal
+exeInstalledDir Snap = (</> relDirInstalledPackages) `liftM` installationRootDeps
+exeInstalledDir Local = (</> relDirInstalledPackages) `liftM` installationRootLocal
 
 -- | Get all of the installed executables
 getInstalledExes :: (MonadReader env m, HasEnvConfig env, MonadIO m, MonadThrow m)
@@ -126,17 +120,17 @@ tryGetBuildCache :: HasEnvConfig env
                  => Path Abs Dir
                  -> NamedComponent
                  -> RIO env (Maybe (Map FilePath FileCacheInfo))
-tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . $(versionedDecodeFile buildCacheVC) =<< buildCacheFile dir component
+tryGetBuildCache dir component = liftM (fmap buildCacheTimes) . decodeBuildCache =<< buildCacheFile dir component
 
 -- | Try to read the dirtiness cache for the given package directory.
 tryGetConfigCache :: HasEnvConfig env
                   => Path Abs Dir -> RIO env (Maybe ConfigCache)
-tryGetConfigCache dir = $(versionedDecodeFile configCacheVC) =<< configCacheFile dir
+tryGetConfigCache dir = decodeConfigCache =<< configCacheFile dir
 
 -- | Try to read the mod time of the cabal file from the last build
 tryGetCabalMod :: HasEnvConfig env
                => Path Abs Dir -> RIO env (Maybe ModTime)
-tryGetCabalMod dir = $(versionedDecodeFile modTimeVC) =<< configCabalMod dir
+tryGetCabalMod dir = decodeModTime =<< configCabalMod dir
 
 -- | Write the dirtiness cache for this package's files.
 writeBuildCache :: HasEnvConfig env
@@ -145,7 +139,7 @@ writeBuildCache :: HasEnvConfig env
                 -> Map FilePath FileCacheInfo -> RIO env ()
 writeBuildCache dir component times = do
     fp <- buildCacheFile dir component
-    $(versionedEncodeFile buildCacheVC) fp BuildCache
+    encodeBuildCache fp BuildCache
         { buildCacheTimes = times
         }
 
@@ -156,7 +150,7 @@ writeConfigCache :: HasEnvConfig env
                 -> RIO env ()
 writeConfigCache dir x = do
     fp <- configCacheFile dir
-    $(versionedEncodeFile configCacheVC) fp x
+    encodeConfigCache fp x
 
 -- | See 'tryGetCabalMod'
 writeCabalMod :: HasEnvConfig env
@@ -165,7 +159,7 @@ writeCabalMod :: HasEnvConfig env
               -> RIO env ()
 writeCabalMod dir x = do
     fp <- configCabalMod dir
-    $(versionedEncodeFile modTimeVC) fp x
+    encodeModTime fp x
 
 -- | Delete the caches for the project.
 deleteCaches :: (MonadIO m, MonadReader env m, HasEnvConfig env, MonadThrow m)
@@ -195,7 +189,7 @@ tryGetFlagCache :: HasEnvConfig env
                 -> RIO env (Maybe ConfigCache)
 tryGetFlagCache gid = do
     fp <- flagCacheFile gid
-    $(versionedDecodeFile configCacheVC) fp
+    decodeConfigCache fp
 
 writeFlagCache :: HasEnvConfig env
                => Installed
@@ -204,23 +198,23 @@ writeFlagCache :: HasEnvConfig env
 writeFlagCache gid cache = do
     file <- flagCacheFile gid
     ensureDir (parent file)
-    $(versionedEncodeFile configCacheVC) file cache
+    encodeConfigCache file cache
 
 -- | Mark a test suite as having succeeded
 setTestSuccess :: HasEnvConfig env
                => Path Abs Dir
                -> RIO env ()
 setTestSuccess dir = do
     fp <- testSuccessFile dir
-    $(versionedEncodeFile testSuccessVC) fp True
+    encodeTestSuccess fp True
 
 -- | Mark a test suite as not having succeeded
 unsetTestSuccess :: HasEnvConfig env
                  => Path Abs Dir
                  -> RIO env ()
 unsetTestSuccess dir = do
     fp <- testSuccessFile dir
-    $(versionedEncodeFile testSuccessVC) fp False
+    encodeTestSuccess fp False
 
 -- | Check if the test suite already passed
 checkTestSuccess :: HasEnvConfig env
@@ -229,7 +223,7 @@ checkTestSuccess :: HasEnvConfig env
 checkTestSuccess dir =
     liftM
         (fromMaybe False)
-        ($(versionedDecodeFile testSuccessVC) =<< testSuccessFile dir)
+        (decodeTestSuccess =<< testSuccessFile dir)
 
 --------------------------------------
 -- Precompiled Cache
@@ -268,7 +262,7 @@ precompiledCacheFile loc copts installedPackageIDs = do
   platformRelDir <- platformGhcRelDir
   let precompiledDir =
             view stackRootL ec
-        </> $(mkRelDir "precompiled")
+        </> relDirPrecompiled
         </> platformRelDir
         </> compiler
         </> cabal
@@ -317,7 +311,7 @@ writePrecompiledCache baseConfigOpts loc copts depIDs mghcPkgId sublibs exes = d
       name <- parseRelFile $ T.unpack exe
       relPath <- stackRootRelative $ bcoSnapInstallRoot baseConfigOpts </> bindirSuffix </> name
       return $ toFilePath relPath
-  $(versionedEncodeFile precompiledCacheVC) file PrecompiledCache
+  encodePrecompiledCache file PrecompiledCache
       { pcLibrary = mlibpath
       , pcSubLibs = sublibpaths
       , pcExes = exes'
@@ -337,7 +331,7 @@ readPrecompiledCache :: forall env. HasEnvConfig env
                      -> RIO env (Maybe PrecompiledCache)
 readPrecompiledCache loc copts depIDs = do
     file <- precompiledCacheFile loc copts depIDs
-    mcache <- $(versionedDecodeFile precompiledCacheVC) file
+    mcache <- decodePrecompiledCache file
     maybe (pure Nothing) (fmap Just . mkAbs) mcache
   where
     -- Since commit ed9ccc08f327bad68dd2d09a1851ce0d055c0422,
@@ -358,8 +352,9 @@ readPrecompiledCache loc copts depIDs = do
 
 -- | Check if a filesystem path is too long.
 pathTooLong :: FilePath -> Bool
-#ifdef mingw32_HOST_OS
-pathTooLong path = utf16StringLength path >= win32MaxPath
+pathTooLong
+  | osIsWindows = \path -> utf16StringLength path >= win32MaxPath
+  | otherwise = const False
   where
     win32MaxPath = 260
     -- Calculate the length of a string in 16-bit units
@@ -369,6 +364,3 @@ pathTooLong path = utf16StringLength path >= win32MaxPath
       where
         utf16CharLength c | ord c < 0x10000 = 1
                           | otherwise       = 2
-#else
-pathTooLong _ = False
-#endif