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

…d documentation

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   = []

Cabal/doc/nix-local-build.rst

@@ -559,12 +559,13 @@ 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 some Windows versions) the ``copy``
+method is used by default. You can specify the install method
+by using ``--install-method`` flag:
 
 ::
 
-    $ cabal v2-install exe:cabal --install-method=copy --installdir=~/bin
+    $ cabal v2-install exe:cabal --install-method=copy --installdir=$HOME/bin
 
 Note that copied executables are not self-contained, since they might use
 data-files from the store.

cabal-install/Distribution/Client/CmdInstall.hs

@@ -85,10 +85,11 @@ import Distribution.Client.DistDirLayout
 import Distribution.Client.RebuildMonad
          ( runRebuild )
 import Distribution.Client.InstallSymlink
-         ( OverwritePolicy(..), symlinkBinary )
+         ( OverwritePolicy(..), symlinkBinary, trySymlink )
+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
@@ -104,7 +105,7 @@ import Distribution.Simple.GHC
          , GhcEnvironmentFileEntry(..)
          , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
 import Distribution.System
-         ( Platform )
+         ( Platform , buildOS, OS (Windows) )
 import Distribution.Types.UnitId
          ( UnitId )
 import Distribution.Types.UnqualComponentName
@@ -140,9 +141,6 @@ import System.Directory
          , removeFile, removeDirectory, copyFile )
 import System.FilePath
          ( (</>), (<.>), takeDirectory, takeBaseName )
-import System.Info
-         ( os )
-
 
 installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
                             , HaddockFlags, TestFlags, BenchmarkFlags
@@ -660,6 +658,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
@@ -670,13 +672,18 @@ installExes verbosity baseCtx buildCtx platform compiler
   where
     overwritePolicy = fromFlagOrDefault NeverOverwrite $
                       cinstOverwritePolicy clientInstallFlags
-    isWindows = System.Info.os == "mingw32"
+    isWindows = buildOS == Windows
+
+    -- 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
+      -- Try symlinking in temporary directory, if it works default to
+      -- symlinking even on windows
+      | isWindows = do
+        symlinks <- trySymlink verbosity
+        return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
+      | otherwise = return InstallMethodSymlink
 
 -- | Install any built library by adding it to the default ghc environment
 installLibraries

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"

cabal-install/Distribution/Client/InstallSymlink.hs

@@ -16,47 +16,9 @@ module Distribution.Client.InstallSymlink (
     OverwritePolicy(..),
     symlinkBinaries,
     symlinkBinary,
+    trySymlink,
   ) where
 
-#ifdef mingw32_HOST_OS
-
-import Distribution.Compat.Binary
-         ( Binary )
-import Distribution.Utils.Structured
-         ( Structured )
-
-import Distribution.Package (PackageIdentifier)
-import Distribution.Types.UnqualComponentName
-import Distribution.Client.InstallPlan (InstallPlan)
-import Distribution.Client.Types (BuildOutcomes)
-import Distribution.Client.Setup (InstallFlags)
-import Distribution.Simple.Setup (ConfigFlags)
-import Distribution.Simple.Compiler
-import Distribution.System
-import GHC.Generics (Generic)
-
-data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
-  deriving (Show, Eq, Generic, Bounded, Enum)
-
-instance Binary OverwritePolicy
-instance Structured OverwritePolicy
-
-symlinkBinaries :: Platform -> Compiler
-                -> OverwritePolicy
-                -> ConfigFlags
-                -> InstallFlags
-                -> InstallPlan
-                -> BuildOutcomes
-                -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
-symlinkBinaries _ _ _ _ _ _ _ = return []
-
-symlinkBinary :: OverwritePolicy
-              -> FilePath -> FilePath -> FilePath -> String
-              -> IO Bool
-symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows"
-
-#else
-
 import Distribution.Compat.Binary
          ( Binary )
 import Distribution.Utils.Structured
@@ -91,12 +53,14 @@ import Distribution.System
          ( Platform )
 import Distribution.Deprecated.Text
          ( display )
+import Distribution.Verbosity  ( Verbosity )
+import Distribution.Simple.Utils ( info, withTempDirectory )
 
 import System.Posix.Files
          ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
          , removeLink )
 import System.Directory
-         ( canonicalizePath )
+         ( canonicalizePath, getTemporaryDirectory )
 import System.FilePath
          ( (</>), splitPath, joinPath, isAbsolute )
 
@@ -111,6 +75,9 @@ import Data.Maybe
 import GHC.Generics
          ( Generic )
 
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+
 data OverwritePolicy = NeverOverwrite | AlwaysOverwrite
   deriving (Show, Eq, Generic, Bounded, Enum)
 
@@ -296,4 +263,27 @@ makeRelative a b = assert (isAbsolute a && isAbsolute b) $
    in joinPath $ [ ".." | _  <- drop commonLen as ]
               ++ drop commonLen bs
 
-#endif
+-- | Try to make a symlink in a temporary directory.
+--
+-- If this works, we can try to symlink: even on Windows.
+--
+trySymlink :: Verbosity -> IO Bool
+trySymlink verbosity = do
+  tmp <- getTemporaryDirectory
+  withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do
+    let from = tmpDirPath </> "file.txt"
+    let to   = tmpDirPath </> "file2.txt"
+
+    -- create a file
+    BS.writeFile from (BS8.pack "TEST")
+
+    -- create a symbolic link
+    let create :: IO Bool
+        create = do
+          createSymbolicLink from to
+          info verbosity $ "Symlinking seems to work"
+          return True
+
+    create `catchIO` \exc -> do
+      info verbosity $ "Symlinking doesn't seem to be working: " ++ show exc
+      return False