Merge pull request #82 from tomsmeding/cabal-3.16

Support new Cabal library in Setup.hs (3.12, 3.14, 3.16)

Author: tomsmeding

Setup.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP             #-}
+{-# LANGUAGE DataKinds       #-}
 {-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 
@@ -33,13 +34,27 @@ import Distribution.PackageDescription.Parse
 #if MIN_VERSION_Cabal(3,8,0)
 import Distribution.Simple.PackageDescription
 #endif
+#if MIN_VERSION_Cabal(3,14,0)
+-- Note [Cabal 3.14]
+--
+-- If you change any path stuff, either test that the package still works with
+-- Cabal 3.12 or stop declaring support for it in cuda.cabal. (If you do the
+-- latter, also remove all of the other conditionals in this file.)
+-- Note that supporting old versions of Cabal is useful for being able to run
+-- e.g. Accelerate on old GPU clusters, which is nice.
+import Distribution.Utils.Path (SymbolicPath, FileOrDir(File, Dir), Lib, Include, Pkg, CWD, makeSymbolicPath, interpretSymbolicPath, makeRelativePathEx)
+import qualified Distribution.Types.LocalBuildConfig as LBC
+#else
+import Data.Kind (Constraint)
+#endif
 
 import Control.Exception
 import Control.Monad
 import Data.Char (isDigit)
 import Data.Function
 import Data.List
 import Data.Maybe
+import Data.String (fromString)
 import System.Directory
 import System.Environment
 import System.FilePath
@@ -67,8 +82,9 @@ defaultCUDAInstallPath _ = "/usr/local/cuda"  -- windows?
 main :: IO ()
 main = defaultMainWithHooks customHooks
   where
+    -- Be careful changing flags/paths stuff here; see Note [Cabal 3.14].
     readHook get_verbosity a flags = do
-        getHookedBuildInfo (fromFlag (get_verbosity flags))
+        getHookedBuildInfo (flagToMaybe (workingDirFlag flags)) (fromFlag (get_verbosity flags))
 
     preprocessors = hookedPreProcessors simpleUserHooks
 
@@ -87,14 +103,16 @@ main = defaultMainWithHooks customHooks
         , preReg              = readHook regVerbosity
         , preUnreg            = readHook regVerbosity
         , postConf            = postConfHook
-        , hookedPreProcessors = ("chs", ppC2hs) : filter (\x -> fst x /= "chs") preprocessors
+        , hookedPreProcessors = (fromString "chs", ppC2hs) : filter (\x -> fst x /= fromString "chs") preprocessors
         }
 
     -- The hook just loads the HookedBuildInfo generated by postConfHook,
     -- unless there is user-provided info that overwrites it.
     --
     preBuildHook :: Args -> BuildFlags -> IO HookedBuildInfo
-    preBuildHook _ flags = getHookedBuildInfo $ fromFlag $ buildVerbosity flags
+    preBuildHook _ flags = getHookedBuildInfo cwd verbosity
+      where cwd = flagToMaybe (workingDirFlag flags)
+            verbosity = fromFlag (buildVerbosity flags)
 
     -- The hook scans system in search for CUDA Toolkit. If the toolkit is not
     -- found, an error is raised. Otherwise the toolkit location is used to
@@ -103,12 +121,14 @@ main = defaultMainWithHooks customHooks
     postConfHook :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()
     postConfHook args flags pkg_descr lbi = do
       let
+          cwd             = flagToMaybe (workingDirFlag flags)
           verbosity       = fromFlagOrDefault normal (configVerbosity flags)
           profile         = fromFlagOrDefault False  (configProfLib flags)
           currentPlatform = hostPlatform lbi
           compilerId_     = compilerId (compiler lbi)
       --
       generateAndStoreBuildInfo
+          cwd
           verbosity
           profile
           currentPlatform
@@ -118,7 +138,7 @@ main = defaultMainWithHooks customHooks
           generatedBuildInfoFilePath
       validateLinker verbosity currentPlatform $ withPrograms lbi
       --
-      actualBuildInfoToUse <- getHookedBuildInfo verbosity
+      actualBuildInfoToUse <- getHookedBuildInfo cwd verbosity
       let pkg_descr' = updatePackageDescription actualBuildInfoToUse pkg_descr
       postConf simpleUserHooks args flags pkg_descr' lbi
 
@@ -131,27 +151,29 @@ escBackslash (f:fs)    = f           : escBackslash fs
 -- visible to underlying build tools.
 --
 libraryBuildInfo
-    :: Verbosity
+    :: Maybe CWDPath
+    -> Verbosity
     -> Bool
     -> FilePath
     -> Platform
     -> Version
-    -> [FilePath]
-    -> [FilePath]
+    -> [ExtraLibsPath]
+    -> [ExtraIncludesPath]
     -> IO HookedBuildInfo
-libraryBuildInfo verbosity profile installPath platform@(Platform arch os) ghcVersion extraLibs extraIncludes = do
+libraryBuildInfo cwd verbosity profile installPath platform@(Platform arch os) ghcVersion extraLibs extraIncludes = do
   let
-      libraryPaths      = cudaLibraryPaths platform installPath ++ extraLibs
-      includePaths      = cudaIncludePath platform installPath : extraIncludes
+      -- Be careful changing flags/paths stuff here; see Note [Cabal 3.14].
+      libraryPaths      = map makeSymbolicPath (cudaLibraryPaths platform installPath) ++ extraLibs
+      includePaths      = makeSymbolicPath (cudaIncludePath platform installPath) : extraIncludes
 
       takeFirstExisting paths = do
-          existing <- filterM doesDirectoryExist libraryPaths
+          existing <- filterM (doesDirectoryExist . interpretSymbolicPath cwd) libraryPaths
           case existing of
                (p0:_) -> return p0
                _      -> die' verbosity $ "Could not find path: " ++ show paths
 
   -- This can only be defined once, so take the first path which exists
-  canonicalLibraryPath <- takeFirstExisting libraryPaths
+  canonicalLibraryPath <- interpretSymbolicPath cwd <$> takeFirstExisting libraryPaths
 
   let
       -- OS-specific escaping for -D path defines
@@ -163,16 +185,16 @@ libraryBuildInfo verbosity profile installPath platform@(Platform arch os) ghcVe
       extraLibDirs'     = libraryPaths
       ccOptions'        = [ "-DCUDA_INSTALL_PATH=\"" ++ escDefPath installPath ++ "\""
                           , "-DCUDA_LIBRARY_PATH=\"" ++ escDefPath canonicalLibraryPath ++ "\""
-                          ] ++ map ("-I" ++) includePaths
-      ldOptions'        = map ("-L" ++) libraryPaths
+                          ] ++ map (("-I" ++) . interpretSymbolicPath cwd) includePaths
+      ldOptions'        = map (("-L" ++) . interpretSymbolicPath cwd) libraryPaths
       ghcOptions        = map ("-optc"++) ccOptions'
                        ++ map ("-optl"++) ldOptions'
                        ++ if os /= Windows && not profile
