Allow specifying default behaviour as a install-method flag input, ad…

…d documentation
haskell · Jan 31, 2020 · b85029f · b85029f
1 parent 7bae16f
commit b85029f
Show file tree

Hide file tree

Showing 4 changed files with 24 additions and 9 deletions.
diff --git a/Cabal/Distribution/Simple/Flag.hs b/Cabal/Distribution/Simple/Flag.hs
@@ -22,6 +22,7 @@ module Distribution.Simple.Flag (
   toFlag,
   fromFlag,
   fromFlagOrDefault,
+  flagElim,
   flagToMaybe,
   flagToList,
   maybeToFlag,
@@ -105,6 +106,11 @@ flagToMaybe :: Flag a -> Maybe a
 flagToMaybe (Flag x) = Just x
 flagToMaybe NoFlag   = Nothing
 
+-- | @since 3.4.0.0
+flagElim :: b -> (a -> b) -> Flag a -> b
+flagElim n _ NoFlag   = n
+flagElim _ f (Flag x) = f x
+
 flagToList :: Flag a -> [a]
 flagToList (Flag x) = [x]
 flagToList NoFlag   = []

diff --git a/Cabal/doc/nix-local-build.rst b/Cabal/doc/nix-local-build.rst
@@ -559,8 +559,9 @@ repository, this command will build cabal-install HEAD and symlink the
 
     $ cabal v2-install exe:cabal
 
-Where symlinking is not possible (eg. on Windows), ``--install-method=copy``
-can be used:
+Where symlinking is not possible (eg. on Windows) the ``copy`` method
+is used by default. You can specify the instll method
+by using ``--install-method`` flag:
 
 ::
 

diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs
@@ -86,9 +86,10 @@ import Distribution.Client.RebuildMonad
          ( runRebuild )
 import Distribution.Client.InstallSymlink
          ( OverwritePolicy(..), symlinkBinary )
+import Distribution.Simple.Flag
+         ( fromFlagOrDefault, flagToMaybe, flagElim )
 import Distribution.Simple.Setup
-         ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags
-         , fromFlagOrDefault, flagToMaybe )
+         ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags )
 import Distribution.Solver.Types.SourcePackage
          ( SourcePackage(..) )
 import Distribution.Simple.Command
@@ -660,6 +661,10 @@ installExes verbosity baseCtx buildCtx platform compiler
                 pure <$> cinstInstalldir clientInstallFlags
   createDirectoryIfMissingVerbose verbosity False installdir
   warnIfNoExes verbosity buildCtx
+
+  installMethod <- flagElim defaultMethod return $
+    cinstInstallMethod clientInstallFlags
+
   let
     doInstall = installUnitExes
                   verbosity
@@ -671,12 +676,14 @@ installExes verbosity baseCtx buildCtx platform compiler
     overwritePolicy = fromFlagOrDefault NeverOverwrite $
                       cinstOverwritePolicy clientInstallFlags
     isWindows = System.Info.os == "mingw32"
+
+    -- This is in IO as we will make environment checks,
+    -- to decide which method is best
+    defaultMethod :: IO InstallMethod
     defaultMethod
       -- Copy since windows doesn't support symlinks by default
-      | isWindows = InstallMethodCopy
-      | otherwise = InstallMethodSymlink
-    installMethod   = fromFlagOrDefault defaultMethod $
-                      cinstInstallMethod clientInstallFlags
+      | isWindows = return InstallMethodCopy
+      | otherwise = return InstallMethodSymlink
 
 -- | Install any built library by adding it to the default ghc environment
 installLibraries

diff --git a/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/Distribution/Client/CmdInstall/ClientInstallFlags.hs
@@ -81,7 +81,7 @@ clientInstallOptions _ =
     "How to install the executables."
     cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v })
     $ reqArg
-        "copy|symlink"
+        "default|copy|symlink"
         readInstallMethodFlag
         showInstallMethodFlag
   , option [] ["installdir"]
@@ -103,6 +103,7 @@ 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"