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 Data.List (stripPrefix)
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath (takeDirectory, takeFileName, (</>))

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

import Distribution.Package (packageName)
import Distribution.PackageDescription
  ( libName
  , pkgBuildableComponents
  )
import Distribution.Simple.InstallDirs (PathTemplate)
import Distribution.Types.Component (Component (CLib))
import Distribution.Types.ComponentName (ComponentName)
import Distribution.Types.LocalBuildInfo (LocalBuildInfo)
import Distribution.Types.PackageName (PackageName)

import Distribution.Simple.Utils (die', notice, warn)

import Distribution.Client.Buck2.Generate
import Distribution.Client.Buck2.LocalPackages (BuiltPackage (..), rootRelativeDir)
import Distribution.Client.Buck2.Spec
import Distribution.Client.Buck2.Starlark
import Distribution.Client.Buck2.Version (cabalBuck2Version)

-- | 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] -> [BuiltPackage] -> Bool -> IO ()
writeAllPackages verbosity projectRoot componentLBIs externalBuildTools projectTestOptions pkgs keepGoing = do
  sources <- traverse (\pkg -> Set.fromList <$> filterM (doesFileExist . (bpDir pkg </>)) (sourceCandidates (bpDescription pkg))) pkgs
  let generateAll skipped = [generate skipped pkg srcs | (pkg, srcs) <- zip pkgs sources]
      -- A library without a rule makes the components that depend on it
      -- skipped, and a library among those makes more of them skipped, so
      -- this goes on until nothing changes.
      fixpoint skipped =
        let results = generateAll skipped
            skipped' = skipped <> Set.fromList (concat [librariesWithoutRule pkg r | (pkg, r) <- zip pkgs results])
         in if skipped' == skipped then results else fixpoint skipped'
  let results = zip pkgs (fixpoint Set.empty)
      problems = concat [warnings | (_, (_, warnings)) <- results]
  unless (null problems) $
    if keepGoing
      then traverse_ (warn verbosity) problems
      else
        die' verbosity $
          unlines $
            ["cabal buck2: some components can't be built with buck2:"]
              ++ map (("  " ++) . withoutPrefix) problems
              ++ ["Use --keep-going to generate everything else anyway."]
  traverse_ (writeOnePackage verbosity projectRoot) results
  where
    generate skipped pkg srcs =
      generatePackageTargets localIndex projectRoot (rootRelativeDir projectRoot (bpDir pkg)) componentLBIs externalBuildTools projectTestOptions srcs skipped (bpInProject pkg) (bpDescription pkg)

    librariesWithoutRule pkg (targets, _) =
      [ (packageName desc, libName lib)
      | CLib lib <- pkgBuildableComponents desc
      , not (any (\c -> scKind c == Library && scName c == libTargetName (packageName desc) (libName lib)) (specComponents (ptSpec targets)))
      ]
      where
        desc = bpDescription pkg

    localIndex :: LocalPackageIndex
    localIndex =
      Map.fromList
        [ (packageName pkgDesc, LocalPackage{lpDir = rootRelativeDir projectRoot (bpDir pkg), lpDescription = pkgDesc})
        | pkg <- pkgs
        , let pkgDesc = bpDescription pkg
        ]

withoutPrefix :: String -> String
withoutPrefix = fromMaybe <*> stripPrefix "cabal buck2: "

writeOnePackage :: Verbosity -> FilePath -> (BuiltPackage, (PackageTargets, [String])) -> IO ()
writeOnePackage verbosity projectRoot (BuiltPackage{bpDir = pkgDir, bpDescription = pkgDesc}, (targets, _)) = do
  let pkgName = packageName pkgDesc
      bzlPath = pkgDir </> "BUCK.cabal.bzl"
      buckPath = pkgDir </> "BUCK"
  traverse_ (notice verbosity) (ptNotes targets)
  when (ptComponentCount targets == 0) $
    warn verbosity $ "cabal buck2: no buck2 targets generated for package " ++ prettyShow pkgName
  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 $
    [ ("cabal_buck2", str cabalBuck2Version)
    , ("package", VDict [("name", str (specPackageName spec)), ("version", str (specPackageVersion spec)), ("dir", str (specPackageDir spec))])
    ]
      ++ listField "ghc_options" (specGhcOptions spec)
      ++ [ ("data", VDict [("dir", str (specDataDir spec)), ("files", strList (specDataFiles spec))])
         | not (null (specDataFiles spec))
         ]
      ++ [("components", VList (map componentValue (specComponents spec)))]

componentValue :: SpecComponent -> Value
componentValue c =
  VDict $
    [("kind", str (kindName (scKind c))), ("name", str (scName c))]
      ++ [("exe_name", str exe) | Just exe <- [scExeName 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 "reexports" (map reexportValue (scReexports c))
      ++ valuesField "build_tools" (map buildToolValue (scBuildTools c))
      ++ listField "c_sources" (scCSources c)
      ++ listField "cc_options" (scCcOptions c)
      ++ listField "cxx_sources" (scCxxSources c)
      ++ listField "cxx_options" (scCxxOptions c)
      ++ listField "cmm_sources" (scCmmSources c)
      ++ listField "asm_sources" (scAsmSources c)
      ++ listField "asm_options" (scAsmOptions c)
      ++ listField "include_dirs" (scIncludeDirs c)
      ++ listField "hsc_options" (scHscOptions c)
      ++ listField "generated_include_dirs" (scGeneratedIncludeDirs 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]]

reexportValue :: SpecReexport -> Value
reexportValue r = VDict ([("module", str (reModule r)), ("original", str (reOriginal r))] ++ [("from", depValue d) | Just d <- [reFrom r]])

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()"
    ]