diff --git a/hwm.cabal b/hwm.cabal --- a/hwm.cabal +++ b/hwm.cabal @@ -1,157 +1,199 @@ -cabal-version: 1.12 +cabal-version: 1.12 +name: hwm +version: 0.2.0 +license: MIT +license-file: LICENSE +copyright: (c) 2026 Daviti Nalchevanidze +maintainer: d.nalchevanidze@gmail.com +author: Daviti Nalchevanidze +homepage: https://github.com/nalchevanidze/hwm#readme +bug-reports: https://github.com/nalchevanidze/hwm/issues +synopsis: + Haskell Workspace Manager - Orchestrates Stack, Cabal, and HLS --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack +description: + HWM (Haskell Workspace Manager) manages multi-package Haskell projects by + generating and synchronizing configuration files for Stack, Cabal, Hpack, and HLS + from a single source of truth (hwm.yaml). It handles dependency management, + build matrices across GHC versions, and coordinated package releases. -name: hwm -version: 0.1.2 -synopsis: Haskell Workspace Manager - Orchestrates Stack, Cabal, and HLS -description: HWM (Haskell Workspace Manager) manages multi-package Haskell projects by - generating and synchronizing configuration files for Stack, Cabal, Hpack, and HLS - from a single source of truth (hwm.yaml). It handles dependency management, - build matrices across GHC versions, and coordinated package releases. -category: Development -homepage: https://github.com/nalchevanidze/hwm#readme -bug-reports: https://github.com/nalchevanidze/hwm/issues -author: Daviti Nalchevanidze -maintainer: d.nalchevanidze@gmail.com -copyright: (c) 2026 Daviti Nalchevanidze -license: MIT -license-file: LICENSE -build-type: Simple +category: Development +build-type: Simple extra-source-files: README.md CHANGELOG.md source-repository head - type: git - location: https://github.com/nalchevanidze/hwm + type: git + location: https://github.com/nalchevanidze/hwm library - exposed-modules: - HWM.CLI.App - HWM.CLI.Command - HWM.CLI.Command.Environment.Add - HWM.CLI.Command.Environment.Ls - HWM.CLI.Command.Environment.Remove - HWM.CLI.Command.Environment.Root - HWM.CLI.Command.Environment.SetDefault - HWM.CLI.Command.Init - HWM.CLI.Command.Registry.Add - HWM.CLI.Command.Registry.Audit - HWM.CLI.Command.Registry.Ls - HWM.CLI.Command.Registry.Root - HWM.CLI.Command.Release.Artifacts - HWM.CLI.Command.Release.Publish - HWM.CLI.Command.Release.Root - HWM.CLI.Command.Run - HWM.CLI.Command.Status - HWM.CLI.Command.Sync - HWM.CLI.Command.Version - HWM.CLI.Command.Workspace.Add - HWM.CLI.Command.Workspace.Ls - HWM.CLI.Command.Workspace.Root - HWM.Core.Common - HWM.Core.Formatting - HWM.Core.Has - HWM.Core.Options - HWM.Core.Parsing - HWM.Core.Pkg - HWM.Core.Result - HWM.Core.Version - HWM.Domain.Bounds - HWM.Domain.Config - HWM.Domain.ConfigT - HWM.Domain.Dependencies - HWM.Domain.Environments - HWM.Domain.Release - HWM.Domain.Workspace - HWM.Integrations.Scaffold - HWM.Integrations.Toolchain.Cabal - HWM.Integrations.Toolchain.Github - HWM.Integrations.Toolchain.Hie - HWM.Integrations.Toolchain.Lib - HWM.Integrations.Toolchain.Package - HWM.Integrations.Toolchain.Stack - HWM.Runtime.Archive - HWM.Runtime.Cache - HWM.Runtime.Files - HWM.Runtime.Logging - HWM.Runtime.Network - HWM.Runtime.Platform - HWM.Runtime.Process - HWM.Runtime.Snapshots - HWM.Runtime.UI - other-modules: - Paths_hwm - hs-source-dirs: - src - ghc-options: -Wall - build-depends: - Cabal >=3.8 && <=3.16.1.0 - , Glob >=0.10.1 && <=0.10.2 - , aeson >=1.5.6.0 && <=2.2.3.0 - , ansi-terminal >=0.11.3 && <=1.1.5 - , async >2.2.3 && <=2.2.6 - , base >=4.7.0 && <5.0.0 - , base16-bytestring >=1.0.1.0 && <=1.0.2.0 - , bytestring >=0.10.4 && <=0.12.2.0 - , containers >=0.4.2.1 && <=0.8 - , cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1 - , directory >=1.0 && <=1.3.10.1 - , filepath >=1.1.0 && <=1.5.5.0 - , hpack >0.34.4 && <=0.39.1 - , modern-uri >=0.3.4.1 && <=0.3.6.1 - , mtl >2.0.0 && <2.6.0 - , optparse-applicative >=0.16.1.0 && <=0.19.0.0 - , process >=1.0.0 && <2.0.0 - , relude >=0.7.0.0 && <=1.2.2.2 - , req >=3.9.0 && <=3.13.4 - , stm >=2.4 && <2.6.0 - , text >=1.2.3 && <3.0.0 - , time >=1.9.2 && <2.0.0 - , transformers >=0.5.6 && <0.7.0 - , typed-process >=0.2.6.1 && <=0.2.13.0 - , unordered-containers >=0.2.14.0 && <=0.2.21 - , yaml >=0.11.5.0 && <=0.11.11.2 - , zip-archive >=0.4.1 && <=0.4.3.2 - default-language: Haskell2010 + exposed-modules: + HWM.CLI.App + HWM.CLI.Command + HWM.CLI.Command.Environment.Add + HWM.CLI.Command.Environment.Ls + HWM.CLI.Command.Environment.Remove + HWM.CLI.Command.Environment.Root + HWM.CLI.Command.Environment.SetDefault + HWM.CLI.Command.Init + HWM.CLI.Command.Registry.Add + HWM.CLI.Command.Registry.Audit + HWM.CLI.Command.Registry.Ls + HWM.CLI.Command.Registry.Root + HWM.CLI.Command.Release.Artifacts + HWM.CLI.Command.Release.Publish + HWM.CLI.Command.Release.Root + HWM.CLI.Command.Run + HWM.CLI.Command.Status + HWM.CLI.Command.Sync + HWM.CLI.Command.Version + HWM.CLI.Command.Workspace.Add + HWM.CLI.Command.Workspace.Ls + HWM.CLI.Command.Workspace.Root + HWM.Core.Common + HWM.Core.Formatting + HWM.Core.Has + HWM.Core.Options + HWM.Core.Parsing + HWM.Core.Pkg + HWM.Core.Result + HWM.Core.Version + HWM.Domain.Bounds + HWM.Domain.Config + HWM.Domain.ConfigT + HWM.Domain.Dependencies + HWM.Domain.Environments + HWM.Domain.Registry + HWM.Domain.Release + HWM.Domain.Workspace + HWM.Integrations.Scaffold + HWM.Integrations.Toolchain.Cabal + HWM.Integrations.Toolchain.Github + HWM.Integrations.Toolchain.Hie + HWM.Integrations.Toolchain.Hpack + HWM.Integrations.Toolchain.Nix + HWM.Integrations.Toolchain.Package + HWM.Integrations.Toolchain.Stack + HWM.Runtime.Archive + HWM.Runtime.Cache + HWM.Runtime.Files + HWM.Runtime.Logging + HWM.Runtime.Network + HWM.Runtime.Platform + HWM.Runtime.Process + HWM.Runtime.Snapshots + HWM.Runtime.UI + hs-source-dirs: src + other-modules: Paths_hwm + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + Cabal >=3.8 && <=3.16.1.0, + Glob >=0.10.1 && <=0.10.2, + aeson >=1.5.6.0 && <=2.2.3.0, + ansi-terminal >=0.11.3 && <=1.1.5, + async >2.2.3 && <=2.2.6, + base >=4.7.0 && <5.0.0, + base16-bytestring >=1.0.1.0 && <=1.0.2.0, + bytestring >=0.10.4 && <=0.12.2.0, + containers >=0.4.2.1 && <=0.8, + cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1, + directory >=1.0 && <=1.3.10.1, + filepath >=1.1.0 && <=1.5.5.0, + hpack >0.34.4 && <=0.39.1, + modern-uri >=0.3.4.1 && <=0.3.6.1, + mtl >2.0.0 && <2.6.0, + optparse-applicative >=0.16.1.0 && <=0.19.0.0, + process >=1.0.0 && <2.0.0, + relude >=0.7.0.0 && <=1.2.2.2, + req >=3.9.0 && <=3.13.4, + stm >=2.4 && <2.6.0, + text >=1.2.3 && <3.0.0, + time >=1.9.2 && <2.0.0, + transformers >=0.5.6 && <0.7.0, + typed-process >=0.2.6.1 && <=0.2.13.0, + unordered-containers >=0.2.14.0 && <=0.2.21, + yaml >=0.11.5.0 && <=0.11.11.2, + zip-archive >=0.4.1 && <=0.4.3.2 + executable hwm - main-is: Main.hs - other-modules: - Paths_hwm - hs-source-dirs: - app - ghc-options: -Wall - build-depends: - Cabal >=3.8 && <=3.16.1.0 - , Glob >=0.10.1 && <=0.10.2 - , aeson >=1.5.6.0 && <=2.2.3.0 - , ansi-terminal >=0.11.3 && <=1.1.5 - , async >2.2.3 && <=2.2.6 - , base >=4.7.0 && <5.0.0 - , base16-bytestring >=1.0.1.0 && <=1.0.2.0 - , bytestring >=0.10.4 && <=0.12.2.0 - , containers >=0.4.2.1 && <=0.8 - , cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1 - , directory >=1.0 && <=1.3.10.1 - , filepath >=1.1.0 && <=1.5.5.0 - , hpack >0.34.4 && <=0.39.1 - , hwm >=0.1.0 && <0.2.0 - , modern-uri >=0.3.4.1 && <=0.3.6.1 - , mtl >2.0.0 && <2.6.0 - , optparse-applicative >=0.16.1.0 && <=0.19.0.0 - , process >=1.0.0 && <2.0.0 - , relude >=0.7.0.0 && <=1.2.2.2 - , req >=3.9.0 && <=3.13.4 - , stm >=2.4 && <2.6.0 - , text >=1.2.3 && <3.0.0 - , time >=1.9.2 && <2.0.0 - , transformers >=0.5.6 && <0.7.0 - , typed-process >=0.2.6.1 && <=0.2.13.0 - , unordered-containers >=0.2.14.0 && <=0.2.21 - , yaml >=0.11.5.0 && <=0.11.11.2 - , zip-archive >=0.4.1 && <=0.4.3.2 - default-language: Haskell2010 + main-is: Main.hs + hs-source-dirs: app + other-modules: Paths_hwm + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + Cabal >=3.8 && <=3.16.1.0, + Glob >=0.10.1 && <=0.10.2, + aeson >=1.5.6.0 && <=2.2.3.0, + ansi-terminal >=0.11.3 && <=1.1.5, + async >2.2.3 && <=2.2.6, + base >=4.7.0 && <5.0.0, + base16-bytestring >=1.0.1.0 && <=1.0.2.0, + bytestring >=0.10.4 && <=0.12.2.0, + containers >=0.4.2.1 && <=0.8, + cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1, + directory >=1.0 && <=1.3.10.1, + filepath >=1.1.0 && <=1.5.5.0, + hpack >0.34.4 && <=0.39.1, + hwm >=0.2.0 && <0.3.0, + modern-uri >=0.3.4.1 && <=0.3.6.1, + mtl >2.0.0 && <2.6.0, + optparse-applicative >=0.16.1.0 && <=0.19.0.0, + process >=1.0.0 && <2.0.0, + relude >=0.7.0.0 && <=1.2.2.2, + req >=3.9.0 && <=3.13.4, + stm >=2.4 && <2.6.0, + text >=1.2.3 && <3.0.0, + time >=1.9.2 && <2.0.0, + transformers >=0.5.6 && <0.7.0, + typed-process >=0.2.6.1 && <=0.2.13.0, + unordered-containers >=0.2.14.0 && <=0.2.21, + yaml >=0.11.5.0 && <=0.11.11.2, + zip-archive >=0.4.1 && <=0.4.3.2 + +test-suite hwm-golden-sync + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + Commands.Init + Commands.Sync + Utils.Core + Utils.Golden + Paths_hwm + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + Cabal >=3.8 && <=3.16.1.0, + Glob >=0.10.1 && <=0.10.2, + aeson >=1.5.6.0 && <=2.2.3.0, + ansi-terminal >=0.11.3 && <=1.1.5, + async >2.2.3 && <=2.2.6, + base >=4.7.0 && <5.0.0, + base16-bytestring >=1.0.1.0 && <=1.0.2.0, + bytestring >=0.10.4 && <=0.12.2.0, + containers >=0.4.2.1 && <=0.8, + cryptohash-sha256 >=0.11.102.0 && <=0.11.102.1, + directory >=1.0 && <=1.3.10.1, + filepath >=1.1.0 && <=1.5.5.0, + hpack >0.34.4 && <=0.39.1, + hspec >=0.0 && >=0.0, + modern-uri >=0.3.4.1 && <=0.3.6.1, + mtl >2.0.0 && <2.6.0, + optparse-applicative >=0.16.1.0 && <=0.19.0.0, + process >=1.0.0 && <2.0.0, + relude >=0.7.0.0 && <=1.2.2.2, + req >=3.9.0 && <=3.13.4, + stm >=2.4 && <2.6.0, + temporary >=0.0 && >=0.0, + text >=1.2.3 && <3.0.0, + time >=1.9.2 && <2.0.0, + transformers >=0.5.6 && <0.7.0, + typed-process >=0.2.6.1 && <=0.2.13.0, + unordered-containers >=0.2.14.0 && <=0.2.21, + yaml >=0.11.5.0 && <=0.11.11.2, + zip-archive >=0.4.1 && <=0.4.3.2 diff --git a/src/HWM/CLI/App.hs b/src/HWM/CLI/App.hs --- a/src/HWM/CLI/App.hs +++ b/src/HWM/CLI/App.hs @@ -111,7 +111,7 @@ if v then putStrLn ("HWM v" ++ currentVersion) else case cmd of - Just c -> runCommand c (defaultOptions {quiet = q}) + Just c -> runCommand c (defaultOptions {optionsQuiet = q}) Nothing -> do putStrLn "HWM: Missing command.\nTry 'hwm --help' for usage." exitFailure diff --git a/src/HWM/CLI/Command/Environment/Add.hs b/src/HWM/CLI/Command/Environment/Add.hs --- a/src/HWM/CLI/Command/Environment/Add.hs +++ b/src/HWM/CLI/Command/Environment/Add.hs @@ -5,24 +5,22 @@ module HWM.CLI.Command.Environment.Add (EnvAddOptions, runEnvAdd) where import Control.Monad.Except (throwError) -import qualified Data.Map as M import qualified Data.Map as Map -import qualified Data.Text as T import HWM.Core.Common (Name) import HWM.Core.Formatting (Format (..), padDots) -import HWM.Core.Parsing (ParseCLI (..)) +import HWM.Core.Parsing (Parse (..), ParseCLI (..)) +import HWM.Core.Version (Version) import HWM.Domain.Config (Config (..)) import HWM.Domain.ConfigT (ConfigT, updateConfig) import HWM.Domain.Environments (Environments (..), existsEnviroment, newEnv, printEnvironments) -import HWM.Runtime.Cache (getSnapshotGHC) -import HWM.Runtime.Snapshots (SnapshotInfo (..), fetchLtsSuggestions, fetchStackageSnapshots) import HWM.Runtime.UI (putLine, section) import Options.Applicative (help, metavar, strArgument) +import Options.Applicative.Builder (argument, str) import Relude data EnvAddOptions = EnvAddOptions { envName :: Name, - envResolver :: Name + envGHC :: Version } deriving (Show) @@ -30,14 +28,7 @@ parseCLI = EnvAddOptions <$> strArgument (metavar "NAME" <> help "Name of the environment to add") - <*> strArgument (metavar "RESOLVER" <> help "Stackage resolver (e.g. lts-21.24)") - -printSuggestions :: [Text] -> [Text] -> Text -printSuggestions [] alt - | null alt = "" - | otherwise = " Here are some available snapshots: " <> T.intercalate ", " alt <> "." -printSuggestions [s] _ = " Did you mean '" <> s <> "'?" -printSuggestions suggestions _ = " Did you mean one of: " <> T.intercalate ", " suggestions <> "?" + <*> argument (str >>= parse) (metavar "GHC" <> help "GHC version (e.g. 8.10.7)") size :: Int size = 16 @@ -51,18 +42,9 @@ throwError $ fromString $ "Environment '" <> toString envName <> "' already exists." else section "new environment" $ do putLine $ padDots size "name" <> envName - ltsMap <- fetchLtsSuggestions - snapshots <- map snapshotName <$> fetchStackageSnapshots - let suggestions = M.elems ltsMap <> take 12 (filter (not . isPrefixOf "nightly" . toString) snapshots) - let prefixMatches = filter (isPrefixOf (toString envResolver) . toString) snapshots - case M.lookup envResolver ltsMap <|> find (== envResolver) snapshots of - Nothing -> throwError $ fromString $ "Resolver '" <> toString envResolver <> "' is not a valid Stackage snapshot." <> toString (printSuggestions prefixMatches suggestions) - Just resolver -> do - putLine $ padDots size "resolver" <> envName - updateConfig - ( \cfg@Config {..} -> do - ghc <- getSnapshotGHC resolver - putLine $ padDots size "ghc" <> format ghc - pure cfg {cfgEnvironments = cfgEnvironments {envTargets = Map.insert envName (newEnv ghc resolver) (envTargets cfgEnvironments)}} - ) - (pure ()) + updateConfig + ( \cfg@Config {..} -> do + putLine $ padDots size "ghc" <> format envGHC + pure cfg {cfgEnvironments = cfgEnvironments {envProfiles = Map.insert envName (newEnv envGHC) (envProfiles cfgEnvironments)}} + ) + (pure ()) diff --git a/src/HWM/CLI/Command/Init.hs b/src/HWM/CLI/Command/Init.hs --- a/src/HWM/CLI/Command/Init.hs +++ b/src/HWM/CLI/Command/Init.hs @@ -13,13 +13,14 @@ import HWM.Core.Formatting (Color (Cyan), Format (format), chalk, padDots) import HWM.Core.Options (Options (..)) import HWM.Core.Parsing (ParseCLI (..), flag) -import HWM.Core.Pkg (Pkg (..), scanPkgs) +import HWM.Core.Pkg (IsPkg (..), scanPkgs) import HWM.Core.Result (Issue) import HWM.Core.Version (Version) import HWM.Domain.Config (Config (..), defaultScripts) import HWM.Domain.ConfigT (resolveResultUI, saveConfig) +import HWM.Domain.Registry (deriveRegistry) import HWM.Domain.Workspace (buildWorkspace) -import HWM.Integrations.Toolchain.Package (deriveRegistry) +import HWM.Integrations.Toolchain.Cabal (readCabalPackage) import HWM.Integrations.Toolchain.Stack (buildMatrix, scanStackFiles) import HWM.Runtime.Files (forbidOverride) import HWM.Runtime.UI (MonadUI, putLine, runUI, section) @@ -52,22 +53,27 @@ root <- liftIO getCurrentDirectory let cfgName = fromMaybe (deriveName root) projectName section "init" $ do - unless forceOverride $ forbidOverride (normalise (root hwm opts)) + unless forceOverride $ forbidOverride (normalise (root optionsHwm opts)) stacks <- scanStackFiles opts root scanning "stack.yaml" stacks pkgs <- scanPkgs root scanning "packages" pkgs - when (null pkgs) $ throwError "No packages listed in stack.yaml. Add at least one package before running 'hwm init'" - (cfgRegistry, graph) <- deriveRegistry pkgs - cfgVersion <- deriveVersion (map pkgVersion pkgs) + when (null pkgs) + $ throwError + "No Haskell packages detected in the current directory.\n\ + \Please ensure you are in the project's root and that your packages are discoverable.\n\ + \Try running 'hwm init' from the root directory containing your package sources." + packages <- traverse readCabalPackage pkgs + cfgVersion <- deriveVersion (map getPkgVersion packages) cfgEnvironments <- buildMatrix pkgs stacks - cfgWorkspace <- buildWorkspace graph pkgs + cfgWorkspace <- buildWorkspace pkgs saveConfig Config { cfgGithub = Nothing, cfgBounds = Nothing, - cfgScripts = defaultScripts, + cfgScripts = Just defaultScripts, cfgRelease = Nothing, + cfgRegistry = Just (deriveRegistry packages), .. } opts diff --git a/src/HWM/CLI/Command/Registry/Add.hs b/src/HWM/CLI/Command/Registry/Add.hs --- a/src/HWM/CLI/Command/Registry/Add.hs +++ b/src/HWM/CLI/Command/Registry/Add.hs @@ -11,8 +11,9 @@ import HWM.Domain.Bounds (deriveBounds) import HWM.Domain.Config (Config (..)) import HWM.Domain.ConfigT (ConfigT, Env (config), updateConfig) -import HWM.Domain.Dependencies (Dependency (Dependency), lookupBounds, singleDeps) +import HWM.Domain.Dependencies (Dependency (Dependency)) import HWM.Domain.Environments (getTestedRange) +import HWM.Domain.Registry (addDependency, lookupBounds) import HWM.Domain.Workspace (forWorkspaceTuple, resolveWorkspaces) import HWM.Integrations.Toolchain.Package import HWM.Runtime.UI (putLine, section, sectionConfig, sectionTableM) @@ -35,7 +36,7 @@ [ ("package", pure $ chalk Magenta (format opsPkgName)), ("target", pure $ chalk Cyan (if null opsWorkspace then "none (registry only)" else T.intercalate ", " opsWorkspace)) ] - registered <- asks (lookupBounds opsPkgName . cfgRegistry . config) + registered <- asks (lookupBounds opsPkgName . fromMaybe mempty . cfgRegistry . config) case registered of Nothing -> do range <- getTestedRange @@ -45,7 +46,7 @@ bounds <- deriveBounds opsPkgName range let dependency = Dependency opsPkgName bounds - ((\cf -> pure cf {cfgRegistry = cfgRegistry cf <> singleDeps dependency}) `updateConfig`) $ do + ((\cf -> pure cf {cfgRegistry = Just $ addDependency dependency (fromMaybe mempty (cfgRegistry cf))}) `updateConfig`) $ do sectionConfig [("hwm.yaml", pure $ chalk Green "✓")] addDepToPackage workspaces dependency Just bounds -> do @@ -53,7 +54,4 @@ putLine $ padDots 16 "registry" <> format bounds <> " (already registered)" addDepToPackage workspaces (Dependency opsPkgName bounds) where - addDepToPackage ws dependency = - unless (null ws) - $ forWorkspaceTuple ws - $ \pkg -> updatePackage (packageModifyDependencies (\deps -> pure (deps <> singleDeps dependency))) pkg + addDepToPackage ws dependency = unless (null ws) $ forWorkspaceTuple ws $ addPkgDependency dependency diff --git a/src/HWM/CLI/Command/Registry/Audit.hs b/src/HWM/CLI/Command/Registry/Audit.hs --- a/src/HWM/CLI/Command/Registry/Audit.hs +++ b/src/HWM/CLI/Command/Registry/Audit.hs @@ -9,9 +9,9 @@ import HWM.Core.Result (Issue (..), MonadIssue (..), Severity (..)) import HWM.Domain.Bounds (BoundCompliance (..), auditBounds, auditHasAny, formatAudit, updateDepBounds) import HWM.Domain.Config (Config (..)) -import HWM.Domain.ConfigT (ConfigT, config, updateConfig) -import HWM.Domain.Dependencies (mapDeps, mapWithName) +import HWM.Domain.ConfigT (ConfigT, updateConfig) import HWM.Domain.Environments (getTestedRange) +import HWM.Domain.Registry (askRegistry, mapDeps, mapWithName) import HWM.Integrations.Toolchain.Package (syncPackages) import HWM.Runtime.UI (indent, printGenTable, putLine, section, sectionConfig, sectionTableM) import Options.Applicative @@ -27,7 +27,7 @@ runRegistryAudit :: RegistryAuditOptions -> ConfigT () runRegistryAudit RegistryAuditOptions {..} = do - originalRegistry <- asks (cfgRegistry . config) + originalRegistry <- askRegistry range <- getTestedRange sectionTableM "audit" [("mode", pure (if auditFix then if auditForce then chalk Yellow "fix (force)" else chalk Cyan "fix" else "check"))] @@ -40,7 +40,7 @@ indent 1 $ putLine "all dependencies are up to date." else do if auditFix - then ((\cf -> pure $ cf {cfgRegistry = mapDeps (updateDepBounds auditForce range) originalRegistry}) `updateConfig`) $ do + then ((\cf -> pure $ cf {cfgRegistry = Just $ mapDeps (updateDepBounds auditForce range) originalRegistry}) `updateConfig`) $ do sectionConfig [("hwm.yaml", pure $ chalk Green "✓")] syncPackages else do diff --git a/src/HWM/CLI/Command/Registry/Ls.hs b/src/HWM/CLI/Command/Registry/Ls.hs --- a/src/HWM/CLI/Command/Registry/Ls.hs +++ b/src/HWM/CLI/Command/Registry/Ls.hs @@ -7,9 +7,8 @@ import qualified Data.Text as T import HWM.Core.Formatting (Format (..), formatTable) import HWM.Core.Parsing (ParseCLI (..)) -import HWM.Domain.Config (Config (..)) -import HWM.Domain.ConfigT (ConfigT, config) -import HWM.Domain.Dependencies (toDependencyList) +import HWM.Domain.ConfigT (ConfigT) +import HWM.Domain.Registry (askRegistry, getDependencies) import HWM.Runtime.UI (putLine, section) import Options.Applicative (help, long, metavar, short, strOption) import Relude @@ -21,6 +20,6 @@ runRegistryLs :: RegistryLsOptions -> ConfigT () runRegistryLs RegistryLsOptions {regSearch} = do - deps <- asks (toDependencyList . cfgRegistry . config) + deps <- getDependencies <$> askRegistry let filtered = maybe deps (\s -> filter (T.isInfixOf s . format) deps) regSearch section "registry" $ forM_ (formatTable (map format filtered)) putLine diff --git a/src/HWM/CLI/Command/Release/Publish.hs b/src/HWM/CLI/Command/Release/Publish.hs --- a/src/HWM/CLI/Command/Release/Publish.hs +++ b/src/HWM/CLI/Command/Release/Publish.hs @@ -22,14 +22,14 @@ statusIcon, ) import HWM.Core.Parsing (ParseCLI (..)) -import HWM.Core.Pkg (Pkg (..), pkgId) +import HWM.Core.Pkg (Pkg (..)) import HWM.Core.Result (Issue, Severity (..), maxSeverity) import HWM.Domain.Config (Config (cfgRelease)) import HWM.Domain.ConfigT (ConfigT, Env (..), askVersion) import HWM.Domain.Dependencies (sortByDependencyHierarchy) import HWM.Domain.Release (Release (..)) -import HWM.Domain.Workspace (WsPkgs, allPackages, resolveWsPkgs) -import HWM.Integrations.Toolchain.Package (deriveRegistry) +import HWM.Domain.Workspace (WsPkgs, printPkgWSRef, resolveWsPkgs) +import HWM.Integrations.Toolchain.Package (deriveDependencyGraph) import HWM.Integrations.Toolchain.Stack (sdist, upload) import HWM.Runtime.UI (printSummary, putLine, section, sectionTableM) import Options.Applicative (argument, help, metavar, str) @@ -53,7 +53,7 @@ arrangePackageRelease :: [Pkg] -> ConfigT [Pkg] arrangePackageRelease pkgs = do - (_, graph) <- allPackages >>= deriveRegistry + graph <- deriveDependencyGraph sortByDependencyHierarchy graph pkgs collectGroups :: Maybe Name -> ConfigT WsPkgs @@ -79,10 +79,10 @@ ] pkgs <- arrangePackageRelease (concatMap snd wgs) - let size = genMaxLen (map pkgId pkgs) + let size = genMaxLen (map printPkgWSRef pkgs) section "publishing plan (topological sort)" $ do for_ (zip pkgs [1 ..] :: [(Pkg, Int)]) $ \(pkg, idx) -> do - putLine $ "└── " <> padDots size (pkgId pkg) <> show idx + putLine $ "└── " <> padDots size (printPkgWSRef pkg) <> show idx issues <- traverse sdist (concatMap snd wgs) failIssues (concat issues) @@ -90,5 +90,5 @@ section "publishing" $ do for_ pkgs $ \pkg -> do (status, publishIssues) <- upload pkg - putLine $ "└── " <> padDots size (pkgId pkg) <> statusIcon status + putLine $ "└── " <> padDots size (printPkgWSRef pkg) <> statusIcon status failIssues publishIssues diff --git a/src/HWM/CLI/Command/Run.hs b/src/HWM/CLI/Command/Run.hs --- a/src/HWM/CLI/Command/Run.hs +++ b/src/HWM/CLI/Command/Run.hs @@ -59,7 +59,7 @@ runScript :: Name -> ScriptOptions -> ConfigT () runScript scriptName ScriptOptions {..} = do cfg <- asks config - case M.lookup scriptName (cfgScripts cfg) of + case cfgScripts cfg >>= M.lookup scriptName of Just script -> do envs <- getEnvs scriptEnvs targets <- concatMap snd <$> resolveWorkspaces scriptTargets diff --git a/src/HWM/CLI/Command/Status.hs b/src/HWM/CLI/Command/Status.hs --- a/src/HWM/CLI/Command/Status.hs +++ b/src/HWM/CLI/Command/Status.hs @@ -7,8 +7,7 @@ import HWM.Domain.Config (Config (..)) import HWM.Domain.ConfigT (ConfigT, config) import HWM.Domain.Environments (printEnvironments) -import HWM.Domain.Workspace (forWorkspace) -import HWM.Integrations.Toolchain.Package (validatePackage) +import HWM.Integrations.Toolchain.Package (validatePackages) import HWM.Runtime.UI (sectionTableM) import Relude @@ -22,4 +21,4 @@ ("version", pure $ chalk Green (format $ cfgVersion cfg)) ] printEnvironments Nothing - forWorkspace validatePackage + validatePackages diff --git a/src/HWM/CLI/Command/Sync.hs b/src/HWM/CLI/Command/Sync.hs --- a/src/HWM/CLI/Command/Sync.hs +++ b/src/HWM/CLI/Command/Sync.hs @@ -7,7 +7,9 @@ import HWM.Core.Formatting (Color (..), Format (..), chalk) import HWM.Domain.ConfigT (ConfigT) import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment) +import HWM.Integrations.Toolchain.Cabal (syncCabalProject) import HWM.Integrations.Toolchain.Hie (syncHie) +import HWM.Integrations.Toolchain.Nix (syncNixFile) import HWM.Integrations.Toolchain.Package (syncPackages) import HWM.Integrations.Toolchain.Stack (syncStackYaml) import HWM.Runtime.Cache (Registry (..), updateRegistry) @@ -24,7 +26,9 @@ ("resolver", pure $ buildResolver env) ] sectionConfig - [ ("stack.yaml", syncStackYaml $> chalk Green "✓"), - ("hie.yaml", syncHie $> chalk Green "✓") - ] + ( [("cabal.project", syncCabalProject $> chalk Green "✓")] + <> [("stack.yaml", syncStackYaml $> chalk Green "✓") | buildStack env] + <> [("flake.nix", syncNixFile $> chalk Green "✓") | buildNix env] + <> [("hie.yaml", syncHie $> chalk Green "✓")] + ) syncPackages diff --git a/src/HWM/CLI/Command/Workspace/Add.hs b/src/HWM/CLI/Command/Workspace/Add.hs --- a/src/HWM/CLI/Command/Workspace/Add.hs +++ b/src/HWM/CLI/Command/Workspace/Add.hs @@ -49,7 +49,7 @@ let ws = Map.insert groupId (WorkGroup opsWorkspaceDir [] opsPrefix) wss updateConfig (\cfg -> pure $ cfg {cfgWorkspace = ws}) $ sectionWorkspace $ do putLine "" - putLine $ "• " <> chalk Bold groupId <> " " <> displayStatus [("added", Checked)] + displayStatus [("added", pure Checked)] >>= putLine . (("• " <> chalk Bold groupId <> " ") <>) runWorkspaceAdd (WorkspaceAddOptions {opsWorkspaceId = WorkspaceRef groupId (Just memberId), ..}) = do when (isJust opsPrefix) $ injectIssue (noEffect "prefix") when (isJust opsWorkspaceDir) $ injectIssue (noEffect "dir") @@ -60,7 +60,7 @@ $ do putLine "" putLine $ "• " <> chalk Bold groupId - putLine $ subPathSign <> padDots 16 memberId <> displayStatus [("added", Checked)] + displayStatus [("added", pure Checked)] >>= putLine . ((subPathSign <> padDots 16 memberId) <>) sectionConfig [ ("stack.yaml", syncStackYaml $> chalk Green "✓"), ("hie.yaml", syncHie $> chalk Green "✓") diff --git a/src/HWM/CLI/Command/Workspace/Ls.hs b/src/HWM/CLI/Command/Workspace/Ls.hs --- a/src/HWM/CLI/Command/Workspace/Ls.hs +++ b/src/HWM/CLI/Command/Workspace/Ls.hs @@ -4,8 +4,7 @@ import HWM.Core.Parsing (ParseCLI (..)) import HWM.Domain.ConfigT (ConfigT) -import HWM.Domain.Workspace (forWorkspace) -import HWM.Integrations.Toolchain.Package (validatePackage) +import HWM.Integrations.Toolchain.Package (validatePackages) import Relude data WorkspaceLsOptions = WorkspaceLsOptions @@ -15,4 +14,4 @@ parseCLI = pure WorkspaceLsOptions runWorkspaceLs :: WorkspaceLsOptions -> ConfigT () -runWorkspaceLs _ = forWorkspace validatePackage +runWorkspaceLs _ = validatePackages diff --git a/src/HWM/Core/Formatting.hs b/src/HWM/Core/Formatting.hs --- a/src/HWM/Core/Formatting.hs +++ b/src/HWM/Core/Formatting.hs @@ -30,6 +30,8 @@ formatList, monadStatus, formatTemplate, + toCamelCase, + formatTableRow, ) where @@ -39,6 +41,7 @@ import qualified Data.List as List import Data.Text (pack) import qualified Data.Text as T +import Distribution.PackageDescription (UnqualComponentName, unUnqualComponentName) import HWM.Core.Result (MonadIssue (catchIssues), Severity (..)) import Relude @@ -100,10 +103,11 @@ monadStatus :: (Functor m, MonadIssue m) => m b -> m Status monadStatus x = statusFromSeverity . fst <$> catchIssues x -displayStatus :: [(Text, Status)] -> Text -displayStatus ls = - let status = deriveStatus (map snd ls) - in if isOk status then statusIcon status else formatStatus ls +displayStatus :: (Monad m) => [(Text, m Status)] -> m Text +displayStatus ls = do + statuses <- mapM snd ls + let status = deriveStatus statuses + if isOk status then return (statusIcon status) else return (formatStatus (zip (map fst ls) statuses)) formatTemplate :: [(Text, Text)] -> Text -> Text formatTemplate vars template = @@ -159,6 +163,9 @@ instance Format Value where format = format . unpack . encode +instance Format UnqualComponentName where + format = pack . unUnqualComponentName + availableOptions :: (Format a) => [a] -> Text availableOptions xs = "Available options: " <> T.intercalate ", " (map format xs) @@ -245,10 +252,23 @@ $ T.intercalate " " $ zipWith (\item s -> T.justifyLeft s ' ' item) ls sizes +formatTableRow :: Table -> Row -> Text +formatTableRow table = printRow (getSizes table) + formatTable :: [Text] -> [Text] -formatTable deps = sort $ map (printRow (getSizes table)) table +formatTable deps = sort $ map (formatTableRow table) table where table = map words deps formatList :: (Format a) => Text -> [a] -> Text formatList x = T.intercalate x . map format + +toCamelCase :: Text -> Text +toCamelCase txt = T.concat $ capitalizeLs $ T.splitOn "-" $ T.replace "_" "-" txt + where + capitalizeLs (x : xs) = x : map capitalize xs + capitalizeLs [] = [] + capitalize t = + case T.uncons t of + Nothing -> "" + Just (c, rest) -> T.toUpper (T.singleton c) <> rest diff --git a/src/HWM/Core/Options.hs b/src/HWM/Core/Options.hs --- a/src/HWM/Core/Options.hs +++ b/src/HWM/Core/Options.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -6,6 +7,7 @@ defaultOptions, askOptions, whenCI, + whenDebug, ) where @@ -16,22 +18,33 @@ askOptions = asks obtain data Options = Options - { hie :: FilePath, - hwm :: FilePath, - stack :: FilePath, - quiet :: Bool + { optionsHie :: FilePath, + optionsHwm :: FilePath, + optionsStack :: FilePath, + optionsQuiet :: Bool, + optionsCabal :: FilePath, + optionsNix :: FilePath, + optionDebug :: Bool } defaultOptions :: Options defaultOptions = Options - { hwm = "./hwm.yaml", - hie = "./hie.yaml", - stack = "./stack.yaml", - quiet = False + { optionsHwm = "./hwm.yaml", + optionsHie = "./hie.yaml", + optionsStack = "./stack.yaml", + optionsQuiet = False, + optionsCabal = "./cabal.project", + optionsNix = "./flake.nix", + optionDebug = False } whenCI :: (MonadIO m) => m () -> m () whenCI action = do ci <- liftIO $ isJust <$> lookupEnv "CI" when ci action + +whenDebug :: (MonadIO m) => m () -> m () +whenDebug action = do + debug <- liftIO $ (Just "true" ==) <$> lookupEnv "DEBUG" + when debug action diff --git a/src/HWM/Core/Pkg.hs b/src/HWM/Core/Pkg.hs --- a/src/HWM/Core/Pkg.hs +++ b/src/HWM/Core/Pkg.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -13,109 +10,116 @@ PkgName (..), makePkg, pkgFile, - pkgYamlPath, - pkgId, - scanPkgs, - cabalFilePath, mkPkgDirPath, resolvePrefix, + IsPkg (..), + scanPkgs, + PkgSource (..), + cabalSource, + hpackSource, + checkVersion, ) where import Control.Monad.Except import Data.Aeson (FromJSON (..), ToJSONKey) import Data.Aeson.Types (FromJSONKey) -import qualified Data.Map as Map import Data.Text (intercalate) import Data.Traversable (for) import Data.Yaml.Aeson (ToJSON) +import Distribution.Package (packageName, pkgVersion) +import Distribution.Types.GenericPackageDescription +import Distribution.Types.PackageDescription +import Distribution.Types.PackageName import HWM.Core.Common (Name) import HWM.Core.Formatting +import HWM.Core.Has (Has) import HWM.Core.Parsing (Parse (..)) -import HWM.Core.Result (Issue) -import HWM.Core.Version (Version) -import HWM.Runtime.Files (cleanRelativePath, readYaml) +import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) +import HWM.Core.Version (Version, askVersion, fromCabalVersion, toCabalVersion) +import HWM.Runtime.Files (cleanRelativePath) import Relude hiding (Undefined, intercalate) -import System.FilePath (makeRelative, takeDirectory) +import System.Directory (listDirectory) +import System.FilePath import System.FilePath.Glob (glob) -import System.FilePath.Posix (joinPath, normalise, takeFileName, ()) -data PkgInfo = PkgInfo {name :: PkgName, version :: Version} - deriving (Generic, FromJSON, Show) - +-- | +-- Represents a reference to a package within the workspace. +-- +-- This type serves as a lightweight pointer to a package, without exposing or depending on its internal structure or contents. +-- It is primarily used for identifying and referencing packages in workspace operations, enabling decoupled package management. +-- Package pointer without any insiight into content, used for referencing packages in the workspace data Pkg = Pkg { pkgName :: PkgName, - pkgVersion :: Version, pkgGroup :: Name, pkgMemberId :: Name, - pkgDirPath :: FilePath + pkgDirPath :: FilePath, + cabalFile :: FilePath, + hpackFile :: Maybe FilePath } deriving (Show, Ord, Eq) -packageYamlFileName :: String -packageYamlFileName = "package.yaml" - --- Helper to ensure "package.yaml" is only appended if not already present -ensurePackageYaml :: FilePath -> FilePath -ensurePackageYaml path - | takeFileName path == packageYamlFileName = path - | otherwise = normalise $ path packageYamlFileName +data PkgSource = PkgSource {pkgSourceName :: Name, pkgSourceFile :: FilePath} -pkgYamlPath :: Pkg -> FilePath -pkgYamlPath pkg = pkgFile pkg packageYamlFileName +cabalSource :: Pkg -> PkgSource +cabalSource pkg = PkgSource (pkgMemberId pkg) (cabalFile pkg) -getPkgInfo :: (MonadError Issue m, MonadIO m) => FilePath -> m PkgInfo -getPkgInfo = readYaml . normalise . ensurePackageYaml +hpackSource :: Pkg -> Maybe PkgSource +hpackSource pkg = PkgSource (pkgMemberId pkg) <$> hpackFile pkg -pkgFile :: Pkg -> FilePath -> FilePath -pkgFile Pkg {..} file = normalise $ joinPath [pkgDirPath, file] +class IsPkg a where + getPkgName :: a -> PkgName -cabalFilePath :: Pkg -> FilePath -cabalFilePath Pkg {..} = normalise $ joinPath [pkgDirPath, toString pkgName <> ".cabal"] + -- version + getPkgVersion :: a -> Version + setVersion :: Version -> a -> a -pkgId :: Pkg -> Text -pkgId Pkg {pkgGroup, pkgMemberId} = pkgGroup <> "/" <> pkgMemberId +instance IsPkg GenericPackageDescription where + getPkgName = PkgName . toText . unPackageName . packageName . package . packageDescription + getPkgVersion = fromCabalVersion . pkgVersion . package . packageDescription + setVersion version gpd = + let pd = packageDescription gpd + pid = package pd + newPid = pid {pkgVersion = toCabalVersion version} + newPd = pd {package = newPid} + in gpd {packageDescription = newPd} -toPkg :: PkgInfo -> Name -> Name -> FilePath -> Pkg -toPkg PkgInfo {name, version} groupName memberName dir = - Pkg - { pkgName = name, - pkgVersion = version, - pkgGroup = groupName, - pkgMemberId = if memberName == "." then "(root)" else memberName, - pkgDirPath = dir - } +pkgFile :: Pkg -> FilePath -> FilePath +pkgFile Pkg {..} file = normalise $ joinPath [pkgDirPath, file] mkPkgDirPath :: Maybe String -> Maybe Text -> Text -> FilePath mkPkgDirPath root prefix memberName = resolvePath root (resolvePrefix prefix memberName) +pickCabalFile :: (MonadError Issue m) => [FilePath] -> m FilePath +pickCabalFile [] = throwError "No .cabal file found in directory" +pickCabalFile [cabalFile] = pure cabalFile +pickCabalFile _ = throwError "Multiple .cabal files found in directory" + makePkg :: (MonadIO m, MonadError Issue m) => Text -> Maybe FilePath -> Maybe Name -> Name -> m Pkg -makePkg groupName root prefix memberName = do +makePkg pkgGroup root prefix memberName = do let pkgDirPath = mkPkgDirPath root prefix memberName - json <- getPkgInfo pkgDirPath - pure $ toPkg json groupName memberName pkgDirPath + files <- liftIO $ listDirectory pkgDirPath + cabal <- pickCabalFile [file | file <- files, takeExtension file == ".cabal"] + let cabalFile = joinPath [pkgDirPath, cabal] + let hpackFile = if "package.yaml" `elem` files then Just (joinPath [pkgDirPath, "package.yaml"]) else Nothing + let pkgName = PkgName (toText $ dropExtension cabal) + pure $ Pkg {pkgMemberId = if memberName == "." then "(root)" else memberName, ..} +scanPkgs :: (MonadIO m, MonadError Issue m) => FilePath -> m [Pkg] +scanPkgs root = do + paths <- map (makeRelative root) <$> liftIO (glob "./**/**/*.cabal") + for paths $ \path -> do + let pkgDir = takeDirectory path + let groupDir = cleanRelativePath (Just (takeDirectory pkgDir)) + let memberName = toText $ takeFileName pkgDir + makePkg (maybe "" toText groupDir) groupDir Nothing memberName + resolvePrefix :: Maybe Text -> Text -> Text resolvePrefix prefix name = intercalate "-" (maybeToList prefix <> [name | name /= "."]) resolvePath :: (ToString a) => Maybe String -> a -> FilePath resolvePath root path = normalise (joinPath (maybeToList (cleanRelativePath root) <> [toString path])) -scanPkgInfos :: (MonadIO m, MonadError Issue m) => FilePath -> m (Map FilePath PkgInfo) -scanPkgInfos root = do - paths <- map (makeRelative root) <$> liftIO (glob $ normalise "./**/**/package.yaml") - pkgInfos <- traverse getPkgInfo paths - pure $ Map.fromList (zip paths pkgInfos) - -scanPkgs :: (MonadIO m, MonadError Issue m) => FilePath -> m [Pkg] -scanPkgs root = do - infos <- scanPkgInfos root - for (Map.toList infos) $ \(path, info) -> do - let pkgDir = takeDirectory path - let memberName = toText $ takeFileName pkgDir - let groupName = maybe "" toText $ cleanRelativePath (Just (takeDirectory pkgDir)) - pure $ toPkg info groupName memberName pkgDir - newtype PkgName = PkgName Text deriving newtype ( FromJSON, @@ -133,3 +137,16 @@ instance Parse PkgName where parse = pure . PkgName + +checkVersion :: (IsPkg a, MonadReader env m, Has env Version, MonadIssue m) => PkgSource -> a -> m () +checkVersion source pkg = do + expectedVersion <- askVersion + let version = getPkgVersion pkg + unless (version == expectedVersion) + $ injectIssue + Issue + { issueTopic = pkgSourceName source, + issueMessage = "version mismatch: " <> format version <> " → " <> format expectedVersion, + issueSeverity = SeverityWarning, + issueDetails = Just GenericIssue {issueFile = pkgSourceFile source} + } diff --git a/src/HWM/Core/Version.hs b/src/HWM/Core/Version.hs --- a/src/HWM/Core/Version.hs +++ b/src/HWM/Core/Version.hs @@ -14,6 +14,13 @@ dropPatch, parseGHCVersion, VersionChange (..), + formatNixGhc, + selectEra, + Era (..), + detectResolver, + fromCabalVersion, + toCabalVersion, + latestGHCVersion, ) where @@ -22,7 +29,9 @@ ToJSON (..), Value (..), ) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Distribution.Simple as Cabal import GHC.Show (Show (..)) import HWM.Core.Formatting (Format (..), formatList) import HWM.Core.Has (Has (obtain)) @@ -39,6 +48,17 @@ Eq ) +fromCabalVersion :: Cabal.Version -> Version +fromCabalVersion v = case fromSeries $ Cabal.versionNumbers v of + Left err -> error $ "Invalid Cabal version: " <> err + Right version -> version + +toCabalVersion :: Version -> Cabal.Version +toCabalVersion version = Cabal.mkVersion (toSeries version) + +formatNixGhc :: Version -> Text +formatNixGhc Version {..} = "ghc" <> T.concat (map (T.pack . show) [major, minor]) + askVersion :: (MonadReader env m, Has env Version) => m Version askVersion = asks obtain @@ -148,3 +168,29 @@ parse x | isBump x = BumpVersion <$> parse x | otherwise = FixedVersion <$> parse x + +data Era = Era + { eraVersion :: Version, + eraStackageResolverName :: Text, + eraNixpkgs :: Text + } + deriving (Show, Eq) + +historicalEras :: NonEmpty Era +historicalEras = + Era (Version 9 10 []) "nightly" "nixos-unstable" + :| [ Era (Version 9 8 []) "lts-23.0" "nixos-24.05", + Era (Version 9 6 []) "lts-22.43" "nixos-24.05", + Era (Version 9 4 []) "lts-21.25" "nixos-23.11", + Era (Version 9 2 []) "lts-20.26" "nixos-23.05", + Era (Version 8 10 []) "lts-18.28" "nixos-22.05" + ] + +selectEra :: Version -> Era +selectEra version = fromMaybe (NE.last historicalEras) $ find (\era -> eraVersion era <= version) historicalEras + +detectResolver :: Version -> Text +detectResolver version = eraStackageResolverName $ selectEra version + +latestGHCVersion :: Version +latestGHCVersion = eraVersion $ head historicalEras diff --git a/src/HWM/Domain/Config.hs b/src/HWM/Domain/Config.hs --- a/src/HWM/Domain/Config.hs +++ b/src/HWM/Domain/Config.hs @@ -10,7 +10,7 @@ module HWM.Domain.Config ( Config (..), - getRule, + getRegistryBounds, defaultScripts, ) where @@ -19,13 +19,13 @@ import Data.Aeson (FromJSON (..), ToJSON (toJSON), genericParseJSON, genericToJSON) import qualified Data.Map as Map import HWM.Core.Common (Check (..), Name) -import HWM.Core.Has (Has) +import HWM.Core.Has (Has, askEnv) import HWM.Core.Pkg import HWM.Core.Result (Issue) import HWM.Core.Version (Version) import HWM.Domain.Bounds (Bounds, versionBounds) -import HWM.Domain.Dependencies (Dependencies, getBounds) import HWM.Domain.Environments (Environments (..)) +import HWM.Domain.Registry (Registry (..), lookupBounds) import HWM.Domain.Release (Release) import HWM.Domain.Workspace (PkgRegistry, Workspace) import HWM.Runtime.Cache (Cache) @@ -34,13 +34,13 @@ data Config = Config { cfgName :: Name, - cfgGithub :: Maybe Text, cfgVersion :: Version, - cfgBounds :: Maybe Bounds, cfgWorkspace :: Workspace, cfgEnvironments :: Environments, - cfgRegistry :: Dependencies, - cfgScripts :: Map Name Text, + cfgGithub :: Maybe Text, + cfgBounds :: Maybe Bounds, + cfgRegistry :: Maybe Registry, + cfgScripts :: Maybe (Map Name Text), cfgRelease :: Maybe Release } deriving @@ -48,10 +48,16 @@ Show ) -getRule :: (MonadError Issue m) => PkgName -> PkgRegistry -> Config -> m Bounds -getRule depName ps Config {..} - | Map.member depName ps = pure (fromMaybe (versionBounds cfgVersion) cfgBounds) - | otherwise = getBounds depName cfgRegistry +getRegistryBounds :: (MonadReader env m, Has env Config, Has env PkgRegistry) => PkgName -> m (Maybe Bounds) +getRegistryBounds name = do + cfg <- askEnv + ps <- askEnv + pure $ getRule' name ps cfg + +getRule' :: PkgName -> PkgRegistry -> Config -> Maybe Bounds +getRule' depName ps Config {..} + | Map.member depName ps = Just (fromMaybe (versionBounds cfgVersion) cfgBounds) + | otherwise = lookupBounds depName (fromMaybe mempty cfgRegistry) prefix :: String prefix = "cfg" diff --git a/src/HWM/Domain/ConfigT.hs b/src/HWM/Domain/ConfigT.hs --- a/src/HWM/Domain/ConfigT.hs +++ b/src/HWM/Domain/ConfigT.hs @@ -35,6 +35,7 @@ import HWM.Core.Version (Version, askVersion) import HWM.Domain.Config (Config (..)) import HWM.Domain.Environments (Environments (..), environmentHash) +import HWM.Domain.Registry (Registry) import HWM.Domain.Release (ArtifactConfig, Release (..)) import HWM.Domain.Workspace (PkgRegistry, Workspace, pkgRegistry) import HWM.Runtime.Cache (Cache, VersionMap, loadCache, saveCache) @@ -85,13 +86,16 @@ instance Has (Env m) PkgRegistry where obtain = pkgs +instance Has (Env m) Registry where + obtain Env {config} = fromMaybe mempty (cfgRegistry config) + instance Has (Env m) Signature where obtain = fileSignature instance MonadUI ConfigT where uiWrite txt = do - Options {quiet} <- asks options - unless quiet $ liftIO $ putStr (toString txt) + Options {optionsQuiet} <- asks options + unless optionsQuiet $ liftIO $ putStr (toString txt) uiIndentLevel = ConfigT $ lift uiIndentLevel uiWithIndent f (ConfigT (ReaderT action)) = ConfigT $ ReaderT (uiWithIndent f . action) @@ -108,12 +112,12 @@ cfg <- asks config ops <- asks options check cfg - debug $ "save " <> format (hwm ops) + debug $ "save " <> format (optionsHwm ops) saveConfig cfg ops saveConfig :: (MonadError Issue m, MonadIO m) => Config -> Options -> m () saveConfig config ops = do - let file = hwm ops + let file = optionsHwm ops rewrite_ file (const $ pure config) addHash file (environmentHash (cfgEnvironments config)) @@ -124,9 +128,9 @@ runConfigT :: ConfigT () -> Options -> IO () runConfigT m opts@Options {..} = do - config <- resolveResultTSilent (readYaml hwm) + config <- resolveResultTSilent (readYaml optionsHwm) cache <- loadCache (envDefault (cfgEnvironments config)) - fileSignature <- getFileSignature hwm + fileSignature <- getFileSignature optionsHwm let currentSignature = environmentHash (cfgEnvironments config) pkgs <- resolveResultTSilent (pkgRegistry (cfgWorkspace config)) let env = Env {options = opts, config, cache, pkgs, fileSignature} diff --git a/src/HWM/Domain/Dependencies.hs b/src/HWM/Domain/Dependencies.hs --- a/src/HWM/Domain/Dependencies.hs +++ b/src/HWM/Domain/Dependencies.hs @@ -1,54 +1,59 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module HWM.Domain.Dependencies - ( Dependencies, + ( Dependencies (..), Dependency (..), - getBounds, - mapDeps, toDependencyList, fromDependencyList, mergeDependencies, normalizeDependencies, - externalRegistry, - DependencyGraph (..), + DependencyMap (..), sortByDependencyHierarchy, - mapWithName, singleDeps, - lookupBounds, + HasDependencies (..), + collectNormalizedDependencies, + buildDependencyGraph, + MapDeps (..), + DependencyIssue, + reportDependencyIssues, + detectDependencyIssue, + mkCabalDependency, ) where import Control.Monad.Error.Class (MonadError (..)) import Data.Aeson ( FromJSON (..), - ToJSON (toJSON), + ToJSON (..), ) import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as T +import Distribution.Package (mainLibSet) +import Distribution.PackageDescription (Benchmark (..), BuildInfo (..), Executable (..), GenericPackageDescription, Library (..), TestSuite (..), UnqualComponentName) +import qualified Distribution.PackageDescription as Cabal +import Distribution.Simple (UpperBound (..), VersionRange, asVersionIntervals) +import Distribution.Types.CondTree +import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..)) +import Distribution.Version (LowerBound (..), VersionInterval (..)) +import qualified Distribution.Version as Cabal +import HWM.Core.Common (Name) import HWM.Core.Formatting (Format (..), formatTable, subPathSign) import HWM.Core.Parsing (Parse (..), firstWord) -import HWM.Core.Pkg (Pkg (..), PkgName) -import HWM.Core.Result (Issue (..), Severity (..)) -import HWM.Domain.Bounds (Bounds, boundsBetter, hasBounds) -import HWM.Runtime.Files (select) -import Relude hiding - ( Undefined, - break, - drop, - fromList, - length, - null, - show, - toList, - ) +import HWM.Core.Pkg (IsPkg (..), Pkg (..), PkgName (..), PkgSource (..)) +import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) +import HWM.Core.Version (fromCabalVersion, toCabalVersion) +import HWM.Domain.Bounds (Bound (..), Bounds (..), Restriction (..), boundsBetter, hasBounds) +import Relude data Dependency = Dependency - { name :: PkgName, - bounds :: Bounds + { hwmDepName :: PkgName, + hwmDepBounds :: Bounds } deriving (Show, Eq) @@ -58,7 +63,7 @@ . firstWord instance Format Dependency where - format Dependency {..} = format name <> " " <> format bounds + format Dependency {..} = format hwmDepName <> " " <> format hwmDepBounds newtype Dependencies = Dependencies {unpackDeps :: Map PkgName Bounds} deriving (Show) @@ -66,20 +71,8 @@ instance Semigroup Dependencies where (Dependencies a) <> (Dependencies b) = Dependencies (a <> b) -lookupBounds :: PkgName -> Dependencies -> Maybe Bounds -lookupBounds name (Dependencies m) = Map.lookup name m - -getBounds :: (MonadError Issue m) => PkgName -> Dependencies -> m Bounds -getBounds name = select "Package " name . unpackDeps - -mapDeps :: (PkgName -> Bounds -> Bounds) -> Dependencies -> Dependencies -mapDeps f (Dependencies xs) = Dependencies $ Map.mapWithKey f xs - -mapWithName :: (PkgName -> Bounds -> b) -> Dependencies -> [b] -mapWithName f (Dependencies xs) = Map.elems $ Map.mapWithKey f xs - singleDeps :: Dependency -> Dependencies -singleDeps (Dependency name bounds) = Dependencies (Map.singleton name bounds) +singleDeps (Dependency hwmDepName bounds) = Dependencies (Map.singleton hwmDepName bounds) initDependencies :: [Dependency] -> Dependencies initDependencies = Dependencies . Map.fromList . map toDuple @@ -102,23 +95,24 @@ mergeDependencies = Map.elems . foldl' step Map.empty where step acc dep = - Map.insertWith prefer (name dep) dep acc - prefer new old = if boundsBetter (bounds new) (bounds old) then new else old + Map.insertWith prefer (hwmDepName dep) dep acc + prefer new old = if boundsBetter (hwmDepBounds new) (hwmDepBounds old) then new else old normalizeDependencies :: [Dependency] -> [Dependency] -normalizeDependencies = filter (hasBounds . bounds) . mergeDependencies +normalizeDependencies = filter (hasBounds . hwmDepBounds) . mergeDependencies -externalRegistry :: [PkgName] -> [Dependency] -> Dependencies -externalRegistry internalPkgs deps = - let externals = filter isExternal (normalizeDependencies deps) - in fromDependencyList (sortOn name externals) - where - internals = Set.fromList internalPkgs - isExternal dep = not (Set.member (name dep) internals) +newtype DependencyMap = DependencyMap (Map PkgName [PkgName]) -newtype DependencyGraph = DependencyGraph (Map PkgName [PkgName]) +buildDependencyGraph :: (IsPkg a) => (a -> [Dependency]) -> [a] -> DependencyMap +buildDependencyGraph collectDeps packages = DependencyMap $ Map.fromList [(getPkgName pkg, internalDeps pkg) | pkg <- packages] + where + internalNames = Set.fromList (map getPkgName packages) + internalDeps pkg = mapMaybe selectInternal (collectDeps pkg) + where + selectInternal (Dependency dName _) = + if Set.member dName internalNames then Just dName else Nothing -instance Format DependencyGraph where +instance Format DependencyMap where format graph = T.intercalate "\n" (map (formatTree 0) (toTree graph)) formatTree :: Int -> Tree -> Text @@ -129,8 +123,8 @@ data Tree = Node PkgName [Tree] -toTree :: DependencyGraph -> [Tree] -toTree (DependencyGraph graph) = +toTree :: DependencyMap -> [Tree] +toTree (DependencyMap graph) = let allPkgs = Map.keysSet graph <> foldMap Set.fromList (Map.elems graph) dependentPkgs = foldMap Set.fromList (Map.elems graph) rootPkgs = Set.toList (Set.difference allPkgs dependentPkgs) @@ -146,8 +140,8 @@ childTrees = map (buildTree graph newVisited) deps in Node pkg childTrees -topologicalSort :: DependencyGraph -> Either [PkgName] [PkgName] -topologicalSort (DependencyGraph graph) = goFunc [] initialZero indegreeMap +topologicalSort :: DependencyMap -> Either [PkgName] [PkgName] +topologicalSort (DependencyMap graph) = goFunc [] initialZero indegreeMap where nodes = Map.keysSet graph <> foldMap Set.fromList (Map.elems graph) indegreeMap = foldl' updateIndegree baseIndegree (Map.toList graph) @@ -173,7 +167,7 @@ updatedZeros = if deg == 0 then Set.insert neighbour zeros else zeros in (updatedZeros, updatedIndegrees) -sortByDependencyHierarchy :: (MonadError Issue m) => DependencyGraph -> [Pkg] -> m [Pkg] +sortByDependencyHierarchy :: (MonadError Issue m) => DependencyMap -> [Pkg] -> m [Pkg] sortByDependencyHierarchy graph ns = do case topologicalSort graph of Left depCycle -> @@ -189,3 +183,199 @@ let indexes = Map.fromList (zip sortedNames [0 ..] :: [(PkgName, Int)]) findIndex pkg = Map.findWithDefault maxBound (pkgName pkg) indexes in pure $ sortOn (Down . findIndex) ns + +class HasDependencies a where + collectDependencies :: [Text] -> a -> [([Text], Dependencies)] + +instance HasDependencies Dependencies where + collectDependencies scope lib = [(scope, lib)] + +instance (HasDependencies a) => HasDependencies (Map Text a) where + collectDependencies scope libs = concatMap (\(name, lib) -> collectDependencies (scope <> [name]) lib) (Map.toList libs) + +instance (HasDependencies a) => HasDependencies (Maybe a) where + collectDependencies scope = maybe [] (collectDependencies scope) + +collectNormalizedDependencies :: (HasDependencies a) => a -> [Dependency] +collectNormalizedDependencies package = normalizeDependencies (concatMap (toDependencyList . snd) $ collectDependencies [] package) + +instance HasDependencies GenericPackageDescription where + collectDependencies xs GenericPackageDescription {..} = + concat + [ collectDependencies (xs <> ["library"]) condLibrary, + collectDependencies (xs <> ["tests"]) condTestSuites, + collectDependencies (xs <> ["executables"]) condExecutables, + collectDependencies (xs <> ["benchmarks"]) condBenchmarks + ] + +instance (HasDependencies deps, HasDependencies lib) => HasDependencies (CondTree v deps lib) where + collectDependencies path condTree = + collectDependencies path (condTreeConstraints condTree) + <> concatMap (collectDependencies path) (condTreeComponents condTree) + <> collectDependencies path (condTreeData condTree) + +instance (HasDependencies a) => HasDependencies [(UnqualComponentName, a)] where + collectDependencies path = concatMap (\(name, info) -> collectDependencies (path <> [format name]) info) + +instance (HasDependencies a, HasDependencies d) => HasDependencies (CondBranch v d a) where + collectDependencies path (CondBranch _ d a) = concatMap (collectDependencies path) d <> collectDependencies path a + +fromCabalDependency :: Cabal.Dependency -> Dependency +fromCabalDependency (Cabal.Dependency pkgName versionRange _) = + Dependency (PkgName (format $ Cabal.unPackageName pkgName)) (toMinMax versionRange) + +depName :: Cabal.Dependency -> Name +depName (Cabal.Dependency pkgName _ _) = format $ Cabal.unPackageName pkgName + +fromCabalDependencies :: [Cabal.Dependency] -> Dependencies +fromCabalDependencies = fromDependencyList . map fromCabalDependency + +instance HasDependencies [Cabal.Dependency] where + collectDependencies path deps = [(path, fromCabalDependencies deps)] + +instance HasDependencies Library where + collectDependencies path deps = collectDependencies path (libBuildInfo deps) + +instance HasDependencies TestSuite where + collectDependencies path deps = collectDependencies path (testBuildInfo deps) + +instance HasDependencies Executable where + collectDependencies path deps = collectDependencies path (buildInfo deps) + +instance HasDependencies Benchmark where + collectDependencies path buildInfo = collectDependencies path (benchmarkBuildInfo buildInfo) + +instance HasDependencies Cabal.BuildInfo where + collectDependencies path buildInfo = collectDependencies path (fromCabalDependencies (targetBuildDepends buildInfo)) + +isInclusive :: Cabal.Bound -> Bool +isInclusive Cabal.InclusiveBound = True +isInclusive Cabal.ExclusiveBound = False + +toBounds :: VersionInterval -> [Bound] +toBounds (VersionInterval (LowerBound v lb) NoUpperBound) = [Bound Min (isInclusive lb) $ fromCabalVersion v] +toBounds (VersionInterval (LowerBound v lb) (UpperBound v2 ub)) = [Bound Min (isInclusive lb) $ fromCabalVersion v, Bound Max (isInclusive ub) $ fromCabalVersion v2] + +toMinMax :: VersionRange -> Bounds +toMinMax range = do + let intervals = map toBounds (asVersionIntervals range) + case sort (concat intervals) of + [] -> Bounds Nothing Nothing -- -none or empty range + intervals' -> + case (viaNonEmpty head intervals', viaNonEmpty last intervals') of + (Just x, Just y) -> Bounds (Just x) (Just y) + (_, _) -> Bounds Nothing Nothing + +type DepsCtx = (PkgSource, [Text]) + +class MapDeps a where + mapDeps :: (Monad m) => DepsCtx -> (DepsCtx -> Dependencies -> m Dependencies) -> a -> m a + +instance MapDeps Dependencies where + mapDeps ctx f = f ctx + +instance (MapDeps a) => MapDeps (Map Text a) where + mapDeps (pkg, path) f = Map.traverseWithKey (\name lib -> mapDeps (pkg, path <> [name]) f lib) + +instance (MapDeps a) => MapDeps (Maybe a) where + mapDeps ctx f = maybe (pure Nothing) (fmap Just . mapDeps ctx f) + +instance MapDeps GenericPackageDescription where + mapDeps (pkg, xs) f GenericPackageDescription {..} = do + coLibrary <- mapDeps (pkg, xs <> ["library"]) f condLibrary + coTestSuites <- mapDeps (pkg, xs <> ["tests"]) f condTestSuites + coExecutables <- mapDeps (pkg, xs <> ["executables"]) f condExecutables + coBenchmarks <- mapDeps (pkg, xs <> ["benchmarks"]) f condBenchmarks + pure GenericPackageDescription {condLibrary = coLibrary, condTestSuites = coTestSuites, condExecutables = coExecutables, condBenchmarks = coBenchmarks, ..} + +instance (MapDeps deps, MapDeps lib) => MapDeps (CondTree v deps lib) where + mapDeps ctx f condTree = do + newConstraints <- mapDeps ctx f (condTreeConstraints condTree) + newComponents <- mapM (mapDeps ctx f) (condTreeComponents condTree) + newData <- mapDeps ctx f (condTreeData condTree) + pure condTree {condTreeConstraints = newConstraints, condTreeComponents = newComponents, condTreeData = newData} + +instance (MapDeps a, MapDeps d) => MapDeps (CondBranch v d a) where + mapDeps ctx f condBranch = do + idTrue <- mapDeps ctx f (condBranchIfTrue condBranch) + ifFalse <- mapM (mapDeps ctx f) (condBranchIfFalse condBranch) + pure condBranch {condBranchIfTrue = idTrue, condBranchIfFalse = ifFalse} + +instance (MapDeps a) => MapDeps [(UnqualComponentName, a)] where + mapDeps ctx f = mapM (\(name, info) -> fmap (name,) (mapDeps (fst ctx, snd ctx <> [format name]) f info)) + +instance MapDeps Library where + mapDeps ctx f lib = do + newBuildInfo <- mapDeps ctx f (libBuildInfo lib) + pure lib {libBuildInfo = newBuildInfo} + +instance MapDeps Executable where + mapDeps ctx f exe = do + newBuildInfo <- mapDeps ctx f (buildInfo exe) + pure exe {buildInfo = newBuildInfo} + +instance MapDeps BuildInfo where + mapDeps ctx f buildInfo = do + newDeps <- mapDeps ctx f (targetBuildDepends buildInfo) + pure buildInfo {targetBuildDepends = newDeps} + +instance MapDeps TestSuite where + mapDeps ctx f test = do + newBuildInfo <- mapDeps ctx f (testBuildInfo test) + pure test {testBuildInfo = newBuildInfo} + +instance MapDeps Benchmark where + mapDeps ctx f bench = do + newBuildInfo <- mapDeps ctx f (benchmarkBuildInfo bench) + pure bench {benchmarkBuildInfo = newBuildInfo} + +instance MapDeps [Cabal.Dependency] where + mapDeps ctx f dep = f ctx (fromCabalDependencies dep) >>= toCabalDependencies regsitry + where + regsitry = Map.fromList $ map (\d -> (depName d, d)) dep + +toCabalDependencies :: (Monad m) => Map Name Cabal.Dependency -> Dependencies -> m [Cabal.Dependency] +toCabalDependencies registry = mapM (toCabalDependency registry) . toDependencyList + +toCabalDependency :: (Monad m) => Map Name Cabal.Dependency -> Dependency -> m Cabal.Dependency +toCabalDependency registry (Dependency name bounds) = do + (Cabal.Dependency n _ c) <- maybe (error "Dependency not found in registry") pure (Map.lookup (format name) registry) + pure (Cabal.Dependency n (toVersionRange bounds) c) + +toVersionRange :: Bounds -> VersionRange +toVersionRange (Bounds (Just minB) (Just maxB)) = Cabal.intersectVersionRanges (toRange minB) (toRange maxB) +toVersionRange (Bounds (Just minB) Nothing) = toRange minB +toVersionRange (Bounds Nothing (Just maxB)) = toRange maxB +toVersionRange (Bounds Nothing Nothing) = Cabal.anyVersion + +toRange :: Bound -> VersionRange +toRange (Bound Min inc version) = if inc then Cabal.orLaterVersion (toCabalVersion version) else Cabal.laterVersion (toCabalVersion version) +toRange (Bound Max inc version) = if inc then Cabal.orEarlierVersion (toCabalVersion version) else Cabal.earlierVersion (toCabalVersion version) + +type DependencyIssue = (Text, PkgName, Bounds, Maybe Bounds) + +reportDependencyIssues :: (MonadIssue m, Applicative m) => PkgSource -> [DependencyIssue] -> m () +reportDependencyIssues source diffs = do + unless (null diffs) + $ injectIssue + Issue + { issueTopic = pkgSourceName source, + issueMessage = show (length diffs) <> " dependency issue(s)", + issueSeverity = SeverityWarning, + issueDetails = + Just + DependencyIssue + { issueDependencies = map (\(scope, dName, actual, expected) -> (scope, format dName, format actual, maybe "unknown" format expected)) diffs, + issueFile = pkgSourceFile source + } + } + +detectDependencyIssue :: [Text] -> Dependency -> Maybe Bounds -> [DependencyIssue] +detectDependencyIssue path (Dependency dname depBounds) registryBounds = case registryBounds of + Nothing -> [(scope, dname, depBounds, Nothing)] + Just expected -> ([(scope, dname, depBounds, Just expected) | depBounds /= expected]) + where + scope = T.intercalate ":" path + +mkCabalDependency :: Dependency -> Cabal.Dependency +mkCabalDependency (Dependency (PkgName name) bounds) = Cabal.Dependency (Cabal.mkPackageName (T.unpack name)) (toVersionRange bounds) mainLibSet diff --git a/src/HWM/Domain/Environments.hs b/src/HWM/Domain/Environments.hs --- a/src/HWM/Domain/Environments.hs +++ b/src/HWM/Domain/Environments.hs @@ -10,9 +10,10 @@ {-# LANGUAGE NoImplicitPrelude #-} module HWM.Domain.Environments - ( EnviromentTarget (..), + ( Enviroment (..), Environments (..), BuildEnvironment (..), + StackEnvironment (..), getBuildEnvironments, getBuildEnvironment, hkgRefs, @@ -22,18 +23,15 @@ newEnv, existsEnviroment, environmentHash, + NixEnvironment (..), + Feature (..), ) where import Control.Monad.Except (MonadError (..)) -import Data.Aeson - ( FromJSON (..), - ToJSON (toJSON), - genericParseJSON, - genericToJSON, - ) +import Data.Aeson (FromJSON (..), ToJSON (toJSON), genericParseJSON, genericToJSON, object) +import Data.Aeson.Types (Value (..)) import Data.Foldable (Foldable (..)) -import Data.List ((\\)) import qualified Data.Map as M import qualified Data.Map as Map import qualified Data.Set as Set @@ -44,11 +42,11 @@ ) import HWM.Core.Formatting (Color (..), Format (..), availableOptions, chalk) import HWM.Core.Has (Has (..), HasAll, askEnv) -import HWM.Core.Pkg (Pkg (..), PkgName, pkgId) +import HWM.Core.Pkg (Pkg (..), PkgName) import HWM.Core.Result (Issue) -import HWM.Core.Version (Version) +import HWM.Core.Version (Era (..), Version, selectEra) import HWM.Domain.Bounds (TestedRange (..)) -import HWM.Domain.Workspace (Workspace, allPackages) +import HWM.Domain.Workspace (Workspace, WorkspaceRef, allPackages, checkWorkspaceRefs, isMember) import HWM.Runtime.Cache (Cache, Registry (currentEnv), VersionMap, getLatestNightlySnapshot, getRegistry, getSnapshot, getVersions) import HWM.Runtime.Files (Signature, aesonYAMLOptions, aesonYAMLOptionsAdvanced, genSignature) import HWM.Runtime.UI (MonadUI, forTable_, sectionEnvironments) @@ -58,26 +56,27 @@ data Environments = Environments { envDefault :: Name, - envTargets :: Map Name EnviromentTarget + envNix :: Maybe Bool, + envStack :: Maybe Bool, + envProfiles :: Map Name Enviroment } deriving ( Generic, Show ) -newEnv :: Version -> Name -> EnviromentTarget -newEnv ghc resolver = - EnviromentTarget +newEnv :: Version -> Enviroment +newEnv ghc = + Enviroment { ghc = ghc, - resolver = resolver, - extraDeps = Nothing, exclude = Nothing, - allowNewer = Nothing + stack = Nothing, + nix = Nothing } environmentHash :: Environments -> Signature environmentHash Environments {..} = - genSignature $ Set.toList $ Set.fromList $ map toSig $ concatMap Map.toList $ mapMaybe extraDeps (toList envTargets) + genSignature $ Set.toList $ Set.fromList $ map toSig $ concatMap Map.toList $ mapMaybe (extraDeps <=< unfeature <=< stack) (toList envProfiles) where toSig (pkg, v) = format pkg <> "-" <> format v @@ -103,20 +102,53 @@ where check Environments {..} = do fileSig <- askEnv - traverse_ (checkTarget fileSig) envTargets + traverse_ (checkTarget fileSig) envProfiles where signature = environmentHash Environments {..} - checkTarget fileSig EnviromentTarget {..} - | fileSig == signature = checkPkgNames exclude + checkTarget fileSig Enviroment {..} + | fileSig == signature = checkExclude -- checking all hkgRefs is expensive, so we skip it if the signature matches - | otherwise = sequence_ [traverse_ check (maybe [] hkgRefs extraDeps), checkPkgNames exclude] + | otherwise = sequence_ [traverse_ check (maybe [] hkgRefs (extraDeps =<< unfeature =<< stack)), checkExclude] + where + checkExclude = checkWorkspaceRefs (fromMaybe [] exclude) -data EnviromentTarget = EnviromentTarget +data Feature a = Enabled a | Disabled deriving (Generic, Show, Ord, Eq) + +unfeature :: Feature a -> Maybe a +unfeature (Enabled a) = Just a +unfeature Disabled = Nothing + +isEnabled :: Maybe Bool -> Maybe (Feature a) -> Bool +isEnabled _ (Just (Enabled _)) = True +isEnabled _ (Just Disabled) = False +isEnabled global Nothing = fromMaybe False global + +instance FromJSON (Feature StackEnvironment) where + parseJSON (Bool b) = pure $ if b then Enabled (StackEnvironment Nothing Nothing Nothing) else Disabled + parseJSON v = Enabled <$> parseJSON v + +instance FromJSON (Feature NixEnvironment) where + parseJSON (Bool b) = pure $ if b then Enabled NixEnvironment else Disabled + parseJSON v = Enabled <$> parseJSON v + +instance (ToJSON a) => ToJSON (Feature a) where + toJSON (Enabled se) = toJSON se + toJSON Disabled = Bool False + +data NixEnvironment = NixEnvironment deriving (Generic, Show, Ord, Eq) + +instance ToJSON NixEnvironment where + toJSON NixEnvironment = object [] + +instance FromJSON NixEnvironment where + parseJSON (Object _) = pure NixEnvironment + parseJSON _ = fail "Invalid Nix environment configuration. Expected an object or a boolean." + +data Enviroment = Enviroment { ghc :: Version, - resolver :: Name, - extraDeps :: Maybe Extras, - exclude :: Maybe [Text], - allowNewer :: Maybe Bool + exclude :: Maybe [WorkspaceRef], + stack :: Maybe (Feature StackEnvironment), + nix :: Maybe (Feature NixEnvironment) } deriving ( Generic, @@ -125,31 +157,34 @@ Eq ) -instance FromJSON EnviromentTarget where +instance FromJSON Enviroment where parseJSON = genericParseJSON aesonYAMLOptions -instance ToJSON EnviromentTarget where +instance ToJSON Enviroment where toJSON = genericToJSON aesonYAMLOptions -checkPkgNames :: - ( MonadError Issue m, - MonadReader env m, - Has env Workspace, - MonadIO m - ) => - Maybe [Text] -> - m () -checkPkgNames ls = do - known <- map pkgId <$> allPackages - let unknown = fromMaybe [] ls \\ known - unless (null unknown) (throwError $ fromString ("unknown packages: " <> show unknown)) +data StackEnvironment = StackEnvironment + { resolver :: Maybe Name, + extraDeps :: Maybe Extras, + allowNewer :: Maybe Bool + } + deriving (Generic, Show, Ord, Eq) +instance FromJSON StackEnvironment where + parseJSON = genericParseJSON aesonYAMLOptions + +instance ToJSON StackEnvironment where + toJSON = genericToJSON aesonYAMLOptions + data BuildEnvironment = BuildEnvironment - { buildEnv :: EnviromentTarget, + { buildGHC :: Version, buildPkgs :: [Pkg], buildName :: Name, buildExtraDeps :: Maybe Extras, - buildResolver :: Name + buildResolver :: Name, + buildAllowNewer :: Maybe Bool, + buildStack :: Bool, + buildNix :: Bool } deriving ( Generic, @@ -159,7 +194,7 @@ ) instance Format BuildEnvironment where - format BuildEnvironment {..} = buildName <> " (" <> format (ghc buildEnv) <> ")" + format BuildEnvironment {..} = buildName <> " (" <> format buildGHC <> ")" getBuildEnvironments :: ( MonadReader env m, @@ -170,19 +205,25 @@ ) => m [BuildEnvironment] getBuildEnvironments = do - envs <- envTargets <$> askEnv + globalEnv <- askEnv + envs <- envProfiles <$> askEnv for (Map.toList envs) $ \(name, env) -> do pkgs <- allPackages pure BuildEnvironment - { buildEnv = env, - buildPkgs = excludePkgs env pkgs, + { buildPkgs = excludePkgs env pkgs, buildName = name, - buildExtraDeps = extraDeps env, - buildResolver = resolver env + buildExtraDeps = extraDeps =<< unfeature =<< stack env, + buildResolver = fromMaybe (eraStackageResolverName $ selectEra (ghc env)) (resolver =<< unfeature =<< stack env), + buildGHC = ghc env, + buildAllowNewer = stack env >>= unfeature >>= allowNewer, + buildStack = isEnabled (envStack globalEnv) (stack env), + buildNix = isEnabled (envNix globalEnv) (nix env) } where - excludePkgs build = filter (\p -> pkgId p `notElem` fromMaybe [] (exclude build)) + excludePkgs build pkgs = + let excluseion = fromMaybe [] (exclude build) + in filter (not . (\pkg -> any (`isMember` pkg) excluseion)) pkgs getBuildEnvironment :: ( MonadReader env m, @@ -239,7 +280,7 @@ existsEnviroment :: (MonadReader env m, Has env Environments) => Name -> m Bool existsEnviroment n = do - envs <- envTargets <$> askEnv + envs <- envProfiles <$> askEnv pure $ isJust $ Map.lookup n envs printEnvironments :: (Monad m, MonadUI m, MonadReader env m, Has env Workspace, Has env Environments, MonadIO m, MonadError Issue m, Has env Cache) => Maybe Name -> m () @@ -265,4 +306,4 @@ -- | Remove an environment from the matrix by name removeEnvironmentByName :: Name -> Environments -> Environments removeEnvironmentByName envName matrix = - matrix {envTargets = Map.delete envName (envTargets matrix)} + matrix {envProfiles = Map.delete envName (envProfiles matrix)} diff --git a/src/HWM/Domain/Registry.hs b/src/HWM/Domain/Registry.hs new file mode 100644 --- /dev/null +++ b/src/HWM/Domain/Registry.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module HWM.Domain.Registry + ( Registry (..), + getDependencies, + lookupBounds, + addDependency, + deriveRegistry, + mapWithName, + mapDeps, + askRegistry, + ) +where + +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + Value (..), + ) +import Data.Foldable (Foldable (..)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import HWM.Core.Formatting (Format (..), formatTableRow) +import HWM.Core.Has (Has (obtain)) +import HWM.Core.Pkg (IsPkg (..), PkgName) +import HWM.Domain.Bounds (Bounds) +import HWM.Domain.Dependencies (Dependency (..), HasDependencies, collectNormalizedDependencies, fromDependencyList, normalizeDependencies, unpackDeps) +import Relude hiding + ( Undefined, + break, + drop, + fromList, + length, + null, + show, + toList, + ) + +askRegistry :: (MonadReader env m, Has env Registry) => m Registry +askRegistry = asks obtain + +newtype Registry = Registry {unpackRegistry :: Map PkgName Bounds} + deriving (Show) + +instance Semigroup Registry where + Registry a <> Registry b = Registry (a <> b) + +instance Monoid Registry where + mempty = Registry mempty + +instance FromJSON Registry where + parseJSON (Array xs) = Registry . unpackDeps <$> parseJSON (Array xs) + parseJSON v = Registry <$> parseJSON v + +instance ToJSON Registry where + toJSON (Registry ms) = toJSON . Map.mapWithKey formatTable $ ms + where + formatTable key value = + let padding = T.replicate (size - T.length (format key)) " " + in String (padding <> formatTableRow table (T.words (format value))) + size = maximum $ map (T.length . format) $ Map.keys ms + table = map (T.words . format) $ Map.elems ms + +lookupBounds :: PkgName -> Registry -> Maybe Bounds +lookupBounds pkgName registry = Map.lookup pkgName (unpackRegistry registry) + +getDependencies :: Registry -> [Dependency] +getDependencies (Registry m) = map (uncurry Dependency) $ Map.toList m + +addDependency :: Dependency -> Registry -> Registry +addDependency Dependency {..} (Registry m) = Registry $ Map.insert hwmDepName hwmDepBounds m + +deriveRegistry :: (HasDependencies a, IsPkg a) => [a] -> Registry +deriveRegistry packages = + let deps = concatMap collectNormalizedDependencies packages + externals = filter isExternal (normalizeDependencies deps) + in Registry . unpackDeps . fromDependencyList $ sortOn hwmDepName externals + where + internals = Set.fromList (map getPkgName packages) + isExternal dep = not (Set.member (hwmDepName dep) internals) + +mapWithName :: (PkgName -> Bounds -> b) -> Registry -> [b] +mapWithName f (Registry xs) = Map.elems $ Map.mapWithKey f xs + +mapDeps :: (PkgName -> Bounds -> Bounds) -> Registry -> Registry +mapDeps f (Registry xs) = Registry $ Map.mapWithKey f xs diff --git a/src/HWM/Domain/Workspace.hs b/src/HWM/Domain/Workspace.hs --- a/src/HWM/Domain/Workspace.hs +++ b/src/HWM/Domain/Workspace.hs @@ -23,6 +23,10 @@ allPackages, resolveWsPkgs, WsPkgs, + checkWorkspaceRefs, + isMember, + toWorkspaceRef, + printPkgWSRef, ) where @@ -44,9 +48,8 @@ import HWM.Core.Common (Name) import HWM.Core.Formatting (Color (..), availableOptions, chalk, commonPrefix, genMaxLen, monadStatus, padDots, slugify, statusIcon, subPathSign) import HWM.Core.Has (Has (..), askEnv) -import HWM.Core.Pkg (Pkg (..), PkgName, makePkg) +import HWM.Core.Pkg (Pkg (..), PkgName (..), makePkg) import HWM.Core.Result -import HWM.Domain.Dependencies (DependencyGraph, sortByDependencyHierarchy) import HWM.Runtime.Files (cleanRelativePath) import HWM.Runtime.UI (MonadUI, putLine, sectionWorkspace) import Relude @@ -57,8 +60,31 @@ { wsRefGroupId :: Name, wsRefMemberId :: Maybe Name } - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, Ord) +isMember :: WorkspaceRef -> Pkg -> Bool +isMember (WorkspaceRef groupId Nothing) pkg = pkgGroup pkg == groupId +isMember (WorkspaceRef groupId (Just memberId)) pkg = pkgGroup pkg == groupId && pkgMemberId pkg == memberId + +toWorkspaceRef :: Pkg -> WorkspaceRef +toWorkspaceRef Pkg {pkgGroup, pkgMemberId} = WorkspaceRef pkgGroup (Just pkgMemberId) + +printPkgWSRef :: Pkg -> Text +printPkgWSRef Pkg {pkgGroup, pkgMemberId} = pkgGroup <> "/" <> pkgMemberId + +checkWorkspaceRefs :: + ( MonadError Issue m, + MonadReader env m, + Has env Workspace, + MonadIO m + ) => + [WorkspaceRef] -> + m () +checkWorkspaceRefs ls = do + pkgs <- allPackages + let unknown = filter (\ref -> not (any (isMember ref) pkgs)) ls + unless (null unknown) (throwError $ fromString ("unknown packages: " <> show unknown)) + instance FromJSON WorkspaceRef where parseJSON = withText "WorkspaceRef" $ pure . parseWorkspaceRef @@ -144,23 +170,27 @@ Just p -> pure [p] Nothing -> throwError $ fromString $ toString $ "Target not found: " <> target -buildWorkspace :: (Monad m, MonadError Issue m) => DependencyGraph -> [Pkg] -> m Workspace -buildWorkspace graph = fmap (Map.fromList . concat) . traverse groupToWorkspace . groupBy sameGroup . sortOn pkgGroup +buildWorkspace :: (Monad m, MonadError Issue m) => [Pkg] -> m Workspace +buildWorkspace = fmap (Map.fromList . concat) . traverse groupToWorkspace . groupBy sameGroup . sortOn pkgGroup where sameGroup left right = pkgGroup left == pkgGroup right groupToWorkspace [] = pure [] groupToWorkspace (pkg : pkgs) = do - sortPkgs <- sortByDependencyHierarchy graph (pkg : pkgs) - let (prefix, members) = commonPrefix (map pkgMemberId sortPkgs) + let (prefix, members) = commonPrefix (map pkgMemberId (pkg : pkgs)) pure [ ( if T.null (pkgGroup pkg) then "libs" else slugify (pkgGroup pkg), WorkGroup { dir = cleanRelativePath (Just $ toString (pkgGroup pkg)), - members, + members = sortBy compareMembers members, prefix = prefix } ) ] + +compareMembers :: Text -> Text -> Ordering +compareMembers "." _ = GT +compareMembers _ "." = LT +compareMembers x y = compare x y forWorkspace :: (MonadIO m, MonadUI m, MonadIssue m, MonadError Issue m, MonadReader env m, Has env Workspace) => (Pkg -> m ()) -> m () forWorkspace f = forWorkspaceCore $ \pkg -> do diff --git a/src/HWM/Integrations/Scaffold.hs b/src/HWM/Integrations/Scaffold.hs --- a/src/HWM/Integrations/Scaffold.hs +++ b/src/HWM/Integrations/Scaffold.hs @@ -6,7 +6,7 @@ import qualified Data.Text as T import HWM.Core.Pkg (PkgName) import HWM.Domain.ConfigT (ConfigT) -import HWM.Integrations.Toolchain.Package (newPackage, savePackage) +import HWM.Integrations.Toolchain.Package (newPackage) import Relude import System.Directory (createDirectoryIfMissing) import System.FilePath (()) @@ -23,6 +23,5 @@ scaffoldPackage :: FilePath -> PkgName -> ConfigT () scaffoldPackage targetDir pkgName = do liftIO $ createDirectoryIfMissing True (targetDir "src") - package <- newPackage pkgName - savePackage (targetDir "package.yaml") package + newPackage targetDir pkgName liftIO $ writeFile (targetDir "src/Lib.hs") (T.unpack libHsTemplate) diff --git a/src/HWM/Integrations/Toolchain/Cabal.hs b/src/HWM/Integrations/Toolchain/Cabal.hs --- a/src/HWM/Integrations/Toolchain/Cabal.hs +++ b/src/HWM/Integrations/Toolchain/Cabal.hs @@ -1,26 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} module HWM.Integrations.Toolchain.Cabal - ( syncCabal, + ( rewriteCabalPackage, validateHackage, + syncCabalProject, + readCabalPackage, + HasSourceDirs (..), + CabalPackage, + newCabalPackage, ) where +import Control.Monad.Except (MonadError (throwError)) +import qualified Data.ByteString as BS import Data.Foldable (Foldable (..)) +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Distribution.PackageDescription (Benchmark (..), Executable (..), GenericPackageDescription (..), PackageDescription (..), PackageIdentifier (..), TestSuite (..), UnqualComponentName, emptyBuildInfo, emptyLibrary, emptyPackageDescription, mkPackageName, packageDescription) import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage) +import Distribution.PackageDescription.Parsec +import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription) import Distribution.Simple.PackageDescription (readGenericPackageDescription) +import Distribution.Types.BuildInfo (BuildInfo (..)) +import Distribution.Types.CondTree (CondTree (..)) +import Distribution.Types.Library (Library (..)) +import Distribution.Utils.Path (getSymbolicPath, unsafeMakeSymbolicPath) import Distribution.Verbosity (normal) -import HWM.Core.Formatting (Status (..)) -import HWM.Core.Pkg (Pkg (..), cabalFilePath, pkgYamlPath) +import HWM.Core.Common (Name) +import HWM.Core.Formatting (Format (..), Status (..)) +import HWM.Core.Options (Options (..)) +import HWM.Core.Pkg (IsPkg (..), Pkg (Pkg, hpackFile), PkgName) +import qualified HWM.Core.Pkg as P import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) +import HWM.Core.Version (Version, toCabalVersion) import HWM.Domain.ConfigT (ConfigT) -import HWM.Runtime.Files (remove) +import qualified HWM.Domain.ConfigT as CT +import HWM.Domain.Dependencies (Dependencies (..), HasDependencies (..), MapDeps (..), mkCabalDependency, toDependencyList) +import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment) import Hpack (Result (..), defaultOptions, hpackResult, setProgramName, setTarget) import qualified Hpack as H import Hpack.Config (ProgramName (..)) import Relude +import System.FilePath (takeDirectory, ()) -- | Translate Cabal warnings into formatting status for downstream reporting. toStatus :: PackageCheck -> Status @@ -44,21 +70,151 @@ ( Issue { issueMessage = "Invalid package: " <> show l, issueSeverity = if isError l then SeverityError else SeverityWarning, - issueTopic = pkgMemberId pkg, + issueTopic = P.pkgMemberId pkg, issueDetails = Just GenericIssue {issueFile = path} } ) pure (map toStatus ls) -syncCabal :: Pkg -> ConfigT Status -syncCabal pkg = do - remove (cabalFilePath pkg) - let programName = ProgramName $ toString $ pkgName pkg - let ops = setTarget (pkgYamlPath pkg) $ setProgramName programName defaultOptions +hpackSync :: Pkg -> ConfigT Status +hpackSync Pkg {hpackFile = Nothing} = pure Checked +hpackSync pkg@Pkg {hpackFile = Just path} = do + let programName = ProgramName $ toString $ P.pkgName pkg + let ops = setTarget path $ setProgramName programName defaultOptions Result {..} <- liftIO $ hpackResult ops - ls <- validateHackage pkg resultCabalFile - - s <- case resultStatus of + case resultStatus of H.OutputUnchanged -> pure Checked _ -> pure Updated + +rewriteCabalPackage :: (CabalPackage -> ConfigT CabalPackage) -> Pkg -> ConfigT Status +rewriteCabalPackage mapCabal pkg = do + s <- hpackSync pkg + ls <- validateHackage pkg (P.cabalFile pkg) + cabalP <- readCabalPackage pkg + newpackage <- mapCabal cabalP + liftIO $ writeGenericPackageDescription (P.cabalFile pkg) (cbOriginal newpackage) pure $ maximum (s : ls) + +generateCabalProject :: [Pkg] -> Text -> Text +generateCabalProject packagePaths ghcVersion = + T.unlines + [ "with-compiler: ghc-" <> ghcVersion, + "packages:\n" <> T.unlines (map ((" " <>) . format . P.pkgDirPath) packagePaths) + ] + +syncCabalProject :: ConfigT () +syncCabalProject = do + ops <- asks CT.options + BuildEnvironment {..} <- getBuildEnvironment Nothing + liftIO $ TIO.writeFile (optionsCabal ops) (generateCabalProject buildPkgs (toText buildGHC)) + +data CabalPackage = CabalPackage + { cbDirectory :: FilePath, + cbOriginal :: 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), + cbOriginal = gpd + } + +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 cbOriginal + +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 . cbOriginal + getPkgVersion = getPkgVersion . cbOriginal + setVersion version pkg = pkg {cbOriginal = setVersion version (cbOriginal pkg)} + +instance HasDependencies CabalPackage where + collectDependencies xs gpd = collectDependencies xs (cbOriginal gpd) + +instance MapDeps CabalPackage where + mapDeps ctx f cabalPkg = do + newGpd <- mapDeps ctx f (cbOriginal cabalPkg) + pure cabalPkg {cbOriginal = newGpd} + +newCabalPackage :: (MonadError Issue m, MonadIO m) => FilePath -> PkgName -> Version -> Dependencies -> m () +newCabalPackage dir name version deps = do + let package = emptyPackage name version deps + liftIO $ writeGenericPackageDescription (dir (toString name <> ".cabal")) package + +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 = [] + } diff --git a/src/HWM/Integrations/Toolchain/Hie.hs b/src/HWM/Integrations/Toolchain/Hie.hs --- a/src/HWM/Integrations/Toolchain/Hie.hs +++ b/src/HWM/Integrations/Toolchain/Hie.hs @@ -14,16 +14,14 @@ where import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object) -import qualified Data.Map as M import HWM.Core.Common (Name) -import HWM.Core.Formatting (Format (..)) +import HWM.Core.Formatting (Format (format)) import HWM.Core.Options (Options (..), askOptions) -import HWM.Core.Pkg (Pkg (..), PkgName, pkgFile, pkgYamlPath) +import HWM.Core.Pkg (Pkg (..), pkgFile) import HWM.Domain.ConfigT (ConfigT) import HWM.Domain.Workspace (allPackages) -import HWM.Integrations.Toolchain.Lib (Libraries, Library (..)) -import HWM.Integrations.Toolchain.Package (Package (..)) -import HWM.Runtime.Files (readYaml, rewrite_) +import HWM.Integrations.Toolchain.Cabal (HasSourceDirs (..), readCabalPackage) +import HWM.Runtime.Files (rewrite_) import Relude data Component = Component @@ -51,34 +49,14 @@ packHie :: Components -> Value packHie value = object [("cradle", object [("stack", toJSON value)])] -(<:>) :: (Semigroup a, IsString a) => a -> a -> a -(<:>) name tag = name <> ":" <> tag - genComponents :: Pkg -> ConfigT [Component] -genComponents path = do - Package {..} <- readYaml (pkgYamlPath path) - pure - $ comp name "lib" library - <> compGroup name "test" tests - <> compGroup name "exe" executables - <> compGroup name "bench" benchmarks +genComponents pkg = map comp . getSourceDirs [format $ pkgName pkg] <$> readCabalPackage pkg where - compGroup :: PkgName -> Text -> Maybe Libraries -> [Component] - compGroup name tag = concatMap mkComp . concatMap M.toList . maybeToList - where - mkComp (k, lib) = comp name (tag <:> k) (Just lib) - comp :: PkgName -> Text -> Maybe Library -> [Component] - comp name tag (Just Library {sourceDirs}) = - [ Component - { path = "./" <> pkgFile path (toString sourceDirs), - component = format name <:> tag - } - ] - comp _ _ _ = [] + comp (tag, sourceDirs) = Component {path = "./" <> pkgFile pkg (toString sourceDirs), component = tag} syncHie :: ConfigT () syncHie = do Options {..} <- askOptions pkgs <- allPackages components <- concat <$> traverse genComponents pkgs - rewrite_ hie (const $ pure $ packHie Components {stackYaml = stack, components}) + rewrite_ optionsHie (const $ pure $ packHie Components {stackYaml = optionsStack, components}) diff --git a/src/HWM/Integrations/Toolchain/Hpack.hs b/src/HWM/Integrations/Toolchain/Hpack.hs new file mode 100644 --- /dev/null +++ b/src/HWM/Integrations/Toolchain/Hpack.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module HWM.Integrations.Toolchain.Hpack + ( HpackPackage (..), + readHpackPackage, + rewriteHpackPackage, + newHpackPackage, + ) +where + +import Control.Monad.Error.Class (MonadError) +import Control.Monad.Except (MonadError (..)) +import Data.Aeson (FromJSON (..), GFromJSON, ToJSON (..), Value (..), genericParseJSON, genericToJSON, withObject) +import Data.Aeson.KeyMap (delete) +import Data.Aeson.Types (Object, Zero) +import Data.Yaml.Aeson (Parser) +import GHC.Generics (Generic (..)) +import HWM.Core.Common (Name) +import HWM.Core.Formatting (Status (Checked)) +import HWM.Core.Pkg (IsPkg (..), Pkg (..), PkgName (..)) +import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..)) +import HWM.Core.Version (Version) +import HWM.Domain.Dependencies (Dependencies, HasDependencies (..), MapDeps (..)) +import HWM.Runtime.Files (aesonYAMLOptions, aesonYAMLOptionsAdvanced, readYaml, rewrite_, statusM) +import Hpack () +import Relude +import System.FilePath (()) + +type Libraries = Map Name Library + +data Library = Library + { sourceDirs :: Name, + dependencies :: Maybe Dependencies, + __unknownFields :: Maybe Object + } + deriving + ( Show, + Generic + ) + +instance FromJSON Library where + parseJSON = fromObject (\t o -> t {__unknownFields = o}) + +instance ToJSON Library where + toJSON t = Object (toObject (genericToJSON aesonYAMLOptions t) <> fromMaybe mempty (__unknownFields t)) + +instance MapDeps Library where + mapDeps ctx f Library {..} = do + newDependencies <- traverse (f ctx) dependencies + pure $ Library {dependencies = newDependencies, ..} + +fromObject :: (Generic a, GFromJSON Zero (Rep a)) => (a -> Maybe Object -> a) -> Value -> Parser a +fromObject f v = do + t <- genericParseJSON aesonYAMLOptions v + o <- withObject "Lib" pure v + pure (f t (Just o)) + +toObject :: Value -> Object +toObject (Object x) = delete "__unknown-fields" x +toObject _ = mempty + +instance HasDependencies Library where + collectDependencies scope (Library {..}) = collectDependencies scope dependencies + +data HpackPackage = HpackPackage + { hpackName :: PkgName, + hpackVersion :: Version, + hpackLibrary :: Maybe Library, + hpackDependencies :: Maybe Dependencies, + hpackTests :: Maybe Libraries, + hpackExecutables :: Maybe Libraries, + hpackBenchmarks :: Maybe Libraries, + hpackInternalLibraries :: Maybe Libraries, + hpackForeignLibraries :: Maybe Libraries + } + deriving (Show, Generic) + +instance IsPkg HpackPackage where + getPkgName = hpackName + getPkgVersion = hpackVersion + setVersion version pkg = pkg {hpackVersion = version} + +instance FromJSON HpackPackage where + parseJSON = genericParseJSON (aesonYAMLOptionsAdvanced "hpack") + +instance ToJSON HpackPackage where + toJSON = genericToJSON (aesonYAMLOptionsAdvanced "hpack") + +instance MapDeps HpackPackage where + mapDeps (pkg, p) f HpackPackage {..} = do + newDependencies <- mapDeps (pkg, p <> ["dependencies"]) f hpackDependencies + newLibrary <- mapDeps (pkg, p <> ["library"]) f hpackLibrary + newTests <- mapDeps (pkg, p <> ["tests"]) f hpackTests + newExecutables <- mapDeps (pkg, p <> ["executables"]) f hpackExecutables + newBenchmarks <- mapDeps (pkg, p <> ["benchmarks"]) f hpackBenchmarks + newInternalLibraries <- mapDeps (pkg, p <> ["internal"]) f hpackInternalLibraries + newForeignLibraries <- mapDeps (pkg, p <> ["foreign"]) f hpackForeignLibraries + pure + $ HpackPackage + { hpackLibrary = newLibrary, + hpackTests = newTests, + hpackExecutables = newExecutables, + hpackBenchmarks = newBenchmarks, + hpackInternalLibraries = newInternalLibraries, + hpackForeignLibraries = newForeignLibraries, + hpackDependencies = newDependencies, + .. + } + +instance HasDependencies HpackPackage where + collectDependencies xs HpackPackage {..} = + concat + [ collectDependencies (xs <> ["dependencies"]) hpackDependencies, + collectDependencies (xs <> ["library"]) hpackLibrary, + collectDependencies (xs <> ["tests"]) hpackTests, + collectDependencies (xs <> ["executables"]) hpackExecutables, + collectDependencies (xs <> ["benchmarks"]) hpackBenchmarks, + collectDependencies (xs <> ["internal"]) hpackInternalLibraries, + collectDependencies (xs <> ["foreign"]) hpackForeignLibraries + ] + +emptyPackage :: PkgName -> Version -> Dependencies -> HpackPackage +emptyPackage name version dependencies = + HpackPackage + { hpackName = name, + hpackVersion = version, + hpackLibrary = Just Library {sourceDirs = "src", dependencies = Just dependencies, __unknownFields = Nothing}, + hpackDependencies = Nothing, + hpackTests = Nothing, + hpackExecutables = Nothing, + hpackBenchmarks = Nothing, + hpackInternalLibraries = Nothing, + hpackForeignLibraries = Nothing + } + +readHpackPackage :: (Monad m, MonadError Issue m, MonadIO m) => Pkg -> m HpackPackage +readHpackPackage pkg = + maybe + ( throwError + $ Issue + { issueTopic = pkgMemberId pkg, + issueMessage = "pkg does not support hpack or could not find package file", + issueSeverity = SeverityWarning, + issueDetails = Just GenericIssue {issueFile = cabalFile pkg} + } + ) + readYaml + (hpackFile pkg) + +rewriteHpackPackage :: (MonadIO m, MonadError Issue m) => (HpackPackage -> m HpackPackage) -> Pkg -> m Status +rewriteHpackPackage f pkg = do + maybe (pure Checked) (\path -> statusM path (rewrite_ path maybePackage)) (hpackFile pkg) + where + maybePackage Nothing = + throwError + $ Issue + { issueTopic = pkgMemberId pkg, + issueMessage = "could not find package file", + issueSeverity = SeverityWarning, + issueDetails = Just GenericIssue {issueFile = cabalFile pkg} + } + maybePackage (Just package) = f package + +newHpackPackage :: (MonadError Issue m, MonadIO m) => FilePath -> PkgName -> Version -> Dependencies -> m () +newHpackPackage dir name version deps = do + let package = emptyPackage name version deps + rewrite_ (dir "package.yaml") (const $ pure package) diff --git a/src/HWM/Integrations/Toolchain/Lib.hs b/src/HWM/Integrations/Toolchain/Lib.hs deleted file mode 100644 --- a/src/HWM/Integrations/Toolchain/Lib.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module HWM.Integrations.Toolchain.Lib - ( Library (..), - updateDependencies, - updateLibrary, - updateLibraries, - checkDependencies, - checkLibrary, - checkLibraries, - BoundsDiff, - Libraries, - ) -where - -#if MIN_VERSION_aeson(2,0,0) -import Data.Aeson.KeyMap (delete) -# else -import Data.HashMap.Lazy (delete) -#endif -import Control.Monad.Except (catchError) -import Data.Aeson.Types - ( FromJSON (..), - GFromJSON, - Object, - Parser, - ToJSON (..), - Value (..), - Zero, - genericParseJSON, - genericToJSON, - withObject, - ) -import qualified Data.Map.Strict as Map -import GHC.Generics (Generic (..)) -import HWM.Core.Common (Name) -import HWM.Core.Formatting (Format (..)) -import HWM.Core.Pkg (Pkg (pkgMemberId), PkgName, pkgYamlPath) -import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) -import HWM.Domain.Bounds (Bounds) -import HWM.Domain.Config (getRule) -import HWM.Domain.ConfigT (ConfigT, config, pkgs) -import HWM.Domain.Dependencies (Dependencies, Dependency (..), fromDependencyList, toDependencyList) -import HWM.Runtime.Files (aesonYAMLOptions) -import Relude - -type Libraries = Map Name Library - -type BoundsDiff = (Text, PkgName, Bounds, Bounds) - -data Library = Library - { sourceDirs :: Name, - dependencies :: Maybe Dependencies, - __unknownFields :: Maybe Object - } - deriving - ( Show, - Generic - ) - -instance FromJSON Library where - parseJSON = fromObject (\t o -> t {__unknownFields = o}) - -instance ToJSON Library where - toJSON t = Object (toObject (genericToJSON aesonYAMLOptions t) <> fromMaybe mempty (__unknownFields t)) - -fromObject :: (Generic a, GFromJSON Zero (Rep a)) => (a -> Maybe Object -> a) -> Value -> Parser a -fromObject f v = do - t <- genericParseJSON aesonYAMLOptions v - o <- withObject "Lib" pure v - pure (f t (Just o)) - -toObject :: Value -> Object -toObject (Object x) = delete "__unknown-fields" x -toObject _ = mempty - -updateDependency :: PkgName -> ConfigT Bounds -updateDependency name = do - cfg <- asks config - pkgs <- asks pkgs - getRule name pkgs cfg - --- | Process dependencies with error handling - shared logic for both check and update -processDependencies :: Pkg -> Text -> Dependencies -> (Dependency -> Maybe Bounds -> Maybe a) -> ConfigT [a] -processDependencies pkg scope deps processor = go [] [] (toDependencyList deps) - where - go results issues [] = do - -- Inject accumulated dependency issues at the end - unless (null issues) - $ injectIssue - Issue - { issueTopic = pkgMemberId pkg, - issueMessage = show (length issues) <> " dependency issue(s) in " <> scope, - issueSeverity = SeverityWarning, - issueDetails = - Just - DependencyIssue - { issueDependencies = issues, - issueFile = pkgYamlPath pkg - } - } - pure (reverse results) - go results issues (dep@(Dependency depName depBounds) : rest) = do - result <- catchError (Just <$> updateDependency depName) (\_ -> pure Nothing) - let (newIssues, maybeItem) = case result of - Nothing -> ((scope, format depName, format depBounds, "unknown") : issues, processor dep Nothing) - Just expected -> (issues, processor dep (Just expected)) - case maybeItem of - Nothing -> go results newIssues rest - Just item -> go (item : results) newIssues rest - -updateDependencies :: Pkg -> Text -> Dependencies -> ConfigT Dependencies -updateDependencies pkg scope deps = do - updated <- processDependencies pkg scope deps $ \(Dependency depName depBounds) maybeExpected -> - case maybeExpected of - Nothing -> Just (Dependency depName depBounds) -- Preserve original when lookup fails - Just expected -> Just (Dependency depName expected) - -- Return updated dependencies using fromDependencyList - pure $ fromDependencyList updated - -checkDependencies :: Pkg -> Text -> Dependencies -> ConfigT [BoundsDiff] -checkDependencies pkg scope deps = - processDependencies pkg scope deps $ \(Dependency depName depBounds) maybeExpected -> - case maybeExpected of - Nothing -> Nothing -- Skip unknown dependencies in diff - Just expected -> - if depBounds == expected - then Nothing - else Just (scope, depName, depBounds, expected) - -updateLibrary :: Pkg -> Text -> Library -> ConfigT Library -updateLibrary pkg scope Library {..} = do - newDependencies <- traverse (updateDependencies pkg scope) dependencies - pure $ Library {dependencies = newDependencies, ..} - -checkLibrary :: Pkg -> Text -> Library -> ConfigT [BoundsDiff] -checkLibrary _ _ Library {dependencies = Nothing} = pure [] -checkLibrary pkg scope Library {dependencies = Just deps} = - checkDependencies pkg scope deps - -updateLibraries :: Pkg -> Text -> Maybe Libraries -> ConfigT (Maybe Libraries) -updateLibraries _ _ Nothing = pure Nothing -updateLibraries pkg scope (Just libs) = do - updated <- traverse (\(name, lib) -> (name,) <$> updateLibrary pkg (scope <> ":" <> name) lib) (Map.toList libs) - pure $ Just $ Map.fromList updated - -checkLibraries :: Pkg -> Text -> Libraries -> ConfigT [BoundsDiff] -checkLibraries pkg scope libs = concat <$> traverse step (Map.toList libs) - where - step (name, lib) = checkLibrary pkg (scope <> ":" <> name) lib diff --git a/src/HWM/Integrations/Toolchain/Nix.hs b/src/HWM/Integrations/Toolchain/Nix.hs new file mode 100644 --- /dev/null +++ b/src/HWM/Integrations/Toolchain/Nix.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module HWM.Integrations.Toolchain.Nix (syncNixFile) where + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import HWM.Core.Common (Name) +import HWM.Core.Formatting (format, toCamelCase) +import HWM.Core.Options (Options (..)) +import HWM.Core.Pkg (Pkg (..)) +import HWM.Core.Version (Era (eraNixpkgs), Version, formatNixGhc, selectEra) +import HWM.Domain.Config (Config (Config, cfgName)) +import HWM.Domain.ConfigT (ConfigT, Env (..)) +import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment) +import Relude + +syncNixFile :: ConfigT () +syncNixFile = do + Config {..} <- asks config + ops <- asks options + BuildEnvironment {buildPkgs, buildGHC} <- getBuildEnvironment Nothing + liftIO $ TIO.writeFile (optionsNix ops) (deriveFlakeNix cfgName buildGHC buildPkgs) + +renderNixName :: Text -> Text +renderNixName name = toCamelCase name <> "WorkspacePackages" + +pkgsNixName :: Text -> Text +pkgsNixName name = "pkgs." <> renderNixName name + +generateOverlay :: Name -> Version -> [Pkg] -> [Text] +generateOverlay projectName ghc pkgs = + [ "haskellOverlay = final: prev: {", + " " <> renderNixName projectName <> " = prev.haskell.packages." <> formatNixGhc ghc <> ".extend (hfinal: hprev: {" + ] + <> map renderPackage pkgs + <> [ " });", + "};" + ] + where + renderPackage pkg = + " " <> format (pkgName pkg) <> " = hfinal.callCabal2nix \"" <> format (pkgName pkg) <> "\" ./" <> format (pkgDirPath pkg) <> " {};" + +deriveFlakeNix :: Name -> Version -> [Pkg] -> Text +deriveFlakeNix projectName version pkgs = + T.unlines + $ braces + ( [ "description = \"A Haskell " <> projectName <> " workspace generated by HWM(Haskell Workspace Manager)\";", + "inputs = {", + " nixpkgs.url = \"github:NixOS/nixpkgs/" <> eraNixpkgs (selectEra version) <> "\";", + "};", + "outputs = { self, nixpkgs }:" + ] + <> letBlock + ( [ "supportedSystems = [ \"x86_64-linux\" \"aarch64-linux\" \"x86_64-darwin\" \"aarch64-darwin\" ];", + "forAllSystems = nixpkgs.lib.genAttrs supportedSystems;" + ] + <> generateOverlay projectName version pkgs + ) + ( forAllSystems "packages" (generatePublicPackages projectName pkgs) + <> forAllSystems "devShells" (generateDevShell projectName pkgs) + ) + False + ) + +braces :: [Text] -> [Text] +braces body = + ["{"] <> map (" " <>) body <> ["}"] + +generatePublicPackages :: Name -> [Pkg] -> [Text] +generatePublicPackages _ [] = [] +generatePublicPackages projectName pkgs = map renderPublicPackage pkgs <> renderDefaultPackage + where + renderPublicPackage pkg = format (pkgName pkg) <> " = " <> pkgsNixName projectName <> "." <> format (pkgName pkg) <> ";" + renderDefaultPackage = + let defaultPkg = maybeToList $ find ((projectName ==) . format . pkgName) pkgs + in map (\pkg -> "default = " <> pkgsNixName projectName <> "." <> format (pkgName pkg) <> ";") defaultPkg + +generateDevShell :: Name -> [Pkg] -> [Text] +generateDevShell _ [] = [] -- Handle empty workspace +generateDevShell projectName pkgs = + [ "default = " <> pkgsNixName projectName <> ".shellFor {", + " packages = p: [ " <> renderPackageList pkgs <> " ];", + " buildInputs = with " <> pkgsNixName projectName <> "; [", + " cabal-install", + " haskell-language-server", + " hlint", + " ];", + "};" + ] + where + renderPackageList = T.intercalate " " . map (\pkg -> "p." <> format (pkgName pkg)) + +letBlock :: [Text] -> [Text] -> Bool -> [Text] +letBlock h body end = + [" let"] + <> map (" " <>) h + <> [ " in", + " {" + ] + <> map (" " <>) body + <> if end then [" });"] else [" };"] + +forAllSystems :: Text -> [Text] -> [Text] +forAllSystems system body = + [system <> " = forAllSystems (system:"] + <> letBlock + ["pkgs = import nixpkgs { inherit system; overlays = [ haskellOverlay ]; };"] + body + True diff --git a/src/HWM/Integrations/Toolchain/Package.hs b/src/HWM/Integrations/Toolchain/Package.hs --- a/src/HWM/Integrations/Toolchain/Package.hs +++ b/src/HWM/Integrations/Toolchain/Package.hs @@ -1,243 +1,105 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} module HWM.Integrations.Toolchain.Package - ( Package (..), - BoundsDiff, - syncPackages, - deriveRegistry, - packageDiffs, - validatePackage, - updatePackage, - packageModifyDependencies, - savePackage, + ( syncPackages, + validatePackages, + addPkgDependency, newPackage, + deriveDependencyGraph, ) where -import Control.Monad.Except (MonadError (..)) -import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) -import qualified Data.Map as Map -import qualified Data.Set as Set -import HWM.Core.Formatting (Format (..), displayStatus) -import HWM.Core.Pkg (Pkg (..), PkgName (PkgName), pkgMemberId, pkgYamlPath) -import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..)) -import HWM.Core.Version (Version) -import HWM.Domain.Config (getRule) -import HWM.Domain.ConfigT (ConfigT, Env (config, pkgs), askVersion) -import HWM.Domain.Dependencies (Dependencies, Dependency (Dependency), DependencyGraph (DependencyGraph), externalRegistry, normalizeDependencies, singleDeps, toDependencyList) -import HWM.Domain.Workspace (forWorkspaceCore) -import HWM.Integrations.Toolchain.Cabal (syncCabal) -import HWM.Integrations.Toolchain.Lib - ( BoundsDiff, - Libraries, - Library (..), - checkDependencies, - checkLibraries, - checkLibrary, - updateDependencies, - updateLibraries, - updateLibrary, +import qualified Data.Text as T +import HWM.Core.Formatting (displayStatus) +import HWM.Core.Pkg (IsPkg (..), Pkg (..), PkgName (PkgName), PkgSource (..), cabalSource, checkVersion, hpackSource) +import HWM.Domain.Bounds (Bounds (Bounds)) +import HWM.Domain.Config (getRegistryBounds) +import HWM.Domain.ConfigT (ConfigT, askVersion) +import HWM.Domain.Dependencies + ( Dependencies, + Dependency (..), + DependencyMap (..), + HasDependencies (..), + MapDeps (..), + buildDependencyGraph, + detectDependencyIssue, + fromDependencyList, + reportDependencyIssues, + singleDeps, + toDependencyList, ) -import HWM.Runtime.Files (aesonYAMLOptions, readYaml, rewrite_, statusM) +import qualified HWM.Domain.Dependencies as M +import HWM.Domain.Workspace (allPackages, forWorkspace, forWorkspaceCore) +import HWM.Integrations.Toolchain.Cabal (CabalPackage, newCabalPackage, readCabalPackage, rewriteCabalPackage) +import HWM.Integrations.Toolchain.Hpack (HpackPackage, newHpackPackage, readHpackPackage, rewriteHpackPackage) import Relude -data Package = Package - { name :: PkgName, - version :: Version, - library :: Maybe Library, - dependencies :: Dependencies, - tests :: Maybe Libraries, - executables :: Maybe Libraries, - benchmarks :: Maybe Libraries, - internalLibraries :: Maybe Libraries, - foreignLibraries :: Maybe Libraries - } - deriving (Show, Generic) - -instance FromJSON Package where - parseJSON = genericParseJSON aesonYAMLOptions - -instance ToJSON Package where - toJSON = genericToJSON aesonYAMLOptions - -newPackage :: PkgName -> ConfigT Package -newPackage name = do - cfg <- asks config - ps <- asks pkgs - let basename = PkgName "base" +newPackage :: FilePath -> PkgName -> ConfigT () +newPackage targetDir name = do + let baseName = PkgName "base" version <- askVersion - base <- getRule basename ps cfg - pure - $ Package - { name = name, - version = version, - library = Just Library {sourceDirs = "src", dependencies = Nothing, __unknownFields = Nothing}, - dependencies = singleDeps (Dependency basename base), - tests = Nothing, - executables = Nothing, - benchmarks = Nothing, - internalLibraries = Nothing, - foreignLibraries = Nothing - } - -mapPackage :: Pkg -> Package -> ConfigT Package -mapPackage pkg Package {..} = do - newLibrary <- traverse (updateLibrary pkg "library") library - newTests <- updateLibraries pkg "tests" tests - newExecutables <- updateLibraries pkg "executables" executables - newBenchmarks <- updateLibraries pkg "benchmarks" benchmarks - newInternalLibraries <- updateLibraries pkg "internal" internalLibraries - newForeignLibraries <- updateLibraries pkg "foreign" foreignLibraries - newDependencies <- updateDependencies pkg "dependencies" dependencies - newVersion <- askVersion - pure - $ Package - { version = newVersion, - library = newLibrary, - tests = newTests, - executables = newExecutables, - benchmarks = newBenchmarks, - internalLibraries = newInternalLibraries, - foreignLibraries = newForeignLibraries, - dependencies = newDependencies, - .. - } - -withMaybe :: (Applicative m) => (a -> m [b]) -> Maybe a -> m [b] -withMaybe = maybe (pure []) - --- | Determine whether a package already matches the expected configuration. -packageDiffs :: Pkg -> Package -> ConfigT [BoundsDiff] -packageDiffs pkg Package {..} = do - depsDiffs <- checkDependencies pkg "dependencies" dependencies - libraryDiffs <- withMaybe (checkLibrary pkg "library") library - testsDiffs <- withMaybe (checkLibraries pkg "tests") tests - executablesDiffs <- withMaybe (checkLibraries pkg "executables") executables - benchmarksDiffs <- withMaybe (checkLibraries pkg "benchmarks") benchmarks - internalDiffs <- withMaybe (checkLibraries pkg "internal") internalLibraries - foreignDiffs <- withMaybe (checkLibraries pkg "foreign") foreignLibraries - pure - ( depsDiffs - <> libraryDiffs - <> testsDiffs - <> executablesDiffs - <> benchmarksDiffs - <> internalDiffs - <> foreignDiffs - ) + base <- fromMaybe (Bounds Nothing Nothing) <$> getRegistryBounds baseName + let deps = M.singleDeps (Dependency baseName base) + newHpackPackage targetDir name version deps + newCabalPackage targetDir name version deps syncPackages :: ConfigT () -syncPackages = forWorkspaceCore $ \pkg -> updatePackage (mapPackage pkg) pkg +syncPackages = forWorkspaceCore $ updatePackage syncPackage syncPackage -packageModifyDependencies :: (Dependencies -> ConfigT Dependencies) -> Package -> ConfigT Package -packageModifyDependencies f Package {..} = do - newDependencies <- f dependencies - pure Package {dependencies = newDependencies, ..} +syncPackage :: (MapDeps a, IsPkg a) => PkgSource -> a -> ConfigT a +syncPackage pkg package = do + result <- mapDeps (pkg, []) syncDeps package + (`setVersion` result) <$> askVersion -updatePackage :: (Package -> ConfigT Package) -> Pkg -> ConfigT Text -updatePackage f pkg = do - let path = pkgYamlPath pkg - package <- statusM path (rewrite_ path maybePackage) - cabal <- syncCabal pkg - pure $ displayStatus [("pkg", package), ("cabal", cabal)] +syncDeps :: (PkgSource, [Text]) -> Dependencies -> ConfigT Dependencies +syncDeps (pkg, path) deps = + fromDependencyList <$> do + (issues, results) <- unzip <$> traverse syncDep (toDependencyList deps) + reportDependencyIssues pkg (concat issues) $> results where - maybePackage Nothing = - throwError - $ Issue - { issueTopic = pkgMemberId pkg, - issueMessage = "could not find package file", - issueSeverity = SeverityWarning, - issueDetails = Just GenericIssue {issueFile = pkgYamlPath pkg} - } - maybePackage (Just package) = f package - -savePackage :: FilePath -> Package -> ConfigT () -savePackage pkg package = rewrite_ pkg (const $ pure package) + syncDep (Dependency depName depBounds) = do + bounds <- getRegistryBounds depName + pure ([(T.intercalate ":" path, depName, depBounds, Nothing) | isNothing bounds], Dependency depName (fromMaybe depBounds bounds)) -collectPackageDependencies :: Package -> [Dependency] -collectPackageDependencies Package {..} = - normalizeDependencies - ( toDependencyList dependencies - <> collectLibrary library - <> collectLibraries tests - <> collectLibraries executables - <> collectLibraries benchmarks - <> collectLibraries internalLibraries - <> collectLibraries foreignLibraries - ) +addDeps :: (MapDeps a) => Dependency -> PkgSource -> a -> ConfigT a +addDeps dependency pkg = mapDeps (pkg, []) onlyMain where - collectLibrary :: Maybe Library -> [Dependency] - collectLibrary Nothing = [] - collectLibrary (Just Library {dependencies = Nothing}) = [] - collectLibrary (Just Library {dependencies = Just deps}) = toDependencyList deps + onlyMain (_, ["dependencies"]) deps = pure (deps <> singleDeps dependency) + onlyMain _ deps = pure deps - collectLibraries :: Maybe Libraries -> [Dependency] - collectLibraries Nothing = [] - collectLibraries (Just libs) = concatMap (collectLibrary . Just) (Map.elems libs) +addPkgDependency :: Dependency -> Pkg -> ConfigT Text +addPkgDependency dep = updatePackage (addDeps dep) (addDeps dep) -deriveRegistry :: (Monad m, MonadError Issue m, MonadIO m) => [Pkg] -> m (Dependencies, DependencyGraph) -deriveRegistry pkgs = do - packages <- traverse (readYaml . pkgYamlPath) pkgs - let graph = deriveDependencyGraph packages - let deps = externalRegistry (map pkgName pkgs) $ concatMap collectPackageDependencies packages - pure (deps, graph) +updatePackage :: (PkgSource -> HpackPackage -> ConfigT HpackPackage) -> (PkgSource -> CabalPackage -> ConfigT CabalPackage) -> Pkg -> ConfigT Text +updatePackage mapHpack mapCabal pkg = + displayStatus + ( map (\s -> ("hpack", rewriteHpackPackage (mapHpack s) pkg)) (maybeToList $ hpackSource pkg) + <> [("cabal", rewriteCabalPackage (mapCabal (cabalSource pkg)) pkg)] + ) -collectCriticalDependencies :: Package -> [Dependency] -collectCriticalDependencies Package {..} = normalizeDependencies (toDependencyList dependencies <> collectLibrary library) +deriveDependencyGraph :: ConfigT DependencyMap +deriveDependencyGraph = buildDependencyGraph (concatMap (toDependencyList . snd) . libDependencies) <$> (allPackages >>= traverse readCabalPackage) where - collectLibrary :: Maybe Library -> [Dependency] - collectLibrary Nothing = [] - collectLibrary (Just Library {dependencies = Nothing}) = [] - collectLibrary (Just Library {dependencies = Just deps}) = toDependencyList deps + libDependencies = filter (\x -> fst x == ["library"]) . collectDependencies [] -deriveDependencyGraph :: [Package] -> DependencyGraph -deriveDependencyGraph pkgs = DependencyGraph $ Map.fromList [(name pkg, internalDeps pkg) | pkg <- pkgs] - where - internalNames = Set.fromList (map name pkgs) - internalDeps pkg = mapMaybe selectInternal (collectCriticalDependencies pkg) - selectInternal (Dependency depName _) = - if Set.member depName internalNames then Just depName else Nothing +validatePackages :: ConfigT () +validatePackages = forWorkspace $ \pkg -> do + cabal <- readCabalPackage pkg + hpack <- traverse (\x -> (x,) <$> readHpackPackage pkg) (maybeToList $ hpackSource pkg) + validatePackage (cabalSource pkg, cabal) + for_ hpack validatePackage --- | Validate package against expected version and configuration -validatePackage :: Pkg -> ConfigT () -validatePackage pkg = do - let path = pkgYamlPath pkg - currentPkg <- readYaml path :: ConfigT Package - expectedVersion <- askVersion - let currentVersion = version currentPkg - versionMatch = currentVersion == expectedVersion - diffs <- packageDiffs pkg currentPkg - unless versionMatch - $ injectIssue - Issue - { issueTopic = pkgMemberId pkg, - issueMessage = "version mismatch: " <> format currentVersion <> " → " <> format expectedVersion, - issueSeverity = SeverityWarning, - issueDetails = Just GenericIssue {issueFile = path} - } - unless (null diffs) - $ injectIssue - Issue - { issueTopic = pkgMemberId pkg, - issueMessage = - let baseMsg = - if versionMatch - then "package out of sync (run 'hwm sync' to fix)" - else "package configuration diverged from expected (run 'hwm sync')" - diffCount = length diffs - countSuffix = if diffCount > 0 then " (" <> show diffCount <> " dependencies differ)" else "" - in baseMsg <> countSuffix, - issueSeverity = SeverityWarning, - issueDetails = - Just - DependencyIssue - { issueDependencies = map (\(scope, depName, actual, expected) -> (scope, format depName, format actual, format expected)) diffs, - issueFile = path - } - } +validatePackage :: (IsPkg a, HasDependencies a) => (PkgSource, a) -> ConfigT () +validatePackage (source, package) = do + checkVersion source package + diffs <- concat <$> traverse checkForDependencyIssues (collectDependencies [] package) + reportDependencyIssues source diffs + where + checkForDependencyIssues (path, deps) = concat <$> traverse (getIssue path) (toDependencyList deps) + getIssue path dep = detectDependencyIssue path dep <$> getRegistryBounds (hwmDepName dep) diff --git a/src/HWM/Integrations/Toolchain/Stack.hs b/src/HWM/Integrations/Toolchain/Stack.hs --- a/src/HWM/Integrations/Toolchain/Stack.hs +++ b/src/HWM/Integrations/Toolchain/Stack.hs @@ -36,17 +36,18 @@ import HWM.Core.Formatting (Format (..), Status (..), indentBlockNum, slugify) import HWM.Core.Options (Options (..), askOptions) import HWM.Core.Parsing (Parse (..)) -import HWM.Core.Pkg (Pkg (..), PkgName, pkgId, pkgYamlPath) +import HWM.Core.Pkg (Pkg (..), PkgName) import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..), fromEither) -import HWM.Core.Version (Version, parseGHCVersion) +import HWM.Core.Version (Version, latestGHCVersion, parseGHCVersion) import HWM.Domain.ConfigT (ConfigT) -import HWM.Domain.Environments (BuildEnvironment (..), EnviromentTarget (..), Environments (..), getBuildEnvironment, hkgRefs) +import HWM.Domain.Environments (BuildEnvironment (..), Enviroment (..), Environments (..), Feature (..), StackEnvironment (..), getBuildEnvironment, hkgRefs) +import HWM.Domain.Workspace (toWorkspaceRef) import HWM.Runtime.Cache (getSnapshotGHC) import HWM.Runtime.Files (aesonYAMLOptions, readYaml, rewrite_) import HWM.Runtime.Logging (logIssue) import HWM.Runtime.Process (exec) import Relude hiding (head, tail) -import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Directory (createDirectoryIfMissing, doesFileExist, makeAbsolute) import System.FilePath (dropExtension, ()) import System.FilePath.Glob (compile, globDir1) import System.FilePath.Posix (takeFileName) @@ -90,34 +91,40 @@ syncStackYaml :: ConfigT () syncStackYaml = do - stackYamlPath <- stack <$> askOptions + stackYamlPath <- optionsStack <$> askOptions rewrite_ stackYamlPath $ const $ do - BuildEnvironment {buildPkgs, buildEnv = EnviromentTarget {..}} <- getBuildEnvironment Nothing + BuildEnvironment {..} <- getBuildEnvironment Nothing pure Stack { saveHackageCreds = Just False, - extraDeps = map format . sort . hkgRefs <$> extraDeps, + extraDeps = map format . sort . hkgRefs <$> buildExtraDeps, packages = map pkgDirPath buildPkgs, compiler = Nothing, + resolver = buildResolver, + allowNewer = buildAllowNewer, .. } stackPath :: Maybe Name -> ConfigT FilePath -stackPath (Just name) = pure $ ".hwm/matrix/stack-" <> toString name <> ".yaml" -stackPath Nothing = stack <$> askOptions +stackPath (Just name) = liftIO $ makeAbsolute $ ".hwm/matrix/stack-" <> toString name <> ".yaml" +stackPath Nothing = do + options <- askOptions + liftIO $ makeAbsolute $ optionsStack options createEnvYaml :: Name -> ConfigT () createEnvYaml target = do path <- stackPath (Just target) liftIO $ createDirectoryIfMissing True ".hwm/matrix/" rewrite_ path $ const $ do - BuildEnvironment {buildEnv = EnviromentTarget {..}, ..} <- getBuildEnvironment (Just target) + BuildEnvironment {..} <- getBuildEnvironment Nothing pure Stack { saveHackageCreds = Just False, extraDeps = map format . sort . hkgRefs <$> buildExtraDeps, packages = map (("../../" <>) . pkgDirPath) buildPkgs, compiler = Nothing, + resolver = buildResolver, + allowNewer = buildAllowNewer, .. } @@ -155,7 +162,7 @@ { issueTopic = pkgMemberId pkg, issueMessage = "Package publishing failed:" <> indentBlockNum 4 ("\n\n" <> T.pack out), issueSeverity = SeverityError, - issueDetails = Just GenericIssue {issueFile = pkgYamlPath pkg} + issueDetails = Just GenericIssue {issueFile = fromMaybe (cabalFile pkg) (hpackFile pkg)} } ] ) @@ -171,15 +178,12 @@ Just _ -> Just SeverityWarning Nothing -> Nothing -scanStackFiles :: (MonadIO m, MonadError Issue m) => Options -> FilePath -> m (NonEmpty (Name, Stack)) +scanStackFiles :: (MonadIO m, MonadError Issue m) => Options -> FilePath -> m [(Name, Stack)] scanStackFiles opts root = do - let defaultPath = root stack opts + let defaultPath = root optionsStack opts defaultExists <- liftIO $ doesFileExist defaultPath variantPaths <- liftIO $ globDir1 (compile "stack-*.yaml") root - stacks <- traverse loadEnv ([defaultPath | defaultExists] <> variantPaths) - case stacks of - [] -> throwError "No stack.yaml found in current directory. Run 'stack init' first or ensure you're in a Stack project" - (defaultEnv : envs) -> pure (defaultEnv :| envs) + traverse loadEnv ([defaultPath | defaultExists] <> variantPaths) where loadEnv path = do seConfig <- readYaml path @@ -189,15 +193,30 @@ deriveEnviromentName :: FilePath -> Maybe Text deriveEnviromentName path = slugify <$> T.stripPrefix "stack-" (toText (dropExtension (takeFileName path))) -buildMatrix :: (MonadIO m, MonadError Issue m) => [Pkg] -> NonEmpty (Name, Stack) -> m Environments -buildMatrix pkgs (defaultEnv :| envs) = do +buildMatrix :: (MonadIO m, MonadError Issue m) => [Pkg] -> [(Name, Stack)] -> m Environments +buildMatrix pkgs (defaultEnv : envs) = do environments <- sortOn (ghc . snd) <$> traverse (inferBuildEnv pkgs) (defaultEnv : envs) - pure Environments {envDefault = fst defaultEnv, envTargets = Map.fromList environments} + pure Environments {envDefault = fst defaultEnv, envProfiles = Map.fromList environments, envStack = Just True, envNix = Nothing} +buildMatrix _ [] = do + let defaultEnv = mkDefaultEnv + pure Environments {envDefault = fst defaultEnv, envProfiles = Map.fromList [defaultEnv], envStack = Nothing, envNix = Nothing} -inferBuildEnv :: (MonadIO m, MonadError Issue m) => [Pkg] -> (Name, Stack) -> m (Name, EnviromentTarget) +mkDefaultEnv :: (Name, Enviroment) +mkDefaultEnv = + ( "default", + Enviroment + { stack = Nothing, + exclude = Nothing, + ghc = latestGHCVersion, + nix = Nothing, + .. + } + ) + +inferBuildEnv :: (MonadIO m, MonadError Issue m) => [Pkg] -> (Name, Stack) -> m (Name, Enviroment) inferBuildEnv allPkgs (name, Stack {extraDeps = deps, ..}) = do ghc <- maybe (getSnapshotGHC resolver) (fromEither "GHC Parsing" . parseGHCVersion) compiler extraDeps <- parseExtraDeps (fromMaybe [] deps) let excludeList = filter ((`notElem` packages) . pkgDirPath) allPkgs - exclude = if null excludeList then Nothing else Just (map pkgId excludeList) - pure (name, EnviromentTarget {..}) + exclude = if null excludeList then Nothing else Just (map toWorkspaceRef excludeList) + pure (name, Enviroment {stack = Just (Enabled StackEnvironment {resolver = Just resolver, ..}), nix = Nothing, ..}) diff --git a/src/HWM/Runtime/Cache.hs b/src/HWM/Runtime/Cache.hs --- a/src/HWM/Runtime/Cache.hs +++ b/src/HWM/Runtime/Cache.hs @@ -18,7 +18,6 @@ getVersions, Versions, VersionMap, - prepareDir, getSnapshotGHC, Snapshot (..), getSnapshot, @@ -138,9 +137,6 @@ vs <- hackage (format name) >>= select "Field" "normal-version" modifyCache (Cache tvar) (\reg -> reg {versions = Map.singleton name vs <> versions reg}) pure vs - -prepareDir :: (MonadIO m) => FilePath -> m () -prepareDir dir = liftIO $ createDirectoryIfMissing True dir data Snapshot = Snapshot {snapshotCompiler :: Version, snapshotPackages :: Map PkgName Version} deriving (Show) diff --git a/src/HWM/Runtime/Files.hs b/src/HWM/Runtime/Files.hs --- a/src/HWM/Runtime/Files.hs +++ b/src/HWM/Runtime/Files.hs @@ -18,6 +18,7 @@ genSignature, Signature, getFileSignature, + prepareDir, ) where @@ -45,7 +46,7 @@ import HWM.Core.Formatting import HWM.Core.Result (Issue) import Relude hiding (readFile, writeFile) -import System.Directory (doesFileExist, removeFile) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) import System.FilePath (joinPath, splitDirectories) import System.IO.Error (isDoesNotExistError) @@ -236,3 +237,6 @@ $ joinPath $ splitDirectories $ fromMaybe name (stripPrefix "./" name) + +prepareDir :: (MonadIO m) => FilePath -> m () +prepareDir dir = liftIO $ createDirectoryIfMissing True dir diff --git a/src/HWM/Runtime/Logging.hs b/src/HWM/Runtime/Logging.hs --- a/src/HWM/Runtime/Logging.hs +++ b/src/HWM/Runtime/Logging.hs @@ -2,13 +2,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -module HWM.Runtime.Logging (logIssue) where +module HWM.Runtime.Logging (logIssue, debug) where import Data.Time (getCurrentTime) import HWM.Core.Common (Name) -import HWM.Core.Options (whenCI) +import HWM.Core.Formatting (Color (Cyan), chalk) +import HWM.Core.Options (whenCI, whenDebug) import HWM.Core.Result (Severity) -import HWM.Runtime.Cache (prepareDir) +import HWM.Runtime.Files (prepareDir) import HWM.Runtime.UI (MonadUI, putLine) import Relude import qualified System.IO as TIO @@ -32,3 +33,6 @@ liftIO $ TIO.appendFile path (toString header) whenCI $ putLine content pure path + +debug :: (MonadIO m, MonadUI m) => Text -> m () +debug msg = whenDebug $ putLine $ chalk Cyan "[DEBUG] " <> msg diff --git a/test/Commands/Init.hs b/test/Commands/Init.hs new file mode 100644 --- /dev/null +++ b/test/Commands/Init.hs @@ -0,0 +1,21 @@ +module Commands.Init (testInit) where + +import Test.Hspec (Spec, describe, it) +import Utils.Golden (Golden (..), goldenTest) + +testInit :: Spec +testInit = describe "init" $ do + it "inits a simple workspace" $ + goldenTest + Golden + { cmd = "init", + project = "simple", + scenario = "init/simple" + } + it "inits a huge monorepo" $ + goldenTest + Golden + { cmd = "init", + project = "morpheus", + scenario = "init/cabal" + } diff --git a/test/Commands/Sync.hs b/test/Commands/Sync.hs new file mode 100644 --- /dev/null +++ b/test/Commands/Sync.hs @@ -0,0 +1,35 @@ +module Commands.Sync (testSync) where + +import Test.Hspec (Spec, describe, it) +import Utils.Golden (Golden (..), goldenTest) + +testSync :: Spec +testSync = describe "sync" $ do + it "syncs a simple workspace" $ + goldenTest + Golden + { cmd = "sync", + project = "simple", + scenario = "sync/simple" + } + it "syncs a cabal-only workspace" $ + goldenTest + Golden + { cmd = "sync", + project = "morpheus", + scenario = "sync/cabal" + } + it "syncs a nix workspace" $ + goldenTest + Golden + { cmd = "sync", + project = "morpheus", + scenario = "sync/nix" + } + it "syncs a stack workspace" $ + goldenTest + Golden + { cmd = "sync", + project = "morpheus", + scenario = "sync/stack" + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,10 @@ +module Main (main) where + +import Commands.Init (testInit) +import Commands.Sync (testSync) +import Test.Hspec (hspec) + +main :: IO () +main = hspec $ do + testInit + testSync diff --git a/test/Utils/Core.hs b/test/Utils/Core.hs new file mode 100644 --- /dev/null +++ b/test/Utils/Core.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Utils.Core (assertNotModified, assertWorkspaceNotModified, copyLocalFiles, inWorkDir, diff, runHWM) where + +import Control.Concurrent (threadDelay) +import qualified Data.List as S +import qualified GHC.IO.Exception as System.Exit +import Relude +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, getCurrentDirectory, getModificationTime, listDirectory, makeAbsolute, setCurrentDirectory) +import System.Directory.Internal.Prelude (bracket) +import System.FilePath (takeExtension, ()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (callCommand, readCreateProcessWithExitCode, shell) +import Test.Hspec (Expectation, expectationFailure, shouldBe) + +assertNotModified :: FilePath -> IO () -> Expectation +assertNotModified path action = do + oldTime <- getModificationTime path + threadDelay 1100000 + action + newTime <- getModificationTime path + newTime `shouldBe` oldTime + +assertWorkspaceNotModified :: FilePath -> IO a -> Expectation +assertWorkspaceNotModified root action = do + managedFiles <- findManagedFiles root + oldTimes <- mapM (\p -> (p,) <$> getModificationTime p) managedFiles + threadDelay 1100000 + _ <- action + newTimes <- mapM (\p -> (p,) <$> getModificationTime p) managedFiles + newTimes `shouldBe` oldTimes + +-- | Helper to find files HWM cares about (.cabal, .yaml, .nix, .project) +findManagedFiles :: FilePath -> IO [FilePath] +findManagedFiles dir = do + contents <- listDirectory dir + paths <- mapM (\path -> let p = dir path in (p,) <$> doesDirectoryExist p) contents + let files = [p | (p, isDir) <- paths, not isDir, isManagedExtension p] + subDirFiles <- concat <$> mapM (\(p, isDir) -> if isDir then findManagedFiles p else return []) paths + return $ files ++ subDirFiles + where + isManagedExtension p = takeExtension p `elem` [".cabal", ".yaml", ".nix", ".project"] + +copyLocalFiles :: FilePath -> IO () +copyLocalFiles = copyDir "." + +copyDir :: FilePath -> FilePath -> IO () +copyDir src dst = do + createDirectoryIfMissing True dst + callCommand $ "cp -r " <> src <> " " <> dst + +copyFrom :: FilePath -> FilePath -> IO () +copyFrom src = copyDir (src <> "/.") + +inWorkDir :: FilePath -> FilePath -> IO a -> IO () +inWorkDir project scenario m = do + projectDir <- makeAbsolute ("test/projects/" project) + overridesDir <- makeAbsolute (scenario "overrides") + withSystemTempDirectory "hwm-golden" $ \tmpDir -> do + let workDir = tmpDir "work" + copyFrom projectDir workDir + whenM (doesDirectoryExist overridesDir) $ copyFrom overridesDir workDir + bracket getCurrentDirectory setCurrentDirectory $ \_ -> do + setCurrentDirectory workDir + m $> () + +diff :: FilePath -> [FilePath] -> IO () +diff expectedDir ignoreList = do + let ignoreFlags = S.unwords ["-x " ++ p | p <- ignoreList] + (diffCode, diffOut, _) <- + readCreateProcessWithExitCode + (shell $ "diff -ruN " ++ ignoreFlags ++ " " ++ expectedDir ++ " .") + "" + unless (diffCode == System.Exit.ExitSuccess) + $ expectationFailure + $ "File diff failed:\n" + <> diffOut + +runHWM :: String -> IO String +runHWM cmd = do + (exitCode, out, err) <- + readCreateProcessWithExitCode + (shell $ "stack exec hwm -- " <> cmd) + "" + unless (exitCode == System.Exit.ExitSuccess) + $ expectationFailure ("Command failed with stdout: " <> out <> "stderr: " <> err) + return out diff --git a/test/Utils/Golden.hs b/test/Utils/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Utils/Golden.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Utils.Golden (Golden (..), goldenTest) where + +import Relude +import System.Directory (makeAbsolute, removePathForcibly) +import System.FilePath (()) +import qualified System.IO as IO +import Test.Hspec (Expectation, shouldBe) +import Utils.Core (copyLocalFiles, diff, inWorkDir, runHWM) + +data Golden = Golden + { cmd :: String, + scenario :: FilePath, + project :: FilePath + } + +isUpdateMode :: IO Bool +isUpdateMode = (== Just "1") <$> lookupEnv "GOLDEN_UPDATE" + +goldenTest :: Golden -> Expectation +goldenTest Golden {..} = do + scenarioDir <- makeAbsolute $ "test/golden/" scenario + let expectedDir = scenarioDir "expected" + let stdoutFile = scenarioDir "stdout.ansi" + updateMode <- isUpdateMode + inWorkDir project scenarioDir $ do + out <- runHWM cmd + if updateMode + then do + removePathForcibly expectedDir + copyLocalFiles expectedDir + IO.writeFile stdoutFile out + else do + diff expectedDir [".hwm", ".stack-work", "dist-newstyle", "*.log"] + expectedStdout <- IO.readFile stdoutFile + out `shouldBe` expectedStdout