Write.hs

-- | Writes the generated files to support building with buck2
module Distribution.Client.Buck2.Write
  ( writeAllPackages
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (makeRelative, takeDirectory, takeFileName, (</>))

import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Distribution.ModuleName as ModuleName
import Distribution.Package (packageName)
import Distribution.PackageDescription
  ( Library (exposedModules, reexportedModules)
  , PackageDescription
  , library
  )
import Distribution.Simple.InstallDirs (PathTemplate)
import Distribution.Types.ComponentName (ComponentName)
import Distribution.Types.LocalBuildInfo (LocalBuildInfo)
import Distribution.Types.ModuleReexport
  ( ModuleReexport (moduleReexportOriginalName, moduleReexportOriginalPackage)
  )
import Distribution.Types.PackageName (PackageName)

import Distribution.Simple.Utils (notice, ordNub, warn)

import Distribution.Client.Buck2.Generate
import Distribution.Client.Buck2.Spec
import Distribution.Client.Buck2.Starlark

-- | Writes the following files for each package:
--
--   * @BUCK.cabal.bzl@ is fully regenerated on every run (it's marked
--     @\@generated@ and never hand-edited) and holds the package's build
--     spec, with a single @generated_targets()@ macro that creates the
--     rules from it. It would be nicer to put this under @cabal-buck2@
--     with the other generated files, but unfortunately buck2 makes
--     that hard by not allowing relative @load()@ declarations.
--   * @BUCK@ is created only if it doesn't already exist, as a two-line
--     file that loads and calls that macro. This is the file a user is
--     free to hand-edit - to add extra targets or customise the
--     target generation.
--   * @cabal-buck2\/autogen@ contains the autogenerated files needed
--     to compile the package, such as @cabal_macros.h@ and @Paths_<pkg>.hs@.
--   * @cabal-buck2\/autogen\/BUCK@ (see 'writeAutogenBuck') has
--     @export_file()@ rules for the autogen files, so they can be
--     easily referenced from anywhere else.
writeAllPackages :: Verbosity -> FilePath -> Map (PackageName, ComponentName) LocalBuildInfo -> Set String -> Map (PackageName, ComponentName) [PathTemplate] -> [(FilePath, PackageDescription)] -> IO ()
writeAllPackages verbosity projectRoot componentLBIs externalBuildTools projectTestOptions pkgs = do
  traverse_ (writeOnePackage verbosity localIndex projectRoot componentLBIs externalBuildTools projectTestOptions) pkgs
  where
    localIndex :: LocalPackageIndex
    localIndex =
      Map.fromList
        [ (packageName pkgDesc, (rootRelativeDir projectRoot pkgDir, reexportOrigins pkgDesc))
        | (pkgDir, pkgDesc) <- pkgs
        ]
    -- Every module exposed by any local package's main library, to
    -- resolve a `reexported-modules:` entry that names only the bare
    -- module, not an explicit `origin-package:Module` - Cabal itself
    -- resolves that form by searching the reexporting package's own
    -- build-depends for whichever one actually defines it, which for a
    -- \*local* origin this index can do too (an external origin doesn't
    -- need this: its real .conf file already declares the reexport
    -- directly to ghc-pkg).
    moduleOwners :: Map.Map ModuleName.ModuleName PackageName
    moduleOwners =
      Map.fromList
        [ (m, packageName pkgDesc)
        | (_, pkgDesc) <- pkgs
        , Just lib <- [library pkgDesc]
        , m <- exposedModules lib
        ]
    reexportOrigins pkgDesc =
      ordNub
        [ pn
        | Just lib <- [library pkgDesc]
        , reexport <- reexportedModules lib
        , Just pn <- [originPackage reexport]
        , pn /= packageName pkgDesc
        ]
    originPackage reexport = case moduleReexportOriginalPackage reexport of
      Just pn -> Just pn
      Nothing -> Map.lookup (moduleReexportOriginalName reexport) moduleOwners

rootRelativeDir :: FilePath -> FilePath -> FilePath
rootRelativeDir projectRoot pkgDir = case makeRelative projectRoot pkgDir of
  "" -> "."
  rel -> rel

writeOnePackage :: Verbosity -> LocalPackageIndex -> FilePath -> Map (PackageName, ComponentName) LocalBuildInfo -> Set String -> Map (PackageName, ComponentName) [PathTemplate] -> (FilePath, PackageDescription) -> IO ()
writeOnePackage verbosity localIndex projectRoot componentLBIs externalBuildTools projectTestOptions (pkgDir, pkgDesc) = do
  sources <- Set.fromList <$> filterM (doesFileExist . (pkgDir </>)) (sourceCandidates pkgDesc)
  let (mtargets, warnings) = generatePackageTargets localIndex (rootRelativeDir projectRoot pkgDir) componentLBIs externalBuildTools projectTestOptions sources pkgDesc
      pkgName = packageName pkgDesc
  traverse_ (warn verbosity) warnings
  case mtargets of
    Nothing -> warn verbosity $ "cabal buck2: no buck2 targets generated for package " ++ show pkgName
    Just targets -> do
      let bzlPath = pkgDir </> "BUCK.cabal.bzl"
          buckPath = pkgDir </> "BUCK"
      writeFile bzlPath (renderGeneratedBzl pkgName (ptSpec targets))
      buckExists <- doesFileExist buckPath
      unless buckExists $ writeFile buckPath renderBuckWrapper
      writeAutogenBuck pkgDir pkgName targets
      notice verbosity $
        "cabal buck2: generated "
          ++ (rootRelativeDir projectRoot pkgDir </> "BUCK.cabal.bzl")
          ++ " ("
          ++ show (ptComponentCount targets)
          ++ " component(s))"
          ++ (if buckExists then "" else ", created " ++ (rootRelativeDir projectRoot pkgDir </> "BUCK"))

-- | Generate an @export_file()@ rule for each autogen file, so that
-- the files can be easily referenced from somewhere else, including
-- subdirs.
writeAutogenBuck :: FilePath -> PackageName -> PackageTargets -> IO ()
writeAutogenBuck pkgDir pkgName targets
  | null files = return ()
  | otherwise = do
      createDirectoryIfMissing True autogenDir
      for_ files $ \f -> do
        createDirectoryIfMissing True (takeDirectory (autogenDir </> autogenPath f))
        writeFile (autogenDir </> autogenPath f) (autogenContents f)
      writeFile (autogenDir </> "BUCK") (renderFile header [] exportCalls)
  where
    files = ptAutogenFiles targets
    autogenDir = pkgDir </> "cabal-buck2" </> "autogen"
    header =
      "@generated by `cabal buck2` from "
        ++ prettyShow pkgName
        ++ ".cabal - do not edit by hand.\nRe-run `cabal buck2` after editing the .cabal file to refresh this file."
    exportCalls =
      [ call
        "export_file"
        [ ("name", str (autogenName f))
        , ("src", str (autogenPath f))
        , ("out", str (takeFileName (autogenPath f)))
        , -- For @Paths_<pkg>.hs@ it's important the exported file has the
          -- same name, because the buck2 Haskell rules derive the
          -- module name from it.
          ("visibility", strList ["PUBLIC"])
        ]
      | f <- files
      ]

renderGeneratedBzl :: PackageName -> BuildSpec -> String
renderGeneratedBzl pkgName spec =
  unlines
    [ "# @generated by `cabal buck2` from " ++ prettyShow pkgName ++ ".cabal - do not edit by hand."
    , "# Re-run `cabal buck2` after editing the .cabal file to refresh this file."
    , ""
    ]
    ++ renderLoad "//buck2:cabal.bzl" ["cabal_targets"]
    ++ "\n"
    ++ renderBinding "local_build_spec" (specValue spec)
    ++ "\n"
    -- kwargs: customisation passed by the BUCK file (see cabal_targets()
    -- in buck2/cabal.bzl).
    ++ "def generated_targets(**kwargs):\n    cabal_targets(local_build_spec, **kwargs)\n"

-- | A build spec as the Starlark dict that buck2\/cabal.bzl reads (see that
-- file for the schema). Optional keys are left out when empty.
specValue :: BuildSpec -> Value
specValue spec =
  VDict $
    [ ("schema", VInt specSchemaVersion)
    , ("package", VDict [("name", str (specPackageName spec)), ("dir", str (specPackageDir spec))])
    ]
      ++ listField "ghc_options" (specGhcOptions spec)
      ++ [("components", VList (map componentValue (specComponents spec)))]

componentValue :: SpecComponent -> Value
componentValue c =
  VDict $
    [("kind", str (kindName (scKind c))), ("name", str (scName c))]
      ++ [("main_is", srcValue src) | Just src <- [scMainIs c]]
      ++ [("srcs", VDict [(m, srcValue src) | (m, src) <- scSrcs c]) | not (null (scSrcs c))]
      ++ listField "test_args" (scTestArgs c)
      ++ listField "ghc_options" (scGhcOptions c)
      ++ listField "cpp_options" (scCppOptions c)
      ++ [("language", str lang) | Just lang <- [scLanguage c]]
      ++ listField "extensions" (scExtensions c)
      ++ listField "extra_libraries" (scExtraLibraries c)
      ++ valuesField "deps" (map depValue (scDeps c))
      ++ valuesField "build_tools" (map buildToolValue (scBuildTools c))
      ++ listField "c_sources" (scCSources c)
      ++ listField "cxx_sources" (scCxxSources c)
      ++ listField "cxx_options" (scCxxOptions c)
      ++ listField "include_dirs" (scIncludeDirs c)
      ++ listField "pkgconfig" (scPkgconfig c)

srcValue :: Src -> Value
srcValue (SrcFile path) = str path
srcValue (SrcAutogen name) = VDict [("autogen", str name)]

depValue :: SpecDep -> Value
depValue d =
  VDict $
    [("package", str (depPackage d))]
      ++ [("library", str lib) | Just lib <- [depLibrary d]]
      ++ [("dir", str dir) | Just dir <- [depDir d]]

buildToolValue :: SpecBuildTool -> Value
buildToolValue (LocalTool exe dir) = VDict [("exe", str exe), ("dir", str dir)]
buildToolValue (ExternalTool exe) = VDict [("exe", str exe), ("external", VBool True)]

-- | A list-valued field, omitted if empty.
listField :: String -> [String] -> [(String, Value)]
listField _ [] = []
listField k xs = [(k, strList xs)]

valuesField :: String -> [Value] -> [(String, Value)]
valuesField _ [] = []
valuesField k xs = [(k, VList xs)]

-- | Content of @BUCK@ in a package's directory
renderBuckWrapper :: String
renderBuckWrapper =
  unlines
    [ "# Hand-maintained: add extra targets below, or stop calling"
    , "# generated_targets() to fully take over this package's BUCK rules."
    , "#"
    , "# generated_targets() can be customised (see cabal_targets() in"
    , "# buck2/cabal.bzl), e.g."
    , "#"
    , "#     generated_targets("
    , "#         defaults = {\"*\": {\"compiler_flags\": [\"-O2\"]}},"
    , "#         overrides = {\"my-test\": {\"test_args\": [\"--quick\"]}},"
    , "#     )"
    , "load(\":BUCK.cabal.bzl\", \"generated_targets\")"
    , ""
    , "generated_targets()"
    ]