hwm 0.1.2 → 0.2.0
raw patch · 39 files changed
+1697/−875 lines, 39 filesdep +hspecdep +temporarydep ~hwm
Dependencies added: hspec, temporary
Dependency ranges changed: hwm
Files
- hwm.cabal +188/−146
- src/HWM/CLI/App.hs +1/−1
- src/HWM/CLI/Command/Environment/Add.hs +11/−29
- src/HWM/CLI/Command/Init.hs +14/−8
- src/HWM/CLI/Command/Registry/Add.hs +5/−7
- src/HWM/CLI/Command/Registry/Audit.hs +4/−4
- src/HWM/CLI/Command/Registry/Ls.hs +3/−4
- src/HWM/CLI/Command/Release/Publish.hs +7/−7
- src/HWM/CLI/Command/Run.hs +1/−1
- src/HWM/CLI/Command/Status.hs +2/−3
- src/HWM/CLI/Command/Sync.hs +7/−3
- src/HWM/CLI/Command/Workspace/Add.hs +2/−2
- src/HWM/CLI/Command/Workspace/Ls.hs +2/−3
- src/HWM/Core/Formatting.hs +25/−5
- src/HWM/Core/Options.hs +21/−8
- src/HWM/Core/Pkg.hs +80/−63
- src/HWM/Core/Version.hs +46/−0
- src/HWM/Domain/Config.hs +17/−11
- src/HWM/Domain/ConfigT.hs +10/−6
- src/HWM/Domain/Dependencies.hs +245/−55
- src/HWM/Domain/Environments.hs +94/−53
- src/HWM/Domain/Registry.hs +90/−0
- src/HWM/Domain/Workspace.hs +38/−8
- src/HWM/Integrations/Scaffold.hs +2/−3
- src/HWM/Integrations/Toolchain/Cabal.hs +169/−13
- src/HWM/Integrations/Toolchain/Hie.hs +7/−29
- src/HWM/Integrations/Toolchain/Hpack.hs +171/−0
- src/HWM/Integrations/Toolchain/Lib.hs +0/−157
- src/HWM/Integrations/Toolchain/Nix.hs +112/−0
- src/HWM/Integrations/Toolchain/Package.hs +77/−215
- src/HWM/Integrations/Toolchain/Stack.hs +42/−23
- src/HWM/Runtime/Cache.hs +0/−4
- src/HWM/Runtime/Files.hs +5/−1
- src/HWM/Runtime/Logging.hs +7/−3
- test/Commands/Init.hs +21/−0
- test/Commands/Sync.hs +35/−0
- test/Main.hs +10/−0
- test/Utils/Core.hs +88/−0
- test/Utils/Golden.hs +38/−0
hwm.cabal view
@@ -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
src/HWM/CLI/App.hs view
@@ -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
src/HWM/CLI/Command/Environment/Add.hs view
@@ -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 ())
src/HWM/CLI/Command/Init.hs view
@@ -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
src/HWM/CLI/Command/Registry/Add.hs view
@@ -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
src/HWM/CLI/Command/Registry/Audit.hs view
@@ -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
src/HWM/CLI/Command/Registry/Ls.hs view
@@ -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
src/HWM/CLI/Command/Release/Publish.hs view
@@ -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
src/HWM/CLI/Command/Run.hs view
@@ -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
src/HWM/CLI/Command/Status.hs view
@@ -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
src/HWM/CLI/Command/Sync.hs view
@@ -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
src/HWM/CLI/Command/Workspace/Add.hs view
@@ -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 "✓")
src/HWM/CLI/Command/Workspace/Ls.hs view
@@ -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
src/HWM/Core/Formatting.hs view
@@ -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
src/HWM/Core/Options.hs view
@@ -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
src/HWM/Core/Pkg.hs view
@@ -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}+ }
src/HWM/Core/Version.hs view
@@ -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
src/HWM/Domain/Config.hs view
@@ -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"
src/HWM/Domain/ConfigT.hs view
@@ -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}
src/HWM/Domain/Dependencies.hs view
@@ -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
src/HWM/Domain/Environments.hs view
@@ -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)}
+ src/HWM/Domain/Registry.hs view
@@ -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
src/HWM/Domain/Workspace.hs view
@@ -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
src/HWM/Integrations/Scaffold.hs view
@@ -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)
src/HWM/Integrations/Toolchain/Cabal.hs view
@@ -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 = []+ }
src/HWM/Integrations/Toolchain/Hie.hs view
@@ -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})
+ src/HWM/Integrations/Toolchain/Hpack.hs view
@@ -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)
− src/HWM/Integrations/Toolchain/Lib.hs
@@ -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
+ src/HWM/Integrations/Toolchain/Nix.hs view
@@ -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
src/HWM/Integrations/Toolchain/Package.hs view
@@ -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)
src/HWM/Integrations/Toolchain/Stack.hs view
@@ -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, ..})
src/HWM/Runtime/Cache.hs view
@@ -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)
src/HWM/Runtime/Files.hs view
@@ -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
src/HWM/Runtime/Logging.hs view
@@ -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
+ test/Commands/Init.hs view
@@ -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"+ }
+ test/Commands/Sync.hs view
@@ -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"+ }
+ test/Main.hs view
@@ -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
+ test/Utils/Core.hs view
@@ -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
+ test/Utils/Golden.hs view
@@ -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