hwm-0.5.0: src/HWM/Integrations/Toolchain/Cabal.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module HWM.Integrations.Toolchain.Cabal
( validateHackage,
validateCabalSourceInclusion,
syncCabalProject,
HasSourceDirs (..),
CabalPackage,
newCabalPackage,
readCabalPackage,
nativeSdist,
setupCabalMatrixEnvironment,
)
where
import Control.Exception (IOException)
import Control.Exception.Base (try)
import Control.Monad.Except (MonadError (throwError))
import qualified Data.ByteString as BS
import Data.Foldable (Foldable (..))
import qualified Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.Package (packageVersion)
import Distribution.PackageDescription (Benchmark (..), Executable (..), ForeignLib (..), GenericPackageDescription (..), PackageDescription (..), PackageIdentifier (..), TestSuite (..), UnqualComponentName, emptyBuildInfo, emptyLibrary, emptyPackageDescription, mkPackageName, packageDescription)
import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage)
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.PackageDescription.Parsec
import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)
import Distribution.Simple.Flag (toFlag)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
import Distribution.Simple.PreProcess (knownSuffixHandlers)
import Distribution.Simple.Setup (SDistFlags (..), defaultSDistFlags)
import Distribution.Simple.SrcDist (sdist)
import Distribution.Text (display)
import Distribution.Types.BuildInfo (BuildInfo (..))
import Distribution.Types.CondTree (CondBranch (..), CondTree (..))
import Distribution.Types.Library (Library (..))
import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath)
import Distribution.Verbosity (normal)
import qualified Distribution.Verbosity as Verbosity
import HWM.Core.Common (Name)
import HWM.Core.Formatting (Format (..), Status (..))
import HWM.Core.Options (Options (..))
import HWM.Core.Pkg (IsPkg (..), PackageIO, Pkg (..), PkgName)
import qualified HWM.Core.Pkg as P
import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..))
import HWM.Core.Sync (SyncMode (..))
import HWM.Core.Version (Version, toCabalVersion)
import HWM.Domain.Build (Builder (CabalBuilder, NixBuilder))
import HWM.Domain.ConfigT (ConfigT)
import qualified HWM.Domain.ConfigT as CT
import HWM.Domain.Dependencies (Dependencies (..), HasDependencies (..), MapDeps (..), mkCabalDependency, toDependencyList)
import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment)
import HWM.Runtime.Files (syncFile)
import HWM.Runtime.Process (EnvVars)
import Hpack (Force (..), Options (..), Result (..), defaultOptions, hpackResult, setProgramName, setTarget)
import qualified Hpack as H
import Hpack.Config (ProgramName (..))
import Relude
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute, removePathForcibly, renameFile, withCurrentDirectory)
import System.FilePath (dropExtension, isExtensionOf, makeRelative, normalise, splitDirectories, takeDirectory, (</>))
toStatus :: PackageCheck -> Status
toStatus p
| isError p = Invalid
| otherwise = Warning
isError :: PackageCheck -> Bool
isError PackageDistInexcusable {} = True
isError PackageBuildImpossible {} = True
isError PackageBuildWarning {} = False
isError PackageDistSuspiciousWarn {} = False
isError PackageDistSuspicious {} = False
toIssue :: Pkg -> PackageCheck -> Issue
toIssue pkg check =
Issue
{ issueMessage = "Invalid Package [Cabal check]: " <> show check,
issueSeverity = if isError check then SeverityError else SeverityWarning,
issueTopic = P.pkgMemberId pkg,
issueDetails = Nothing
}
validateHackage :: Pkg -> ConfigT Status
validateHackage pkg = do
gpd <- liftIO $ readGenericPackageDescription normal (P.cabalFile pkg)
let ls = checkPackage gpd Nothing
for_ ls $ \l -> injectIssue (toIssue pkg l)
pure (maximum (Checked : map toStatus ls))
validateCabalSourceInclusion :: Pkg -> ConfigT Status
validateCabalSourceInclusion pkg = do
gpd <- liftIO $ readGenericPackageDescription normal (P.cabalFile pkg)
issues <- liftIO $ sourceInclusionIssues pkg gpd
for_ issues injectIssue
pure $ if null issues then Checked else Warning
sourceInclusionIssues :: Pkg -> GenericPackageDescription -> IO [Issue]
sourceInclusionIssues pkg gpd = do
expected <- syncGenericPackageDescription (takeDirectory (P.cabalFile pkg)) gpd
let declared = declaredModules gpd
let target = declaredModules expected
pure (mkSourceIssues pkg declared target)
declaredModules :: GenericPackageDescription -> Map Text (Set.Set ModuleName)
declaredModules GenericPackageDescription {..} =
Map.fromList
$ maybeToList ((\tree -> ("library", moduleSetLibrary (condTreeData tree))) <$> condLibrary)
<> map (\(name, tree) -> ("library:" <> format name, moduleSetLibrary (condTreeData tree))) condSubLibraries
<> map (\(name, tree) -> ("foreign:" <> format name, moduleSetForeign (condTreeData tree))) condForeignLibs
<> map (\(name, tree) -> ("exe:" <> format name, moduleSetExecutable (condTreeData tree))) condExecutables
<> map (\(name, tree) -> ("test:" <> format name, moduleSetTest (condTreeData tree))) condTestSuites
<> map (\(name, tree) -> ("bench:" <> format name, moduleSetBenchmark (condTreeData tree))) condBenchmarks
moduleSetLibrary :: Library -> Set.Set ModuleName
moduleSetLibrary Library {..} = Set.fromList (exposedModules <> otherModules libBuildInfo)
moduleSetForeign :: ForeignLib -> Set.Set ModuleName
moduleSetForeign ForeignLib {..} = Set.fromList (otherModules foreignLibBuildInfo)
moduleSetExecutable :: Executable -> Set.Set ModuleName
moduleSetExecutable Executable {..} = Set.fromList (otherModules buildInfo)
moduleSetTest :: TestSuite -> Set.Set ModuleName
moduleSetTest TestSuite {..} = Set.fromList (otherModules testBuildInfo)
moduleSetBenchmark :: Benchmark -> Set.Set ModuleName
moduleSetBenchmark Benchmark {..} = Set.fromList (otherModules benchmarkBuildInfo)
mkSourceIssues :: Pkg -> Map Text (Set.Set ModuleName) -> Map Text (Set.Set ModuleName) -> [Issue]
mkSourceIssues pkg declared target = concatMap toIssues (Set.toList labels)
where
labels = Set.union (Map.keysSet declared) (Map.keysSet target)
toIssues label =
let current = Map.findWithDefault Set.empty label declared
expected = Map.findWithDefault Set.empty label target
missingInCabal = map moduleToFile (Set.toList (Set.difference expected current))
missingInCode = map moduleToFile (Set.toList (Set.difference current expected))
in catMaybes
[ mkIssue SeverityWarning "Source files exist in codebase but are missing in .cabal" label missingInCabal,
mkIssue SeverityError "Modules/files declared in .cabal are missing in codebase" label missingInCode
]
mkIssue severity message component targets =
if null targets
then Nothing
else
Just
Issue
{ issueTopic = P.pkgMemberId pkg,
issueSeverity = severity,
issueMessage = message,
issueDetails = Just (SourceInclusionIssue component targets)
}
moduleToFile :: ModuleName -> Text
moduleToFile m = toText (ModuleName.toFilePath m <> ".hs")
instance PackageIO CabalPackage ConfigT where
rewritePackage = rewriteCabalPackage
readPackage = readCabalPackage
rewriteCabalPackage :: (CabalPackage -> ConfigT (Maybe CabalPackage)) -> Pkg -> ConfigT Status
rewriteCabalPackage mapCabal pkg = do
original <- readCabalPackage pkg
synced <- runCabalSync mapCabal pkg original
let changed = cbContent synced /= cbContent original
update <-
if changed
then case hpackFile pkg of
Just path -> hpackForceUpdate pkg path
Nothing -> liftIO (writeGenericPackageDescription (P.cabalFile pkg) (cbContent synced)) $> Updated
else pure Checked
validation <- validateHackage pkg
pure $ max validation update
runCabalSync :: (CabalPackage -> ConfigT (Maybe CabalPackage)) -> Pkg -> CabalPackage -> ConfigT CabalPackage
runCabalSync mapCabal pkg original = do
mapped <- fromMaybe original <$> mapCabal original
case hpackFile pkg of
Just _ -> pure mapped
Nothing -> liftIO (syncDiscoveredModules mapped)
hpackForceUpdate :: (MonadIO m) => Pkg -> FilePath -> m Status
hpackForceUpdate pkg path = do
let programName = ProgramName $ toString $ P.pkgName pkg
let ops = setTarget path $ setProgramName programName defaultOptions {optionsForce = Force}
Result {..} <- liftIO $ hpackResult ops
case resultStatus of
H.OutputUnchanged -> pure Checked
_ -> pure Updated
generateCabalProject :: Text -> BuildEnvironment -> Text
generateCabalProject prefix BuildEnvironment {..} =
T.unlines
$ ["with-compiler: ghc-" <> format buildGHC | not dependsOnNix]
<> ("packages:" : map printPkg buildPkgs)
where
printPkg pkg = " " <> prefix <> format (P.pkgDirPath pkg)
dependsOnNix = buildBuilder == CabalBuilder True || buildBuilder == NixBuilder
setupCabalMatrixEnvironment :: BuildEnvironment -> ConfigT EnvVars
setupCabalMatrixEnvironment env = do
matrixDir <- liftIO $ makeAbsolute ".hwm/matrix/"
liftIO $ createDirectoryIfMissing True matrixDir
let projectPath = matrixDir <> "cabal-" <> toString (buildName env) <> ".project"
_ <- syncFile projectPath (generateCabalProject "../../" env)
pure [("CABAL_PROJECT_FILE", projectPath)]
syncCabalProject :: SyncMode -> ConfigT Status
syncCabalProject SyncModeSync = do
cabalFilePath <- asks (optionsCabal . CT.options)
env <- getBuildEnvironment Nothing
syncFile cabalFilePath (generateCabalProject "" env)
syncCabalProject SyncModeCheck = do
cabalFilePath <- asks (optionsCabal . CT.options)
exists <- liftIO $ doesFileExist cabalFilePath
pure $ if exists then Checked else Warning
syncCabalProject SyncModeIgnore = pure Ignored
data CabalPackage = CabalPackage
{ cbDirectory :: FilePath,
cbContent :: GenericPackageDescription
}
deriving (Show)
readCabalFile :: (MonadIO m, MonadError Issue m) => Pkg -> m GenericPackageDescription
readCabalFile pkg = do
let path = P.cabalFile pkg
content <- liftIO $ BS.readFile path
case runParseResult (parseGenericPackageDescription content) of
(_, Right gpd) -> pure gpd
(_, Left (_, errors)) ->
throwError $ fromString $ "Cabal parsing failed: " ++ show errors
readCabalPackage :: (MonadIO m, MonadError Issue m) => Pkg -> m CabalPackage
readCabalPackage pkg = do
gpd <- readCabalFile pkg
pure
CabalPackage
{ cbDirectory = takeDirectory (P.cabalFile pkg),
cbContent = gpd
}
syncDiscoveredModules :: CabalPackage -> IO CabalPackage
syncDiscoveredModules pkg@CabalPackage {..} = do
nextContent <- syncGenericPackageDescription cbDirectory cbContent
pure pkg {cbContent = nextContent}
syncGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO GenericPackageDescription
syncGenericPackageDescription dir gpd@GenericPackageDescription {..} = do
nextLibrary <- traverse (mapCondTree syncLibraryModules dir) condLibrary
nextSubLibraries <- traverse (syncNamedCondTree syncLibraryModules dir) condSubLibraries
nextForeignLibs <- traverse (syncNamedCondTree syncForeignLibraryModules dir) condForeignLibs
nextExecutables <- traverse (syncNamedCondTree syncExecutableModules dir) condExecutables
nextTests <- traverse (syncNamedCondTree syncTestModules dir) condTestSuites
nextBenches <- traverse (syncNamedCondTree syncBenchmarkModules dir) condBenchmarks
pure
gpd
{ condLibrary = nextLibrary,
condSubLibraries = nextSubLibraries,
condForeignLibs = nextForeignLibs,
condExecutables = nextExecutables,
condTestSuites = nextTests,
condBenchmarks = nextBenches
}
syncNamedCondTree :: (FilePath -> a -> IO a) -> FilePath -> (k, CondTree v c a) -> IO (k, CondTree v c a)
syncNamedCondTree syncComponent dir (name, tree) = do
nextTree <- mapCondTree syncComponent dir tree
pure (name, nextTree)
mapCondTree :: (FilePath -> a -> IO a) -> FilePath -> CondTree v c a -> IO (CondTree v c a)
mapCondTree syncComponent dir tree@CondNode {..} = do
nextData <- syncComponent dir condTreeData
nextComponents <-
forM condTreeComponents $ \CondBranch {..} -> do
nextIf <- mapCondTree syncComponent dir condBranchIfTrue
nextElse <- traverse (mapCondTree syncComponent dir) condBranchIfFalse
pure CondBranch {condBranchCondition = condBranchCondition, condBranchIfTrue = nextIf, condBranchIfFalse = nextElse}
pure tree {condTreeData = nextData, condTreeComponents = nextComponents}
syncLibraryModules :: FilePath -> Library -> IO Library
syncLibraryModules dir lib@Library {..} = do
discovered <- discoverModules dir (map getSymbolicPath (hsSourceDirs libBuildInfo))
let generated = filter isGeneratedModule (otherModules libBuildInfo)
let expected = sort (Data.List.nub (generated <> discovered))
let declared = sort (Data.List.nub (exposedModules <> otherModules libBuildInfo))
if moduleListsEqual declared expected
then pure lib
else
pure
lib
{ exposedModules = discovered,
libBuildInfo = libBuildInfo {otherModules = sort (Data.List.nub generated)}
}
syncForeignLibraryModules :: FilePath -> ForeignLib -> IO ForeignLib
syncForeignLibraryModules dir foreignLib@ForeignLib {..} = do
discovered <- discoverModules dir (map getSymbolicPath (hsSourceDirs foreignLibBuildInfo))
let generated = filter isGeneratedModule (otherModules foreignLibBuildInfo)
let expected = sort (Data.List.nub (generated <> discovered))
let declared = sort (Data.List.nub (otherModules foreignLibBuildInfo))
if moduleListsEqual declared expected
then pure foreignLib
else pure foreignLib {foreignLibBuildInfo = foreignLibBuildInfo {otherModules = expected}}
syncExecutableModules :: FilePath -> Executable -> IO Executable
syncExecutableModules dir exe@Executable {..} = do
discovered <- discoverModules dir (map getSymbolicPath (hsSourceDirs buildInfo))
let mainModule = toModuleName modulePath
let generated = filter isGeneratedModule (otherModules buildInfo)
let discoveredWithoutMain = maybe discovered (`Data.List.delete` discovered) mainModule
let expected = sort (Data.List.nub (generated <> discoveredWithoutMain))
let declared = sort (Data.List.nub (otherModules buildInfo))
if moduleListsEqual declared expected
then pure exe
else pure exe {buildInfo = buildInfo {otherModules = expected}}
syncTestModules :: FilePath -> TestSuite -> IO TestSuite
syncTestModules dir test@TestSuite {..} = do
discovered <- discoverModules dir (map getSymbolicPath (hsSourceDirs testBuildInfo))
let generated = filter isGeneratedModule (otherModules testBuildInfo)
let expected = sort (Data.List.nub (generated <> discovered))
let declared = sort (Data.List.nub (otherModules testBuildInfo))
if moduleListsEqual declared expected
then pure test
else pure test {testBuildInfo = testBuildInfo {otherModules = expected}}
syncBenchmarkModules :: FilePath -> Benchmark -> IO Benchmark
syncBenchmarkModules dir bench@Benchmark {..} = do
discovered <- discoverModules dir (map getSymbolicPath (hsSourceDirs benchmarkBuildInfo))
let generated = filter isGeneratedModule (otherModules benchmarkBuildInfo)
let expected = sort (Data.List.nub (generated <> discovered))
let declared = sort (Data.List.nub (otherModules benchmarkBuildInfo))
if moduleListsEqual declared expected
then pure bench
else pure bench {benchmarkBuildInfo = benchmarkBuildInfo {otherModules = expected}}
discoverModules :: FilePath -> [FilePath] -> IO [ModuleName]
discoverModules dir sourceDirs = do
files <- concat <$> traverse (discoverModulesInDir dir) sourceDirs
pure (sort (Data.List.nub files))
discoverModulesInDir :: FilePath -> FilePath -> IO [ModuleName]
discoverModulesInDir base sourceDir = do
let root = normalise (base </> sourceDir)
exists <- doesDirectoryExist root
if not exists
then pure []
else do
hsFiles <- walkHsFiles root
pure (mapMaybe (toModuleName . makeRelative root) hsFiles)
walkHsFiles :: FilePath -> IO [FilePath]
walkHsFiles dir = do
children <- listDirectory dir
paths <-
forM children $ \name -> do
let path = dir </> name
isDir <- doesDirectoryExist path
if isDir
then walkHsFiles path
else pure [path | ".hs" `isExtensionOf` path]
pure (concat paths)
toModuleName :: FilePath -> Maybe ModuleName
toModuleName path =
if ".hs" `isExtensionOf` path
then
let parts = splitDirectories (dropExtension path)
cleaned = filter (not . null) parts
in if null cleaned then Nothing else Just (ModuleName.fromString (Data.List.intercalate "." cleaned))
else Nothing
isGeneratedModule :: ModuleName -> Bool
isGeneratedModule moduleName = "Paths_" `isPrefixOf` ModuleName.toFilePath moduleName
moduleListsEqual :: [ModuleName] -> [ModuleName] -> Bool
moduleListsEqual a b = Set.fromList a == Set.fromList b
class HasSourceDirs a where
getSourceDirs :: [Text] -> a -> [(Text, Name)]
instance (HasSourceDirs a) => HasSourceDirs (Maybe a) where
getSourceDirs tag (Just l) = getSourceDirs tag l
getSourceDirs _ Nothing = []
instance (HasSourceDirs a) => HasSourceDirs (Map Text a) where
getSourceDirs tags libs = concatMap (\(name, lib) -> getSourceDirs (tags <> [name]) lib) (Map.toList libs)
instance HasSourceDirs CabalPackage where
getSourceDirs p CabalPackage {..} = getSourceDirs p cbContent
instance HasSourceDirs GenericPackageDescription where
getSourceDirs p GenericPackageDescription {..} =
getSourceDirs (p <> ["lib"]) condLibrary
<> getSourceDirs (p <> ["exe"]) condExecutables
<> getSourceDirs (p <> ["test"]) condTestSuites
<> getSourceDirs (p <> ["bench"]) condBenchmarks
instance (HasSourceDirs a) => HasSourceDirs (CondTree v c a) where
getSourceDirs path condTree = getSourceDirs path (condTreeData condTree)
instance (HasSourceDirs a) => HasSourceDirs [(UnqualComponentName, a)] where
getSourceDirs path = concatMap (\(name, info) -> getSourceDirs (path <> [format name]) info)
instance HasSourceDirs Library where
getSourceDirs path Library {..} = getSourceDirs path libBuildInfo
instance HasSourceDirs Executable where
getSourceDirs path Executable {..} = getSourceDirs path buildInfo
instance HasSourceDirs TestSuite where
getSourceDirs path TestSuite {..} = getSourceDirs path testBuildInfo
instance HasSourceDirs Benchmark where
getSourceDirs path Benchmark {..} = getSourceDirs path benchmarkBuildInfo
instance HasSourceDirs BuildInfo where
getSourceDirs path buildInfo = map (withKey . getSymbolicPath) (hsSourceDirs buildInfo)
where
withKey dir = (T.intercalate ":" path, format dir)
instance IsPkg CabalPackage where
getPkgName = getPkgName . cbContent
getPkgVersion = getPkgVersion . cbContent
setVersion version pkg = pkg {cbContent = setVersion version (cbContent pkg)}
instance HasDependencies CabalPackage where
collectDependencies xs gpd = collectDependencies xs (cbContent gpd)
instance MapDeps CabalPackage where
mapDeps ctx f cabalPkg = do
newGpd <- mapDeps ctx f (cbContent cabalPkg)
pure cabalPkg {cbContent = newGpd}
newCabalPackage :: (MonadError Issue m, MonadIO m) => FilePath -> PkgName -> Version -> Dependencies -> m Status
newCabalPackage dir name version deps = do
let package = emptyPackage name version deps
liftIO $ writeGenericPackageDescription (dir </> (toString name <> ".cabal")) package
pure Updated
emptyPackage :: PkgName -> Version -> Dependencies -> GenericPackageDescription
emptyPackage (P.PkgName name) version dependencies =
let lib =
emptyLibrary
{ libBuildInfo =
emptyBuildInfo
{ targetBuildDepends = map mkCabalDependency (toDependencyList dependencies),
hsSourceDirs = [unsafeMakeSymbolicPath "src"]
}
}
in GenericPackageDescription
{ packageDescription =
emptyPackageDescription
{ package = PackageIdentifier (mkPackageName (toString name)) (toCabalVersion version),
library = Just lib
},
condLibrary = Just (CondNode lib [] []),
condExecutables = [],
condTestSuites = [],
condBenchmarks = [],
gpdScannedVersion = Nothing,
genPackageFlags = [],
condSubLibraries = [],
condForeignLibs = []
}
err :: Pkg -> Text -> Issue
err pkg msg = Issue (P.pkgMemberId pkg) SeverityError msg Nothing
nativeSdist :: Pkg -> ConfigT ((Pkg, Maybe FilePath), [Issue])
nativeSdist pkg = do
gpkg <- readCabalFile pkg
outDir <- liftIO (makeAbsolute $ "./.hwm/sdist" </> toString (P.pkgName pkg))
(filePath, issues) <- runNativeSDist pkg (flattenPackageDescription gpkg) outDir
pure ((pkg, filePath), issues <> map (toIssue pkg) (checkPackage gpkg Nothing))
runNativeSDist :: Pkg -> PackageDescription -> FilePath -> ConfigT (Maybe FilePath, [Issue])
runNativeSDist pkg pkgDesc outDir = do
let tarName = toString (P.pkgName pkg) <> "-" <> display (packageVersion (package pkgDesc)) <> ".tar.gz"
-- We'll look for it here: package_dir/dist/package-version.tar.gz
localDistDir = P.pkgDirPath pkg </> "dist"
tempTarPath = localDistDir </> tarName
finalPath = outDir </> tarName
result <- liftIO $ try $ do
-- Setup the HWM output dir
removePathForcibly outDir
createDirectoryIfMissing True outDir
-- prepare the 'dist' folder inside the package dir and run sdist
removePathForcibly localDistDir
createDirectoryIfMissing True localDistDir
withCurrentDirectory (P.pkgDirPath pkg) $ sdist pkgDesc (defaultSDistFlags {sDistVerbosity = toFlag Verbosity.silent}) (const "") knownSuffixHandlers
exists <- doesFileExist tempTarPath
if exists
then renameFile tempTarPath finalPath >> pure (Just finalPath)
else pure Nothing
case result of
Right (Just path) -> pure (Just path, [])
Right Nothing ->
pure (Nothing, [err pkg $ "Cabal sdist ran, but " <> toText tarName <> " was not found."])
Left (e :: IOException) ->
pure (Nothing, [err pkg $ "Cabal sdist IO Error: " <> show e])