SetupHooks.hs

{-# LANGUAGE RecordWildCards, OverloadedRecordDot #-}
-- | Module to automatically produce a XCFramework binary distribution package
-- from a Haskell library
module Distribution.XCFramework.SetupHooks
  ( xcframeworkHooks

    -- * Re-exports from Cabal-hooks
  , SetupHooks )
  where

import System.IO.Temp
import System.Process
import System.FilePath
import Distribution.Simple.SetupHooks
import Distribution.Simple.LocalBuildInfo
    ( interpretSymbolicPathLBI, withPrograms )
-- import Distribution.Simple.BuildPaths (mkSharedLibName)
import Distribution.Simple.Setup (setupVerbosity)
import Distribution.Pretty (prettyShow)
import Distribution.Simple.Flag (fromFlag)
import Distribution.Simple.Program
import System.Directory
import Control.Monad
import Data.Maybe

-- | Add these hooks to your 'setupHooks' in @SetupHooks.hs@ to automatically
-- produce at the given location an xcframework from the Haskell library
-- component being built.
--
-- Non-library components (tests and executables) are ignored.
--
-- The resulting XCFramework includes the RTS and FFI headers, and the dylib
-- (TODO: configurable?) resulting from building the library component.
xcframeworkHooks :: FilePath -- ^ XCFramework result output filepath (must end with .xcframework)
                 -> SetupHooks
xcframeworkHooks out = noSetupHooks
  { buildHooks = noBuildHooks
    { postBuildComponentHook = Just $ postBuild out
    }
  }

-- TODO: This library should eventually also include the header files produced
-- by the library compiled. Currently swift-ffi handles that part separately.

-- | A per-component post-build action which produces the *.xcframework.
postBuild :: FilePath -- ^ XCFramework result output filepath (must end with .xcframework)
          -> PostBuildComponentInputs
          -> IO ()
postBuild outFile PostBuildComponentInputs{..} = do
  let
    verbosity = fromFlag $ setupVerbosity $ buildCommonFlags buildFlags
    i = interpretSymbolicPathLBI localBuildInfo
    clbi = targetCLBI targetInfo
    -- platform = hostPlatform localBuildInfo
    -- compiler = Distribution.Simple.LocalBuildInfo.compiler localBuildInfo
    -- compiler_id = compilerId compiler
    -- uid = componentUnitId clbi
    progDb = withPrograms localBuildInfo

    do_it libHSname = do

      let buildDir = i (componentBuildDir localBuildInfo clbi)
      let libHS = buildDir </> libHSname

      -- Get ghc-pkg program
      (ghcPkgProg, _) <- requireProgram verbosity ghcPkgProgram progDb
      let ghcPkg = programPath ghcPkgProg

      includeDirsStr <- readProcess ghcPkg ["field", "rts", "include-dirs", "--simple-output"] ""
      -- TODO: `words` won't work if the include dirs have spaces in them.
      let includeDirs = words includeDirsStr

      tmpDir <- getCanonicalTemporaryDirectory
      withTempDirectory tmpDir "xcframework" $ \finalHeadersDir -> do

        -- All headers are written to the finalHeadersDir,
        -- Note: If there are duplicate headers name in the RTS+Libffi+library
        -- include dirs, things will break.

        -- Copy the RTS headers
        mapM_ (\idir -> copyHeaderFiles idir finalHeadersDir) includeDirs

        -- Copy the headers (only) generated from foreign exports in this package
        -- It returns all the headers included as part of this package -- we'll add all those to the module map
        hsLibraryHeaders <- copyHeaderFiles buildDir (finalHeadersDir)

        -- Write the module map
        writeFile (finalHeadersDir </> "module.modulemap") $ unlines $
          [ "// This file is automatically generated by swift-ffi"
          , "// Do not edit manually."
          , ""
          , "module Haskell {"
          , "  module Foreign {"
          , ""
          , "    module Rts {"
          , "      header \"HsFFI.h\"" -- always imports HsFFI.h from the RTS
          , "      export *"
          , "    }"
          , ""  -- Export all Haskell foreign exports from this module
          , "    module Exports {"
          ]
          ++
          [ "      header \"" ++ h ++ "\""
          | h <- hsLibraryHeaders ]
          ++
          [ "      export *"
          , "    }"
          , ""
          , "  }" ]
          ++
          [ "}" ]

        let cmd = unwords $
              [ "xcodebuild", "-create-xcframework"
              , "-output", outFile
              , "-library", libHS
              , "-headers", finalHeadersDir
              ]

        xcfExists <- doesDirectoryExist outFile
        when (xcfExists && takeExtension outFile == ".xcframework") $ do
          putStrLn $ "Removing existing XCFramework at " ++ outFile
          removePathForcibly outFile

        putStrLn "Creating XCFramework..."
        putStrLn cmd

        callCommand cmd

  case targetCLBI targetInfo of
    l@LibComponentLocalBuildInfo{}
      -> 
        -- do_it (mkSharedLibName platform compiler_id uid)
        -- Does not work, neither with static libraries (mkLibName)
      putStrLn $
        "Ignoring xcframeworkHooks for library (but not foreign-lib) component, because libraries are currently unsupported "
          ++ prettyShow (componentLocalName l)
    FLibComponentLocalBuildInfo{componentLocalName=CFLibName flibName}
      -> do_it ("lib" ++ prettyShow flibName ++ ".dylib")
    other ->
      putStrLn $
        "Ignoring xcframeworkHooks for non-library component "
          ++ prettyShow (componentLocalName other)

-- Recursively get all .h files and all symlinks directories
getHeaderFiles :: FilePath -> IO [FilePath]
getHeaderFiles dir = do
    contents <- listDirectory dir
    paths <- forM contents $ \name -> do
        let path = dir </> name
        isDir <- doesDirectoryExist path
        isSymlink <- pathIsSymbolicLink path
        if isDir && not isSymlink
            then getHeaderFiles path
            else return [path | takeExtension name == ".h" || (isSymlink && isDir)]
    return (concat paths)

-- Copy each .h file preserving directory structure
-- Returns the relative paths from the destDir to all header files that were included
copyHeaderFiles :: FilePath -> FilePath -> IO [FilePath]
copyHeaderFiles srcDir destDir = catMaybes <$> do
    headerFiles <- getHeaderFiles srcDir
    forM headerFiles $ \srcPath -> do
        srcIsSymlink <- pathIsSymbolicLink srcPath
        let relPath = makeRelative srcDir srcPath
            destPath = destDir </> relPath
            destDirPath = takeDirectory destPath
        if srcIsSymlink then do
          tgt <- getSymbolicLinkTarget srcPath
          createDirectoryLink tgt destPath
          return Nothing
        else do
          createDirectoryIfMissing True destDirPath
          copyFile srcPath destPath
          return (Just relPath)


-- TODO:
-- Avoid using dynamic library files (.dylib files) for dynamic linking. An
-- XCFramework can include dynamic library files, but only macOS supports these
-- libraries for dynamic linking. Dynamic linking on iOS, iPadOS, tvOS,
-- visionOS, and watchOS requires the XCFramework to contain .framework
-- bundles. [1]
-- [1] https://developer.apple.com/documentation/xcode/creating-a-multi-platform-binary-framework-bundle

-- Note: the result will not be a Swift module; but it will allow one to have a
-- C file which #includes the headers and links against the exported symbols.
-- See swift-ffi for a way to generate a Swift module from the C headers