diff --git a/package.yaml b/package.yaml index ab71dacebb..5738d350ab 100644 --- a/package.yaml +++ b/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: diff --git a/src/Data/Attoparsec/Interpreter.hs b/src/Data/Attoparsec/Interpreter.hs index a84ec9b336..c8889a8f58 100644 --- a/src/Data/Attoparsec/Interpreter.hs +++ b/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) diff --git a/src/Network/HTTP/Download/Verified.hs b/src/Network/HTTP/Download/Verified.hs index 01272c9ba6..97a69dd3e9 100644 --- a/src/Network/HTTP/Download/Verified.hs +++ b/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) diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index c5bec20a1a..a982bd3e52 100644 --- a/src/Stack/Build.hs +++ b/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) 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 diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index 47a17b5b92..7e82bfb6e4 100644 --- a/src/Stack/Build/Cache.hs +++ b/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 diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 4d16030781..d0e8599524 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 8cb2389d34..4f84362620 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} diff --git a/src/Stack/Config/Docker.hs b/src/Stack/Config/Docker.hs index cbacc9a7c1..99102014cb 100644 --- a/src/Stack/Config/Docker.hs +++ b/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 diff --git a/src/Stack/Constants.hs b/src/Stack/Constants.hs index 4765cd1eef..067f98b041 100644 --- a/src/Stack/Constants.hs +++ b/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") diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 80bbbcb617..c5982d572a 100644 --- a/src/Stack/Docker.hs +++ b/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 diff --git a/src/Stack/FileWatch.hs b/src/Stack/FileWatch.hs index 516d8daac7..2f04d862bd 100644 --- a/src/Stack/FileWatch.hs +++ b/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 ()) diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 8e4d7294e2..a786369ae5 100644 --- a/src/Stack/Ghci.hs +++ b/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 diff --git a/src/Stack/Prelude.hs b/src/Stack/Prelude.hs index deda7551ef..30724f539a 100644 --- a/src/Stack/Prelude.hs +++ b/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 diff --git a/src/Stack/Script.hs b/src/Stack/Script.hs index 7db68ccffa..366c609232 100644 --- a/src/Stack/Script.hs +++ b/src/Stack/Script.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} module Stack.Script diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index 5d2a5c5acf..c541aacd5e 100644 --- a/src/Stack/Setup.hs +++ b/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 diff --git a/src/Stack/Sig/Sign.hs b/src/Stack/Sig/Sign.hs index becfd3e52e..d454f5d746 100644 --- a/src/Stack/Sig/Sign.hs +++ b/src/Stack/Sig/Sign.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 6bf3734a3a..6ec2a27652 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -1305,12 +1304,9 @@ platformGhcVerOnlyRelDirStr = do -- SHA1 hash of the path used on other architectures, encode with base -- 16 and take first 8 symbols of it. useShaPathOnWindows :: MonadThrow m => Path Rel Dir -> m (Path Rel Dir) -useShaPathOnWindows = -#ifdef mingw32_HOST_OS - shaPath -#else - return -#endif +useShaPathOnWindows + | osIsWindows = shaPath + | otherwise = pure shaPath :: (IsPath Rel t, MonadThrow m) => Path Rel t -> m (Path Rel t) shaPath = shaPathForBytes . encodeUtf8 . T.pack . toFilePath diff --git a/src/Stack/Types/Resolver.hs b/src/Stack/Types/Resolver.hs index aaaf4b41ea..f70258d3ad 100644 --- a/src/Stack/Types/Resolver.hs +++ b/src/Stack/Types/Resolver.hs @@ -1,6 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Stack/Types/Runner.hs b/src/Stack/Types/Runner.hs index 8af10b48ff..e97aacf774 100644 --- a/src/Stack/Types/Runner.hs +++ b/src/Stack/Types/Runner.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/src/Stack/Upgrade.hs b/src/Stack/Upgrade.hs index 857295e9a6..26c59b106b 100644 --- a/src/Stack/Upgrade.hs +++ b/src/Stack/Upgrade.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -21,10 +20,7 @@ import qualified Paths_stack as Paths import Stack.Build import Stack.Config import Stack.Constants --- Following import is redundant on non-Windows operating systems -#ifdef WINDOWS import Stack.DefaultColorWhen (defaultColorWhen) -#endif import Stack.PrettyPrint import Stack.Setup import Stack.Types.Config @@ -207,13 +203,11 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) = -- --git" not working for earlier versions. let args = [ "clone", repo , "stack", "--depth", "1", "--recursive", "--branch", branch] withWorkingDir (toFilePath tmp) $ proc "git" args runProcess_ -#ifdef WINDOWS -- On Windows 10, an upstream issue with the `git clone` command -- means that command clears, but does not then restore, the -- ENABLE_VIRTUAL_TERMINAL_PROCESSING flag for native terminals. -- The folowing hack re-enables the lost ANSI-capability. - _ <- liftIO defaultColorWhen -#endif + when osIsWindows $ void $ liftIO defaultColorWhen return $ Just $ tmp relDirStackProgName Nothing -> do void $ updateHackageIndex diff --git a/src/main/Main.hs b/src/main/Main.hs index 3badcde9c4..6fdbfe7e9b 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -110,6 +110,7 @@ import System.Exit import System.FilePath (isValid, pathSeparator) import qualified System.FilePath as FP import System.IO (stderr, stdin, stdout, BufferMode(..), hPutStrLn, hPrint, hGetEncoding, hSetEncoding) +import System.Terminal (hIsTerminalDeviceOrMinTTY) -- | Change the character encoding of the given Handle to transliterate -- on unsupported characters instead of throwing an exception diff --git a/src/unix/System/Permissions.hs b/src/unix/System/Permissions.hs new file mode 100644 index 0000000000..bf9fb180ed --- /dev/null +++ b/src/unix/System/Permissions.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module System.Permissions + ( setScriptPerms + , osIsWindows + , setFileExecutable + ) where + +import qualified System.Posix.Files as Posix +import Stack.Prelude + +-- | True if using Windows OS. +osIsWindows :: Bool +osIsWindows = False + +setScriptPerms :: MonadIO m => FilePath -> m () +setScriptPerms fp = do + liftIO $ Posix.setFileMode fp $ + Posix.ownerReadMode `Posix.unionFileModes` + Posix.ownerWriteMode `Posix.unionFileModes` + Posix.groupReadMode `Posix.unionFileModes` + Posix.otherReadMode + +setFileExecutable :: MonadIO m => FilePath -> m () +setFileExecutable fp = liftIO $ Posix.setFileMode fp 0o755 diff --git a/src/unix/System/Terminal.hsc b/src/unix/System/Terminal.hsc index 3ca408d91c..1e16c18765 100644 --- a/src/unix/System/Terminal.hsc +++ b/src/unix/System/Terminal.hsc @@ -2,10 +2,13 @@ module System.Terminal ( getTerminalWidth +, fixCodePage +, hIsTerminalDeviceOrMinTTY ) where import Foreign import Foreign.C.Types +import RIO (MonadIO, Handle, hIsTerminalDevice) #include #include @@ -33,3 +36,11 @@ getTerminalWidth = else do WindowWidth w <- peek p return . Just . fromIntegral $ w + +fixCodePage :: x -> y -> a -> a +fixCodePage _ _ = id + +-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal +-- devices, but isMinTTYHandle does. +hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool +hIsTerminalDeviceOrMinTTY = hIsTerminalDevice diff --git a/src/windows/System/Permissions.hs b/src/windows/System/Permissions.hs new file mode 100644 index 0000000000..2a49f8d8dc --- /dev/null +++ b/src/windows/System/Permissions.hs @@ -0,0 +1,15 @@ +module System.Permissions + ( setScriptPerms + , osIsWindows + , setFileExecutable + ) where + +-- | True if using Windows OS. +osIsWindows :: Bool +osIsWindows = True + +setScriptPerms :: Monad m => FilePath -> m () +setScriptPerms _ = return () + +setFileExecutable :: Monad m => FilePath -> m () +setFileExecutable _ = return () diff --git a/src/windows/System/Terminal.hs b/src/windows/System/Terminal.hs index b8bc7747e1..a01dc709aa 100644 --- a/src/windows/System/Terminal.hs +++ b/src/windows/System/Terminal.hs @@ -1,6 +1,71 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module System.Terminal ( getTerminalWidth +, fixCodePage +,hIsTerminalDeviceOrMinTTY ) where + +import Distribution.Types.Version (mkVersion) +import Stack.Prelude +import System.Win32 (isMinTTYHandle, withHandleToHANDLE) +import System.Win32.Console (setConsoleCP, setConsoleOutputCP, getConsoleCP, getConsoleOutputCP) + -- | Get the width, in columns, of the terminal if we can. getTerminalWidth :: IO (Maybe Int) getTerminalWidth = return Nothing + +-- | Set the code page for this process as necessary. Only applies to Windows. +-- See: https://github.com/commercialhaskell/stack/issues/738 +fixCodePage + :: HasLogFunc env + => Bool -- ^ modify code page? + -> Version -- ^ GHC version + -> RIO env a + -> RIO env a +fixCodePage mcp ghcVersion inner = do + 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" + +-- | hIsTerminaDevice does not recognise handles to mintty terminals as terminal +-- devices, but isMinTTYHandle does. +hIsTerminalDeviceOrMinTTY :: MonadIO m => Handle -> m Bool +hIsTerminalDeviceOrMinTTY h = do + isTD <- hIsTerminalDevice h + if isTD + then return True + else liftIO $ withHandleToHANDLE h isMinTTYHandle