-                            then map ("-optl-Wl,-rpath,"++) extraLibDirs'
+                            then map (("-optl-Wl,-rpath," ++) . interpretSymbolicPath cwd) extraLibDirs'
                             else []
       extraLibs'        = cudaLibraries platform
-      frameworks'       = [ "CUDA" | os == OSX ]
-      frameworkDirs'    = [ "/Library/Frameworks" | os == OSX ]
+      frameworks'       = [ makeRelativePathEx "CUDA" | os == OSX ]
+      frameworkDirs'    = [ makeSymbolicPath "/Library/Frameworks" | os == OSX ]
 
       -- options or c2hs
       archFlag          = case arch of
@@ -427,17 +449,18 @@ windowsLinkerBugMsg ldPath = printf (unlines msg) windowsHelpPage ldPath
 -- Runs CUDA detection procedure and stores .buildinfo to a file.
 --
 generateAndStoreBuildInfo
-    :: Verbosity
+    :: Maybe CWDPath
+    -> Verbosity
     -> Bool
     -> Platform
     -> CompilerId
-    -> [FilePath]
-    -> [FilePath]
+    -> [ExtraLibsPath]
+    -> [ExtraIncludesPath]
     -> FilePath
     -> IO ()
-generateAndStoreBuildInfo verbosity profile platform (CompilerId _ghcFlavor ghcVersion) extraLibs extraIncludes path = do
+generateAndStoreBuildInfo cwd verbosity profile platform (CompilerId _ghcFlavor ghcVersion) extraLibs extraIncludes path = do
   installPath <- findCUDAInstallPath verbosity platform
-  hbi         <- libraryBuildInfo verbosity profile installPath platform ghcVersion extraLibs extraIncludes
+  hbi         <- libraryBuildInfo cwd verbosity profile installPath platform ghcVersion extraLibs extraIncludes
   storeHookedBuildInfo verbosity path hbi
 
 storeHookedBuildInfo
@@ -622,21 +645,22 @@ findProgram verbosity prog = do
 -- (generated one should be always present, as it is created in the post-conf step)
 --
 getHookedBuildInfo
-    :: Verbosity
+    :: Maybe CWDPath
+    -> Verbosity
     -> IO HookedBuildInfo
-getHookedBuildInfo verbosity = do
-  doesCustomBuildInfoExists <- doesFileExist customBuildInfoFilePath
+getHookedBuildInfo cwd verbosity = do
+  doesCustomBuildInfoExists <- doesFileExist (customBuildInfoFilePath)
   if doesCustomBuildInfoExists
     then do
       notice verbosity $ printf "The user-provided buildinfo from file %s will be used. To use default settings, delete this file.\n" customBuildInfoFilePath
