Reduce CPP usage as well #4272

Author: snoyberg

package.yaml

@@ -93,7 +93,7 @@ dependencies:
 - project-template
 - regex-applicative-text
 - resourcet
-- retry
+- retry >= 0.7
 - rio
 - semigroups
 - split
@@ -258,6 +258,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
 
@@ -145,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,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -39,9 +38,7 @@ 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
@@ -359,8 +356,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
@@ -370,6 +368,3 @@ pathTooLong path = utf16StringLength path >= win32MaxPath
       where
         utf16CharLength c | ord c < 0x10000 = 1
                           | otherwise       = 2
-#else
-pathTooLong _ = False
-#endif

src/Stack/Build/Execute.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}

src/Stack/Config.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveFoldable #-}
 {-# LANGUAGE DeriveFunctor #-}

src/Stack/Config/Docker.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE CPP, DeriveDataTypeable, RecordWildCards #-}
+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
 
 -- | Docker configuration
 module Stack.Config.Docker where

src/Stack/Constants.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-} -- keep TH usage here
@@ -132,6 +131,7 @@ import           Path as FL
 import           Stack.Prelude
 import           Stack.Types.Compiler
 import           Stack.Types.TemplateName
+import           System.Permissions (osIsWindows)
 
 -- | Extensions used for Haskell modules. Excludes preprocessor ones.
 haskellFileExts :: [Text]
@@ -325,15 +325,6 @@ maxTerminalWidth = 200
 defaultTerminalWidth :: Int
 defaultTerminalWidth = 100
 
--- | True if using Windows OS.
-osIsWindows :: Bool
-osIsWindows =
-#ifdef WINDOWS
-  True
-#else
-  False
-#endif
-
 relFileSetupHs :: Path Rel File
 relFileSetupHs = $(mkRelFile "Setup.hs")
 

src/Stack/Docker.hs

@@ -66,6 +66,7 @@ import           System.IO.Unsafe (unsafePerformIO)
 import qualified System.PosixCompat.User as User
 import qualified System.PosixCompat.Files as Files
 import           System.Process.PagerEditor (editByteString)
+import           System.Terminal (hIsTerminalDeviceOrMinTTY)
 import           RIO.Process
 import           Text.Printf (printf)
 
@@ -347,6 +348,8 @@ runContainerAndExit getCmdArgs
          ,[cmnd]
          ,args])
      before
+-- MSS 2018-08-30 can the CPP below be removed entirely, and instead exec the
+-- `docker` process so that it can handle the signals directly?
 #ifndef WINDOWS
      run <- askRunInIO
      oldHandlers <- forM [sigINT,sigABRT,sigHUP,sigPIPE,sigTERM,sigUSR1,sigUSR2] $ \sig -> do

src/Stack/FileWatch.hs

@@ -14,6 +14,7 @@ import GHC.IO.Exception
 import Path
 import System.FSNotify
 import System.IO (hPutStrLn, getLine)
+import System.Terminal
 
 fileWatch :: Handle
           -> ((Set (Path Abs File) -> IO ()) -> IO ())

src/Stack/Ghci.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 
 -- | Run a GHCi configured with the user's package(s).
@@ -50,10 +49,7 @@ import           Stack.Types.Package
 import           Stack.Types.Runner
 import           System.IO (putStrLn)
 import           System.IO.Temp (getCanonicalTemporaryDirectory)
-
-#ifndef WINDOWS
-import qualified System.Posix.Files as Posix
-#endif
+import           System.Permissions (setScriptPerms)
 
 -- | Command-line options for GHC.
 data GhciOpts = GhciOpts
@@ -887,20 +883,6 @@ getExtraLoadDeps loadAllDeps sourceMap targets =
             (_, Just PSRemote{}) -> return loadAllDeps
             (_, _) -> return False
 
-setScriptPerms :: MonadIO m => FilePath -> m ()
-#ifdef WINDOWS
-setScriptPerms _ = do
-    return ()
-#else
-setScriptPerms fp = do
-    liftIO $ Posix.setFileMode fp $ foldl1 Posix.unionFileModes
-        [ Posix.ownerReadMode
-        , Posix.ownerWriteMode
-        , Posix.groupReadMode
-        , Posix.otherReadMode
-        ]
-#endif
-
 unionTargets :: Ord k => Map k Target -> Map k Target -> Map k Target
 unionTargets = M.unionWith $ \l r ->
     case (l, r) of

src/Stack/Prelude.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                        #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
@@ -11,7 +10,6 @@ module Stack.Prelude
   , readProcessNull
   , withProcessContext
   , stripCR
-  , hIsTerminalDeviceOrMinTTY
   , prompt
   , promptPassword
   , promptBool
@@ -31,10 +29,6 @@ import qualified Path.IO
 
 import           System.IO.Echo (withoutInputEcho)
 
-#ifdef WINDOWS
-import           System.Win32 (isMinTTYHandle, withHandleToHANDLE)
-#endif
-
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.List as CL
 import           Data.Conduit.Process.Typed (withLoggedProcess_, createSource)
@@ -127,19 +121,6 @@ withProcessContext pcNew inner = do
 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
-
 -- | Prompt the user by sending text to stdout, and taking a line of
 -- input from stdin.
 prompt :: MonadIO m => Text -> m Text

src/Stack/Script.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections     #-}
 module Stack.Script

src/Stack/Setup.hs

@@ -95,6 +95,7 @@ import              System.Exit (ExitCode (..), exitFailure)
 import              System.IO.Error (isPermissionError)
 import              System.FilePath (searchPathSeparator)
 import qualified    System.FilePath as FP
+import              System.Permissions (setFileExecutable)
 import              RIO.Process
 import              Text.Printf (printf)
 
@@ -103,7 +104,6 @@ import              System.Uname (uname, release)
 import              Data.List.Split (splitOn)
 import              Foreign.C (throwErrnoIfMinus1_, peekCString)
 import              Foreign.Marshal (alloca)
-import              System.Posix.Files (setFileMode)
 #endif
 
 -- | Default location of the stack-setup.yaml file
@@ -1899,9 +1899,7 @@ downloadStackExe platforms0 archiveInfo destDir checkPath testExe = do
     platform <- view platformL
 
     liftIO $ do
-#if !WINDOWS
-      setFileMode (toFilePath tmpFile) 0o755
-#endif
+      setFileExecutable (toFilePath tmpFile)
 
       testExe tmpFile
 
@@ -1986,9 +1984,7 @@ performPathChecking newFile = do
     tmpFile <- parseAbsFile $ executablePath ++ ".tmp"
     eres <- tryIO $ do
       liftIO $ copyFile newFile tmpFile
-#if !WINDOWS
-      liftIO $ setFileMode (toFilePath tmpFile) 0o755
-#endif
+      setFileExecutable (toFilePath tmpFile)
       liftIO $ renameFile tmpFile executablePath'
       logInfo "Stack executable copied successfully!"
     case eres of

src/Stack/Sig/Sign.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}