Skip to content

Commit

Permalink
Merge pull request #5972 from commercialhaskell/imports
Browse files Browse the repository at this point in the history
Add explicit import lists
mpilgrem authored Dec 11, 2022

Verified

This commit was created on GitHub.com and signed with GitHub’s verified signature. The key has expired.
2 parents ca4bc6c + 8d668c6 commit bb40e56
Showing 4 changed files with 297 additions and 290 deletions.
47 changes: 26 additions & 21 deletions src/Options/Applicative/Args.hs
Original file line number Diff line number Diff line change
@@ -4,35 +4,40 @@
-- | Accepting arguments to be passed through to a sub-process.

module Options.Applicative.Args
(argsArgument
,argsOption
,cmdOption)
where
( argsArgument
, argsOption
, cmdOption
) where

import Data.Attoparsec.Args
import Data.Attoparsec.Args ( EscapingMode (..), parseArgsFromString )
import qualified Options.Applicative as O
import Stack.Prelude

-- | An argument which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@.
-- | An argument which accepts a list of arguments
-- e.g. @--ghc-options="-X P.hs \"this\""@.
argsArgument :: O.Mod O.ArgumentFields [String] -> O.Parser [String]
argsArgument =
O.argument
(do s <- O.str
either O.readerError pure (parseArgsFromString Escaping s))
O.argument
(do s <- O.str
either O.readerError pure (parseArgsFromString Escaping s))

-- | An option which accepts a list of arguments e.g. @--ghc-options="-X P.hs \"this\""@.
-- | An option which accepts a list of arguments
-- e.g. @--ghc-options="-X P.hs \"this\""@.
argsOption :: O.Mod O.OptionFields [String] -> O.Parser [String]
argsOption =
O.option
(do s <- O.str
either O.readerError pure (parseArgsFromString Escaping s))
O.option
(do s <- O.str
either O.readerError pure (parseArgsFromString Escaping s))

-- | An option which accepts a command and a list of arguments e.g. @--exec "echo hello world"@
cmdOption :: O.Mod O.OptionFields (String, [String]) -> O.Parser (String, [String])
-- | An option which accepts a command and a list of arguments
-- e.g. @--exec "echo hello world"@
cmdOption ::
O.Mod O.OptionFields (String, [String])
-> O.Parser (String, [String])
cmdOption =
O.option
(do s <- O.str
xs <- either O.readerError pure (parseArgsFromString Escaping s)
case xs of
[] -> O.readerError "Must provide a command"
x:xs' -> pure (x, xs'))
O.option
(do s <- O.str
xs <- either O.readerError pure (parseArgsFromString Escaping s)
case xs of
[] -> O.readerError "Must provide a command"
x:xs' -> pure (x, xs'))
79 changes: 41 additions & 38 deletions src/Stack/Config/Nix.hs
Original file line number Diff line number Diff line change
@@ -5,19 +5,19 @@

-- | Nix configuration
module Stack.Config.Nix
(nixOptsFromMonoid
,nixCompiler
,nixCompilerVersion
) where
( nixCompiler
, nixCompilerVersion
, nixOptsFromMonoid
) where

import Control.Monad.Extra ( ifM )
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Distribution.System ( OS (..) )
import Stack.Constants
import Stack.Constants ( osIsWindows )
import Stack.Prelude
import Stack.Types.Config
import Stack.Types.Nix
import Stack.Types.Config ( HasRunner )
import Stack.Types.Nix ( NixOpts (..), NixOptsMonoid (..) )
import System.Directory ( doesFileExist )

-- | Type representing exceptions thrown by functions exported by the
@@ -42,37 +42,40 @@ instance Exception ConfigNixException where
++ "Only GHC is supported by 'stack --nix'."

-- | Interprets NixOptsMonoid options.
nixOptsFromMonoid
:: HasRunner env
=> NixOptsMonoid
-> OS
-> RIO env NixOpts
nixOptsFromMonoid ::
HasRunner env
=> NixOptsMonoid
-> OS
-> RIO env NixOpts
nixOptsFromMonoid NixOptsMonoid{..} os = do
let defaultPure = case os of
OSX -> False
_ -> True
nixPureShell = fromFirst defaultPure nixMonoidPureShell
nixPackages = fromFirst [] nixMonoidPackages
nixInitFile = getFirst nixMonoidInitFile
nixShellOptions = fromFirst [] nixMonoidShellOptions
++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath)
nixAddGCRoots = fromFirstFalse nixMonoidAddGCRoots
let defaultPure = case os of
OSX -> False
_ -> True
nixPureShell = fromFirst defaultPure nixMonoidPureShell
nixPackages = fromFirst [] nixMonoidPackages
nixInitFile = getFirst nixMonoidInitFile
nixShellOptions = fromFirst [] nixMonoidShellOptions
++ prefixAll (T.pack "-I") (fromFirst [] nixMonoidPath)
nixAddGCRoots = fromFirstFalse nixMonoidAddGCRoots

