Unverified Commit a4f20826 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub

Merge pull request #6817 from phadej/types-install-method-overwrite-policy

Make own modules for InstallMethod and OverwritePolicy
parents 827d6558 84735695
...@@ -92,7 +92,9 @@ import Distribution.Client.DistDirLayout ...@@ -92,7 +92,9 @@ import Distribution.Client.DistDirLayout
import Distribution.Client.RebuildMonad import Distribution.Client.RebuildMonad
( runRebuild ) ( runRebuild )
import Distribution.Client.InstallSymlink import Distribution.Client.InstallSymlink
( OverwritePolicy(..), symlinkBinary, trySymlink ) ( symlinkBinary, trySymlink )
import Distribution.Client.Types.OverwritePolicy
( OverwritePolicy (..) )
import Distribution.Simple.Flag import Distribution.Simple.Flag
( fromFlagOrDefault, flagToMaybe, flagElim ) ( fromFlagOrDefault, flagToMaybe, flagElim )
import Distribution.Simple.Setup import Distribution.Simple.Setup
......
...@@ -8,24 +8,23 @@ module Distribution.Client.CmdInstall.ClientInstallFlags ...@@ -8,24 +8,23 @@ module Distribution.Client.CmdInstall.ClientInstallFlags
) where ) where
import Distribution.Client.Compat.Prelude import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.ReadE import Distribution.ReadE
( ReadE(..), succeedReadE ) ( succeedReadE, parsecToReadE )
import Distribution.Simple.Command import Distribution.Simple.Command
( ShowOrParseArgs(..), OptionField(..), option, reqArg ) ( ShowOrParseArgs(..), OptionField(..), option, reqArg )
import Distribution.Simple.Setup import Distribution.Simple.Setup
( Flag(..), trueArg, flagToList, toFlag ) ( Flag(..), trueArg, flagToList, toFlag )
import Distribution.Parsec (Parsec (..), CabalParsing)
import Distribution.Pretty (prettyShow)
import Distribution.Client.InstallSymlink import Distribution.Client.Types.InstallMethod
( InstallMethod (..) )
import Distribution.Client.Types.OverwritePolicy
( OverwritePolicy(..) ) ( OverwritePolicy(..) )
import qualified Distribution.Compat.CharParsing as P
data InstallMethod = InstallMethodCopy
| InstallMethodSymlink
deriving (Eq, Show, Generic, Bounded, Enum)
instance Binary InstallMethod
instance Structured InstallMethod
data ClientInstallFlags = ClientInstallFlags data ClientInstallFlags = ClientInstallFlags
{ cinstInstallLibs :: Flag Bool { cinstInstallLibs :: Flag Bool
...@@ -67,42 +66,26 @@ clientInstallOptions _ = ...@@ -67,42 +66,26 @@ clientInstallOptions _ =
, option [] ["overwrite-policy"] , option [] ["overwrite-policy"]
"How to handle already existing symlinks." "How to handle already existing symlinks."
cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v })
$ reqArg $ reqArg "always|never"
"always|never" (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec))
readOverwritePolicyFlag (map prettyShow . flagToList)
showOverwritePolicyFlag
, option [] ["install-method"] , option [] ["install-method"]
"How to install the executables." "How to install the executables."
cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v }) cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v })
$ reqArg $ reqArg
"default|copy|symlink" "default|copy|symlink"
readInstallMethodFlag (parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod))
showInstallMethodFlag (map prettyShow . flagToList)
, option [] ["installdir"] , option [] ["installdir"]
"Where to install (by symlinking or copying) the executables in." "Where to install (by symlinking or copying) the executables in."
cinstInstalldir (\v flags -> flags { cinstInstalldir = v }) cinstInstalldir (\v flags -> flags { cinstInstalldir = v })
$ reqArg "DIR" (succeedReadE Flag) flagToList $ reqArg "DIR" (succeedReadE Flag) flagToList
] ]
readOverwritePolicyFlag :: ReadE (Flag OverwritePolicy) parsecInstallMethod :: CabalParsing m => m InstallMethod
readOverwritePolicyFlag = ReadE $ \case parsecInstallMethod = do
"always" -> Right $ Flag AlwaysOverwrite name <- P.munch1 isAlpha
"never" -> Right $ Flag NeverOverwrite case name of
policy -> Left $ "'" <> policy <> "' isn't a valid overwrite policy" "copy" -> pure InstallMethodCopy
"symlink" -> pure InstallMethodSymlink
showOverwritePolicyFlag :: Flag OverwritePolicy -> [String] _ -> P.unexpected $ "InstallMethod: " ++ name
showOverwritePolicyFlag (Flag AlwaysOverwrite) = ["always"]
showOverwritePolicyFlag (Flag NeverOverwrite) = ["never"]
showOverwritePolicyFlag NoFlag = []
readInstallMethodFlag :: ReadE (Flag InstallMethod)
readInstallMethodFlag = ReadE $ \case
"default" -> Right $ NoFlag
"copy" -> Right $ Flag InstallMethodCopy
"symlink" -> Right $ Flag InstallMethodSymlink
method -> Left $ "'" <> method <> "' isn't a valid install-method"
showInstallMethodFlag :: Flag InstallMethod -> [String]
showInstallMethodFlag (Flag InstallMethodCopy) = ["copy"]
showInstallMethodFlag (Flag InstallMethodSymlink) = ["symlink"]
showInstallMethodFlag NoFlag = []
...@@ -94,7 +94,8 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReports ...@@ -94,7 +94,8 @@ import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports import qualified Distribution.Client.BuildReports.Storage as BuildReports
( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure ) ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
import qualified Distribution.Client.InstallSymlink as InstallSymlink import qualified Distribution.Client.InstallSymlink as InstallSymlink
( OverwritePolicy(..), symlinkBinaries ) ( symlinkBinaries )
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.Client.World as World import qualified Distribution.Client.World as World
import qualified Distribution.InstalledPackageInfo as Installed import qualified Distribution.InstalledPackageInfo as Installed
...@@ -963,7 +964,7 @@ symlinkBinaries :: Verbosity ...@@ -963,7 +964,7 @@ symlinkBinaries :: Verbosity
symlinkBinaries verbosity platform comp configFlags installFlags symlinkBinaries verbosity platform comp configFlags installFlags
plan buildOutcomes = do plan buildOutcomes = do
failed <- InstallSymlink.symlinkBinaries platform comp failed <- InstallSymlink.symlinkBinaries platform comp
InstallSymlink.NeverOverwrite NeverOverwrite
configFlags installFlags configFlags installFlags
plan buildOutcomes plan buildOutcomes
case failed of case failed of
......
...@@ -13,16 +13,13 @@ ...@@ -13,16 +13,13 @@
-- Managing installing binaries with symlinks. -- Managing installing binaries with symlinks.
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module Distribution.Client.InstallSymlink ( module Distribution.Client.InstallSymlink (
OverwritePolicy(..),
symlinkBinaries, symlinkBinaries,
symlinkBinary, symlinkBinary,
trySymlink, trySymlink,
) where ) where
import Distribution.Compat.Binary import Distribution.Client.Compat.Prelude hiding (ioError)
( Binary ) import Prelude ()
import Distribution.Utils.Structured
( Structured )
import Distribution.Client.Types import Distribution.Client.Types
( ConfiguredPackage(..), BuildOutcomes ) ( ConfiguredPackage(..), BuildOutcomes )
...@@ -60,28 +57,18 @@ import System.Directory ...@@ -60,28 +57,18 @@ import System.Directory
import System.FilePath import System.FilePath
( (</>), splitPath, joinPath, isAbsolute ) ( (</>), splitPath, joinPath, isAbsolute )
import Prelude hiding (ioError)
import System.IO.Error import System.IO.Error
( isDoesNotExistError, ioError ) ( isDoesNotExistError, ioError )
import Distribution.Compat.Exception ( catchIO ) import Distribution.Compat.Exception ( catchIO )
import Control.Exception import Control.Exception
( assert ) ( assert )
import Data.Maybe
( catMaybes )
import GHC.Generics
( Generic )
import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink ) import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )
import Distribution.Client.Types.OverwritePolicy
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Char8 as BS8
data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
deriving (Show, Eq, Generic, Bounded, Enum)
instance Binary OverwritePolicy
instance Structured OverwritePolicy
-- | We would like by default to install binaries into some location that is on -- | We would like by default to install binaries into some location that is on
-- the user's PATH. For per-user installations on Unix systems that basically -- the user's PATH. For per-user installations on Unix systems that basically
-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ -- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@
...@@ -120,7 +107,7 @@ symlinkBinaries platform comp overwritePolicy ...@@ -120,7 +107,7 @@ symlinkBinaries platform comp overwritePolicy
publicBinDir <- canonicalizePath symlinkBinDir publicBinDir <- canonicalizePath symlinkBinDir
-- TODO: do we want to do this here? : -- TODO: do we want to do this here? :
-- createDirectoryIfMissing True publicBinDir -- createDirectoryIfMissing True publicBinDir
fmap catMaybes $ sequence fmap catMaybes $ sequenceA
[ do privateBinDir <- pkgBinDir pkg ipid [ do privateBinDir <- pkgBinDir pkg ipid
ok <- symlinkBinary ok <- symlinkBinary
overwritePolicy overwritePolicy
......
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.Types.InstallMethod where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Parsec (Parsec (..))
import Distribution.Pretty (Pretty (..))
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as PP
data InstallMethod
= InstallMethodCopy
| InstallMethodSymlink
deriving (Eq, Show, Generic, Bounded, Enum)
instance Binary InstallMethod
instance Structured InstallMethod
-- | Last
instance Semigroup InstallMethod where
_ <> x = x
instance Parsec InstallMethod where
parsec = do
name <- P.munch1 isAlpha
case name of
"copy" -> pure InstallMethodCopy
"symlink" -> pure InstallMethodSymlink
_ -> P.unexpected $ "InstallMethod: " ++ name
instance Pretty InstallMethod where
pretty InstallMethodCopy = PP.text "copy"
pretty InstallMethodSymlink = PP.text "symlink"
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.Types.OverwritePolicy where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Parsec (Parsec (..))
import Distribution.Pretty (Pretty (..))
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as PP
data OverwritePolicy
= NeverOverwrite
| AlwaysOverwrite
deriving (Show, Eq, Generic, Bounded, Enum)
instance Binary OverwritePolicy
instance Structured OverwritePolicy
instance Parsec OverwritePolicy where
parsec = do
name <- P.munch1 isAlpha
case name of
"always" -> pure AlwaysOverwrite
"never" -> pure NeverOverwrite
_ -> P.unexpected $ "OverwritePolicy: " ++ name
instance Pretty OverwritePolicy where
pretty NeverOverwrite = PP.text "never"
pretty AlwaysOverwrite = PP.text "always"
...@@ -256,9 +256,11 @@ executable cabal ...@@ -256,9 +256,11 @@ executable cabal
Distribution.Client.Types Distribution.Client.Types
Distribution.Client.Types.AllowNewer Distribution.Client.Types.AllowNewer
Distribution.Client.Types.BuildResults Distribution.Client.Types.BuildResults
Distribution.Client.Types.Credentials
Distribution.Client.Types.ConfiguredId Distribution.Client.Types.ConfiguredId
Distribution.Client.Types.ConfiguredPackage Distribution.Client.Types.ConfiguredPackage
Distribution.Client.Types.Credentials
Distribution.Client.Types.InstallMethod
Distribution.Client.Types.OverwritePolicy
Distribution.Client.Types.PackageLocation Distribution.Client.Types.PackageLocation
Distribution.Client.Types.PackageSpecifier Distribution.Client.Types.PackageSpecifier
Distribution.Client.Types.ReadyPackage Distribution.Client.Types.ReadyPackage
......
...@@ -197,9 +197,11 @@ Version: 3.3.0.0 ...@@ -197,9 +197,11 @@ Version: 3.3.0.0
Distribution.Client.Types Distribution.Client.Types
Distribution.Client.Types.AllowNewer Distribution.Client.Types.AllowNewer
Distribution.Client.Types.BuildResults Distribution.Client.Types.BuildResults
Distribution.Client.Types.Credentials
Distribution.Client.Types.ConfiguredId Distribution.Client.Types.ConfiguredId
Distribution.Client.Types.ConfiguredPackage Distribution.Client.Types.ConfiguredPackage
Distribution.Client.Types.Credentials
Distribution.Client.Types.InstallMethod
Distribution.Client.Types.OverwritePolicy
Distribution.Client.Types.PackageLocation Distribution.Client.Types.PackageLocation
Distribution.Client.Types.PackageSpecifier Distribution.Client.Types.PackageSpecifier
Distribution.Client.Types.ReadyPackage Distribution.Client.Types.ReadyPackage
......
...@@ -37,7 +37,7 @@ import Distribution.Client.Glob (FilePathGlob (..), Fil ...@@ -37,7 +37,7 @@ import Distribution.Client.Glob (FilePathGlob (..), Fil
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..)) import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp)
import Distribution.Client.InstallSymlink (OverwritePolicy) import Distribution.Client.Types.OverwritePolicy (OverwritePolicy)
import Distribution.Client.Targets import Distribution.Client.Targets
import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy) import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy)
import Distribution.Client.Types.AllowNewer import Distribution.Client.Types.AllowNewer
......
...@@ -14,10 +14,10 @@ import Distribution.Client.Dependency.Types ...@@ -14,10 +14,10 @@ import Distribution.Client.Dependency.Types
import Distribution.Client.IndexUtils.ActiveRepos import Distribution.Client.IndexUtils.ActiveRepos
import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.InstallSymlink
import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectConfig.Types
import Distribution.Client.Targets import Distribution.Client.Targets
import Distribution.Client.Types import Distribution.Client.Types
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy)
import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage) import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage)
import UnitTests.Distribution.Client.GenericInstances () import UnitTests.Distribution.Client.GenericInstances ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment