Commit 84735695 authored by Oleg Grenrus's avatar Oleg Grenrus

Make own modules for InstallMethod and OverwritePolicy

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