-- Enable Nix-mode by default on NixOS, unless Docker-mode was specified
osIsNixOS <- isNixOS
let nixEnable0 = fromFirst osIsNixOS nixMonoidEnable
-- Enable Nix-mode by default on NixOS, unless Docker-mode was specified
osIsNixOS <- isNixOS
let nixEnable0 = fromFirst osIsNixOS nixMonoidEnable

nixEnable <- case () of _
| nixEnable0 && osIsWindows -> do
logInfo "Note: Disabling nix integration, since this is being run in Windows"
pure False
| otherwise -> pure nixEnable0
nixEnable <- case () of
_
| nixEnable0 && osIsWindows -> do
logInfo
"Note: Disabling nix integration, since this is being run in Windows"
pure False
| otherwise -> pure nixEnable0

when (not (null nixPackages) && isJust nixInitFile) $
throwIO NixCannotUseShellFileAndPackagesException
pure NixOpts{..}
where prefixAll p (x:xs) = p : x : prefixAll p xs
prefixAll _ _ = []
when (not (null nixPackages) && isJust nixInitFile) $
throwIO NixCannotUseShellFileAndPackagesException
pure NixOpts{..}
where
prefixAll p (x:xs) = p : x : prefixAll p xs
prefixAll _ _ = []

nixCompiler :: WantedCompiler -> Either ConfigNixException T.Text
nixCompiler compilerVersion =
@@ -112,7 +115,7 @@ nixCompilerVersion compilerVersion =

isNixOS :: MonadIO m => m Bool
isNixOS = liftIO $ do
let fp = "/etc/os-release"
ifM (doesFileExist fp)
(T.isInfixOf "ID=nixos" <$> TIO.readFile fp)
(pure False)
let fp = "/etc/os-release"
ifM (doesFileExist fp)
(T.isInfixOf "ID=nixos" <$> TIO.readFile fp)
(pure False)
260 changes: 129 additions & 131 deletions src/Stack/Constants.hs
Original file line number Diff line number Diff line change
@@ -6,141 +6,139 @@
-- | Constants used throughout the project.

module Stack.Constants
(buildPlanDir
,buildPlanCacheDir
,haskellFileExts
,haskellDefaultPreprocessorExts
,stackDotYaml
,stackWorkEnvVar
,stackRootEnvVar
,stackXdgEnvVar
,stackRootOptionName
,stackGlobalConfigOptionName
,pantryRootEnvVar
,deprecatedStackRootOptionName
,inContainerEnvVar
,inNixShellEnvVar
,stackProgNameUpper
,wiredInPackages
,cabalPackageName
,implicitGlobalProjectDirDeprecated
,implicitGlobalProjectDir
,defaultUserConfigPathDeprecated
,defaultUserConfigPath
,defaultGlobalConfigPathDeprecated
,defaultGlobalConfigPath
,platformVariantEnvVar
,compilerOptionsCabalFlag
,ghcColorForceFlag
,minTerminalWidth
,maxTerminalWidth
,defaultTerminalWidth
,osIsWindows
,relFileSetupHs
,relFileSetupLhs
,relFileHpackPackageConfig
,relDirGlobalAutogen
,relDirAutogen
,relDirLogs
,relFileCabalMacrosH
,relDirBuild
,relDirBin
,relDirPantry
,relDirPrograms
,relDirUpperPrograms
,relDirStackProgName
,relDirStackWork
,relFileReadmeTxt
,relDirScript
,relFileConfigYaml
,relDirSnapshots
,relDirGlobalHints
,relFileGlobalHintsYaml
,relDirInstall
,relDirCompilerTools
,relDirHoogle
,relFileDatabaseHoo
,relDirPkgdb
,relFileStorage
,relDirLoadedSnapshotCache
,bindirSuffix
,docDirSuffix
,relDirHpc
,relDirLib
,relDirShare
,relDirLibexec
,relDirEtc
,setupGhciShimCode
,relDirSetupExeCache
,relDirSetupExeSrc
,relFileConfigure
,relDirDist
,relFileSetupMacrosH
,relDirSetup
,relFileSetupLower
,relDirMingw
,relDirMingw32
,relDirMingw64
,relDirLocal
,relDirUsr
,relDirInclude
,relFileIndexHtml
,relDirAll
,relFilePackageCache
,relFileDockerfile
,relDirHaskellStackGhci
,relFileGhciScript
,relDirCombined
,relFileHpcIndexHtml
,relDirCustom
,relDirPackageConfInplace
,relDirExtraTixFiles
,relDirInstalledPackages
,backupUrlRelPath
,relDirDotLocal
,relDirDotSsh
,relDirDotStackProgName
,relDirUnderHome
,relDirSrc
,relFileLibtinfoSo5
,relFileLibtinfoSo6
,relFileLibncurseswSo6
,relFileLibgmpSo10
,relFileLibgmpSo3
,relDirNewCabal
,relFileSetupExe
,relFileSetupUpper
,relFile7zexe
,relFile7zdll
,relFileMainHs
,relFileStack
,relFileStackDotExe
,relFileStackDotTmpDotExe
,relFileStackDotTmp
,ghcShowOptionsOutput
,hadrianScriptsWindows
,hadrianScriptsPosix
,usrLibDirs
,testGhcEnvRelFile
,relFileBuildLock
,stackDeveloperModeDefault
,globalFooter
)
where

import Data.ByteString.Builder (byteString)
import Data.Char (toUpper)
import Data.FileEmbed (embedFile, makeRelativeToProject)
( buildPlanDir
, buildPlanCacheDir
, haskellFileExts
, haskellDefaultPreprocessorExts
, stackDotYaml
, stackWorkEnvVar
, stackRootEnvVar
, stackXdgEnvVar
, stackRootOptionName
, stackGlobalConfigOptionName
, pantryRootEnvVar
, deprecatedStackRootOptionName
, inContainerEnvVar
, inNixShellEnvVar
, stackProgNameUpper
, wiredInPackages
, cabalPackageName
, implicitGlobalProjectDirDeprecated
, implicitGlobalProjectDir
, defaultUserConfigPathDeprecated
, defaultUserConfigPath
, defaultGlobalConfigPathDeprecated
, defaultGlobalConfigPath
, platformVariantEnvVar
, compilerOptionsCabalFlag
, ghcColorForceFlag
, minTerminalWidth
, maxTerminalWidth
, defaultTerminalWidth
, osIsWindows
, relFileSetupHs
, relFileSetupLhs
, relFileHpackPackageConfig
, relDirGlobalAutogen
, relDirAutogen
, relDirLogs
, relFileCabalMacrosH
, relDirBuild
, relDirBin
, relDirPantry
, relDirPrograms
, relDirUpperPrograms
, relDirStackProgName
, relDirStackWork
, relFileReadmeTxt
, relDirScript
, relFileConfigYaml
, relDirSnapshots
, relDirGlobalHints
, relFileGlobalHintsYaml
, relDirInstall
, relDirCompilerTools
, relDirHoogle
, relFileDatabaseHoo
, relDirPkgdb
, relFileStorage
, relDirLoadedSnapshotCache
, bindirSuffix
, docDirSuffix
, relDirHpc
, relDirLib
, relDirShare
, relDirLibexec
, relDirEtc
, setupGhciShimCode
, relDirSetupExeCache
, relDirSetupExeSrc
, relFileConfigure
, relDirDist
, relFileSetupMacrosH
, relDirSetup
, relFileSetupLower
, relDirMingw
, relDirMingw32
, relDirMingw64
, relDirLocal
, relDirUsr
, relDirInclude
, relFileIndexHtml
, relDirAll
, relFilePackageCache
, relFileDockerfile
, relDirHaskellStackGhci
, relFileGhciScript
, relDirCombined
, relFileHpcIndexHtml
, relDirCustom
, relDirPackageConfInplace
, relDirExtraTixFiles
, relDirInstalledPackages
, backupUrlRelPath
, relDirDotLocal
, relDirDotSsh
, relDirDotStackProgName
, relDirUnderHome
, relDirSrc
, relFileLibtinfoSo5
, relFileLibtinfoSo6
, relFileLibncurseswSo6
, relFileLibgmpSo10
, relFileLibgmpSo3
, relDirNewCabal
, relFileSetupExe
, relFileSetupUpper
, relFile7zexe
, relFile7zdll
, relFileMainHs
, relFileStack
, relFileStackDotExe
, relFileStackDotTmpDotExe
, relFileStackDotTmp
, ghcShowOptionsOutput
, hadrianScriptsWindows
, hadrianScriptsPosix
, usrLibDirs
, testGhcEnvRelFile
, relFileBuildLock
, stackDeveloperModeDefault
, globalFooter
) where

