{-# LANGUAGE RecordWildCards, OverloadedRecordDot #-}
-- | Module to automatically produce a XCFramework binary distribution package
-- from a Haskell library
module Distribution.XCFramework.SetupHooks
  ( SetupHooks, xcframeworkHooks )
  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 :: String -> SetupHooks
xcframeworkHooks String
out = SetupHooks
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 :: String -> PostBuildComponentInputs -> IO ()
postBuild String
outFile PostBuildComponentInputs{TargetInfo
LocalBuildInfo
BuildFlags
buildFlags :: BuildFlags
localBuildInfo :: LocalBuildInfo
targetInfo :: TargetInfo
buildFlags :: PostBuildComponentInputs -> BuildFlags
localBuildInfo :: PostBuildComponentInputs -> LocalBuildInfo
targetInfo :: PostBuildComponentInputs -> TargetInfo
..} = do
  let
    verbosity :: Verbosity
verbosity = Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ BuildFlags -> CommonSetupFlags
buildCommonFlags BuildFlags
buildFlags
    i :: SymbolicPathX allowAbsolute Pkg to -> String
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
interpretSymbolicPathLBI LocalBuildInfo
localBuildInfo
    clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
targetInfo
    -- platform = hostPlatform localBuildInfo
    -- compiler = Distribution.Simple.LocalBuildInfo.compiler localBuildInfo
    -- compiler_id = compilerId compiler
    -- uid = componentUnitId clbi
    progDb :: ProgramDb
progDb = LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
localBuildInfo

    do_it :: String -> IO ()
do_it String
libHSname = do

      let buildDir :: String
buildDir = SymbolicPathX 'AllowAbsolute Pkg ('Dir Build) -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i (LocalBuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Build)
componentBuildDir LocalBuildInfo
localBuildInfo ComponentLocalBuildInfo
clbi)
      let libHS :: String
libHS = String
buildDir String -> String -> String
</> String
libHSname

      -- Get ghc-pkg program
      (ghcPkgProg, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcPkgProgram ProgramDb
progDb
      let ghcPkg = ConfiguredProgram -> String
programPath ConfiguredProgram
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 = String -> [String]
words String
includeDirsStr

      tmpDir <- getCanonicalTemporaryDirectory
      withTempDirectory tmpDir "xcframework" $ \String
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
        (String -> IO [String]) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\String
idir -> String -> String -> IO [String]
copyHeaderFiles String
idir String
finalHeadersDir) [String]
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 <- String -> String -> IO [String]
copyHeaderFiles String
buildDir (String
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 = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
              [ String
"xcodebuild", String
"-create-xcframework"
              , String
"-output", String
outFile
              , String
"-library", String
libHS
              , String
"-headers", String
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 TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
targetInfo of
    l :: ComponentLocalBuildInfo
l@LibComponentLocalBuildInfo{}
      -> 
        -- do_it (mkSharedLibName platform compiler_id uid)
        -- Does not work, neither with static libraries (mkLibName)
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Ignoring xcframeworkHooks for library (but not foreign-lib) component, because libraries are currently unsupported "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
forall a. Pretty a => a -> String
prettyShow (ComponentLocalBuildInfo -> ComponentName
componentLocalName ComponentLocalBuildInfo
l)
    FLibComponentLocalBuildInfo{componentLocalName :: ComponentLocalBuildInfo -> ComponentName
componentLocalName=CFLibName UnqualComponentName
flibName}
      -> String -> IO ()
do_it (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
flibName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".dylib")
    ComponentLocalBuildInfo
other ->
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"Ignoring xcframeworkHooks for non-library component "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
forall a. Pretty a => a -> String
prettyShow (ComponentLocalBuildInfo -> ComponentName
componentLocalName ComponentLocalBuildInfo
other)

-- Recursively get all .h files and all symlinks directories
getHeaderFiles :: FilePath -> IO [FilePath]
getHeaderFiles :: String -> IO [String]
getHeaderFiles String
dir = do
    contents <- String -> IO [String]
listDirectory String
dir
    paths <- forM contents $ \String
name -> do
        let path :: String
path = String
dir String -> String -> String
</> String
name
        isDir <- String -> IO Bool
doesDirectoryExist String
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 :: String -> String -> IO [String]
copyHeaderFiles String
srcDir String
destDir = [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    headerFiles <- String -> IO [String]
getHeaderFiles String
srcDir
    forM headerFiles $ \String
srcPath -> do
        srcIsSymlink <- String -> IO Bool
pathIsSymbolicLink String
srcPath
        let relPath = String -> String -> String
makeRelative String
srcDir String
srcPath
            destPath = String
destDir String -> String -> String
</> String
relPath
            destDirPath = String -> String
takeDirectory String
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