-      readHookedBuildInfo verbosity customBuildInfoFilePath
+      readHookedBuildInfoWithCWD verbosity cwd (makeSymbolicPath customBuildInfoFilePath)
     else do
       doesGeneratedBuildInfoExists <- doesFileExist generatedBuildInfoFilePath
       if doesGeneratedBuildInfoExists
         then do
           notice verbosity $ printf "Using build information from '%s'.\n" generatedBuildInfoFilePath
           notice verbosity $ printf "Provide a '%s' file to override this behaviour.\n" customBuildInfoFilePath
-          readHookedBuildInfo verbosity generatedBuildInfoFilePath
+          readHookedBuildInfoWithCWD verbosity cwd (makeSymbolicPath generatedBuildInfoFilePath)
         else
           die' verbosity $ printf "Unexpected failure. Neither the default %s nor custom %s exist.\n" generatedBuildInfoFilePath customBuildInfoFilePath
 
@@ -672,7 +696,7 @@ ppC2hs bi lbi
 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
 getCppOptions bi lbi
     = hcDefines (compiler lbi)
-   ++ ["-I" ++ dir | dir <- includeDirs bi]
+   ++ ["-I" ++ interpretSymbolicPath (lbiCWD lbi) dir | dir <- includeDirs bi]
    ++ [opt | opt@('-':c:_) <- ccOptions bi, c `elem` "DIU"]
 
 hcDefines :: Compiler -> [String]
@@ -706,3 +730,66 @@ die' :: Verbosity -> String -> IO a
 die' _ = die
 #endif
 
+
+-- Compatibility across Cabal 3.14 symbolic paths.
+-- If we want to drop pre-Cabal-3.14 compatibility at some point, this should all be merged in above.
+
+workingDirFlag :: HasCommonFlags flags => flags -> Flag CWDPath
+lbiCWD :: LocalBuildInfo -> Maybe CWDPath
+
+#if MIN_VERSION_Cabal(3,14,0)
+type ExtraLibsPath = SymbolicPath Pkg ('Dir Lib)
+type ExtraIncludesPath = SymbolicPath Pkg ('Dir Include)
+type CWDPath = SymbolicPath CWD ('Dir Pkg)
+
+regVerbosity :: RegisterFlags -> Flag Verbosity
+regVerbosity = setupVerbosity . registerCommonFlags
+
+workingDirFlag = setupWorkingDir . getCommonFlags
+
+lbiCWD = flagToMaybe . setupWorkingDir . configCommonFlags . LBC.configFlags . LBC.packageBuildDescr . localBuildDescr
+
+-- makeSymbolicPath is an actual useful function in Cabal 3.14
+-- makeRelativePathEx is an actual useful function in Cabal 3.14
+-- interpretSymbolicPath is an actual useful function in Cabal 3.14
+
+class HasCommonFlags flags where getCommonFlags :: flags -> CommonSetupFlags
+instance HasCommonFlags BuildFlags where getCommonFlags = buildCommonFlags
+instance HasCommonFlags CleanFlags where getCommonFlags = cleanCommonFlags
+instance HasCommonFlags ConfigFlags where getCommonFlags = configCommonFlags
+instance HasCommonFlags CopyFlags where getCommonFlags = copyCommonFlags
+instance HasCommonFlags InstallFlags where getCommonFlags = installCommonFlags
+instance HasCommonFlags HscolourFlags where getCommonFlags = hscolourCommonFlags
+instance HasCommonFlags HaddockFlags where getCommonFlags = haddockCommonFlags
+instance HasCommonFlags RegisterFlags where getCommonFlags = registerCommonFlags
+
+readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> SymbolicPath Pkg 'File -> IO HookedBuildInfo
+readHookedBuildInfoWithCWD = readHookedBuildInfo
+#else
+type ExtraLibsPath = FilePath
+type ExtraIncludesPath = FilePath
+type CWDPath = ()
+
+-- regVerbosity is still present as an actual field in Cabal 3.12
+
+workingDirFlag _ = NoFlag
+
+lbiCWD _ = Nothing
+
+makeSymbolicPath :: FilePath -> FilePath
+makeSymbolicPath = id
+
+makeRelativePathEx :: FilePath -> FilePath
+makeRelativePathEx = id
+
+interpretSymbolicPath :: Maybe CWDPath -> FilePath -> FilePath
+interpretSymbolicPath _ = id
+
+type HasCommonFlags flags = () :: Constraint
+getCommonFlags :: flags -> ()
+getCommonFlags _ = ()
+
+readHookedBuildInfoWithCWD :: Verbosity -> Maybe CWDPath -> FilePath -> IO HookedBuildInfo
+readHookedBuildInfoWithCWD verb _ path = readHookedBuildInfo verb path
+#endif
+

cuda.cabal

@@ -68,7 +68,7 @@ Extra-source-files:
 custom-setup
   setup-depends:
       base              >= 4.7  && < 5
-    , Cabal             >= 1.24 && < 3.11
+    , Cabal             >= 1.24 && < 3.17
     , directory         >= 1.0
     , filepath          >= 1.0