import Data.ByteString.Builder ( byteString )
import Data.Char ( toUpper )
import Data.FileEmbed ( embedFile, makeRelativeToProject )
import qualified Data.Set as Set
import Distribution.Package (mkPackageName)
import Distribution.Package ( mkPackageName )
import qualified Hpack.Config as Hpack
import qualified Language.Haskell.TH.Syntax as TH (runIO, lift)
import qualified Language.Haskell.TH.Syntax as TH ( runIO, lift )
import Path as FL
import RIO
import Stack.Prelude
import Stack.Types.Compiler
import System.Permissions (osIsWindows)
import System.Process (readProcess)
import Stack.Types.Compiler ( WhichCompiler (..) )
import System.Permissions ( osIsWindows )
import System.Process ( readProcess )

-- | Type representing exceptions thrown by functions exported by the
-- "Stack.Constants" module.
201 changes: 101 additions & 100 deletions src/Stack/GhcPkg.hs
Original file line number Diff line number Diff line change
@@ -6,101 +6,102 @@
-- | Functions for the GHC package database.

module Stack.GhcPkg
(getGlobalDB
,findGhcPkgField
,createDatabase
,unregisterGhcPkgIds
,ghcPkgPathEnvVar
,mkGhcPackagePath)
where
( createDatabase
, findGhcPkgField
, getGlobalDB
, ghcPkgPathEnvVar
, mkGhcPackagePath
, unregisterGhcPkgIds
) where

