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

Make own modules for InstallMethod and OverwritePolicy

cabal-install/Distribution/Client/CmdInstall.hs

@@ -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

cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs

@@ -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

cabal-install/Distribution/Client/Install.hs

@@ -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

cabal-install/Distribution/Client/InstallSymlink.hs

@@ -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

cabal-install/Distribution/Client/Types/InstallMethod.hs

+{-# 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"

cabal-install/Distribution/Client/Types/OverwritePolicy.hs

+{-# 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"

cabal-install/cabal-install.cabal

@@ -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

cabal-install/cabal-install.cabal.pp

@@ -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

cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs

@@ -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

cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs

@@ -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 ()