import Stack.Prelude
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Path (parent, (</>))
import Path.Extra (toFilePathNoTrailingSep)
import Path ( (</>), parent )
import Path.Extra ( toFilePathNoTrailingSep )
import Path.IO
import Stack.Constants
import Stack.Types.Config (GhcPkgExe (..))
import Stack.Types.GhcPkgId
import Stack.Types.Compiler
import System.FilePath (searchPathSeparator)
import RIO.Process
( doesDirExist, doesFileExist, ensureDir, resolveDir' )
import RIO.Process ( HasProcessContext, proc, readProcess_ )
import Stack.Constants ( relFilePackageCache )
import Stack.Prelude
import Stack.Types.Config ( GhcPkgExe (..) )
import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
import Stack.Types.Compiler ( WhichCompiler (..) )
import System.FilePath ( searchPathSeparator )

-- | Get the global package database
getGlobalDB
:: (HasProcessContext env, HasLogFunc env)
getGlobalDB ::
(HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> RIO env (Path Abs Dir)
getGlobalDB pkgexe = do
logDebug "Getting global package database location"
-- This seems like a strange way to get the global package database
-- location, but I don't know of a better one
bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO pure
let fp = S8.unpack $ stripTrailingColon $ firstLine bs
liftIO $ resolveDir' fp
where
stripTrailingColon bs
| S8.null bs = bs
| S8.last bs == ':' = S8.init bs
| otherwise = bs
firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
logDebug "Getting global package database location"
-- This seems like a strange way to get the global package database
-- location, but I don't know of a better one
bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO pure
let fp = S8.unpack $ stripTrailingColon $ firstLine bs
liftIO $ resolveDir' fp
where
stripTrailingColon bs
| S8.null bs = bs
| S8.last bs == ':' = S8.init bs
| otherwise = bs
firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')

-- | Run the ghc-pkg executable
ghcPkg
:: (HasProcessContext env, HasLogFunc env)
ghcPkg ::
(HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir]
-> [String]
-> RIO env (Either SomeException S8.ByteString)
ghcPkg pkgexe@(GhcPkgExe pkgPath) pkgDbs args = do
eres <- go
case eres of
Left _ -> do
mapM_ (createDatabase pkgexe) pkgDbs
go
Right _ -> pure eres
where
pkg = toFilePath pkgPath
go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_
args' = packageDbFlags pkgDbs ++ args
eres <- go
case eres of
Left _ -> do
mapM_ (createDatabase pkgexe) pkgDbs
go
Right _ -> pure eres
where
pkg = toFilePath pkgPath
go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_
args' = packageDbFlags pkgDbs ++ args

-- | Create a package database in the given directory, if it doesn't exist.
createDatabase
:: (HasProcessContext env, HasLogFunc env)
createDatabase ::
(HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir
-> RIO env ()
createDatabase (GhcPkgExe pkgPath) db = do
exists <- doesFileExist (db </> relFilePackageCache)
unless exists $ do
-- ghc-pkg requires that the database directory does not exist
-- yet. If the directory exists but the package.cache file
-- does, we're in a corrupted state. Check for that state.
dirExists <- doesDirExist db
args <- if dirExists
then do
logWarn $
"The package database located at " <>
fromString (toFilePath db) <>
" is corrupted (missing its package.cache file)."
logWarn "Proceeding with a recache"
pure ["--package-db", toFilePath db, "recache"]
else do
-- Creating the parent doesn't seem necessary, as ghc-pkg
-- seems to be sufficiently smart. But I don't feel like
-- finding out it isn't the hard way
ensureDir (parent db)
pure ["init", toFilePath db]
void $ proc (toFilePath pkgPath) args $ \pc ->
onException (readProcess_ pc) $
logError $
"Error: [S-9735]\n" <>
"Unable to create package database at " <>
fromString (toFilePath db)
exists <- doesFileExist (db </> relFilePackageCache)
unless exists $ do
-- ghc-pkg requires that the database directory does not exist
-- yet. If the directory exists but the package.cache file
-- does, we're in a corrupted state. Check for that state.
dirExists <- doesDirExist db
args <- if dirExists
then do
logWarn $
"The package database located at " <>
fromString (toFilePath db) <>
" is corrupted (missing its package.cache file)."
logWarn "Proceeding with a recache"
pure ["--package-db", toFilePath db, "recache"]
else do
-- Creating the parent doesn't seem necessary, as ghc-pkg
-- seems to be sufficiently smart. But I don't feel like
-- finding out it isn't the hard way
ensureDir (parent db)
pure ["init", toFilePath db]
void $ proc (toFilePath pkgPath) args $ \pc ->
onException (readProcess_ pc) $
logError $
"Error: [S-9735]\n" <>
"Unable to create package database at " <>
fromString (toFilePath db)

-- | Get the environment variable to use for the package DB paths.
ghcPkgPathEnvVar :: WhichCompiler -> Text
@@ -109,48 +110,48 @@ ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH"
-- | Get the necessary ghc-pkg flags for setting up the given package database
packageDbFlags :: [Path Abs Dir] -> [String]
packageDbFlags pkgDbs =
"--no-user-package-db"
: map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
"--no-user-package-db"
: map (\x -> "--package-db=" ++ toFilePath x) pkgDbs

-- | Get the value of a field of the package.
findGhcPkgField
:: (HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir] -- ^ package databases
-> String -- ^ package identifier, or GhcPkgId
-> Text
-> RIO env (Maybe Text)
findGhcPkgField ::
(HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> [Path Abs Dir] -- ^ package databases
-> String -- ^ package identifier, or GhcPkgId
-> Text
-> RIO env (Maybe Text)
findGhcPkgField pkgexe pkgDbs name field = do
result <-
ghcPkg
pkgexe
pkgDbs
["field", "--simple-output", name, T.unpack field]
pure $
case result of
Left{} -> Nothing
Right bs ->
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs
result <-
ghcPkg
pkgexe
pkgDbs
["field", "--simple-output", name, T.unpack field]
pure $
case result of
Left{} -> Nothing
Right bs ->
fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs

-- | unregister list of package ghcids, batching available from GHC 8.2.1,
-- see https://github.com/commercialhaskell/stack/issues/2662#issuecomment-460342402
-- using GHC package id where available (from GHC 7.9)
unregisterGhcPkgIds
:: (HasProcessContext env, HasLogFunc env)
unregisterGhcPkgIds ::
(HasProcessContext env, HasLogFunc env)
=> GhcPkgExe
-> Path Abs Dir -- ^ package database
-> NonEmpty (Either PackageIdentifier GhcPkgId)
-> RIO env ()
unregisterGhcPkgIds pkgexe pkgDb epgids = do
eres <- ghcPkg pkgexe [pkgDb] args
case eres of
Left e -> logWarn $ displayShow e
Right _ -> pure ()
where
(idents, gids) = partitionEithers $ toList epgids
args = "unregister" : "--user" : "--force" :
map packageIdentifierString idents ++
if null gids then [] else "--ipid" : map ghcPkgIdString gids
eres <- ghcPkg pkgexe [pkgDb] args
case eres of
Left e -> logWarn $ displayShow e
Right _ -> pure ()
where
(idents, gids) = partitionEithers $ toList epgids
args = "unregister" : "--user" : "--force" :
map packageIdentifierString idents ++
if null gids then [] else "--ipid" : map ghcPkgIdString gids

-- | Get the value for GHC_PACKAGE_PATH
mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text

0 comments on commit bb40e56

Please sign in to comment.