hix 0.8.0 → 0.9.0
raw patch · 221 files changed
+9493/−2905 lines, 221 filesdep +monad-controldep +networkdep +network-uridep ~hix
Dependencies added: monad-control, network, network-uri, template-haskell
Dependency ranges changed: hix
Files
- hix.cabal +171/−13
- lib/Hix.hs +29/−47
- lib/Hix/Bootstrap.hs +34/−12
- lib/Hix/Cabal.hs +28/−9
- lib/Hix/Class/EncodeNix.hs +4/−4
- lib/Hix/Class/Map.hs +83/−12
- lib/Hix/Color.hs +53/−0
- lib/Hix/Component.hs +6/−7
- lib/Hix/Console.hs +4/−1
- lib/Hix/Data/AppContext.hs +10/−0
- lib/Hix/Data/BootstrapProjectConfig.hs +3/−1
- lib/Hix/Data/ComponentConfig.hs +33/−11
- lib/Hix/Data/ComponentName.hs +21/−0
- lib/Hix/Data/Dep.hs +4/−0
- lib/Hix/Data/Error.hs +36/−13
- lib/Hix/Data/GhciConfig.hs +3/−3
- lib/Hix/Data/GhciTest.hs +3/−4
- lib/Hix/Data/GlobalOptions.hs +14/−9
- lib/Hix/Data/Json.hs +27/−1
- lib/Hix/Data/LogLevel.hs +15/−0
- lib/Hix/Data/MDep.hs +23/−0
- lib/Hix/Data/Monad.hs +13/−17
- lib/Hix/Data/NewProjectConfig.hs +30/−4
- lib/Hix/Data/NixExpr.hs +9/−1
- lib/Hix/Data/Options.hs +102/−28
- lib/Hix/Data/OutputTarget.hs +2/−0
- lib/Hix/Data/Overrides.hs +85/−10
- lib/Hix/Data/PackageId.hs +9/−0
- lib/Hix/Data/PackageName.hs +5/−5
- lib/Hix/Data/PathSpec.hs +37/−0
- lib/Hix/Data/VersionBounds.hs +15/−1
- lib/Hix/Env.hs +32/−7
- lib/Hix/Error.hs +47/−20
- lib/Hix/Ghci.hs +141/−59
- lib/Hix/Hackage.hs +106/−101
- lib/Hix/Hackage/Hash.hs +63/−0
- lib/Hix/Hackage/Versions.hs +48/−0
- lib/Hix/Http.hs +7/−0
- lib/Hix/Json.hs +7/−16
- lib/Hix/Log.hs +37/−17
- lib/Hix/Managed/App.hs +23/−0
- lib/Hix/Managed/Build.hs +43/−35
- lib/Hix/Managed/Build/Adapt.hs +127/−0
- lib/Hix/Managed/Build/Mutation.hs +3/−3
- lib/Hix/Managed/Build/NixOutput.hs +41/−53
- lib/Hix/Managed/Build/NixOutput/Analysis.hs +113/−7
- lib/Hix/Managed/Build/NixProcess.hs +171/−0
- lib/Hix/Managed/Build/Single.hs +5/−3
- lib/Hix/Managed/Build/Solve.hs +22/−7
- lib/Hix/Managed/Build/SolverPackages.hs +71/−0
- lib/Hix/Managed/Build/Target.hs +143/−0
- lib/Hix/Managed/BuildOutput.hs +39/−32
- lib/Hix/Managed/BuildOutput/CommitMsg.hs +32/−9
- lib/Hix/Managed/BuildOutput/GithubActionsPr.hs +6/−21
- lib/Hix/Managed/Bump/App.hs +11/−11
- lib/Hix/Managed/Bump/Candidates.hs +2/−1
- lib/Hix/Managed/Bump/Optimize.hs +40/−18
- lib/Hix/Managed/Cabal/Changes.hs +6/−4
- lib/Hix/Managed/Cabal/Config.hs +128/−0
- lib/Hix/Managed/Cabal/ContextHackageRepo.hs +75/−0
- lib/Hix/Managed/Cabal/Data/Config.hs +74/−18
- lib/Hix/Managed/Cabal/Data/ContextHackageRepo.hs +133/−0
- lib/Hix/Managed/Cabal/Data/HackageLocation.hs +99/−0
- lib/Hix/Managed/Cabal/Data/HackageRepo.hs +78/−0
- lib/Hix/Managed/Cabal/Data/InstalledOverrides.hs +11/−0
- lib/Hix/Managed/Cabal/Data/Packages.hs +10/−1
- lib/Hix/Managed/Cabal/Data/Revision.hs +23/−0
- lib/Hix/Managed/Cabal/Data/SolverState.hs +0/−7
- lib/Hix/Managed/Cabal/HackageLocation.hs +99/−0
- lib/Hix/Managed/Cabal/HackageRepo.hs +39/−0
- lib/Hix/Managed/Cabal/Init.hs +33/−21
- lib/Hix/Managed/Cabal/Mock.hs +20/−14
- lib/Hix/Managed/Cabal/Mock/SourcePackage.hs +23/−16
- lib/Hix/Managed/Cabal/PackageDescription.hs +28/−0
- lib/Hix/Managed/Cabal/Repo.hs +40/−40
- lib/Hix/Managed/Cabal/Resources.hs +50/−37
- lib/Hix/Managed/Cabal/Sdist.hs +41/−0
- lib/Hix/Managed/Cabal/Solve.hs +5/−3
- lib/Hix/Managed/Cabal/Upload.hs +182/−0
- lib/Hix/Managed/Data/BuildConfig.hs +15/−4
- lib/Hix/Managed/Data/BuildOutput.hs +40/−5
- lib/Hix/Managed/Data/Constraints.hs +1/−0
- lib/Hix/Managed/Data/EnvConfig.hs +9/−1
- lib/Hix/Managed/Data/EnvContext.hs +10/−15
- lib/Hix/Managed/Data/EnvState.hs +7/−3
- lib/Hix/Managed/Data/Envs.hs +4/−0
- lib/Hix/Managed/Data/Initial.hs +1/−1
- lib/Hix/Managed/Data/MaintConfig.hs +33/−0
- lib/Hix/Managed/Data/MaintContext.hs +42/−0
- lib/Hix/Managed/Data/ManagedPackage.hs +46/−21
- lib/Hix/Managed/Data/ManagedPackageProto.hs +0/−44
- lib/Hix/Managed/Data/Mutable.hs +38/−14
- lib/Hix/Managed/Data/Mutation.hs +0/−2
- lib/Hix/Managed/Data/MutationState.hs +5/−5
- lib/Hix/Managed/Data/NixOutput.hs +49/−0
- lib/Hix/Managed/Data/Packages.hs +4/−0
- lib/Hix/Managed/Data/ProcessState.hs +23/−24
- lib/Hix/Managed/Data/ProjectContext.hs +5/−4
- lib/Hix/Managed/Data/ProjectContextProto.hs +17/−6
- lib/Hix/Managed/Data/ProjectState.hs +15/−4
- lib/Hix/Managed/Data/ProjectStateProto.hs +8/−4
- lib/Hix/Managed/Data/RevisionConfig.hs +22/−0
- lib/Hix/Managed/Data/SpecialMaintHandlers.hs +5/−0
- lib/Hix/Managed/Data/StageContext.hs +3/−2
- lib/Hix/Managed/Data/StageState.hs +30/−8
- lib/Hix/Managed/Data/StateFileConfig.hs +12/−5
- lib/Hix/Managed/Data/Targets.hs +22/−49
- lib/Hix/Managed/Diff.hs +3/−3
- lib/Hix/Managed/EnvContext.hs +20/−18
- lib/Hix/Managed/EnvRequest.hs +35/−16
- lib/Hix/Managed/Flake.hs +102/−0
- lib/Hix/Managed/Flow.hs +8/−7
- lib/Hix/Managed/Git.hs +267/−0
- lib/Hix/Managed/Handlers/AvailableVersions.hs +32/−0
- lib/Hix/Managed/Handlers/AvailableVersions/Prod.hs +12/−0
- lib/Hix/Managed/Handlers/AvailableVersions/Test.hs +12/−0
- lib/Hix/Managed/Handlers/Build.hs +43/−45
- lib/Hix/Managed/Handlers/Build/Prod.hs +111/−295
- lib/Hix/Managed/Handlers/Build/Test.hs +40/−56
- lib/Hix/Managed/Handlers/Cabal/Prod.hs +51/−19
- lib/Hix/Managed/Handlers/Context.hs +119/−0
- lib/Hix/Managed/Handlers/Hackage.hs +0/−17
- lib/Hix/Managed/Handlers/Hackage/Prod.hs +0/−23
- lib/Hix/Managed/Handlers/HackageClient.hs +56/−0
- lib/Hix/Managed/Handlers/HackageClient/Prod.hs +185/−0
- lib/Hix/Managed/Handlers/Maint.hs +17/−0
- lib/Hix/Managed/Handlers/Maint/Prod.hs +90/−0
- lib/Hix/Managed/Handlers/Maint/Test.hs +62/−0
- lib/Hix/Managed/Handlers/Mutation.hs +1/−2
- lib/Hix/Managed/Handlers/Mutation/Bump.hs +3/−3
- lib/Hix/Managed/Handlers/Mutation/Lower.hs +3/−3
- lib/Hix/Managed/Handlers/Project.hs +19/−0
- lib/Hix/Managed/Handlers/Project/Prod.hs +24/−0
- lib/Hix/Managed/Handlers/Report/Prod.hs +1/−2
- lib/Hix/Managed/Handlers/Revision.hs +11/−0
- lib/Hix/Managed/Handlers/Revision/Prod.hs +21/−0
- lib/Hix/Managed/Handlers/SourceHash.hs +18/−0
- lib/Hix/Managed/Handlers/SourceHash/Prod.hs +26/−0
- lib/Hix/Managed/Handlers/StateFile/Prod.hs +5/−3
- lib/Hix/Managed/Lower/App.hs +14/−13
- lib/Hix/Managed/Lower/Auto.hs +6/−7
- lib/Hix/Managed/Lower/Candidates.hs +14/−14
- lib/Hix/Managed/Lower/Init.hs +7/−9
- lib/Hix/Managed/Lower/Optimize.hs +6/−11
- lib/Hix/Managed/Lower/Stabilize.hs +17/−32
- lib/Hix/Managed/Maint/Data/MaintEnv.hs +14/−0
- lib/Hix/Managed/Maint/Data/MaintPlan.hs +16/−0
- lib/Hix/Managed/Maint/Data/MaintPrep.hs +12/−0
- lib/Hix/Managed/Maint/Data/MaintResult.hs +125/−0
- lib/Hix/Managed/Maint/Data/MaintTarget.hs +31/−0
- lib/Hix/Managed/Maint/Git.hs +155/−0
- lib/Hix/Managed/Maint/MaintPlan.hs +51/−0
- lib/Hix/Managed/Maint/MaintResult.hs +75/−0
- lib/Hix/Managed/Maint/Package.hs +130/−0
- lib/Hix/Managed/Maint/Prep.hs +90/−0
- lib/Hix/Managed/Maint/RevisionPlan.hs +119/−0
- lib/Hix/Managed/ManagedPackage.hs +39/−15
- lib/Hix/Managed/ManagedPackageProto.hs +0/−27
- lib/Hix/Managed/Overrides.hs +40/−14
- lib/Hix/Managed/Path.hs +0/−14
- lib/Hix/Managed/Process.hs +11/−4
- lib/Hix/Managed/ProjectContext.hs +19/−26
- lib/Hix/Managed/ProjectContextProto.hs +39/−30
- lib/Hix/Managed/ProjectStateProto.hs +22/−31
- lib/Hix/Managed/ReleaseMaintenance.hs +88/−0
- lib/Hix/Managed/Report.hs +15/−3
- lib/Hix/Managed/StageContext.hs +4/−3
- lib/Hix/Managed/StageResult.hs +6/−6
- lib/Hix/Managed/StageState.hs +0/−2
- lib/Hix/Managed/StateFile.hs +20/−10
- lib/Hix/Managed/Targets.hs +30/−0
- lib/Hix/Managed/UpdateState.hs +35/−9
- lib/Hix/Monad.hs +169/−44
- lib/Hix/Network.hs +33/−0
- lib/Hix/New.hs +52/−16
- lib/Hix/NixCode.hs +21/−0
- lib/Hix/NixExpr.hs +9/−9
- lib/Hix/Options.hs +206/−116
- lib/Hix/Optparse.hs +42/−63
- lib/Hix/OutputWriter.hs +125/−16
- lib/Hix/Path.hs +26/−2
- lib/Hix/Preproc.hs +19/−13
- lib/Hix/Pretty.hs +159/−1
- lib/Hix/Trace.hs +5/−6
- lib/Hix/Version.hs +4/−2
- test/Hix/Test/BootstrapTest.hs +1/−1
- test/Hix/Test/GhciTest.hs +59/−31
- test/Hix/Test/Hedgehog.hs +0/−69
- test/Hix/Test/Managed/AnalyzeTest.hs +22/−0
- test/Hix/Test/Managed/BuildOutputTest.hs +10/−10
- test/Hix/Test/Managed/Bump/CandidatesTest.hs +10/−6
- test/Hix/Test/Managed/Bump/MutationTest.hs +293/−71
- test/Hix/Test/Managed/BumpNativeTest.hs +0/−135
- test/Hix/Test/Managed/DiffTest.hs +36/−9
- test/Hix/Test/Managed/HackageTest.hs +69/−0
- test/Hix/Test/Managed/LowerAuto/MutationOptimizeTest.hs +15/−11
- test/Hix/Test/Managed/LowerAuto/MutationStabilizeTest.hs +12/−11
- test/Hix/Test/Managed/LowerInit/MutationTest.hs +70/−19
- test/Hix/Test/Managed/LowerNativeTest.hs +16/−22
- test/Hix/Test/Managed/LowerOptimize/CandidatesTest.hs +14/−9
- test/Hix/Test/Managed/LowerOptimize/MutationTest.hs +14/−11
- test/Hix/Test/Managed/LowerOptimize/OrderTest.hs +4/−4
- test/Hix/Test/Managed/LowerStabilize/MutationTest.hs +15/−14
- test/Hix/Test/Managed/Maint/Handlers.hs +377/−0
- test/Hix/Test/Managed/ProjectContextProtoTest.hs +67/−49
- test/Hix/Test/Managed/ReleaseMaintenance/Case.hs +138/−0
- test/Hix/Test/Managed/ReleaseMaintenance/Gen.hs +107/−0
- test/Hix/Test/Managed/ReleaseMaintenanceTest.hs +172/−0
- test/Hix/Test/Managed/Run.hs +0/−147
- test/Hix/Test/Managed/SolveTest.hs +0/−52
- test/Hix/Test/Managed/TagTest.hs +58/−0
- test/Hix/Test/Managed/UnsafeIsString.hs +0/−81
- test/Hix/Test/ManagedTest.hs +7/−1
- test/Hix/Test/NewTest.hs +16/−3
- test/Hix/Test/Utils.hs +0/−42
- test/Main.hs +1/−2
- testing/Hix/Test/Hedgehog.hs +71/−0
- testing/Hix/Test/Managed/Run.hs +147/−0
- testing/Hix/Test/Managed/UnsafeIsString.hs +83/−0
- testing/Hix/Test/Run.hs +62/−0
- testing/Hix/Test/Utils.hs +56/−0
hix.cabal view
@@ -1,11 +1,11 @@-cabal-version: 2.2+cabal-version: 3.0 -- This file has been generated from package.yaml by hpack version 0.36.1. -- -- see: https://github.com/sol/hpack name: hix-version: 0.8.0+version: 0.9.0 synopsis: Haskell/Nix development build tools description: See https://hackage.haskell.org/package/hix/docs/Hix.html category: Build@@ -31,12 +31,15 @@ Hix.Class.EncodeNix Hix.Class.Map Hix.Class.SOP+ Hix.Color Hix.Compat Hix.Component Hix.Console+ Hix.Data.AppContext Hix.Data.BootstrapProjectConfig Hix.Data.Bounds Hix.Data.ComponentConfig+ Hix.Data.ComponentName Hix.Data.Dep Hix.Data.EnvName Hix.Data.Error@@ -44,6 +47,8 @@ Hix.Data.GhciTest Hix.Data.GlobalOptions Hix.Data.Json+ Hix.Data.LogLevel+ Hix.Data.MDep Hix.Data.Monad Hix.Data.NewProjectConfig Hix.Data.NixExpr@@ -53,6 +58,7 @@ Hix.Data.Overrides Hix.Data.PackageId Hix.Data.PackageName+ Hix.Data.PathSpec Hix.Data.PreprocConfig Hix.Data.ProjectFile Hix.Data.Version@@ -61,14 +67,22 @@ Hix.Error Hix.Ghci Hix.Hackage+ Hix.Hackage.Hash+ Hix.Hackage.Versions+ Hix.Http Hix.Json Hix.Log+ Hix.Managed.App Hix.Managed.Build+ Hix.Managed.Build.Adapt Hix.Managed.Build.Mutation Hix.Managed.Build.NixOutput Hix.Managed.Build.NixOutput.Analysis+ Hix.Managed.Build.NixProcess Hix.Managed.Build.Single Hix.Managed.Build.Solve+ Hix.Managed.Build.SolverPackages+ Hix.Managed.Build.Target Hix.Managed.BuildOutput Hix.Managed.BuildOutput.CommitMsg Hix.Managed.BuildOutput.GithubActionsPr@@ -77,24 +91,35 @@ Hix.Managed.Bump.Optimize Hix.Managed.Cabal.Changes Hix.Managed.Cabal.Config+ Hix.Managed.Cabal.ContextHackageRepo Hix.Managed.Cabal.Data.Config+ Hix.Managed.Cabal.Data.ContextHackageRepo+ Hix.Managed.Cabal.Data.HackageLocation+ Hix.Managed.Cabal.Data.HackageRepo+ Hix.Managed.Cabal.Data.InstalledOverrides Hix.Managed.Cabal.Data.Packages+ Hix.Managed.Cabal.Data.Revision Hix.Managed.Cabal.Data.SolveResources Hix.Managed.Cabal.Data.SolverState Hix.Managed.Cabal.Data.SolveTarget Hix.Managed.Cabal.Data.SourcePackage+ Hix.Managed.Cabal.HackageLocation+ Hix.Managed.Cabal.HackageRepo Hix.Managed.Cabal.Init Hix.Managed.Cabal.Installed Hix.Managed.Cabal.Mock Hix.Managed.Cabal.Mock.InstalledPackage Hix.Managed.Cabal.Mock.SourcePackage+ Hix.Managed.Cabal.PackageDescription Hix.Managed.Cabal.Print Hix.Managed.Cabal.Repo Hix.Managed.Cabal.Resources+ Hix.Managed.Cabal.Sdist Hix.Managed.Cabal.Solve Hix.Managed.Cabal.Sort Hix.Managed.Cabal.Source Hix.Managed.Cabal.Targets+ Hix.Managed.Cabal.Upload Hix.Managed.Constraints Hix.Managed.Data.BuildConfig Hix.Managed.Data.BuildOutput@@ -111,13 +136,15 @@ Hix.Managed.Data.Initial Hix.Managed.Data.Lower Hix.Managed.Data.LowerConfig+ Hix.Managed.Data.MaintConfig+ Hix.Managed.Data.MaintContext Hix.Managed.Data.ManagedPackage- Hix.Managed.Data.ManagedPackageProto Hix.Managed.Data.Mutable Hix.Managed.Data.MutableId Hix.Managed.Data.Mutation Hix.Managed.Data.MutationMode Hix.Managed.Data.MutationState+ Hix.Managed.Data.NixOutput Hix.Managed.Data.Packages Hix.Managed.Data.ProcessState Hix.Managed.Data.ProjectContext@@ -127,6 +154,8 @@ Hix.Managed.Data.ProjectStateProto Hix.Managed.Data.Query Hix.Managed.Data.QueryDep+ Hix.Managed.Data.RevisionConfig+ Hix.Managed.Data.SpecialMaintHandlers Hix.Managed.Data.StageContext Hix.Managed.Data.StageResult Hix.Managed.Data.StageState@@ -136,20 +165,35 @@ Hix.Managed.EnvContext Hix.Managed.EnvRequest Hix.Managed.EnvResult+ Hix.Managed.Flake Hix.Managed.Flow+ Hix.Managed.Git+ Hix.Managed.Handlers.AvailableVersions+ Hix.Managed.Handlers.AvailableVersions.Prod+ Hix.Managed.Handlers.AvailableVersions.Test Hix.Managed.Handlers.Build Hix.Managed.Handlers.Build.Prod Hix.Managed.Handlers.Build.Test Hix.Managed.Handlers.Cabal Hix.Managed.Handlers.Cabal.Prod- Hix.Managed.Handlers.Hackage- Hix.Managed.Handlers.Hackage.Prod+ Hix.Managed.Handlers.Context+ Hix.Managed.Handlers.HackageClient+ Hix.Managed.Handlers.HackageClient.Prod+ Hix.Managed.Handlers.Maint+ Hix.Managed.Handlers.Maint.Prod+ Hix.Managed.Handlers.Maint.Test Hix.Managed.Handlers.Mutation Hix.Managed.Handlers.Mutation.Bump Hix.Managed.Handlers.Mutation.Lower+ Hix.Managed.Handlers.Project+ Hix.Managed.Handlers.Project.Prod Hix.Managed.Handlers.Report Hix.Managed.Handlers.Report.Prod Hix.Managed.Handlers.Report.Test+ Hix.Managed.Handlers.Revision+ Hix.Managed.Handlers.Revision.Prod+ Hix.Managed.Handlers.SourceHash+ Hix.Managed.Handlers.SourceHash.Prod Hix.Managed.Handlers.StateFile Hix.Managed.Handlers.StateFile.Prod Hix.Managed.Handlers.StateFile.Test@@ -160,25 +204,38 @@ Hix.Managed.Lower.Init Hix.Managed.Lower.Optimize Hix.Managed.Lower.Stabilize+ Hix.Managed.Maint.Data.MaintEnv+ Hix.Managed.Maint.Data.MaintPlan+ Hix.Managed.Maint.Data.MaintPrep+ Hix.Managed.Maint.Data.MaintResult+ Hix.Managed.Maint.Data.MaintTarget+ Hix.Managed.Maint.Git+ Hix.Managed.Maint.MaintPlan+ Hix.Managed.Maint.MaintResult+ Hix.Managed.Maint.Package+ Hix.Managed.Maint.Prep+ Hix.Managed.Maint.RevisionPlan Hix.Managed.ManagedPackage- Hix.Managed.ManagedPackageProto Hix.Managed.Overrides- Hix.Managed.Path Hix.Managed.Process Hix.Managed.ProjectContext Hix.Managed.ProjectContextProto Hix.Managed.ProjectResult Hix.Managed.ProjectStateProto Hix.Managed.QueryDep+ Hix.Managed.ReleaseMaintenance Hix.Managed.Report Hix.Managed.StageContext Hix.Managed.StageResult Hix.Managed.StageState Hix.Managed.StateFile+ Hix.Managed.Targets Hix.Managed.UpdateState Hix.Maybe Hix.Monad+ Hix.Network Hix.New+ Hix.NixCode Hix.NixExpr Hix.Options Hix.Optparse@@ -253,11 +310,15 @@ , incipit-base >=0.5 && <0.7 , lens >=5.1 && <5.4 , lens-regex-pcre ==1.1.*+ , monad-control ==1.0.*+ , network+ , network-uri , optparse-applicative >=0.17 && <0.19 , path ==0.9.* , path-io >=1.7 && <1.9 , pretty , random ==1.2.*+ , template-haskell , these ==1.2.* , time , transformers@@ -269,6 +330,99 @@ , incipit-base hiding (IncipitBase) default-language: GHC2021 +library testing+ visibility: public+ exposed-modules:+ Hix.Test.Hedgehog+ Hix.Test.Managed.Run+ Hix.Test.Managed.UnsafeIsString+ Hix.Test.Run+ Hix.Test.Utils+ hs-source-dirs:+ testing+ default-extensions:+ StrictData+ AllowAmbiguousTypes+ ApplicativeDo+ BlockArguments+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ DisambiguateRecordFields+ DuplicateRecordFields+ FunctionalDependencies+ GADTs+ LambdaCase+ LiberalTypeSynonyms+ MonadComprehensions+ MultiWayIf+ OverloadedLabels+ OverloadedLists+ OverloadedStrings+ PackageImports+ PartialTypeSignatures+ PatternSynonyms+ QuantifiedConstraints+ QuasiQuotes+ RecordWildCards+ RecursiveDo+ RoleAnnotations+ TemplateHaskell+ TypeFamilies+ TypeFamilyDependencies+ UndecidableInstances+ UnicodeSyntax+ ViewPatterns+ OverloadedRecordDot+ NoFieldSelectors+ ghc-options: -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages+ build-depends:+ Cabal+ , aeson >=2.0 && <2.3+ , base ==4.*+ , bytestring+ , cabal-install+ , cabal-install-solver+ , casing >=0.1.4 && <0.2+ , containers+ , exceptions ==0.10.*+ , exon >=1.4 && <1.8+ , extra ==1.7.*+ , filepattern ==0.1.*+ , generic-lens ==2.2.*+ , generics-sop ==0.5.*+ , hedgehog >=1.1 && <1.5+ , hix:hix ==0.9.0+ , http-client ==0.7.*+ , http-client-tls ==0.3.*+ , http-types ==0.12.*+ , incipit-base >=0.5 && <0.7+ , lens >=5.1 && <5.4+ , lens-regex-pcre ==1.1.*+ , monad-control ==1.0.*+ , network+ , network-uri+ , optparse-applicative >=0.17 && <0.19+ , path ==0.9.*+ , path-io >=1.7 && <1.9+ , pretty+ , random ==1.2.*+ , tasty ==1.4.*+ , tasty-hedgehog >=1.3 && <1.5+ , template-haskell+ , these ==1.2.*+ , time+ , transformers+ , typed-process ==0.2.*+ , unix+ mixins:+ base hiding (Prelude)+ , incipit-base (IncipitBase as Prelude)+ , incipit-base hiding (IncipitBase)+ default-language: GHC2021+ executable hix main-is: Main.hs hs-source-dirs:@@ -330,12 +484,12 @@ Hix.Test.CabalFile Hix.Test.CabalTest Hix.Test.GhciTest- Hix.Test.Hedgehog+ Hix.Test.Managed.AnalyzeTest Hix.Test.Managed.BuildOutputTest Hix.Test.Managed.Bump.CandidatesTest Hix.Test.Managed.Bump.MutationTest- Hix.Test.Managed.BumpNativeTest Hix.Test.Managed.DiffTest+ Hix.Test.Managed.HackageTest Hix.Test.Managed.LowerAuto.MutationOptimizeTest Hix.Test.Managed.LowerAuto.MutationStabilizeTest Hix.Test.Managed.LowerInit.MutationTest@@ -344,14 +498,15 @@ Hix.Test.Managed.LowerOptimize.MutationTest Hix.Test.Managed.LowerOptimize.OrderTest Hix.Test.Managed.LowerStabilize.MutationTest+ Hix.Test.Managed.Maint.Handlers Hix.Test.Managed.ProjectContextProtoTest- Hix.Test.Managed.Run- Hix.Test.Managed.SolveTest- Hix.Test.Managed.UnsafeIsString+ Hix.Test.Managed.ReleaseMaintenance.Case+ Hix.Test.Managed.ReleaseMaintenance.Gen+ Hix.Test.Managed.ReleaseMaintenanceTest+ Hix.Test.Managed.TagTest Hix.Test.ManagedTest Hix.Test.NewTest Hix.Test.PreprocTest- Hix.Test.Utils Hix.Test.VersionTest hs-source-dirs: test@@ -401,12 +556,15 @@ , extra ==1.7.* , hedgehog >=1.1 && <1.5 , hix+ , hix:testing ==0.9.0 , incipit-base >=0.5 && <0.7 , path ==0.9.* , path-io >=1.7 && <1.9+ , pretty , tasty ==1.4.* , tasty-hedgehog >=1.3 && <1.5 , these ==1.2.*+ , time , transformers mixins: base hiding (Prelude)
lib/Hix.hs view
@@ -4,71 +4,53 @@ import Hix.Bootstrap (bootstrapProject) import qualified Hix.Console as Console-import Hix.Console (errorMessage) import qualified Hix.Data.GlobalOptions-import Hix.Data.GlobalOptions (GlobalOptions (GlobalOptions))+import Hix.Data.LogLevel (LogLevel) import qualified Hix.Data.Options as Options-import Hix.Data.Options (- Command (..),- LowerCommand (LowerAutoCmd, LowerInitCmd, LowerOptimizeCmd, LowerStabilizeCmd),- Options (Options),- )-import Hix.Env (printEnvRunner)-import Hix.Error (- Error (..),- printBootstrapError,- printEnvError,- printError,- printFatalError,- printGhciError,- printNewError,- printPreprocError,- )-import Hix.Ghci (printGhciCmdline, printGhcidCmdline)+import Hix.Data.Options (Command (..), HackageCommand (..), InfoCommand (..), LowerCommand (..), Options (Options))+import Hix.Env (printEnvRunner, runEnvCommand)+import Hix.Error (Error, printError)+import Hix.Ghci (printGhciCmdline, printGhcidCmdline, runGhci, runGhcid) import Hix.Managed.Bump.App (bumpCli) import Hix.Managed.Lower.App (lowerAutoCli, lowerInitCli, lowerOptimizeCli, lowerStabilizeCli)+import Hix.Managed.ReleaseMaintenance (releaseMaintenanceCli, revisionCli) import Hix.Monad (M, runMWith)-import Hix.New (newProject)+import Hix.New (initProject, newProject) import Hix.Options (parseCli) import Hix.Preproc (preprocess) -handleError ::- MonadIO m =>- GlobalOptions ->- Error ->- m ()-handleError GlobalOptions {verbose} = \case- PreprocError err -> printPreprocError err- EnvError err -> printEnvError err- GhciError err -> printGhciError err- NewError err -> printNewError err- BootstrapError err -> printBootstrapError err- NoMatch msg | verbose -> printPreprocError msg- NoMatch _ -> unit- Fatal err -> printFatalError err- Client err -> Console.err (errorMessage err)+hixVersion :: Text+hixVersion = "0.9.0" runCommand :: Command -> M () runCommand = \case+ Info InfoVersion -> Console.out hixVersion Preproc opts -> preprocess opts EnvRunner opts -> printEnvRunner opts.options GhcidCmd opts -> printGhcidCmdline opts GhciCmd opts -> printGhciCmdline opts- NewCmd opts -> newProject opts.config- BootstrapCmd opts -> bootstrapProject opts.config- BumpCmd opts -> bumpCli opts- LowerCmd sub -> case sub of- LowerInitCmd opts -> lowerInitCli opts- LowerOptimizeCmd opts -> lowerOptimizeCli opts- LowerStabilizeCmd opts -> lowerStabilizeCli opts- LowerAutoCmd opts -> lowerAutoCli opts+ RunGhci opts -> runGhci opts+ RunGhcid opts -> runGhcid opts+ RunCommand opts -> runEnvCommand opts+ Init opts -> initProject opts.config+ New opts -> newProject opts.config+ Bootstrap opts -> bootstrapProject opts.config+ Bump opts -> bumpCli opts+ Lower sub -> case sub of+ LowerInit opts -> lowerInitCli opts+ LowerOptimize opts -> lowerOptimizeCli opts+ LowerStabilize opts -> lowerStabilizeCli opts+ LowerAuto opts -> lowerAutoCli opts+ Hackage sub -> case sub of+ ReleaseMaint opts -> releaseMaintenanceCli opts+ Revision opts -> revisionCli opts -failure :: Bool -> Error -> IO ()-failure verbose err = do- printError verbose err+failure :: LogLevel -> Error -> IO ()+failure logLevel err = do+ printError logLevel err exitFailure main :: IO () main = do Options global cmd <- parseCli- leftA (failure global.verbose) =<< runMWith global (runCommand cmd)+ leftA (failure global.logLevel) =<< runMWith global (runCommand cmd)
lib/Hix/Bootstrap.hs view
@@ -2,7 +2,6 @@ module Hix.Bootstrap where -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ask) import qualified Data.Text as Text import Distribution.Compiler (PerCompilerFlavor (PerCompilerFlavor))@@ -29,14 +28,20 @@ import qualified Hix.Data.BootstrapProjectConfig import Hix.Data.BootstrapProjectConfig (BootstrapProjectConfig) import qualified Hix.Data.Monad (AppResources (cwd))-import Hix.Data.Monad (M (M))+import Hix.Data.Monad (M (M), appRes) import qualified Hix.Data.NewProjectConfig-import Hix.Data.NixExpr (Expr (ExprAttrs, ExprLit, ExprPrefix, ExprString), ExprAttr (ExprAttr, ExprAttrNil))+import Hix.Data.NixExpr (+ Expr (ExprAttrs, ExprLit, ExprPrefix, ExprString),+ ExprAttr (ExprAttr, ExprAttrNil),+ ExprKey (..),+ ) import Hix.Data.PackageName (PackageName (PackageName)) import qualified Hix.Data.ProjectFile import Hix.Data.ProjectFile (ProjectFile (ProjectFile), createFile)-import Hix.Error (pathText, tryIO)-import Hix.Monad (AppResources (AppResources), noteBootstrap)+import Hix.Error (pathText)+import Hix.Managed.Flake (runFlakeGenCabal, runFlakeLock)+import Hix.Managed.Git (GitNative (cmd', cmd_), runGitNative)+import Hix.Monad (AppResources (AppResources), noteBootstrap, tryIOM) import Hix.NixExpr (mkAttrs, multi, multiOrSingle, nonEmptyAttrs, renderRootExpr, single, singleOpt) import qualified Hix.Prelude import Hix.Prelude (Prelude, findPrelude)@@ -235,9 +240,9 @@ | otherwise = ExprString (toText p.prelude.preludePackage) key = case special of Library -> "library"- Executable name -> [exon|executables.#{name}|]- Test name -> [exon|tests.#{name}|]- Benchmark name -> [exon|benchmarks.#{name}|]+ Executable name -> [exon|executables.##{name}|]+ Test name -> [exon|tests.##{name}|]+ Benchmark name -> [exon|benchmarks.##{name}|] enable = case special of Library -> [ExprAttr "enable" (ExprLit "true")] _ -> []@@ -263,14 +268,17 @@ ExprAttr "inputs.hix.url" (ExprString conf.hixUrl.unHixUrl), ExprAttr "outputs" (ExprPrefix "{hix, ...}: hix.lib.flake" (ExprAttrs [ ExprAttr "packages" (ExprAttrs (flakePackage <$> pkgs)),- mainPackage pkgs+ mainPackage pkgs,+ devCli ])) ]+ where+ devCli = if conf.devCli then ExprAttr "internal.hixCli.dev" (ExprLit "true") else ExprAttrNil bootstrapFiles :: BootstrapProjectConfig -> M [ProjectFile] bootstrapFiles conf = do- AppResources {cwd} <- M ask- cabals <- paths =<< M (lift (tryIO (getDirectoryFilesIgnore (toFilePath cwd) ["**/*.cabal"] ["dist-newstyle/**"])))+ cwd <- appRes.cwd+ cabals <- paths =<< tryIOM (getDirectoryFilesIgnore (toFilePath cwd) ["**/*.cabal"] ["dist-newstyle/**"]) pkgs <- fmap convert <$> traverse (readCabal cwd) cabals pure [ ProjectFile {path = [relfile|flake.nix|], content = renderRootExpr (flake conf pkgs)}@@ -278,6 +286,20 @@ where paths = traverse (noteBootstrap "File path error" . parseRelFile) ++initGitAndFlake :: M ()+initGitAndFlake = do+ AppResources { cwd } <- M ask+ runGitNative cwd "init new project" \ git -> do+ statusResult <- git.cmd' ["status"]+ when (isLeft statusResult) $ git.cmd_ ["init"]+ git.cmd_ ["add", "."]+ runFlakeLock cwd+ git.cmd_ ["add", "flake.lock"]+ runFlakeGenCabal cwd+ git.cmd_ ["add", "*.cabal"]+ bootstrapProject :: BootstrapProjectConfig -> M ()-bootstrapProject conf =+bootstrapProject conf = do traverse_ createFile =<< bootstrapFiles conf+ unless conf.noInitGitAndFlake initGitAndFlake
lib/Hix/Cabal.hs view
@@ -2,7 +2,8 @@ module Hix.Cabal where -import Control.Monad.Trans.Except (ExceptT (ExceptT), throwE)+import Control.Exception (try)+import Control.Monad.Trans.Except (ExceptT (..), throwE) import Distribution.PackageDescription (BuildInfo (..), GenericPackageDescription (..)) import Distribution.Types.Benchmark (benchmarkBuildInfo) import Distribution.Types.CondTree (CondTree (..))@@ -27,12 +28,15 @@ toFilePath, (</>), )+import System.Exit (ExitCode) import System.FilePattern.Directory (getDirectoryFiles)-import System.IO.Error (tryIOError) +import qualified Hix.Color as Color import Hix.Compat (readGenericPackageDescription)-import Hix.Data.Error (Error (..))-import Hix.Error (pathText, sourceError)+import Hix.Data.Error (Error (..), ErrorMessage (Client, Fatal))+import Hix.Data.LogLevel (LogLevel (LogVerbose))+import Hix.Error (pathText, sourceError, throwMessage, tryIO)+import Hix.Monad (M, fromEither, tryIOMWith) #if MIN_VERSION_Cabal(3,14,0) import Distribution.Utils.Path (makeSymbolicPath)@@ -40,15 +44,15 @@ noMatch :: Text -> Path b File -> ExceptT Error IO a noMatch reason source =- throwE (NoMatch (sourceError reason source))+ throwE (Error {message = Client (sourceError reason source), context = [], level = Just LogVerbose}) cabalsInDir :: Path Abs Dir -> ExceptT Error IO [Path Abs File] cabalsInDir dir = do matches <- liftIO (getDirectoryFiles (toFilePath dir) ["*.cabal"])- let err = PreprocError [exon|Internal error when parsing globbed paths in '#{pathText dir}': #{show matches}|]- maybe (throwE err) pure (traverse parse matches)+ let err = Fatal [exon|Internal error when parsing globbed paths in '#{pathText dir}': #{show matches}|]+ maybe (throwMessage err) pure (traverse parse matches) where parse f = do rel <- parseRelFile f@@ -70,13 +74,13 @@ sub <- stripProperPrefix (parent cabal) source pure (cabal, sub) [] -> spin (parent dir)- _ -> throwE (PreprocError (sourceError "Multiple cabal files in parent dir of" source))+ _ -> throwMessage (Client (sourceError "Multiple cabal files in parent dir of" source)) notFound = noMatch "No cabal file found for " source parseCabal :: Path Abs File -> ExceptT Error IO GenericPackageDescription parseCabal path =- ExceptT $ fmap (first (PreprocError . show)) $ tryIOError do+ tryIO do #if MIN_VERSION_Cabal(3,14,0) readGenericPackageDescription Cabal.verbose Nothing (makeSymbolicPath (toFilePath path)) #else@@ -111,3 +115,18 @@ (cabalPath, sourceRel) <- findCabal source pkg <- parseCabal cabalPath matchComponent pkg sourceRel++catchExitCode :: Text -> IO a -> IO (Either ErrorMessage a)+catchExitCode preface ma =+ first errorExit <$> liftIO (try ma)+ where+ errorExit (_ :: ExitCode) =+ Fatal [exon|#{preface}: Cabal attempted to terminate the process 🙄 Please re-run with #{option}|]++ option = Color.shellCommand @Text "--cabal-verbose"++catchExitCodeM :: Text -> IO a -> M a+catchExitCodeM preface ma =+ fromEither =<< tryIOMWith general (catchExitCode preface ma)+ where+ general err = Fatal [exon|#{preface}#{err}|]
lib/Hix/Class/EncodeNix.hs view
@@ -8,7 +8,7 @@ import Text.PrettyPrint (Doc) import Hix.Class.SOP (Field (Field), FieldK (FieldK), ToFields (toFields))-import Hix.Data.NixExpr (Expr (..), ExprAttr (ExprAttr), ViaPretty (ViaPretty), exprBool, exprShow)+import Hix.Data.NixExpr (Expr (..), ExprAttr (ExprAttr), ExprKey (..), ViaPretty (ViaPretty), exprBool, exprShow) type EncodeField :: FieldK -> Constraint class EncodeField field where@@ -19,7 +19,7 @@ EncodeNix a ) => EncodeField ('FieldK name a) where encodeField (Field a) =- ExprAttr (toText (symbolVal (Proxy @name))) (encodeNix a)+ ExprAttr (ExprKey (toText (symbolVal (Proxy @name)))) (encodeNix a) class EncodeProd a where encodeProd :: a -> Expr@@ -36,10 +36,10 @@ toFields class EncodeNixKey a where- encodeNixKey :: a -> Text+ encodeNixKey :: a -> ExprKey instance EncodeNixKey Text where- encodeNixKey = id+ encodeNixKey = ExprKey class EncodeNix a where encodeNix :: a -> Expr
lib/Hix/Class/Map.hs view
@@ -29,6 +29,8 @@ nGet :: map -> Map k v nGet = coerce +instance Ord k => NMap (Map k v) k v LookupMaybe where+ lookupError :: ∀ k v . Show k =>@@ -60,9 +62,6 @@ instance NLookup LookupMaybe k v (Maybe v) where nLookup _ = id -instance Show k => NLookup LookupFatal k v (Text -> M v) where- nLookup k v thing = lookupError thing k v- (!?) :: ∀ map k v sort . NMap map k v sort =>@@ -196,19 +195,37 @@ nMapWithKey1 f = nMapWithKey \ k -> nMapWithKey (f k) -nTransform ::+nOver ::+ NMap map1 k v1 sort1 =>+ NMap map2 k v2 sort2 =>+ map1 ->+ (v1 -> v2) ->+ map2+nOver =+ flip nMap++nViaList :: NMap map1 k1 v1 sort1 => NMap map2 k2 v2 sort2 =>- (k1 -> v1 -> (k2, v2)) ->+ ([(k1, v1)] -> [(k2, v2)]) -> map1 -> map2-nTransform f =+nViaList f = coerce . Map.fromList .- fmap (uncurry f) .+ f . Map.toList . nGet +nTransform ::+ NMap map1 k1 v1 sort1 =>+ NMap map2 k2 v2 sort2 =>+ (k1 -> v1 -> (k2, v2)) ->+ map1 ->+ map2+nTransform f =+ nViaList (fmap (uncurry f))+ nTransformMaybe :: NMap map1 k1 v1 sort1 => NMap map2 k2 v2 sort2 =>@@ -216,12 +233,17 @@ map1 -> map2 nTransformMaybe f =- coerce .- Map.fromList .- mapMaybe (uncurry f) .- Map.toList .- nGet+ nViaList (mapMaybe (uncurry f)) +nTransformMulti ::+ NMap map1 k1 v1 sort1 =>+ NMap map2 k2 v2 sort2 =>+ (k1 -> v1 -> [(k2, v2)]) ->+ map1 ->+ map2+nTransformMulti f =+ nViaList (>>= (uncurry f))+ nMapMaybe :: NMap map1 k v1 sort1 => NMap map2 k v2 sort2 =>@@ -508,6 +530,46 @@ map3 nZip f = nZipWithKey (const f) +nPartitionWithKey ::+ ∀ map1 map2 map3 k1 k2 k3 v1 v2 v3 s1 s2 s3 .+ NMap map1 k1 v1 s1 =>+ NMap map2 k2 v2 s2 =>+ NMap map3 k3 v3 s3 =>+ (k1 -> v1 -> Either (k2, v2) (k3, v3)) ->+ map1 ->+ (map2, map3)+nPartitionWithKey f =+ coerce .+ Map.foldl' step (Map.empty, Map.empty) .+ Map.mapWithKey f .+ nGet+ where+ step (l, r) = \case+ Left (k, v2) -> (Map.insert k v2 l, r)+ Right (k, v3) -> (l, Map.insert k v3 r)++nPartitionByKey ::+ ∀ map1 map2 map3 k1 k2 k3 v s1 s2 s3 .+ NMap map1 k1 v s1 =>+ NMap map2 k2 v s2 =>+ NMap map3 k3 v s3 =>+ (k1 -> Either k2 k3) ->+ map1 ->+ (map2, map3)+nPartitionByKey f =+ nPartitionWithKey \ k1 v -> bimap (,v) (,v) (f k1)++nPartition ::+ ∀ map1 map2 map3 k v1 v2 v3 s1 s2 s3 .+ NMap map1 k v1 s1 =>+ NMap map2 k v2 s2 =>+ NMap map3 k v3 s3 =>+ (v1 -> Either v2 v3) ->+ map1 ->+ (map2, map3)+nPartition f =+ nPartitionWithKey \ k v1 -> bimap (k,) (k,) (f v1)+ nFromList :: NMap map k v sort => [(k, v)] ->@@ -654,6 +716,15 @@ m map nFor values f = nFromList <$> for values \ v -> (,v) <$> f v++nForAssoc ::+ Applicative m =>+ NMap map k v sort =>+ [a] ->+ (a -> m (k, v)) ->+ m map+nForAssoc seed f =+ nFromList <$> traverse f seed nElems :: ∀ map k v s .
+ lib/Hix/Color.hs view
@@ -0,0 +1,53 @@+module Hix.Color where++import Hix.Console (ColorOffsets (..), color, colors)+import Hix.Pretty (HPretty (hpretty))++prettyColor :: HPretty a => Int -> a -> Text+prettyColor offset a =+ color offset (show (hpretty a))++black :: HPretty a => a -> Text+black = prettyColor colors.black++red :: HPretty a => a -> Text+red = prettyColor colors.red++green :: HPretty a => a -> Text+green = prettyColor colors.green++yellow :: HPretty a => a -> Text+yellow = prettyColor colors.yellow++blue :: HPretty a => a -> Text+blue = prettyColor colors.blue++magenta :: HPretty a => a -> Text+magenta = prettyColor colors.magenta++cyan :: HPretty a => a -> Text+cyan = prettyColor colors.cyan++white :: HPretty a => a -> Text+white = prettyColor colors.white++path :: HPretty a => a -> Text+path = blue++shellCommand :: HPretty a => a -> Text+shellCommand = blue++url :: HPretty a => a -> Text+url = blue++package :: HPretty a => a -> Text+package = cyan++number :: HPretty a => a -> Text+number = cyan++config :: HPretty a => a -> Text+config = yellow++env :: HPretty a => a -> Text+env = config
lib/Hix/Component.hs view
@@ -16,13 +16,12 @@ Target (Target), TargetOrDefault (DefaultTarget, ExplicitTarget, NoDefaultTarget), )-import Hix.Data.Error (Error (EnvError)) import qualified Hix.Data.Options as Options import Hix.Data.Options (ComponentCoords, ComponentSpec (ComponentSpec), PackageSpec (PackageSpec), TargetSpec (..)) import Hix.Data.PackageName (PackageName (PackageName)) import Hix.Error (pathText)-import Hix.Monad (M, noteEnv, throwM)-import Hix.Path (rootDir)+import Hix.Monad (M, clientError, noteEnv)+import Hix.Path (PathSpecResolver (resolvePathSpec), rootDir) data ResolvedPackage = ResolvedPackage Bool PackageConfig@@ -126,9 +125,9 @@ where match cand = matchComponent cand comp targetInPackage (ResolvedPackage True package) Nothing =- either (throwM . EnvError) pure (ExplicitTarget <$> defaultComponent package)+ either clientError (pure . ExplicitTarget) (defaultComponent package) targetInPackage (ResolvedPackage False package) Nothing = do- either (pure . NoDefaultTarget) pure (DefaultTarget <$> defaultComponent package)+ either (pure . NoDefaultTarget) (pure . DefaultTarget) (defaultComponent package) targetInPackage (NoPackage err) _ = pure (NoDefaultTarget err) targetForComponent ::@@ -172,7 +171,7 @@ TargetForComponent spec -> targetForComponent root mainPkg config spec TargetForFile spec ->- ExplicitTarget <$> targetForFile root config spec+ ExplicitTarget <$> (targetForFile root config =<< resolvePathSpec spec) targetComponent :: Maybe (Path Abs Dir) ->@@ -194,4 +193,4 @@ targetComponent cliRoot mainPkg config spec >>= \case ExplicitTarget t -> pure t DefaultTarget t -> pure t- NoDefaultTarget err -> throwM (EnvError err)+ NoDefaultTarget err -> clientError err
lib/Hix/Console.hs view
@@ -79,6 +79,9 @@ withChevrons col msg = [exon|#{sgis [show (30 + col), "1"] ">>>"} #{msg}|] +withErrorChevrons :: Text -> Text+withErrorChevrons = withChevrons 1+ errorMessage :: Text -> Text errorMessage msg =- withChevrons 1 [exon|Error: #{msg}|]+ withErrorChevrons [exon|Error: #{msg}|]
+ lib/Hix/Data/AppContext.hs view
@@ -0,0 +1,10 @@+module Hix.Data.AppContext where++import Hix.Data.LogLevel (LogLevel)++data AppContext =+ AppContext {+ description :: Text,+ level :: LogLevel+ }+ deriving stock (Eq, Show)
lib/Hix/Data/BootstrapProjectConfig.hs view
@@ -4,6 +4,8 @@ data BootstrapProjectConfig = BootstrapProjectConfig {- hixUrl :: HixUrl+ hixUrl :: HixUrl,+ noInitGitAndFlake :: Bool,+ devCli :: Bool } deriving stock (Eq, Show, Generic)
lib/Hix/Data/ComponentConfig.hs view
@@ -1,10 +1,19 @@-module Hix.Data.ComponentConfig where+module Hix.Data.ComponentConfig (+ module Hix.Data.ComponentConfig,+ ComponentName (..),+) where import Data.Aeson (FromJSON (parseJSON), FromJSONKey, withObject, (.:))-import Distribution.Pretty (Pretty (pretty))+import Distribution.Parsec (Parsec (parsec))+import Distribution.Pretty (Pretty (..))+import Distribution.Simple (Dependency (..)) import Path (Abs, Dir, File, Path, Rel)+import Text.PrettyPrint (brackets, (<+>)) +import Hix.Data.ComponentName (ComponentName (..))+import Hix.Data.Json (jsonParsec) import Hix.Data.PackageName (PackageName)+import Hix.Pretty (prettyL) newtype PackagePath = PackagePath { unPackagePath :: Path Rel Dir }@@ -31,14 +40,6 @@ deriving stock (Eq, Show, Generic) deriving newtype (IsString, Ord, FromJSON, FromJSONKey) -newtype ComponentName =- ComponentName { unComponentName :: Text }- deriving stock (Eq, Show, Generic)- deriving newtype (IsString, Ord, FromJSON, FromJSONKey)--instance Pretty ComponentName where- pretty (ComponentName n) = fromString (toString n)- newtype EnvRunner = EnvRunner (Path Abs File) deriving stock (Eq, Show, Generic)@@ -71,6 +72,22 @@ module_ <- o .: "module" pure PreludeConfig {..} +newtype ComponentDep =+ ComponentDep Dependency+ deriving stock (Eq, Show)+ deriving newtype (Ord, Pretty)++instance Parsec ComponentDep where+ parsec = ComponentDep <$> parsec++instance FromJSON ComponentDep where+ parseJSON v =+ cabal <|> structured v+ where+ structured = withObject "ComponentDep" \ o -> jsonParsec <$> o .: "name"++ cabal = jsonParsec <$> parseJSON v+ data ComponentConfig = ComponentConfig { name :: ComponentName,@@ -79,10 +96,15 @@ extensions :: [String], language :: String, ghcOptions :: [String],- prelude :: Maybe PreludeConfig+ prelude :: Maybe PreludeConfig,+ deps :: Set ComponentDep } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON)++instance Pretty ComponentConfig where+ pretty ComponentConfig {..} =+ pretty name <+> brackets (prettyL deps) data PackageConfig = PackageConfig {
+ lib/Hix/Data/ComponentName.hs view
@@ -0,0 +1,21 @@+module Hix.Data.ComponentName where++import Data.Aeson (FromJSON, FromJSONKey)+import Distribution.Pretty (Pretty (..))+import Distribution.Types.LibraryName (LibraryName (..))+import Distribution.Types.UnqualComponentName (unUnqualComponentName)++import Hix.Pretty (prettyText)++newtype ComponentName =+ ComponentName { unComponentName :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Ord, FromJSON, FromJSONKey)++instance Pretty ComponentName where+ pretty (ComponentName n) = prettyText n++fromCabal :: LibraryName -> ComponentName+fromCabal = \case+ LMainLibName -> "library"+ LSubLibName name -> fromString (unUnqualComponentName name)
lib/Hix/Data/Dep.hs view
@@ -8,6 +8,7 @@ import Distribution.Version (VersionRange, thisVersion) import Exon (exon) +import Hix.CabalParsec (unsafeParsec) import Hix.Data.Json (aesonParsec, jsonParsec) import qualified Hix.Data.PackageName as PackageName import Hix.Data.PackageName (PackageName)@@ -57,3 +58,6 @@ withVersion :: VersionRange -> Dep -> Dep withVersion version dep = dep {version}++unsafeDep :: String -> Dep+unsafeDep = fromCabal . unsafeParsec
lib/Hix/Data/Error.hs view
@@ -1,19 +1,42 @@ module Hix.Data.Error where -data Error =- PreprocError Text- |- EnvError Text- |- GhciError Text- |- NewError Text- |- BootstrapError Text- |- NoMatch Text- |+import Distribution.Pretty (Pretty (..))+import GHC.Exts (IsList)+import Text.PrettyPrint (text, vcat, ($$), (<+>))++import Hix.Data.AppContext (AppContext (..))+import Hix.Data.LogLevel (LogLevel)++data ErrorMessage = Fatal Text |+ FatalExternal Text+ | Client Text deriving stock (Eq, Show, Generic)++instance Pretty ErrorMessage where+ pretty = \case+ Fatal msg -> fatal msg+ FatalExternal msg -> fatal msg+ Client msg -> text (toString msg)+ where+ fatal msg = "Fatal:" <+> text (toString msg)++newtype ErrorContext =+ ErrorContext [AppContext]+ deriving stock (Eq, Show)+ deriving newtype (IsList)++data Error =+ Error {+ message :: ErrorMessage,+ context :: ErrorContext,+ level :: Maybe LogLevel+ }+ deriving stock (Eq, Show)++instance Pretty Error where+ pretty Error {context = ErrorContext ctx, ..} =+ vcat ["While" <+> text (toString description) | AppContext {description} <- reverse ctx] $$+ pretty message
lib/Hix/Data/GhciConfig.hs view
@@ -41,11 +41,11 @@ data GhciConfig = GhciConfig {- packages :: PackagesConfig,- mainPackage :: Maybe PackageName,+ env :: EnvConfig, setup :: Map RunnerName GhciSetupCode, run :: Map RunnerName GhciRunExpr,- args :: GhciArgs+ args :: GhciArgs,+ manualCabal :: Bool } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON)
lib/Hix/Data/GhciTest.hs view
@@ -16,16 +16,15 @@ data GhciRun = GhciRun { test :: GhciTest,- shell :: Text,+ shell :: NonEmpty Text, run :: Maybe Text,- scriptFile :: Path Abs File,- cmdline :: Text+ scriptFile :: Path Abs File } deriving stock (Eq, Show, Generic) data GhcidRun = GhcidRun {- cmdline :: Text,+ args :: NonEmpty Text, ghci :: GhciRun } deriving stock (Eq, Show, Generic)
lib/Hix/Data/GlobalOptions.hs view
@@ -1,16 +1,18 @@ module Hix.Data.GlobalOptions where -import Path (Abs, Dir, Path)+import Path (Abs, Dir, Path, SomeBase (Abs)) +import Hix.Data.LogLevel (LogLevel (LogInfo)) import Hix.Data.OutputFormat (OutputFormat (OutputNone)) import Hix.Data.OutputTarget (OutputTarget (OutputDefault))+import Hix.Data.PathSpec (PathSpec (PathConcrete)) data GlobalOptions = GlobalOptions {- verbose :: Bool,- debug :: Bool,- quiet :: Bool,- cwd :: Path Abs Dir,+ logLevel :: LogLevel,+ cabalVerbose :: Bool,+ cwd :: PathSpec Dir,+ root :: PathSpec Dir, output :: OutputFormat, target :: OutputTarget }@@ -19,10 +21,13 @@ defaultGlobalOptions :: Path Abs Dir -> GlobalOptions defaultGlobalOptions cwd = GlobalOptions {- verbose = False,- debug = False,- quiet = False,- cwd,+ logLevel = LogInfo,+ cabalVerbose = False,+ cwd = cwdSpec,+ root = cwdSpec, output = OutputNone, target = OutputDefault }+ where+ cwdSpec :: PathSpec Dir+ cwdSpec = PathConcrete (Abs cwd)
lib/Hix/Data/Json.hs view
@@ -1,8 +1,9 @@ module Hix.Data.Json where -import Data.Aeson (FromJSON (parseJSON), Key, Object, (.:?))+import Data.Aeson (FromJSON (parseJSON), Key, Object, Value, (.:?)) import Data.Aeson.Types (Parser) import Distribution.Parsec (Parsec, eitherParsec)+import qualified Text.Show as Show aesonParsec :: Parsec a =>@@ -32,6 +33,24 @@ foldMissing o k = fold <$> o .:? k +useMissing ::+ FromJSON a =>+ a ->+ Object ->+ Key ->+ Parser a+useMissing a o k =+ fromMaybe a <$> o .:? k++defMissing ::+ Default a =>+ FromJSON a =>+ Object ->+ Key ->+ Parser a+defMissing =+ useMissing def+ newtype JsonEither a b = JsonEither (Either a b) deriving stock (Eq, Show)@@ -42,3 +61,10 @@ instance (FromJSON a, FromJSON b) => FromJSON (JsonEither a b) where parseJSON v = JsonEither <$> ((Right <$> parseJSON v) <|> (Left <$> parseJSON v))++newtype JsonConfig =+ JsonConfig { unJsonConfig :: IO (Either String Value) }+ deriving stock (Generic)++instance Show JsonConfig where+ show (JsonConfig _) = "JsonConfig"
+ lib/Hix/Data/LogLevel.hs view
@@ -0,0 +1,15 @@+module Hix.Data.LogLevel where++data LogLevel =+ LogError+ |+ LogWarn+ |+ LogInfo+ |+ LogVerbose+ |+ LogDebug+ |+ LogTrace+ deriving stock (Eq, Show, Generic, Ord)
+ lib/Hix/Data/MDep.hs view
@@ -0,0 +1,23 @@+module Hix.Data.MDep where++import Distribution.Package (mainLibSet)+import Distribution.Pretty (Pretty, pretty)+import Distribution.Types.Dependency (Dependency (Dependency))++import qualified Hix.Data.PackageName as PackageName+import Hix.Data.VersionBounds (majorRange, VersionBounds)+import Hix.Data.PackageName (PackageName)++data MDep =+ MDep {+ package :: PackageName,+ bounds :: VersionBounds+ }+ deriving stock (Eq, Show, Generic)++toCabal :: MDep -> Dependency+toCabal MDep {..} =+ Dependency (PackageName.toCabal package) (majorRange bounds) mainLibSet++instance Pretty MDep where+ pretty = pretty . toCabal
lib/Hix/Data/Monad.hs view
@@ -1,39 +1,35 @@-module Hix.Data.Monad where+module Hix.Data.Monad (+ module Hix.Data.Monad,+ module Hix.Data.LogLevel,+) where import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Reader (ReaderT, asks)+import Data.Generics.Labels () import GHC.Records (HasField (getField)) import Path (Abs, Dir, Path) +import Hix.Data.AppContext (AppContext) import Hix.Data.Error (Error)+import Hix.Data.LogLevel (LogLevel (..)) import Hix.Data.OutputFormat (OutputFormat) import Hix.Data.OutputTarget (OutputTarget) -data LogLevel =- LogError- |- LogWarn- |- LogInfo- |- LogVerbose- |- LogDebug- deriving stock (Eq, Show, Generic)- data AppResources = AppResources { cwd :: Path Abs Dir, tmp :: Path Abs Dir,- verbose :: Bool,- debug :: Bool,- quiet :: Bool,+ root :: Path Abs Dir,+ logLevel :: LogLevel,+ cabalVerbose :: Bool, output :: OutputFormat, target :: OutputTarget,- logger :: LogLevel -> Text -> M ()+ logger :: LogLevel -> Text -> M (),+ context :: [AppContext] }+ deriving stock (Generic) newtype M a = M (ReaderT AppResources (ExceptT Error IO) a)
lib/Hix/Data/NewProjectConfig.hs view
@@ -1,5 +1,9 @@ module Hix.Data.NewProjectConfig where +import Path (Dir)++import Hix.Data.PathSpec (PathSpec)+ newtype ProjectName = ProjectName { unProjectName :: Text } deriving stock (Eq, Show, Generic)@@ -18,11 +22,33 @@ deriving stock (Eq, Show, Generic) deriving newtype (IsString, Ord) -data NewProjectConfig =- NewProjectConfig {- name :: ProjectName,+newtype ProjectDirectory =+ ProjectDirectory { unProjectDirectory :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Ord)++data CreateProjectConfig =+ CreateProjectConfig { packages :: Bool, hixUrl :: HixUrl,- author :: Author+ author :: Author,+ noInitGitAndFlake :: Bool,+ devCli :: Bool+ }+ deriving stock (Eq, Show, Generic)++data InitProjectConfig =+ InitProjectConfig {+ name :: ProjectName,+ config :: CreateProjectConfig+ }+ deriving stock (Eq, Show, Generic)++data NewProjectConfig =+ NewProjectConfig {+ directory :: PathSpec Dir,+ name :: Maybe ProjectName,+ printDirectory :: Bool,+ config :: CreateProjectConfig } deriving stock (Eq, Show, Generic)
lib/Hix/Data/NixExpr.hs view
@@ -1,8 +1,13 @@ module Hix.Data.NixExpr where +newtype ExprKey =+ ExprKey Text+ deriving stock (Eq, Show)+ deriving newtype (IsString, Ord, Semigroup, Monoid)+ data ExprAttr = ExprAttr {- name :: Text,+ name :: ExprKey, value :: Expr } |@@ -22,6 +27,9 @@ | ExprPrefix Text Expr deriving stock (Eq, Show, Generic)++exprAttrs :: [(ExprKey, Expr)] -> Expr+exprAttrs = ExprAttrs . fmap (uncurry ExprAttr) exprShow :: Show a => a -> Expr exprShow =
lib/Hix/Data/Options.hs view
@@ -1,30 +1,40 @@ module Hix.Data.Options where -import Path (Abs, Dir, File, Path, SomeBase)+import Path (Dir, File, SomeBase)+import Text.Show (show) import Hix.Data.BootstrapProjectConfig (BootstrapProjectConfig) import Hix.Data.ComponentConfig (ComponentName, ModuleName, SourceDir) import Hix.Data.EnvName (EnvName) import Hix.Data.GhciConfig (ChangeDir, EnvConfig, GhciConfig, RunnerName) import Hix.Data.GlobalOptions (GlobalOptions)-import Hix.Data.NewProjectConfig (NewProjectConfig)+import Hix.Data.Json (JsonConfig)+import Hix.Data.NewProjectConfig (InitProjectConfig, NewProjectConfig) import Hix.Data.PackageName (PackageName)+import Hix.Data.PathSpec (PathSpec) import Hix.Data.PreprocConfig (PreprocConfig)-import Hix.Managed.Cabal.Data.Config (CabalConfig)-import Hix.Managed.Data.BuildConfig (BuildConfig)+import Hix.Managed.Cabal.Data.ContextHackageRepo (ContextHackageRepo)+import Hix.Managed.Cabal.Data.HackageRepo (HackageName)+import Hix.Managed.Data.BuildConfig (BuildConfig, SpecialBuildHandlers)+import Hix.Managed.Data.MaintConfig (MaintConfig)+import Hix.Managed.Data.MaintContext (MaintContext) import Hix.Managed.Data.ProjectContextProto (ProjectContextProto) import Hix.Managed.Data.Query (RawQuery)+import Hix.Managed.Data.RevisionConfig (RevisionConfig)+import Hix.Managed.Data.SpecialMaintHandlers (SpecialMaintHandlers) import Hix.Managed.Data.StateFileConfig (StateFileConfig)-import Hix.Managed.Handlers.Build (SpecialBuildHandlers)-import Hix.Optparse (JsonConfig) +data InfoCommand =+ InfoVersion+ deriving stock (Eq, Show)+ data PreprocOptions = PreprocOptions { config :: Maybe (Either PreprocConfig JsonConfig),- root :: Maybe (Path Abs Dir),- source :: Path Abs File,- inFile :: Path Abs File,- outFile :: Path Abs File+ root :: Maybe (PathSpec Dir),+ source :: PathSpec File,+ inFile :: PathSpec File,+ outFile :: PathSpec File } deriving stock (Show, Generic) @@ -50,7 +60,7 @@ deriving stock (Eq, Show, Generic) data TargetSpec =- TargetForFile (Path Abs File)+ TargetForFile (PathSpec File) | TargetForComponent ComponentCoords deriving stock (Eq, Show, Generic)@@ -67,7 +77,7 @@ data EnvRunnerOptions = EnvRunnerOptions { config :: Either EnvConfig JsonConfig,- root :: Maybe (Path Abs Dir),+ root :: Maybe (PathSpec Dir), component :: Maybe TargetSpec } deriving stock (Show, Generic)@@ -85,10 +95,11 @@ data GhciOptions = GhciOptions { config :: Either GhciConfig JsonConfig,- root :: Maybe (Path Abs Dir),+ root :: Maybe (PathSpec Dir), component :: TargetSpec, test :: TestOptions,- extra :: Maybe ExtraGhciOptions+ extra :: Maybe ExtraGhciOptions,+ args :: [Text] } deriving stock (Show, Generic) @@ -99,6 +110,20 @@ } deriving stock (Show, Generic) +data CommandOptions =+ CommandOptions {+ env :: EnvRunnerOptions,+ exe :: Text,+ args :: [Text]+ }+ deriving stock (Show)++data InitOptions =+ InitOptions {+ config :: InitProjectConfig+ }+ deriving stock (Eq, Show, Generic)+ data NewOptions = NewOptions { config :: NewProjectConfig@@ -120,23 +145,38 @@ } deriving stock (Show, Generic) +data CabalOptions =+ CabalOptions {+ hackage :: [(HackageName, ContextHackageRepo -> ContextHackageRepo)]+ }++instance Show CabalOptions where+ show CabalOptions {} = "CabalOptions"++instance Default CabalOptions where+ def = CabalOptions {hackage = []}+ data ProjectOptions = ProjectOptions { build :: BuildConfig,+ cabal :: CabalOptions, envs :: [EnvName], query :: RawQuery, readUpperBounds :: Bool,- mergeBounds :: Bool+ mergeBounds :: Bool,+ localDeps :: Bool }- deriving stock (Eq, Show, Generic)+ deriving stock (Show, Generic) instance Default ProjectOptions where def = ProjectOptions { build = def,+ cabal = def, envs = [], query = [], readUpperBounds = False,- mergeBounds = False+ mergeBounds = False,+ localDeps = False } projectOptions :: [EnvName] -> ProjectOptions@@ -144,10 +184,9 @@ data ManagedOptions = ManagedOptions {- context :: Either ProjectContextProto JsonConfig,+ context :: Either ProjectContextProto (Maybe JsonConfig), project :: ProjectOptions, stateFile :: StateFileConfig,- cabal :: CabalConfig, handlers :: Maybe SpecialBuildHandlers } deriving stock (Show, Generic)@@ -168,31 +207,66 @@ deriving stock (Show) data LowerCommand =- LowerInitCmd LowerOptions+ LowerInit LowerOptions |- LowerOptimizeCmd LowerOptions+ LowerOptimize LowerOptions |- LowerStabilizeCmd LowerOptions+ LowerStabilize LowerOptions |- LowerAutoCmd LowerOptions+ LowerAuto LowerOptions deriving stock (Show) +data ReleaseMaintOptions =+ ReleaseMaintOptions {+ context :: Either MaintContext (Maybe JsonConfig),+ managed :: ManagedOptions,+ handlers :: Maybe SpecialMaintHandlers,+ config :: MaintConfig+ }+ deriving stock (Show)++data RevisionOptions =+ RevisionOptions {+ context :: Either MaintContext (Maybe JsonConfig),+ config :: RevisionConfig,+ cabal :: CabalOptions+ }+ deriving stock (Show)++data HackageCommand =+ ReleaseMaint ReleaseMaintOptions+ |+ Revision RevisionOptions+ deriving stock (Show)+ data Command =+ Info InfoCommand+ | Preproc PreprocOptions | EnvRunner EnvRunnerCommandOptions |+ GhciCmd GhciOptions+ | GhcidCmd GhcidOptions |- GhciCmd GhciOptions+ RunGhci GhciOptions |- NewCmd NewOptions+ RunGhcid GhcidOptions |- BootstrapCmd BootstrapOptions+ RunCommand CommandOptions |- BumpCmd BumpOptions+ Init InitOptions |- LowerCmd LowerCommand+ New NewOptions+ |+ Bootstrap BootstrapOptions+ |+ Bump BumpOptions+ |+ Lower LowerCommand+ |+ Hackage HackageCommand deriving stock (Show) data Options =
lib/Hix/Data/OutputTarget.hs view
@@ -8,4 +8,6 @@ OutputStdout | OutputFile (Path Abs File)+ |+ OutputGithub deriving stock (Eq, Show, Generic)
lib/Hix/Data/Overrides.hs view
@@ -1,34 +1,109 @@ module Hix.Data.Overrides where -import Data.Aeson (FromJSON (parseJSON), withObject, (.:))+import Data.Aeson (FromJSON (parseJSON), withObject, (.:), (.:?)) import Distribution.Pretty (Pretty (pretty)) import Distribution.Types.Version (Version) import GHC.Exts (IsList)-import Text.PrettyPrint (brackets, (<+>))+import Text.PrettyPrint (brackets, hcat, text, (<+>)) -import Hix.Class.EncodeNix (EncodeNix)+import Hix.Class.EncodeNix (EncodeNix (..)) import Hix.Class.Map (LookupMaybe, NMap, nPretty) import Hix.Data.Json (JsonParsec (JsonParsec))+import Hix.Data.NixExpr (Expr (ExprAttrs), ExprAttr (..), ExprKey) import Hix.Data.PackageName (PackageName) import Hix.Data.Version (SourceHash)+import Hix.Managed.Cabal.Data.HackageRepo (HackageName (..))+import Hix.Pretty (hpretty) +data IsRevision =+ IsRevision+ |+ IsNotRevision+ deriving stock (Eq, Show)++isRevision :: IsRevision -> Bool+isRevision = \case+ IsRevision -> True+ IsNotRevision -> False++toIsRevision :: Bool -> IsRevision+toIsRevision = \case+ True -> IsRevision+ False -> IsNotRevision++instance FromJSON IsRevision where+ parseJSON v =+ toIsRevision <$> parseJSON v++instance EncodeNix IsRevision where+ encodeNix = encodeNix . isRevision+ data Override = Override { version :: Version,- hash :: SourceHash+ hash :: SourceHash,+ repo :: Maybe HackageName,+ revision :: Maybe IsRevision }+ |+ Jailbreak+ |+ Local deriving stock (Eq, Show, Generic)- deriving anyclass (EncodeNix) +instance EncodeNix Override where+ encodeNix = \case+ Override {..} ->+ ExprAttrs (static <> foldMap (pure . assoc "repo") repo <> foldMap (pure . assoc "revision") revision)+ where+ static = [assoc "version" version, assoc "hash" hash]++ assoc :: EncodeNix a => ExprKey -> a -> ExprAttr+ assoc name a = ExprAttr {name, value = encodeNix a}+ Jailbreak ->+ ExprAttrs [ExprAttr {name = "jailbreak", value = encodeNix True}]+ Local ->+ ExprAttrs [ExprAttr {name = "local", value = encodeNix True}]++override :: Version -> SourceHash -> Override+override version hash =+ Override {repo = Nothing, revision = Nothing, ..}+ instance FromJSON Override where parseJSON =- withObject "Override" \ o -> do- JsonParsec version <- o .: "version"- hash <- o .: "hash"- pure Override {..}+ withObject "Override" \ o ->+ regular o <|> jailbreak o <|> local o+ where+ regular o = do+ JsonParsec version <- o .: "version"+ hash <- o .: "hash"+ repo <- o .:? "repo"+ revision <- o .:? "revision"+ pure Override {..} + jailbreak o = do+ flag <- o .: "jailbreak"+ guard flag+ pure Jailbreak++ local o = do+ flag <- o .: "local"+ guard flag+ pure Local+ instance Pretty Override where- pretty Override {..} = pretty version <+> brackets (pretty hash)+ pretty = \case+ Override {..} ->+ pretty version <+> brackets (pretty hash <> foldMap renderRepo repo <> foldMap renderRevision revision)+ Jailbreak -> "jailbreak"+ Local -> "local"+ where+ renderRepo (HackageName name) =+ hcat [text ",", hpretty name]++ renderRevision = \case+ IsRevision -> ",rev"+ IsNotRevision -> mempty -- | Overrides can be either for mutable (direct, nonlocal) deps, or for transitive deps, so they must use -- 'PackageName'.
lib/Hix/Data/PackageId.hs view
@@ -1,10 +1,13 @@ module Hix.Data.PackageId where +import Data.Aeson (FromJSON (..)) import Distribution.Package (PackageIdentifier (PackageIdentifier))+import Distribution.Parsec (Parsec (..)) import Distribution.Pretty (Pretty (pretty)) import Distribution.Version (Version) import Exon (exon) +import Hix.Data.Json (jsonParsec) import qualified Hix.Data.PackageName as PackageName import Hix.Data.PackageName (PackageName (..)) import Hix.Pretty (prettyText, showP)@@ -30,3 +33,9 @@ fromCabal :: PackageIdentifier -> PackageId fromCabal (PackageIdentifier (PackageName.fromCabal -> name) version) = PackageId {..}++instance Parsec PackageId where+ parsec = fromCabal <$> parsec++instance FromJSON PackageId where+ parseJSON = fmap jsonParsec . parseJSON
lib/Hix/Data/PackageName.hs view
@@ -13,7 +13,7 @@ newtype PackageName = PackageName Text deriving stock (Eq, Show, Generic)- deriving newtype (IsString, Ord, FromJSON, FromJSONKey, ToJSON, ToJSONKey, EncodeNixKey)+ deriving newtype (IsString, ToString, Ord, FromJSON, FromJSONKey, ToJSON, ToJSONKey, EncodeNixKey) instance Pretty PackageName where pretty (PackageName n) = prettyText n@@ -31,15 +31,15 @@ fromCabal . depPkgName newtype LocalPackage =- LocalPackage PackageName+ LocalPackage { name :: PackageName } deriving stock (Eq, Show, Generic)- deriving newtype (IsString, Ord, FromJSON, FromJSONKey, Pretty, EncodeNixKey)+ deriving newtype (IsString, ToString, Ord, FromJSON, FromJSONKey, ToJSON, ToJSONKey, Pretty, EncodeNixKey) localPackageName :: LocalPackage -> PackageName localPackageName = coerce -localPackageNames :: [LocalPackage] -> [PackageName]-localPackageNames = coerce+localPackageNames :: Functor f => f LocalPackage -> f PackageName+localPackageNames = fmap coerce sameLocalPackage :: LocalPackage -> PackageName -> Bool sameLocalPackage (LocalPackage lp) p = lp == p
+ lib/Hix/Data/PathSpec.hs view
@@ -0,0 +1,37 @@+module Hix.Data.PathSpec where++import Control.Monad.Trans.Except (ExceptT)+import Path (Abs, Dir, Path, Rel, SomeBase (Abs, Rel), (</>))+import Path.IO (AnyPath (AbsPath, makeAbsolute))++import Hix.Data.Error (Error)+import Hix.Error (tryIO)++data PathSpec t = PathConcrete (SomeBase t) | PathUser Text+ deriving stock (Eq, Show)++instance IsString (PathSpec t) where+ fromString str = PathUser (fromString str)++resolvePathSpec ::+ (Path Abs Dir -> FilePath -> IO (Path Abs t)) ->+ Path Abs Dir ->+ PathSpec t ->+ ExceptT Error IO (Path Abs t)+resolvePathSpec resolver cwd = \case+ PathConcrete path -> case path of+ Abs a -> pure a+ Rel r -> pure $ cwd </> r+ PathUser path -> tryIO $ resolver cwd (toString path)++resolvePathSpec' ::+ (Path Abs t ~ AbsPath (Path Rel t)) =>+ (AnyPath (Path Rel t)) =>+ (FilePath -> IO (Path Abs t)) ->+ PathSpec t ->+ ExceptT Error IO (Path Abs t)+resolvePathSpec' resolver = \case+ PathConcrete path -> case path of+ Abs a -> pure a+ Rel r -> tryIO $ makeAbsolute r+ PathUser path -> tryIO $ resolver (toString path)
lib/Hix/Data/VersionBounds.hs view
@@ -18,7 +18,7 @@ import Hix.Data.Json (aesonParsec, jsonParsec) import Hix.Data.Version (range0) import Hix.Pretty (showP)-import Hix.Version (lowerVersion, upperVersion)+import Hix.Version (lowerVersion, upperVersion, nextMajor, prevMajor) data Bound = BoundLower@@ -160,3 +160,17 @@ where clamp old | old > upper = Nothing | otherwise = Just old++amendUpper :: Version -> VersionBounds -> VersionBounds+amendUpper new bounds+ | Just _ <- bounds.upper+ = bounds+ | otherwise+ = withUpper new bounds++updateWithCorrection :: VersionBounds -> VersionBounds -> VersionBounds+updateWithCorrection VersionBounds {lower = Just lower, upper = Nothing} VersionBounds {upper = Just upper} =+ VersionBounds {lower = Just lower, upper = Just if upper > lower then upper else nextMajor lower}+updateWithCorrection VersionBounds {lower = Nothing, upper = Just upper} VersionBounds {lower = Just lower} =+ VersionBounds {lower = Just if lower < upper then lower else prevMajor upper, upper = Just upper}+updateWithCorrection new old = new <> old
lib/Hix/Env.hs view
@@ -1,18 +1,26 @@ module Hix.Env where +import qualified Data.Text as Text import qualified Data.Text.IO as Text-import Path (Abs, Dir, Path)+import Exon (exon)+import Path (Abs, Dir, Path, toFilePath)+import System.Exit (ExitCode (..))+import System.Process.Typed (inherit, proc, runProcess, setStderr, setStdout) +import qualified Hix.Color as Color import Hix.Component (targetComponent) import qualified Hix.Data.ComponentConfig-import Hix.Data.ComponentConfig (EnvRunner (EnvRunner), PackagesConfig, TargetOrDefault (DefaultTarget, ExplicitTarget))-import Hix.Error (Error (EnvError), pathText)+import Hix.Data.ComponentConfig (EnvRunner (..), PackagesConfig, TargetOrDefault (..)) import qualified Hix.Data.GhciConfig+import Hix.Data.Monad (M) import qualified Hix.Data.Options as Options-import Hix.Data.Options (EnvRunnerOptions, TargetSpec)+import Hix.Data.Options (CommandOptions (..), EnvRunnerOptions, TargetSpec) import Hix.Data.PackageName (PackageName)+import Hix.Error (pathText) import Hix.Json (jsonConfigE)-import Hix.Data.Monad (M)+import qualified Hix.Log as Log+import Hix.Monad (fatalError)+import Hix.Path (resolvePathSpec) -- TODO when there is a solution for default command env fallback configuration, the DefaultTarget case must return -- Nothing when the config requests it@@ -30,11 +38,28 @@ envRunner :: EnvRunnerOptions -> M EnvRunner envRunner opts = do- config <- jsonConfigE EnvError opts.config- let runner = componentRunner opts.root config.mainPackage config.packages+ config <- jsonConfigE opts.config+ root <- traverse resolvePathSpec opts.root+ let runner = componentRunner root config.mainPackage config.packages fromMaybe config.defaultEnv . join <$> traverse runner opts.component printEnvRunner :: EnvRunnerOptions -> M () printEnvRunner opts = do EnvRunner runner <- envRunner opts liftIO (Text.putStrLn (pathText runner))++runEnvProcess ::+ EnvRunnerOptions ->+ Text ->+ [Text] ->+ M ()+runEnvProcess options exe args = do+ EnvRunner runner <- envRunner options+ let cmd = Text.unwords (exe : args)+ Log.debug [exon|Starting process: #{pathText runner} #{cmd}|]+ runProcess (setStderr inherit (setStdout inherit (proc (toFilePath runner) (toString <$> exe : args)))) >>= \case+ ExitSuccess -> unit+ ExitFailure n -> fatalError [exon|#{Color.shellCommand exe} exited with code #{Color.number n}|]++runEnvCommand :: CommandOptions -> M ()+runEnvCommand CommandOptions {..} = runEnvProcess env exe args
lib/Hix/Error.hs view
@@ -3,14 +3,16 @@ module Hix.Error, ) where -import Control.Monad.Trans.Except (ExceptT, throwE)+import Control.Monad.Trans.Except (ExceptT, throwE, withExceptT) import Exon (exon) import Path (Path, toFilePath) import System.IO.Error (tryIOError) import qualified Hix.Console as Console-import Hix.Console (errorMessage)-import Hix.Data.Error (Error (..))+import Hix.Console (errorMessage, withErrorChevrons)+import Hix.Data.AppContext (AppContext (..))+import Hix.Data.Error (Error (..), ErrorContext (..), ErrorMessage (..))+import Hix.Data.LogLevel (LogLevel) pathText :: Path b t -> Text pathText =@@ -66,10 +68,22 @@ printFatalError = prefixedError "Fatal error" +printFatalWhenError ::+ MonadIO m =>+ Text ->+ Text ->+ m ()+printFatalWhenError context =+ prefixedError [exon|Fatal error when #{context}|]+ sourceError :: Text -> Path b t -> Text sourceError reason source = [exon|#{reason} the source file '#{pathText source}'|] +throwMessage :: ErrorMessage -> ExceptT Error IO a+throwMessage message =+ throwE Error {message, level = Nothing, context = []}+ catchIO :: (Text -> ExceptT e IO a) -> IO a ->@@ -88,28 +102,41 @@ Right a -> pure a Left err -> throwE (mkErr (show err)) -tryIO ::+tryIOContext ::+ ErrorContext -> IO a -> ExceptT Error IO a-tryIO =- tryIOWith Fatal+tryIOContext context =+ tryIOWith \ message -> Error {message = Fatal message, level = Nothing, ..} -note :: Text -> Maybe a -> ExceptT Error IO a-note err =- maybe (throwE (GhciError err)) pure+tryIO :: IO a -> ExceptT Error IO a+tryIO = tryIOContext [] +errorLevel ::+ LogLevel ->+ ExceptT Error IO a ->+ ExceptT Error IO a+errorLevel new =+ withExceptT \ Error {..} -> Error {level = Just new, ..}++formatError :: ErrorMessage -> Text+formatError = \case+ Fatal msg -> [exon|Fatal: #{msg}|]+ FatalExternal msg -> [exon|Fatal: #{msg}|]+ Client msg -> msg+ printError :: MonadIO m =>- Bool ->+ LogLevel -> Error -> m ()-printError verbose = \case- PreprocError err -> printPreprocError err- EnvError err -> printEnvError err- GhciError err -> printGhciError err- NewError err -> printNewError err- BootstrapError err -> printBootstrapError err- NoMatch msg | verbose -> printPreprocError msg- NoMatch _ -> unit- Fatal err -> printFatalError err- Client err -> Console.err (errorMessage err)+printError logLevel Error {..}+ | Just messageLevel <- level+ , messageLevel < logLevel+ = unit+ | ErrorContext ctxLines <- context+ = do+ for_ (reverse ctxLines) \ ctx ->+ when (ctx.level >= logLevel) do+ Console.err (withErrorChevrons [exon|While #{ctx.description}|])+ Console.err (errorMessage (formatError message))
lib/Hix/Ghci.hs view
@@ -2,10 +2,12 @@ import Control.Monad.Trans.Except (ExceptT, catchE) import Data.List.Extra (nubOrd)+import Data.List.NonEmpty (appendList, prependList) import qualified Data.Map.Strict as Map import Data.Map.Strict ((!?)) import qualified Data.Text as Text import qualified Data.Text.IO as Text+import Distribution.Simple (Dependency (..)) import Exon (exon) import Path (Abs, Dir, File, Path, Rel, parseRelDir, reldir, splitExtension, stripProperPrefix, toFilePath, (</>)) import Path.IO (createDirIfMissing, getTempDir, openTempFile)@@ -16,11 +18,13 @@ import qualified Hix.Data.ComponentConfig import Hix.Data.ComponentConfig ( ComponentConfig,- ModuleName (ModuleName),- PackageConfig,- SourceDir (SourceDir),- Target (Target),+ ComponentDep (..),+ ModuleName (..),+ PackageConfig (..),+ SourceDir (..),+ Target (..), )+import qualified Hix.Data.ComponentName as ComponentName import qualified Hix.Data.GhciConfig import Hix.Data.GhciConfig (GhciConfig, GhciRunExpr (GhciRunExpr), GhciSetupCode (GhciSetupCode)) import qualified Hix.Data.GhciTest as GhciTest@@ -28,18 +32,22 @@ import Hix.Data.Monad (liftE) import qualified Hix.Data.Options as Options import Hix.Data.Options (- ExtraGhciOptions (ExtraGhciOptions),- ExtraGhcidOptions (ExtraGhcidOptions),- GhciOptions (GhciOptions),+ EnvRunnerOptions (..),+ ExtraGhciOptions (..),+ ExtraGhcidOptions (..),+ GhciOptions (..), GhcidOptions,- TargetSpec (TargetForFile),- TestOptions (TestOptions),+ TargetSpec (..),+ TestOptions (..), )+import qualified Hix.Data.PackageName as PackageName import Hix.Data.PackageName (PackageName)-import Hix.Error (Error (GhciError), note, pathText, tryIO)+import Hix.Env (runEnvProcess)+import Hix.Error (Error, ErrorMessage (..), pathText, throwMessage, tryIO) import Hix.Json (jsonConfigE)-import Hix.Monad (M, noteGhci)-import Hix.Path (rootDir)+import Hix.Maybe (fromMaybeA)+import Hix.Monad (M, noteGhci, withTempDir)+import Hix.Path (PathSpecResolver (resolvePathSpec), rootDir) relativeToComponent :: Path Abs Dir ->@@ -58,8 +66,8 @@ M ModuleName moduleName package component = \case GhciOptions {component = TargetForFile path, root = cliRoot} -> do- root <- rootDir cliRoot- rel <- relativeToComponent root package component path+ root <- rootDir =<< traverse resolvePathSpec cliRoot+ rel <- relativeToComponent root package component =<< resolvePathSpec path pure (ModuleName (Text.replace "/" "." (withoutExt rel))) GhciOptions {test} -> pure test.mod where@@ -71,31 +79,61 @@ Maybe SourceDir -> GhciOptions -> M Text-ghciScript config package component opt = do- ModuleName module_ <- moduleName package component opt+ghciScript config package component options = do+ ModuleName module_ <- moduleName package component options pure [exon|#{cdCode}#{setup} :load #{module_} import #{module_}|] where- cdCode | opt.test.cd.unChangeDir = [exon|:cd #{pathText package.src}+ cdCode | options.test.cd.unChangeDir = [exon|:cd #{pathText package.src} |] | otherwise = ""- GhciSetupCode setup = fold (flip Map.lookup config.setup =<< opt.test.runner)+ GhciSetupCode setup = fold (flip Map.lookup config.setup =<< options.test.runner) -componentSearchPaths :: PackageConfig -> ComponentConfig -> [Path Rel Dir]-componentSearchPaths pkg comp = do+componentSearchPaths :: Path Rel Dir -> ComponentConfig -> [Path Rel Dir]+componentSearchPaths src comp = do SourceDir dir <- coerce comp.sourceDirs- pure (pkg.src </> dir)+ pure (src </> dir) +depClosure ::+ Map PackageName PackageConfig ->+ ComponentConfig ->+ [(Path Rel Dir, ComponentConfig)]+depClosure pkgs =+ Map.elems . spin []+ where+ spin z comp =+ foldl' dep z comp.deps++ dep z (ComponentDep (Dependency pkgName _ comps)) =+ case pkgs !? PackageName.fromCabal pkgName of+ Just pkg -> foldl' (depComp pkg) z comps+ Nothing -> z++ depComp PackageConfig {name = pkgName, src, components} z (ComponentName.fromCabal -> compName)+ | let key = (pkgName, compName)+ , not (Map.member key z)+ , Just comp <- components !? compName+ = spin (Map.insert key (src, comp) z) comp++ | otherwise+ = z++depSearchPath :: Map PackageName PackageConfig -> PackageConfig -> ComponentConfig -> [Path Rel Dir]+depSearchPath pkgs pkg comp =+ nubOrd (concatMap (uncurry componentSearchPaths) components)+ where+ components = (pkg.src, comp) : depClosure pkgs comp+ librarySearchPaths :: Map PackageName PackageConfig -> [Path Rel Dir] librarySearchPaths pkgs = do pkg <- Map.elems pkgs comp <- maybeToList (pkg.components !? "library")- componentSearchPaths pkg comp+ componentSearchPaths pkg.src comp -searchPath :: Map PackageName PackageConfig -> PackageConfig -> ComponentConfig -> [Path Rel Dir]-searchPath pkgs pkg comp =- nubOrd (componentSearchPaths pkg comp <> librarySearchPaths pkgs)+legacySearchPath :: Map PackageName PackageConfig -> PackageConfig -> ComponentConfig -> [Path Rel Dir]+legacySearchPath pkgs pkg comp =+ nubOrd (componentSearchPaths pkg.src comp <> librarySearchPaths pkgs) testRun :: GhciConfig -> TestOptions -> Maybe Text testRun config = \case@@ -107,26 +145,29 @@ Nothing assemble :: GhciOptions -> M GhciTest-assemble opt = do- config <- jsonConfigE GhciError opt.config- root <- rootDir opt.root- Target {..} <- targetComponentOrError opt.root config.mainPackage config.packages opt.component- script <- ghciScript config package sourceDir opt+assemble options = do+ config <- jsonConfigE options.config+ mRoot <- traverse resolvePathSpec options.root+ root <- rootDir mRoot+ Target {..} <- targetComponentOrError mRoot config.env.mainPackage config.env.packages options.component+ script <- ghciScript config package sourceDir options+ let searchPath = if config.manualCabal then legacySearchPath else depSearchPath pure GhciTest { script,- test = testRun config opt.test,+ test = testRun config options.test, args = config.args,- searchPath = (root </>) <$> searchPath config.packages package component- }+ searchPath = (root </>) <$> searchPath config.env.packages package component+ } -hixTempDir ::- ExceptT Error IO (Path Abs Dir)+hixTempDir :: ExceptT Error IO (Path Abs Dir) hixTempDir = do tmp <- tryIO getTempDir- user <- note "Couldn't determine user name" . parseRelDir =<< catchE (tryIO getLoginName) (const (pure "user"))+ user <- parseError . parseRelDir =<< catchE (tryIO getLoginName) (const (pure "user")) let hixTmp = tmp </> [reldir|hix|] </> user tryIO (createDirIfMissing True hixTmp) pure hixTmp+ where+ parseError = fromMaybeA (throwMessage (FatalExternal "Couldn't convert user name to path")) ghciScriptFile :: Path Abs Dir ->@@ -155,54 +196,95 @@ ghciCmdline :: GhciTest -> Maybe ExtraGhciOptions ->+ [Text] -> Path Abs File -> Maybe (Path Abs File) -> GhciRun-ghciCmdline test extra scriptFile runScriptFile =+ghciCmdline test extra args scriptFile runScriptFile = GhciRun {..} where- cmdline = [exon|ghci#{shell}#{optArg run}|]- shell = [exon|#{argFrag args}#{argFrag sp} -ghci-script=##{toFilePath scriptFile}#{argFrag extraOpts}|]- args = Text.unwords (coerce test.args)+ shell = appendList (prependList (coerce test.args ++ searchPath) [scriptArg]) extraOpts++ scriptArg = [exon|-ghci-script=##{toFilePath scriptFile}|]+ run = runScriptFile <&> \ f -> [exon|-ghci-script=##{toFilePath f}|]- sp = foldMap searchPathArg (nonEmpty test.searchPath)- extraOpts | Just (ExtraGhciOptions o) <- extra = o- | otherwise = "" + searchPath = foldMap (pure . searchPathArg) (nonEmpty test.searchPath)++ extraOpts = maybe [] (Text.words . coerce) extra ++ args+ ghciCmdlineFromOptions :: Path Abs Dir -> GhciOptions -> M GhciRun-ghciCmdlineFromOptions tmp opt = do- conf <- assemble opt+ghciCmdlineFromOptions tmp options = do+ conf <- assemble options shellScriptFile <- liftE (ghciScriptFile tmp conf.script) runScriptFile <- liftE (traverse (ghciScriptFile tmp) conf.test)- pure (ghciCmdline conf opt.extra shellScriptFile runScriptFile)+ pure (ghciCmdline conf options.extra options.args shellScriptFile runScriptFile) ghcidCmdlineFromOptions :: Path Abs Dir -> GhcidOptions -> M GhcidRun-ghcidCmdlineFromOptions tmp opt = do- ghci <- ghciCmdlineFromOptions tmp opt.ghci- let- test = fromMaybe "main" ghci.test.test- pure (GhcidRun [exon|ghcid --command="ghci#{ghci.shell}" --test='##{test}'#{foldMap extra opt.extra}|] ghci)- where- extra (ExtraGhcidOptions o) = [exon| ##{o}|]+ghcidCmdlineFromOptions tmp options = do+ ghci <- ghciCmdlineFromOptions tmp options.ghci+ let test = fromMaybe "main" ghci.test.test+ pure GhcidRun {+ args = appendList [+ [exon|--command=ghci #{Text.unwords (toList ghci.shell)}|],+ [exon|--test=##{test}|]+ ] (coerce (maybeToList options.extra)),+ ghci+ } +quoteArgs ::+ Functor t =>+ t Text ->+ t Text+quoteArgs =+ fmap \ a -> [exon|"#{Text.replace "\"" "\\\"" a}"|]+ printGhciCmdline :: GhciOptions -> M ()-printGhciCmdline opt = do+printGhciCmdline options = do tmp <- liftE hixTempDir- cmd <- ghciCmdlineFromOptions tmp opt- liftIO (Text.putStrLn [exon|ghci #{cmd.shell} #{fold cmd.run}|])+ cmd <- ghciCmdlineFromOptions tmp options+ let cmdline = "ghci" : quoteArgs (toList cmd.shell ++ maybeToList cmd.run)+ liftIO (Text.putStrLn (Text.unwords cmdline)) printGhcidCmdline :: GhcidOptions -> M ()-printGhcidCmdline opt = do+printGhcidCmdline options = do tmp <- liftE hixTempDir- cmd <- ghcidCmdlineFromOptions tmp opt- liftIO (Text.putStrLn cmd.cmdline)+ cmd <- ghcidCmdlineFromOptions tmp options+ let cmdline = "ghcid" : toList (quoteArgs cmd.args)+ liftIO (Text.putStrLn (Text.unwords cmdline))++processWithRunner ::+ GhciOptions ->+ Text ->+ [Text] ->+ M ()+processWithRunner GhciOptions {config = configRaw, component, root} exe args = do+ config <- jsonConfigE configRaw+ let envOptions = EnvRunnerOptions {config = Left config.env, component = Just component, root}+ runEnvProcess envOptions exe args++argsGhciRun :: GhciRun -> [Text]+argsGhciRun cmd =+ toList cmd.shell ++ maybeToList cmd.run++runGhci :: GhciOptions -> M ()+runGhci options =+ withTempDir "ghci-cmd" \ tmp -> do+ cmd <- ghciCmdlineFromOptions tmp options+ processWithRunner options "ghci" (argsGhciRun cmd)++runGhcid :: GhcidOptions -> M ()+runGhcid options =+ withTempDir "ghcid-cmd" \ tmp -> do+ cmd <- ghcidCmdlineFromOptions tmp options+ processWithRunner options.ghci "ghcid" (toList cmd.args)
lib/Hix/Hackage.hs view
@@ -1,32 +1,16 @@ module Hix.Hackage where -import Control.Monad.Extra (fromMaybeM)-import Data.Aeson (FromJSON (parseJSON), eitherDecodeStrict', withObject, (.:))-import Data.IORef (IORef, modifyIORef', readIORef)-import qualified Data.Map.Strict as Map-import Data.Map.Strict ((!?))-import qualified Data.Text as Text-import Distribution.Parsec (eitherParsec)-import Hix.Data.Version (Version)-import Exon (exon)-import Network.HTTP.Client (Manager, Request (..), Response (..), defaultRequest, httpLbs)-import Network.HTTP.Types (- Status (statusCode, statusMessage),- hAccept,- statusIsClientError,- statusIsServerError,- statusIsSuccessful,- )-import System.Exit (ExitCode (ExitFailure, ExitSuccess))-import System.Process.Typed (proc, readProcess)+import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON (parseJSON), ToJSON, withObject, (.:)) -import Hix.Data.Error (Error (Fatal))-import Hix.Data.PackageId (PackageId, renderPackage)-import Hix.Data.PackageName (PackageName)-import Hix.Data.Version (SourceHash (SourceHash))-import qualified Hix.Log as Log-import Hix.Monad (M, throwM, tryIOM)-import Hix.Pretty (showP)+import Hix.Data.Monad (M)+import Hix.Managed.Handlers.HackageClient (+ HackageClient (..),+ HackageError (..),+ HackageRequest (..),+ HackageResponse (HackageResponseJson),+ )+import Hix.Monad (fatalError) data HackageVersions = HackageVersions {@@ -37,84 +21,105 @@ instance FromJSON HackageVersions where parseJSON = withObject "HackageVersions" \ o -> HackageVersions <$> o .: "normal-version" -parseVersion :: String -> Either (String, String) Version-parseVersion s = first (s,) (eitherParsec s)--parseResult :: LByteString -> M (Either Text [Version])-parseResult body =- case eitherDecodeStrict' (toStrict body) of- Left err ->- noVersion [exon|Hackage response parse error: #{toText err}|]- Right (HackageVersions []) ->- noVersion "No versions on Hackage"- Right (HackageVersions versions) ->- case traverse parseVersion versions of- Left (v, err) -> noVersion (toText [exon|Version '#{v}' has invalid format (#{err})|])- Right vs -> pure (Right vs)- where- noVersion = pure . Left--versionsHackage :: Manager -> PackageName -> M [Version]-versionsHackage manager pkg = do- res <- liftIO (httpLbs request manager)- let- body = responseBody res-- status = responseStatus res-- errorStatus category = noVersion [exon|#{category} (#{decodeUtf8 (statusMessage status)})|]-- if- | statusIsSuccessful status -> leftA noVersion =<< parseResult body- | statusCode status == 404 -> noVersion "PackageId does not exist"- | statusIsClientError status -> errorStatus "Client error"- | statusIsServerError status -> errorStatus "Server error"- | otherwise -> errorStatus "Weird error"-- where- request =- defaultRequest {- host = "hackage.haskell.org",- secure = False,- method = "GET",- path = [exon|/package/##{pkg}/preferred|],- requestHeaders = [(hAccept, "application/json")]- }+hackageRequest ::+ ∀ a b .+ (a -> Either Text b) ->+ HackageClient ->+ HackageRequest a ->+ M (Either HackageError b)+hackageRequest process HackageClient {request = run} request = do+ response <- run request+ pure (first HackageParseError . process =<< response) - noVersion msg =- [] <$ Log.error [exon|Hackage request for '##{pkg}' failed: #{msg}|]+hackageGet ::+ ∀ a b .+ (a -> Either Text b) ->+ HackageClient ->+ Text ->+ HackageResponse a ->+ M (Either HackageError b)+hackageGet process client path accept =+ hackageRequest process client HackageRequest {+ method = "GET",+ path,+ body = Nothing,+ query = Nothing,+ accept+ } -latestVersionHackage :: Manager -> PackageName -> M (Maybe Version)-latestVersionHackage manager pkg =- head <$> versionsHackage manager pkg+hackagePostJson ::+ ∀ a b body .+ FromJSON a =>+ Typeable a =>+ ToJSON body =>+ (a -> Either Text b) ->+ HackageClient ->+ Text ->+ body ->+ M (Either HackageError b)+hackagePostJson process client path body =+ hackageRequest process client HackageRequest {+ method = "POST",+ path,+ body = Just (Right (Aeson.encode body)),+ query = Nothing,+ accept = HackageResponseJson+ } -fetchHashHackage ::- PackageId ->- M SourceHash-fetchHashHackage package = do- Log.debug [exon|Fetching hash for '##{slug}' from ##{url}|]- tryIOM (readProcess conf) >>= \case- (ExitFailure _, _, err) ->- throwM (Fatal [exon|Prefetching source of '##{slug}' from hackage failed: #{decodeUtf8 err}|])- (ExitSuccess, hash, _) ->- pure (SourceHash (Text.stripEnd (decodeUtf8 hash)))- where- conf = proc "nix-prefetch-url" ["--unpack", url]- url = [exon|https://hackage.haskell.org/package/#{slug}/#{slug}.tar.gz|]- slug = showP package+hackagePostQuery ::+ ∀ a b .+ (a -> Either Text b) ->+ HackageClient ->+ Text ->+ NonEmpty (Text, Text) ->+ HackageResponse a ->+ M (Either HackageError b)+hackagePostQuery process client path query accept =+ hackageRequest process client HackageRequest {+ method = "POST",+ path,+ body = Nothing,+ query = Just (bimap encodeUtf8 encodeUtf8 <$> query),+ accept+ } -fetchHashHackageCached ::- IORef (Map Text SourceHash) ->- PackageId ->- M SourceHash-fetchHashHackageCached cacheRef package =- liftIO (readIORef cacheRef) >>= \ cache ->- fromMaybeM fetch (pure (cache !? cacheKey))- where- fetch = do- hash <- fetchHashHackage package- hash <$ addToCache hash+hackagePostForm ::+ ∀ a b .+ (a -> Either Text b) ->+ HackageClient ->+ Text ->+ NonEmpty (Text, Text) ->+ HackageResponse a ->+ M (Either HackageError b)+hackagePostForm process client path fields accept =+ hackageRequest process client HackageRequest {+ method = "POST",+ path,+ body = Just (Left fields),+ query = Nothing,+ accept+ } - addToCache hash = liftIO (modifyIORef' cacheRef (Map.insert cacheKey hash))+hackagePut ::+ ∀ a b .+ FromJSON a =>+ Typeable a =>+ (a -> Either Text b) ->+ HackageClient ->+ Text ->+ M (Either HackageError b)+hackagePut process client path =+ hackageRequest process client HackageRequest {+ method = "PUT",+ path,+ body = Nothing,+ query = Nothing,+ accept = HackageResponseJson+ } - cacheKey = renderPackage package+fatalHackageRequest :: Either HackageError a -> M a+fatalHackageRequest =+ leftA $ fatalError . \case+ HackageNotFound -> "Not found"+ HackageFatal msg -> msg+ HackageParseError msg -> msg
+ lib/Hix/Hackage/Hash.hs view
@@ -0,0 +1,63 @@+module Hix.Hackage.Hash where++import Control.Monad.Extra (firstJustM)+import Data.IORef (IORef, modifyIORef', readIORef)+import qualified Data.Map.Strict as Map+import Data.Map.Strict ((!?))+import qualified Data.Text as Text+import Exon (exon)+import System.Exit (ExitCode (ExitFailure, ExitSuccess))+import System.Process.Typed (proc, readProcess)++import qualified Hix.Color as Color+import Hix.Data.PackageId (PackageId, renderPackage)+import Hix.Data.Version (SourceHash (SourceHash))+import qualified Hix.Log as Log+import Hix.Managed.Cabal.Data.HackageRepo (HackageName, HackageRepo (..))+import qualified Hix.Managed.Cabal.HackageLocation as HackageLocation+import Hix.Monad (M, appContextVerbose, tryIOM)+import Hix.Pretty (showP)++fetchHashHackageRepo ::+ PackageId ->+ HackageRepo ->+ M (Maybe (SourceHash, HackageName))+fetchHashHackageRepo package HackageRepo {name, location} =+ appContextVerbose [exon|trying ##{url}|] do+ tryIOM (readProcess conf) >>= \case+ (ExitFailure _, _, err) -> do+ Log.debug [exon|Error for ##{url}: #{decodeUtf8 err}|]+ pure Nothing+ (ExitSuccess, hash, _) ->+ pure (Just (SourceHash (Text.stripEnd (decodeUtf8 hash)), name))+ where+ conf = proc "nix-prefetch-url" ["--unpack", url]+ url = [exon|#{HackageLocation.renderMinimal location}/package/#{slug}/#{slug}.tar.gz|]+ slug = showP package++fetchHashHackage ::+ NonEmpty HackageRepo ->+ PackageId ->+ M (Either Text (SourceHash, HackageName))+fetchHashHackage repos package =+ appContextVerbose [exon|fetching hash for #{Color.package package} from Hackage repos|] do+ maybeToRight notFound <$> firstJustM (fetchHashHackageRepo package) (toList repos)+ where+ notFound = [exon|No Hackage repo knows the package ID #{Color.package package}|]++fetchHashHackageCached ::+ IORef (Map Text (SourceHash, HackageName)) ->+ NonEmpty HackageRepo ->+ PackageId ->+ M (Either Text (SourceHash, Maybe HackageName))+fetchHashHackageCached cacheRef repos package =+ liftIO (readIORef cacheRef) >>= \ cache ->+ fmap (second Just) <$> maybe fetch (pure . Right) (cache !? cacheKey)+ where+ fetch = do+ result <- fetchHashHackage repos package+ result <$ traverse addToCache result++ addToCache hash = liftIO (modifyIORef' cacheRef (Map.insert cacheKey hash))++ cacheKey = renderPackage package
+ lib/Hix/Hackage/Versions.hs view
@@ -0,0 +1,48 @@+module Hix.Hackage.Versions where++import qualified Data.Set as Set+import Distribution.Parsec (eitherParsec)+import Exon (exon)++import Hix.Data.Monad (M)+import Hix.Data.PackageName (PackageName)+import Hix.Data.Version (Version)+import Hix.Hackage (HackageVersions (HackageVersions), hackageGet)+import Hix.Managed.Handlers.HackageClient (HackageClient, HackageError (..), HackageResponse (HackageResponseJson))+import Hix.Monad (fatalError, appContextVerbose)++parseVersion :: String -> Either (String, String) Version+parseVersion s = first (s,) (eitherParsec s)++parseVersions :: HackageVersions -> Either Text (Set Version)+parseVersions (HackageVersions versions)+ -- | null versions+ -- = Left "No versions on Hackage"+ -- | otherwise+ = bimap parseError Set.fromList (traverse parseVersion versions)+ where+ parseError (v, err) = toText [exon|Version '#{v}' has invalid format (#{err})|]++-- TODO @fold@ here suppresses errors – it should probably only filter out NotFound and fail (or warn?) on server errors+--+-- TODO parseVersions fails when there are no versions – it should be executed on the aggregated results.+allClientVersions :: NonEmpty HackageClient -> PackageName -> M (Set Version)+allClientVersions clients pkg = do+ results <- for clients \ client -> hackageGet parseVersions client path HackageResponseJson+ appContextVerbose [exon|fetching versions for ##{pkg}|] do+ sconcat <$> traverse (leftA check) results+ where+ path = [exon|/package/##{pkg}/preferred|]++ check = \case+ HackageNotFound -> pure mempty+ HackageFatal err -> fatalError err+ HackageParseError err -> fatalError err++versionsHackage :: NonEmpty HackageClient -> PackageName -> M [Version]+versionsHackage clients pkg =+ Set.toDescList <$> allClientVersions clients pkg++latestVersionHackage :: NonEmpty HackageClient -> PackageName -> M (Maybe Version)+latestVersionHackage client pkg =+ Set.lookupMax <$> allClientVersions client pkg
+ lib/Hix/Http.hs view
@@ -0,0 +1,7 @@+module Hix.Http where++import Network.HTTP.Client (Manager, newManager)+import Network.HTTP.Client.TLS (tlsManagerSettings)++httpManager :: MonadIO m => m Manager+httpManager = liftIO (newManager tlsManagerSettings)
lib/Hix/Json.hs view
@@ -4,30 +4,21 @@ import Data.Aeson (FromJSON, fromJSON) import Exon (exon) -import Hix.Data.Error (Error)+import Hix.Data.Json (JsonConfig (..)) import Hix.Data.Monad (M)-import Hix.Monad (throwM)-import Hix.Optparse (JsonConfig (JsonConfig))+import Hix.Monad (fatalError) jsonConfig :: FromJSON a =>- (Text -> Error) -> JsonConfig -> M a-jsonConfig consError (JsonConfig mv) =+jsonConfig (JsonConfig mv) = liftIO mv >>= \case- Left msg -> failure [exon|Invalid JSON: #{toText msg}|]+ Left msg -> fatalError [exon|Invalid JSON: #{toText msg}|] Right v -> case fromJSON v of Aeson.Success a -> pure a- Aeson.Error err -> failure [exon|Invalid JSON: #{toText err}+ Aeson.Error err -> fatalError [exon|Invalid JSON: #{toText err} #{show v}|]- where- failure = throwM . consError -jsonConfigE ::- FromJSON a =>- (Text -> Error) ->- Either a JsonConfig ->- M a-jsonConfigE consError =- either pure (jsonConfig consError)+jsonConfigE :: FromJSON a => Either a JsonConfig -> M a+jsonConfigE = either pure jsonConfig
lib/Hix/Log.hs view
@@ -5,53 +5,73 @@ import Text.PrettyPrint (Doc) import Hix.Console (color, withChevrons)+import Hix.Data.LogLevel (LogLevel (..)) import qualified Hix.Data.Monad-import Hix.Data.Monad (LogLevel (..), M (M))+import Hix.Data.Monad (M (M)) +decorate :: Text -> LogLevel -> Text+decorate msg = \case+ LogTrace -> [exon|[#{color 3 "trace"}] #{msg}|]+ LogDebug -> [exon|[#{color 6 "debug"}] #{msg}|]+ LogVerbose -> withChevrons 4 msg+ LogInfo -> withChevrons 5 msg+ LogWarn -> withChevrons 3 msg+ LogError -> withChevrons 1 [exon|Error: #{msg}|]+ log :: LogLevel -> Text -> M () log level msg = do env <- M ask env.logger level msg -verbose :: Text -> M ()-verbose msg =- log LogVerbose (withChevrons 4 msg)+logDecorated :: LogLevel -> Text -> M ()+logDecorated level msg =+ log level (decorate msg level) +trace :: Text -> M ()+trace = logDecorated LogTrace++traceP :: Doc -> M ()+traceP = trace . show+ debug :: Text -> M ()-debug msg =- log LogDebug [exon|[#{color 6 "debug"}] #{msg}|]+debug = logDecorated LogDebug debugP :: Doc -> M () debugP = debug . show +verbose :: Text -> M ()+verbose = logDecorated LogVerbose+ info :: Text -> M ()-info msg =- log LogInfo (withChevrons 5 msg)+info = logDecorated LogInfo +infoP :: Doc -> M ()+infoP = info . show+ infoPlain :: Text -> M () infoPlain msg = log LogInfo msg -warn :: Text -> M ()-warn msg =- log LogWarn (withChevrons 3 msg)- infoCont :: Text -> M () infoCont msg = log LogInfo [exon| #{msg}|] +warn :: Text -> M ()+warn = logDecorated LogWarn+ error :: Text -> M ()-error msg =- log LogError (withChevrons 1 [exon|Error: #{msg}|])+error = logDecorated LogError logWith :: (LogLevel -> Text -> IO ()) -> LogLevel -> Text -> M () logWith handler level msg = do env <- M ask let- minVerbose = env.verbose || env.debug- minInfo = minVerbose || not env.quiet+ minDebug = env.logLevel >= LogDebug+ minVerbose = env.logLevel >= LogVerbose+ minInfo = env.logLevel >= LogInfo case level of- LogDebug | env.debug -> accept+ LogTrace | env.logLevel >= LogTrace -> accept+ LogDebug | minDebug -> accept LogVerbose | minVerbose -> accept LogInfo | minInfo -> accept LogWarn | minInfo -> accept
+ lib/Hix/Managed/App.hs view
@@ -0,0 +1,23 @@+module Hix.Managed.App where++import Hix.Data.Monad (M)+import qualified Hix.Data.Options+import Hix.Data.Options (ManagedOptions)+import Hix.Managed.Data.ProjectContext (ProjectContext (..))+import Hix.Managed.Data.ProjectContextProto (ProjectContextProto (..))+import Hix.Managed.Data.ProjectResult (ProjectResult)+import Hix.Managed.Handlers.Build (BuildHandlers)+import Hix.Managed.Handlers.Build.Test (chooseHandlers)+import qualified Hix.Managed.Handlers.Project.Prod as Project+import Hix.Managed.ProjectContext (withProjectContext)++managedApp ::+ ManagedOptions ->+ ProjectContextProto ->+ (BuildHandlers -> ProjectContext -> M ProjectResult) ->+ M ProjectResult+managedApp opts proto use = do+ handlersProject <- Project.handlersProd opts.stateFile+ withProjectContext handlersProject opts.project proto \ context -> do+ handlers <- chooseHandlers opts.handlers handlersProject context.build context.cabal+ use handlers context
lib/Hix/Managed/Build.hs view
@@ -2,22 +2,23 @@ import Control.Monad (foldM) import qualified Data.Map.Strict as Map+import qualified Data.Set as Set import qualified Data.Text as Text import Distribution.Pretty (Pretty) import Exon (exon) import Text.PrettyPrint (vcat) +import Hix.Class.Map (nToMaybe)+import qualified Hix.Color as Color import qualified Hix.Console import Hix.Console (color, colors)-import Hix.Data.EnvName (EnvName (EnvName))+import Hix.Data.EnvName (EnvName) import Hix.Data.Monad (M)-import Hix.Data.Overrides (Overrides)-import qualified Hix.Data.PackageId-import Hix.Data.PackageId (PackageId)+import Hix.Data.Overrides (IsRevision (..), Override (..), Overrides)+import Hix.Data.PackageId (PackageId (..)) import Hix.Data.Version (Version, Versions) import Hix.Data.VersionBounds (VersionBounds) import qualified Hix.Log as Log-import Hix.Managed.Build.NixOutput (PackageDerivation (..)) import Hix.Managed.Build.Solve (solveMutation) import qualified Hix.Managed.Cabal.Changes import Hix.Managed.Cabal.Config (isNonReinstallableDep, isReinstallableId)@@ -31,6 +32,7 @@ import Hix.Managed.Data.Mutation (BuildMutation (BuildMutation), DepMutation, MutationResult (..)) import qualified Hix.Managed.Data.MutationState import Hix.Managed.Data.MutationState (MutationState (MutationState), updateBoundsWith)+import Hix.Managed.Data.NixOutput (PackageDerivation (..)) import Hix.Managed.Data.Query (Query (Query)) import qualified Hix.Managed.Data.QueryDep import Hix.Managed.Data.QueryDep (QueryDep)@@ -53,6 +55,7 @@ import qualified Hix.Managed.Handlers.Mutation import Hix.Managed.Handlers.Mutation (MutationHandlers) import Hix.Managed.StageState (updateStageState)+import Hix.Monad (appContext, appContextDebug) import Hix.Pretty (prettyL, showP, showPL) logBuildInputs ::@@ -61,15 +64,15 @@ [PackageId] -> M () logBuildInputs env description overrides = do- Log.info [exon|Building targets in #{color colors.yellow (coerce env)} with #{description}...|]+ Log.info [exon|Building targets in #{Color.env env} with #{Color.package description}...|] Log.debugP (vcat ["Overrides:", prettyL overrides]) logBuildResult :: Text -> BuildResult -> M () logBuildResult description result =- Log.info [exon|Build with ##{description} #{describeResult result}#{describePackages result}|]+ Log.info [exon|Build with ##{Color.package description} #{describeResult result}#{describePackages result}|] where describeResult = \case- BuildSuccess -> "succeeded"+ BuildSuccess _ -> "succeeded" BuildFailure (TimeoutFailure _) -> "timed out" BuildFailure _ -> "failed" @@ -81,7 +84,7 @@ packageFragment pkgs = [exon| in #{names}|] where- names = Text.intercalate ", " (color colors.blue . showP . (.name) <$> pkgs)+ names = Text.intercalate ", " (Color.package . (.name) <$> pkgs) updateMutationState :: (Version -> VersionBounds -> VersionBounds) ->@@ -105,12 +108,12 @@ Bool -> Versions -> [PackageId] ->- M (Overrides, Set PackageId, BuildStatus)+ M (Overrides, BuildStatus) buildVersions builder context description allowRevisions versions overrideVersions = do logBuildInputs context.env description reinstallable- (result, (overrides, revisions)) <- builder.buildWithState allowRevisions versions reinstallable+ (result, overrides) <- builder.buildTargets allowRevisions versions reinstallable logBuildResult description result- pure (overrides, revisions, buildStatus result)+ pure (overrides, buildStatus result) where reinstallable = filter isReinstallableId overrideVersions @@ -119,29 +122,32 @@ EnvContext -> Text -> Bool ->- Set PackageId ->+ Overrides -> SolverState ->- M (Maybe (Versions, Overrides, Set PackageId, BuildStatus))-buildConstraints builder context description allowRevisions prevRevisions state =+ M (Maybe (Versions, Overrides, BuildStatus))+buildConstraints builder context description allowRevisions prevOverrides state = solveMutation builder.cabal context.deps prevRevisions state >>= traverse \ changes -> do- (overrides, revisions, status) <-+ (overrides, status) <- buildVersions builder context description allowRevisions changes.versions changes.overrides- pure (changes.versions, overrides, prevRevisions <> revisions, status)+ pure (changes.versions, overrides, status)+ where+ prevRevisions =+ Set.fromList $ nToMaybe prevOverrides \cases+ name Override {version, revision = Just IsRevision} -> Just PackageId {..}+ _ _ -> Nothing buildMutation :: EnvBuilder -> EnvContext -> MutationState ->- Set PackageId -> BuildMutation ->- M (Maybe (MutationState, Set PackageId))-buildMutation builder context state prevRevisions BuildMutation {description, solverState, updateBound} =- result <$> buildConstraints builder context description True prevRevisions solverState+ M (Maybe MutationState)+buildMutation builder context state BuildMutation {description, solverState, updateBound} =+ result <$> buildConstraints builder context description True state.overrides solverState where result = \case- Just (versions, overrides, revisions, status) -> do- new <- justSuccess (updateMutationState updateBound versions overrides state) status- pure (new, revisions)+ Just (versions, overrides, status) ->+ justSuccess (updateMutationState updateBound versions overrides state) status Nothing -> Nothing logMutationResult ::@@ -170,13 +176,13 @@ logMutationResult mutation.package result pure (updateStageState stageState mutation result) where- processReinstallable- | isNonReinstallableDep mutation.package- = pure MutationKeep- | otherwise- = handlers.process stageState.ext mutation build- build = buildMutation envBuilder context stageState.state stageState.revisions+ processReinstallable =+ if isNonReinstallableDep mutation.package+ then pure MutationKeep+ else handlers.process stageState.ext mutation build + build = buildMutation envBuilder context stageState.state+ convergeMutations :: Pretty a => MutationHandlers a s ->@@ -199,15 +205,16 @@ | otherwise = do- Log.debug [exon|Iteration #{show (state.iterations + 1)} for '##{context.env :: EnvName}'|]- newState <- build state mutations+ let iteration = state.iterations + 1+ newState <- appContextDebug [exon|converging #{Color.env context.env} (iteration #{Color.number iteration})|] do+ build state iteration mutations if Map.size newState.success == Map.size state.success then pure newState -- reversing so the build order is consistent else spin newState (reverse newState.failed) - build statePre mutations = do- let state = statePre {failed = [], iterations = statePre.iterations + 1}+ build statePre iterations mutations = do+ let state = statePre {failed = [], iterations} Log.debug [exon|Building targets with mutations: #{showPL mutations}|] foldM (validateMutation builder context handlers) state mutations @@ -216,7 +223,8 @@ Query -> M [DepMutation a] reinstallableCandidates candidates (Query query) =- catMaybes <$> traverse reinstallableOnly (toList query)+ appContext "collecting mutation candidates" do+ catMaybes <$> traverse reinstallableOnly (toList query) where reinstallableOnly dep | isNonReinstallableDep dep.package
+ lib/Hix/Managed/Build/Adapt.hs view
@@ -0,0 +1,127 @@+module Hix.Managed.Build.Adapt where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (StateT, gets, modify')+import qualified Data.Map.Strict as Map+import Data.Map.Strict ((!?))+import qualified Data.Text as Text+import Distribution.Pretty (Pretty (..))+import Exon (exon)+import Text.PrettyPrint (brackets, (<+>))++import Hix.Class.Map (nInsert, (!!))+import qualified Hix.Color as Color+import Hix.Data.Monad (M)+import Hix.Data.Overrides (Override (..), Overrides)+import Hix.Data.PackageId (PackageId (..))+import Hix.Data.PackageName (PackageName)+import Hix.Data.Version (Version)+import qualified Hix.Log as Log+import Hix.Managed.Build.NixOutput.Analysis (FailureReason (..), analyzeEarlyFailure, analyzeLog)+import Hix.Managed.Data.NixOutput (PackageDerivation (..))+import Hix.Managed.Data.StageState (BuildFailure (..), BuildResult (..))+import Hix.Maybe (justIf)+import Hix.Monad (appContextT)+import Hix.Pretty (showP)++data FailedPackage =+ FailedPackage {+ package :: PackageName,+ version :: Maybe Version+ }+ deriving stock (Eq, Show)++failedPackageId :: FailedPackage -> Maybe PackageId+failedPackageId FailedPackage {..} =+ version <&> \ v -> PackageId {name = package, version = v}++data RetryPackage =+ RetryPackage {+ package :: PackageId,+ override :: Override+ }+ deriving stock (Eq, Show)++instance Pretty RetryPackage where+ pretty RetryPackage {..} =+ pretty package <+> brackets (shortOverride override)+ where+ shortOverride = \case+ Override {version} -> pretty version+ Jailbreak -> "jailbreak"+ Local -> "local"++data FailureCounts =+ FailureCounts {+ clear :: Word+ }+ deriving stock (Eq, Show)++incrementOrInit :: Maybe Word -> Maybe Word+incrementOrInit = \case+ Just old -> Just (old + 1)+ Nothing -> Just 1++recordRetry :: RetryPackage -> (Overrides, Map PackageId Word) -> (Overrides, Map PackageId Word)+recordRetry retry (overrides, counts) =+ (+ nInsert retry.package.name retry.override overrides,+ Map.alter incrementOrInit retry.package counts+ )++failureCounts :: NonEmpty FailureReason -> FailureCounts+failureCounts pkgs =+ FailureCounts {clear}+ where+ clear = fromIntegral $ length $ flip filter (toList pkgs) \case+ Unclear -> False+ _ -> True++manageableFailures :: BuildResult -> Maybe (NonEmpty (FailedPackage, FailureReason))+manageableFailures = \case+ BuildFailure (PackageFailure pkgs) ->+ Just [+ (FailedPackage {package = name, version = Just version, ..}, analyzeLog log)+ |+ PackageDerivation {package = PackageId {..}, ..} <- pkgs+ ]+ BuildFailure (UnexpectedFailure log) ->+ analyzeEarlyFailure log <&> \ (package, reason) -> pure (FailedPackage {version = Nothing, ..}, reason)+ _ -> Nothing++buildAdaptive ::+ (Overrides -> M BuildResult) ->+ (FailureCounts -> FailedPackage -> Maybe Override -> FailureReason -> M (Maybe RetryPackage)) ->+ StateT (Overrides, Map PackageId Word) M BuildResult+buildAdaptive runBuild suggestOverride = do+ build+ where+ build = do+ result <- lift . runBuild =<< gets fst+ collectRetries result >>= \case+ Just (Just retries) -> retryFailures retries+ Just Nothing -> result <$ lift (Log.verbose "Could not fix any failures heuristically")+ Nothing -> pure result++ collectRetries failure =+ for (manageableFailures failure) \ reasons -> do+ let counts = failureCounts (snd <$> reasons)+ potentialOverrides <- catMaybes <$> traverse (findOverride counts) (toList reasons)+ overrides <- catMaybes <$> traverse limitOverrides potentialOverrides+ pure (nonEmpty overrides)++ retryFailures :: NonEmpty RetryPackage -> StateT (Overrides, Map PackageId Word) M BuildResult+ retryFailures retries = do+ lift $ Log.verbose [exon|Some packages failed, retrying with overrides: #{ids}|]+ traverse_ (modify' . recordRetry) retries+ build+ where+ ids = Text.intercalate ", " (Color.package <$> toList retries)++ limitOverrides pkg =+ gets (\ (_, counts) -> justIf (fromMaybe 0 (counts !? pkg.package) < 4) pkg)++ findOverride counts (pkg, reason) =+ appContextT [exon|finding an override for #{Color.package pkg.package} (#{showP reason})|] do+ old <- gets \ (ovs, _) -> ovs !! pkg.package+ lift (suggestOverride counts pkg old reason)
lib/Hix/Managed/Build/Mutation.hs view
@@ -56,18 +56,18 @@ -- TODO If we'd use the @retract@ field from @DepMutation@ and the target bound here, we could probably use a universal -- bounds updater without leaking implementation...investigate. buildCandidate ::- (BuildMutation -> M (Maybe (MutationState, Set PackageId))) ->+ (BuildMutation -> M (Maybe MutationState)) -> (Version -> VersionBounds -> VersionBounds) -> (MutableId -> PackageId -> MutationConstraints -> MutationConstraints) -> SolverState -> MutableDep -> Version ->- M (Maybe (MutableId, SolverState, MutationState, Set PackageId))+ M (Maybe (MutableId, SolverState, MutationState)) buildCandidate build updateStateBound updateConstraintBound solverState package version = do Log.debug [exon|Mutation constraints for #{showP candidate}: #{showP mutationSolverState.constraints}|] fmap result <$> build (candidateMutation mutationSolverState candidate updateStateBound) where- result (newState, revisions) = (candidate, newSolverState newState, newState, revisions)+ result newState = (candidate, newSolverState newState, newState) candidate = MutableId {name = package, version}
lib/Hix/Managed/Build/NixOutput.hs view
@@ -22,53 +22,24 @@ import Hix.Data.Json (jsonEither) import Hix.Data.Monad (M) import qualified Hix.Data.PackageId as PackageId-import Hix.Data.PackageId (PackageId (..)) import qualified Hix.Log as Log+import Hix.Managed.Data.BuildConfig (BuildConfig (..))+import Hix.Managed.Data.NixOutput (+ BuildsState (..),+ Derivation (..),+ OutputResult (..),+ OutputState (..),+ PackageDerivation (..),+ ) import Hix.Pretty (showP) -data Derivation =- Derivation {- path :: Text,- log :: (Seq Text, Seq Text)- }- deriving stock (Eq, Show, Generic)--data PackageDerivation =- PackageDerivation {- package :: PackageId,- success :: Bool,- log :: [Text]- }- deriving stock (Eq, Show, Generic)--data BuildsState =- BuildsState {- id :: Integer,- done :: Int,- failed :: Int,- unassigned :: [Bool]- }- deriving stock (Eq, Show, Generic)--data OutputState =- OutputState {- builds :: Maybe BuildsState,- running :: Map Integer Derivation,- finished :: [PackageDerivation]- }- deriving stock (Eq, Show, Generic)- deriving anyclass (Default)--data OutputResult =+outputResult :: OutputState -> OutputResult+outputResult OutputState {finished, messages} = OutputResult {- failedPackages :: Maybe (NonEmpty PackageDerivation)+ failedPackages = nonEmpty (filter (not . (.success)) finished),+ unknownMessages = reverse messages }- deriving stock (Eq, Show, Generic) -outputResult :: OutputState -> OutputResult-outputResult OutputState {finished} =- OutputResult {failedPackages = nonEmpty (filter (not . (.success)) finished)}- runOutputState :: Monad m => StateT OutputState m a ->@@ -87,7 +58,7 @@ | NixStartOther Integer |- NixMessage+ NixMessage (Maybe Text) deriving stock (Eq, Show, Generic) instance FromJSON NixAction where@@ -112,7 +83,9 @@ "stop" -> do i <- o .: "id" pure (NixStop i)- "msg" -> pure NixMessage+ "msg" -> do+ msg <- o .:? "msg"+ pure (NixMessage msg) (act :: Text) -> fail [exon|Unknown action: #{toString act}|] parseError :: String -> StateT s M ()@@ -165,7 +138,7 @@ reportFinished :: Either Derivation PackageDerivation -> StateT OutputState M () reportFinished result =- lift $ Log.debug [exon|Nix build of #{desc} #{status}|]+ lift $ Log.trace [exon|Nix build of #{desc} #{status}|] where (desc, status) = case result of Right PackageDerivation {package, success} -> (showP package, if success then "succeeded" else "failed")@@ -187,10 +160,12 @@ processResult :: Integer -> Int -> [Either Text Int] -> OutputState -> OutputState processResult aid rtype fields s+ -- result type @Progress@ | rtype == 105 , Just BuildsState {id = buildsId} <- s.builds , aid == buildsId = updateBuilds fields s+ -- result type @BuildLogLine@ | rtype == 101 , Left message : _ <- fields = s {running = Map.adjust (addLogMessage message) aid s.running}@@ -198,29 +173,42 @@ = s processMessage ::+ BuildConfig -> ByteString -> NixAction -> StateT OutputState M ()-processMessage _ = \case- NixResult {aid, rtype, fields} -> do- -- lift (Log.debug (decodeUtf8 payload))+processMessage config _raw = \case+ NixResult {aid, rtype, fields} -> modify' (processResult aid rtype fields)- NixStartBuilds i -> modify' \ s -> s {builds = Just BuildsState {id = i, done = 0, failed = 0, unassigned = []}}++ NixStartBuilds i ->+ modify' \ s -> s {builds = Just BuildsState {id = i, done = 0, failed = 0, unassigned = []}}+ NixStart i path -> do- lift $ Log.debug [exon|Started build of #{path} (#{show i})|]+ lift $ Log.trace [exon|Started build of #{path} (#{show i})|] modify' \ OutputState {running, ..} -> OutputState {running = Map.insert i (Derivation path mempty) running, ..}+ NixStop i -> do result <- state \ OutputState {running, ..} -> do let (result, package, newBuilds) = tryFinish builds (running !? i) (result, OutputState {running = Map.delete i running, finished = finished ++ package, builds = newBuilds, ..}) traverse_ reportFinished result+ NixStartOther _ -> unit- NixMessage -> unit -outputParse :: ByteString -> StateT OutputState M ()-outputParse outputLine+ NixMessage mb_msg ->+ for_ mb_msg \ msg -> do+ when config.buildOutput do+ lift $ Log.infoPlain msg+ modify' \ s -> s {messages = msg : s.messages}++outputParse ::+ BuildConfig ->+ ByteString ->+ StateT OutputState M ()+outputParse config outputLine | Just payload <- ByteString.stripPrefix "@nix " outputLine- = either parseError (processMessage payload) (Aeson.eitherDecodeStrict' payload)+ = either parseError (processMessage config payload) (Aeson.eitherDecodeStrict' payload) | otherwise = lift (Log.debug (decodeUtf8 outputLine))
lib/Hix/Managed/Build/NixOutput/Analysis.hs view
@@ -1,16 +1,122 @@ module Hix.Managed.Build.NixOutput.Analysis where -import Distribution.Parsec (simpleParsec)+import Data.List.Extra (firstJust, trim)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text+import Distribution.Compat.CharParsing (anyChar, char, digit, string)+import qualified Distribution.Compat.Parsing as P+import Distribution.Compat.Parsing (manyTill, sepEndByNonEmpty, skipMany, try)+import Distribution.Parsec (Parsec (..), simpleParsec)+import Distribution.Pretty (Pretty (..)) import Distribution.Simple (Dependency)+import Exon (exon) import qualified Hix.Data.Dep as Dep import Hix.Data.Dep (Dep)+import Hix.Data.PackageName (PackageName)+import Hix.Managed.Report (pluralLength)+import Hix.Pretty (prettyText, showP) -analyzeLog :: [Text] -> Maybe (NonEmpty Dep)+newtype BuildErrorId =+ BuildErrorId Text+ deriving stock (Eq, Show)+ deriving newtype (IsString, Ord)++instance Parsec BuildErrorId where+ parsec = do+ manyTill anyChar (try (string "error"))+ manyTill anyChar (char ':')+ manyTill anyChar (try (string "[GHC-"))+ maybe (fail "impossible: invalid digits") (pure . BuildErrorId) . readMaybe =<< (P.some digit <* skipMany anyChar)++newtype UnknownDepMessage =+ UnknownDepMessage PackageName+ deriving stock (Eq, Show)+ deriving newtype (IsString, Ord)++-- TODO maybe we can add a module option that toggles errors in json or something, with which we can reliably extract+-- this information+instance Parsec UnknownDepMessage where+ parsec = do+ _ <- manyTill anyChar (try (string "The Cabal config for '"))+ _local <- tillQuote+ string " in the env '"+ _env <- tillQuote+ string " has a dependency on the nonexistent package '"+ name <- tillQuote+ many anyChar+ pure (fromString name)+ where+ tillQuote = manyTill anyChar (char '\'')++data FailureReason =+ Unclear+ |+ BuildError (NonEmpty BuildErrorId)+ |+ BoundsError (NonEmpty Dep)+ |+ UnknownDep+ deriving stock (Eq, Show)++listThree :: NonEmpty Text -> Text+listThree things =+ [exon|#{examples}#{ellipsis}|]+ where+ (three, rest) = NonEmpty.splitAt 3 things+ examples = Text.intercalate ", " three+ ellipsis = if null rest then "" else "..."++instance Pretty FailureReason where+ pretty = \case+ Unclear -> "unclear"+ BuildError ids ->+ prettyText [exon|build error#{pluralLength ids} #{listThree (coerce ids)}|]+ BoundsError deps ->+ prettyText [exon|bounds error#{pluralLength deps} #{listThree (showP . (.package) <$> deps)}|]+ UnknownDep ->+ "unknown package"++boundsMarker1 :: Text+boundsMarker1 = "Encountered missing or private dependencies:"++boundsMarker2 :: Text+boundsMarker2 = "Error: Setup: " <> boundsMarker1++boundsMarkers :: [Text]+boundsMarkers = [boundsMarker1, boundsMarker2]++newtype CommaSeparatedDeps =+ CommaSeparatedDeps { deps :: NonEmpty Dependency }+ deriving stock (Eq, Show)++instance Parsec CommaSeparatedDeps where+ parsec =+ CommaSeparatedDeps <$> sepEndByNonEmpty parsec (char ',' *> many (char ' ')) <* skipMany anyChar++analyzeLog :: [Text] -> FailureReason analyzeLog log =- nonEmpty bounds+ fromMaybe Unclear variants where- bounds = catMaybes (takeWhile isJust (parseDep <$> afterBoundsMarker))- afterBoundsMarker = drop 1 (dropWhile (boundsMarker /=) log)- boundsMarker = "Error: Setup: Encountered missing or private dependencies:"- parseDep = fmap Dep.fromCabal . simpleParsec @Dependency . toString+ variants =+ (BoundsError <$> bounds)+ <|>+ (BuildError <$> buildErrors)++ buildErrors = nonEmpty (mapMaybe simpleParsec logStrings)++ bounds = nonEmpty (concat (catMaybes (takeWhile isJust (parseDeps <$> afterBoundsMarker))))++ afterBoundsMarker = drop 1 (dropWhile (not . flip elem boundsMarkers) log)++ parseDeps line = do+ CommaSeparatedDeps {deps} <- simpleParsec @CommaSeparatedDeps (trim (toString line))+ pure (Dep.fromCabal <$> toList deps)++ logStrings = toString <$> log++analyzeEarlyFailure :: NonEmpty Text -> Maybe (PackageName, FailureReason)+analyzeEarlyFailure log =+ firstJust simpleParsec (toList logStrings) <&> \ (UnknownDepMessage name) -> (name, UnknownDep)+ where+ logStrings = toString <$> log
+ lib/Hix/Managed/Build/NixProcess.hs view
@@ -0,0 +1,171 @@+module Hix.Managed.Build.NixProcess where++import Control.Concurrent.STM (STM, atomically)+import qualified Data.ByteString.Char8 as ByteString+import qualified Data.Text as Text+import Exon (exon)+import Path (Abs, Dir, Path, toFilePath)+import System.IO (BufferMode (LineBuffering), Handle, hSetBuffering)+import System.IO.Error (tryIOError)+import System.Process.Typed (+ ExitCode (ExitFailure, ExitSuccess),+ ProcessConfig,+ byteStringOutput,+ createPipe,+ getStderr,+ getStdout,+ inherit,+ nullStream,+ proc,+ setStderr,+ setStdout,+ setWorkingDir,+ waitExitCode,+ withProcessTerm,+ )+import System.Timeout (timeout)++import Hix.Data.Error (Error)+import Hix.Data.Monad (LogLevel (LogDebug), M)+import Hix.Error (pathText)+import qualified Hix.Log as Log+import Hix.Managed.Build.NixOutput (outputParse, runOutputState)+import qualified Hix.Managed.Data.BuildConfig+import Hix.Managed.Data.BuildConfig (BuildConfig)+import Hix.Managed.Data.NixOutput (OutputResult (..))+import Hix.Managed.Data.StageState (BuildFailure (..), BuildResult (..))+import Hix.Monad (shouldLog, withLowerTry')++data OutputConfig =+ OutputDebug+ |+ OutputParse+ |+ OutputIgnore++data NixProcResult =+ NixProcSuccess [Text]+ |+ NixProcFailure Text+ deriving stock (Eq, Show, Generic)++outputLines ::+ MonadIO m =>+ (ByteString -> m ()) ->+ Handle ->+ m (Maybe Text)+outputLines parse handle = do+ liftIO (hSetBuffering handle LineBuffering)+ spin mempty+ where+ spin buf = do+ liftIO (tryIOError (ByteString.hGet handle 4096)) >>= \case+ Left err -> pure (Just (show err))+ Right new ->+ join <$> for (completeLines buf new) \ (lns, newBuf) -> do+ for_ lns parse+ spin newBuf++ completeLines = \cases+ -- Empty output means the handle was closed, empty buffer means we can terminate+ "" "" ->+ Nothing+ -- First iteration after handle was closed, need to emit the last line+ buf "" ->+ Just ([buf], "")+ buf new ->+ Just (breakNl [] (buf <> new))++ breakNl acc s =+ case ByteString.break (== '\n') s of+ (rest, "") -> (reverse acc, rest)+ (ln, rest) -> breakNl (ln : acc) (ByteString.drop 1 rest)++nixProc ::+ OutputConfig ->+ Path Abs Dir ->+ [Text] ->+ Text ->+ [Text] ->+ M (ProcessConfig () (STM LByteString) (Maybe Handle))+nixProc output root cmd installable extra = do+ Log.debug [exon|Running nix at '#{pathText root}' with args #{show args}|]+ pure conf+ where+ conf =+ err $+ setStdout byteStringOutput $+ setWorkingDir (toFilePath root) $+ proc "nix" args++ err = case output of+ OutputParse -> setStderr (Just <$> createPipe)+ OutputDebug -> setStderr (Nothing <$ inherit)+ OutputIgnore -> setStderr (Nothing <$ nullStream)++ args = toString <$> cmd ++ [exon|path:#{".#"}#{installable}|] : extra ++ logArgs++ logArgs = case output of+ OutputParse -> ["--log-format", "internal-json"]+ OutputDebug -> ["-L"]+ OutputIgnore -> []++runProc ::+ BuildConfig ->+ (Handle -> M a) ->+ ProcessConfig () (STM LByteString) (Maybe Handle) ->+ M (Maybe (Maybe (Either Error a), [Text], ExitCode))+runProc buildConf pipeHandler conf =+ withLowerTry' \ lower -> withProcessTerm conf \ prc -> do+ limit do+ result <- traverse (lower . pipeHandler) (getStderr prc)+ res <- waitExitCode prc+ stdout <- atomically (getStdout prc)+ pure (result, Text.lines (decodeUtf8 stdout), res)+ where+ limit | Just t <- buildConf.timeout+ , t > 0+ = timeout (coerce t * 1_000_000)+ | otherwise = fmap Just++outputResult ::+ Maybe (Either Error (Maybe Text, OutputResult)) ->+ [Text] ->+ ExitCode ->+ BuildResult+outputResult result stdout = \case+ ExitSuccess -> BuildSuccess stdout+ ExitFailure _ -> BuildFailure (maybe UnknownFailure failure result)+ where+ failure = \case+ Right (unhandled, OutputResult {unknownMessages, failedPackages}) ->+ let alt = maybe UnknownFailure UnexpectedFailure (nonEmpty unknownMessages <> (pure <$> unhandled))+ in maybe alt PackageFailure failedPackages+ Left err ->+ AppFailure err++nixBuild ::+ BuildConfig ->+ Path Abs Dir ->+ Text ->+ M BuildResult+nixBuild buildConf root attr = do+ debug <- shouldLog LogDebug+ conf <- nixProc (outputHandler debug) root args [exon|__hix-internal__.#{attr}|] []+ runProc buildConf runOutput conf <&> \case+ Just (result, stdout, code) ->+ outputResult result stdout code+ Nothing -> BuildFailure (TimeoutFailure [])+ where+ args = ["build", "--no-link", "--show-trace", "--print-out-paths"]++ runOutput handle =+ runOutputState (outputLines (outputParse buildConf) handle)++ outputHandler debug+ | buildConf.disableNixMonitor =+ if debug || buildConf.buildOutput+ then OutputDebug+ else OutputIgnore+ | otherwise =+ OutputParse
lib/Hix/Managed/Build/Single.hs view
@@ -1,6 +1,7 @@ module Hix.Managed.Build.Single where import Hix.Data.Monad (M)+import Hix.Data.Overrides (Overrides) import Hix.Data.VersionBounds (exactVersion) import Hix.Managed.Build (buildConstraints) import Hix.Managed.Cabal.Data.SolverState (solverState)@@ -18,10 +19,11 @@ EnvContext -> Text -> MutableVersions ->+ Maybe Overrides -> M BuildStatus-buildVersions builder context description versions =- buildConstraints builder context description False [] solver <&> \case- Just (_, _, _, status) -> status+buildVersions builder context description versions prevOverrides =+ buildConstraints builder context description False (fold prevOverrides) solver <&> \case+ Just (_, _, status) -> status Nothing -> Failure where solver = solverState context.solverBounds context.deps (fromVersions exactVersion versions) def
lib/Hix/Managed/Build/Solve.hs view
@@ -9,9 +9,7 @@ import Hix.Class.Map (nRestrictKeys) import Hix.Data.Monad (M)-import qualified Hix.Data.PackageId-import Hix.Data.PackageId (PackageId (PackageId))-import Hix.Data.PackageName (isLocalPackage)+import Hix.Data.PackageId (PackageId) import Hix.Data.Version (packageIdVersions) import qualified Hix.Log as Log import qualified Hix.Managed.Cabal.Changes@@ -23,12 +21,25 @@ import Hix.Managed.Data.Mutable (depName) import qualified Hix.Managed.Handlers.Cabal import Hix.Managed.Handlers.Cabal (CabalHandlers)+import Hix.Monad (appContextVerbose) import Hix.Pretty (prettyL, showPL) logNonReinstallable :: NonEmpty PackageId -> M () logNonReinstallable ids = Log.verbose [exon|NOTE: Cabal solver suggested new versions for non-reinstallable packages: #{showPL ids}|] +-- | Forcing revisions means that any package that has a revision in the Hackage snapshot will be treated as an+-- override, i.e. it will be built from Hackage despite having the same version as the one installed in nixpkgs.+--+-- The benefit of doing this is that often nixpkgs will be outdated in comparison with Hackage, and therefore have+-- tighter dependency bounds.+-- When Cabal resolves a plan based on revised bounds in packages whose versions match nixpkgs, but not their revisions,+-- the nix build will fail with bounds errors, requiring a restart with revisions.+--+-- On the other hand, in many situations (like lower bound mutations), this is entirely irrelevant; in others, the+-- original bounds might just work for the current build; and most often nixpkgs actually has the latest revision, which+-- we cannot observe at this point.+-- Therefore, this feature is disabled until it can be refined. checkRevision :: Bool -> CabalHandlers ->@@ -59,14 +70,17 @@ "Forced revisions:" <+> prettyL forcedRevisions $$ "Reused revisions:" <+> prettyL reusedRevisions traverse_ logNonReinstallable nonReinstallable- pure SolverChanges {versions, overrides, projectDeps}+ pure SolverChanges {versions, overrides} where projectDeps = nRestrictKeys mutablePIds versions versions = packageIdVersions (overrides ++ installed)- overrides = filter notLocal (changes ++ forcedRevisions ++ reusedRevisions)+ overrides = changes ++ forcedRevisions ++ reusedRevisions+ -- If a package has been selected for revision during a prior build, add it to the overrides despite its matching+ -- version.+ -- This simply ensures that the revision procedure can be skipped in this build, since the same version will likely+ -- cause the same dependency bounds error that triggered the revision. (reusedRevisions, installed) = partition (flip Set.member prevRevisions) noForcedRevisions (noForcedRevisions, forcedRevisions) = partitionEithers (checkRevision forceRevisions cabal <$> matching)- notLocal PackageId {name} = not (isLocalPackage deps.local name) mutablePIds = Set.fromList (depName <$> Set.toList deps.mutable) -- TODO probably best to store the revisions in the SolverState@@ -77,4 +91,5 @@ SolverState -> M (Maybe SolverChanges) solveMutation cabal deps prevRevisions state =- traverse (processSolverPlan state.flags.forceRevisions cabal deps prevRevisions) =<< cabal.solveForVersion state+ appContextVerbose "resolving a mutation build plan" do+ traverse (processSolverPlan state.flags.forceRevisions cabal deps prevRevisions) =<< cabal.solveForVersion state
+ lib/Hix/Managed/Build/SolverPackages.hs view
@@ -0,0 +1,71 @@+module Hix.Managed.Build.SolverPackages where++import Control.Monad.Trans.State.Strict (runStateT)+import Exon (exon)+import Path (Abs, Dir, Path, parseAbsDir)++import Hix.Data.EnvName (EnvName)+import Hix.Data.Monad (M)+import Hix.Data.Overrides (Overrides)+import qualified Hix.Log as Log+import Hix.Managed.Build.Adapt (buildAdaptive)+import Hix.Managed.Build.Target (BuilderResources (..), buildSolverPackages, suggestJailbreakAndLatestVersion)+import Hix.Managed.Cabal.Data.Config (GhcDb (..), GhcPath (..))+import Hix.Managed.Data.Initial (Initial (..))+import Hix.Managed.Data.StageState (BuildResult (..))+import Hix.Monad (appContext, eitherFatal)+import Hix.Pretty (showP)++badOutput :: Text -> Text+badOutput output = [exon|The output of building the solver package set is not a single valid store path: #{output}|]++validateSolverSuccess :: [Text] -> Either Text (Path Abs Dir)+validateSolverSuccess = \case+ [output] -> maybeToRight (badOutput output) (parseAbsDir (toString output))+ [] -> Left (badOutput "<empty output>")+ output : _ -> Left (badOutput output)++-- | Check stdout of the Nix build to verify it consists of a single line, and parse that line as an absolute path to a+-- GHC package set.+solverBuildResult :: (BuildResult, a) -> Either Text (GhcDb, a)+solverBuildResult = \case+ (BuildSuccess output, overrides) ->+ validateSolverSuccess output <&> \ path ->+ (GhcDbSystem (Just (GhcPath path)), overrides)+ (BuildFailure failure, _) ->+ Left [exon|Some packages could not be fixed automatically. Reason: #{showP failure}|]++solverResult :: (BuildResult, (a, b)) -> M (GhcDb, a)+solverResult (result, (overrides, _)) =+ eitherFatal (solverBuildResult (result, overrides))++nixSolverGhc ::+ BuilderResources ->+ EnvName ->+ Initial Overrides ->+ M (GhcDb, Overrides)+nixSolverGhc resources env (Initial storedOverrides) =+ appContext "validating the solver package set" do+ leftA cleanBuild =<< previousBuild+ where+ cleanBuild err = do+ Log.verbose "Build with previous solver overrides failed"+ Log.debug err+ appContext "computing the overrides for the solver package set" do+ solverResult =<< runStateT (build (suggestJailbreakAndLatestVersion resources)) (mempty, mempty)++ previousBuild = do+ result <- buildSolverPackages resources env storedOverrides+ pure (solverBuildResult (result, storedOverrides))++ build = buildAdaptive (buildSolverPackages resources env)++solverGhc ::+ BuilderResources ->+ EnvName ->+ Initial Overrides ->+ Maybe GhcDb ->+ M (GhcDb, Maybe Overrides)+solverGhc resources env overrides = \case+ Nothing -> second Just <$> nixSolverGhc resources env overrides+ Just ghc -> pure (ghc, Nothing)
+ lib/Hix/Managed/Build/Target.hs view
@@ -0,0 +1,143 @@+module Hix.Managed.Build.Target where++import Control.Monad.Trans.State.Strict (StateT (runStateT))+import Exon (exon)+import Path (Abs, Dir, Path)++import Hix.Data.EnvName (EnvName)+import Hix.Data.Monad (M)+import Hix.Data.Overrides (Override (..), Overrides)+import Hix.Data.PackageId (PackageId (..))+import Hix.Data.PackageName (LocalPackage, PackageName)+import Hix.Data.Version (Versions)+import Hix.Managed.Build.Adapt (+ FailedPackage (..),+ FailureCounts (..),+ RetryPackage (..),+ buildAdaptive,+ failedPackageId,+ )+import Hix.Managed.Build.NixOutput.Analysis (FailureReason (..))+import Hix.Managed.Build.NixProcess (nixBuild)+import Hix.Managed.Data.BuildConfig (BuildConfig)+import Hix.Managed.Data.StageState (BuildResult (..), buildUnsuccessful)+import Hix.Managed.Data.Targets (Targets, firstMTargets)+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers (..))+import Hix.Managed.Handlers.SourceHash (SourceHashHandlers)+import Hix.Managed.Handlers.StateFile (StateFileHandlers)+import Hix.Managed.Overrides (packageOverrideRegular, packageOverrides, packageRevision)+import Hix.Managed.StateFile (writeBuildStateFor, writeSolverStateFor)++data BuilderResources =+ BuilderResources {+ hackage :: SourceHashHandlers,+ stateFile :: StateFileHandlers,+ versions :: AvailableVersionsHandlers,+ root :: Path Abs Dir,+ buildConfig :: BuildConfig+ }++data EnvBuilderResources =+ EnvBuilderResources {+ global :: BuilderResources,+ env :: EnvName,+ targets :: Targets,+ localUnavailable :: Set LocalPackage+ }++buildWithOverrides ::+ BuilderResources ->+ EnvName ->+ LocalPackage ->+ Overrides ->+ M BuildResult+buildWithOverrides builder env target overrides = do+ writeBuildStateFor "current build" builder.stateFile builder.root env overrides+ nixBuild builder.buildConfig builder.root [exon|env.##{env}.##{target}|]++buildSolverPackages ::+ BuilderResources ->+ EnvName ->+ Overrides ->+ M BuildResult+buildSolverPackages builder env overrides = do+ writeSolverStateFor "solver packages" builder.stateFile builder.root env overrides+ nixBuild builder.buildConfig builder.root [exon|env.##{env}.solver|]++suggestRevision ::+ BuilderResources ->+ FailureCounts ->+ FailedPackage ->+ Maybe Override ->+ FailureReason ->+ M (Maybe RetryPackage)+suggestRevision resources _ pkg = \cases+ Nothing (BoundsError _)+ | Just package <- failedPackageId pkg+ -> do+ override <- packageRevision resources.hackage [] package+ pure (Just RetryPackage {package, ..})+ _ _ -> pure Nothing++suggestNothing ::+ FailureCounts ->+ FailedPackage ->+ Maybe Override ->+ FailureReason ->+ M (Maybe a)+suggestNothing _ _ _ _ =+ pure Nothing++latestVersionFor :: BuilderResources -> PackageName -> M (Maybe RetryPackage)+latestVersionFor resources target =+ resources.versions.latest target >>= traverse \ latest -> do+ override <- packageOverrideRegular resources.hackage [] PackageId {name = target, version = latest}+ pure RetryPackage {package = PackageId {name = target, version = override.version}, ..}++-- | This might seem wrong at first glance – it immediately jailbreaks the entire package even though a newer revision+-- might relax just the right bounds and leave the rest intact.+-- However, at this point bounds are entirely useless, since a) we already incorporated proper bounds in our plan by+-- running the solver, and b) nix cannot select between different versions anyway.+suggestJailbreakAndLatestVersion ::+ BuilderResources ->+ FailureCounts ->+ FailedPackage ->+ Maybe Override ->+ FailureReason ->+ M (Maybe RetryPackage)+suggestJailbreakAndLatestVersion resources counts pkg = \cases+ Nothing (BoundsError _)+ | Just package <- failedPackageId pkg+ -> pure (Just RetryPackage {package, override = Jailbreak})+ Nothing UnknownDep -> latestVersionFor resources pkg.package+ _ (BuildError _) -> latestVersion+ _ Unclear | counts.clear == 0 -> latestVersion+ _ _ -> pure Nothing+ where+ latestVersion = latestVersionFor resources pkg.package++-- | Build an env's target packages using the given package IDs for its dependencies.+-- Return a resolved set of overrides with hashes for these versions, as well as the set of packages that have been+-- revised.+--+-- Revisions are tried for each package that fails with a bounds error, assuming that nixpkgs has an outdated revision+-- for this package, while Cabal's snapshot is more up to date.+-- In that case, building the same version from Hackage will result in the latest revision being pulled in, which might+-- have updated bounds.+--+-- While the preparation of the solver overrides allows arbitrary substitutions for broken packages, we cannot do that+-- here – the mutation algorithms rely on the property of this function that all deps are built at the specified+-- versions.+buildTargets ::+ EnvBuilderResources ->+ Bool ->+ Versions ->+ [PackageId] ->+ M (BuildResult, Overrides)+buildTargets builder allowRevisions _ overrideVersions = do+ overrides <- packageOverrides builder.global.hackage builder.localUnavailable overrideVersions+ let build target = buildAdaptive (buildWithOverrides builder.global builder.env target) suggest+ s0 = (overrides, [])+ second fst <$> runStateT (firstMTargets (BuildSuccess []) buildUnsuccessful build builder.targets) s0+ where+ suggest = if allowRevisions then suggestRevision builder.global else suggestNothing
lib/Hix/Managed/BuildOutput.hs view
@@ -1,19 +1,20 @@ module Hix.Managed.BuildOutput where -import qualified Data.Aeson as Aeson import Data.List.Extra (nubSortOn)-import qualified Data.Text as Text import Data.These.Combinators (justThere) import Hix.Data.Monad (M) import Hix.Data.OutputFormat (OutputFormat (..)) import Hix.Data.OutputTarget (OutputTarget (..))-import Hix.Data.PackageName (PackageName (PackageName))-import Hix.Managed.BuildOutput.CommitMsg (formatCommit)+import Hix.Managed.BuildOutput.CommitMsg (formatCommit, formatMutableDeps, modifiedIdNames, commit) import Hix.Managed.BuildOutput.GithubActionsPr (githubActionsPr) import qualified Hix.Managed.Data.BuildOutput-import Hix.Managed.Data.BuildOutput (BuildOutput (BuildOutput), ModifiedId (ModifiedId))-import Hix.Managed.Data.Mutable (MutableDep, depName)+import Hix.Managed.Data.BuildOutput (+ BuildOutput (BuildOutput),+ DepChanges (..),+ DepChangesNames (..),+ ModifiedId (ModifiedId),+ ) import qualified Hix.Managed.Data.Mutation import Hix.Managed.Data.ProjectResult (ProjectResult) import qualified Hix.Managed.EnvResult@@ -25,29 +26,18 @@ ) import qualified Hix.Managed.ProjectResult as ProjectResult import qualified Hix.OutputWriter-import Hix.OutputWriter (outputWriterGlobal)+import Hix.OutputWriter (OutputWriter, writeOutput, OutputSpecial (..)) -outputResult :: BuildOutput -> OutputTarget -> OutputFormat -> M ()-outputResult output target = \case- OutputNone -> unit- OutputJson -> writer.bytes (toStrict (Aeson.encode output))- OutputCommitMsg -> traverse_ writer.text (formatCommit output)- OutputGaPr -> githubActionsPr output target- where- writer = outputWriterGlobal target+writeCommit :: BuildOutput -> OutputWriter -> M ()+writeCommit output writer =+ traverse_ writer.text (formatCommit output.changes) -buildOutputFromLists :: [ModifiedId] -> [MutableDep] -> [MutableDep] -> BuildOutput-buildOutputFromLists modified unmodified failed =- BuildOutput {- modified,- unmodified,- failed,- modifiedNames = comma ((.package) <$> modified),- unmodifiedNames = comma unmodified,- failedNames = comma failed- }- where- comma = fmap (Text.intercalate ", " . fmap (coerce . depName) . toList) . nonEmpty+outputResult :: OutputTarget -> OutputFormat -> BuildOutput -> M ()+outputResult =+ writeOutput \ output -> \case+ OutputSpecialCommitMsg -> pure (commit output.changes)+ OutputSpecialGaPr -> githubActionsPr output.changes+ OutputSpecialGithubOutputKey -> pure "build" modifiedId :: DepResult -> ModifiedId modifiedId result =@@ -58,10 +48,27 @@ DepModified (DepAdded _) -> Just result.bounds _ -> Nothing -buildOutput :: ProjectResult -> BuildOutput-buildOutput result =- buildOutputFromLists modified ((.package) <$> unmodified) failed- where- modified = modifiedId <$> nubSortOn (.package) (added ++ updated)+depChanges :: ProjectResult -> DepChanges+depChanges result =+ DepChanges {+ modified = modifiedId <$> nubSortOn (.package) (added ++ updated),+ unmodified = (.package) <$> unmodified, failed = (.package) <$> ProjectResult.failures result+ }+ where DepResults {..} = ProjectResult.grouped result++depChangesNames :: DepChanges -> DepChangesNames+depChangesNames DepChanges {..} =+ DepChangesNames {+ modifiedNames = modifiedIdNames modified,+ unmodifiedNames = formatMutableDeps unmodified,+ failedNames = formatMutableDeps failed+ }++buildOutput :: DepChanges -> BuildOutput+buildOutput changes =+ BuildOutput {+ changes,+ names = depChangesNames changes+ }
lib/Hix/Managed/BuildOutput/CommitMsg.hs view
@@ -3,8 +3,10 @@ import qualified Data.Text as Text import Exon (exon) +import Hix.Data.PackageName (PackageName (..)) import qualified Hix.Managed.Data.BuildOutput-import Hix.Managed.Data.BuildOutput (BuildOutput, ModifiedId)+import Hix.Managed.Data.BuildOutput (DepChanges, ModifiedId)+import Hix.Managed.Data.Mutable (MutableDep (..), depName) import Hix.Pretty (showP) commitMessage :: Int -> Text -> Text@@ -17,16 +19,37 @@ candidateList :: [ModifiedId] -> [Text] candidateList = fmap \ c -> [exon|* #{showP c}|] -commitBody :: [ModifiedId] -> [Text]-commitBody candidates =- ["New versions:", ""] ++ candidateList candidates+commitBody :: [Text] -> [ModifiedId] -> [Text]+commitBody preamble candidates =+ preamble ++ space ++ ["New versions:", ""] ++ candidateList candidates+ where+ space = if null preamble then [] else [""] -commit :: BuildOutput -> Maybe (Text, [Text])-commit output =- output.modifiedNames <&> \ names ->- (commitMessage (length output.modified) names, commitBody output.modified)+formatMutableDepsNE :: NonEmpty MutableDep -> Text+formatMutableDepsNE =+ Text.intercalate ", " . fmap (coerce . depName) . toList -formatCommit :: BuildOutput -> Maybe Text+formatMutableDeps :: [MutableDep] -> Maybe Text+formatMutableDeps =+ fmap formatMutableDepsNE . nonEmpty++modifiedIdNamesNE :: NonEmpty ModifiedId -> Text+modifiedIdNamesNE modified =+ formatMutableDepsNE ((.package) <$> modified)++modifiedIdNames :: [ModifiedId] -> Maybe Text+modifiedIdNames modified =+ formatMutableDeps ((.package) <$> modified)++commitModified :: [Text] -> NonEmpty ModifiedId -> (Text, [Text])+commitModified preamble modified =+ (commitMessage (length modified) (modifiedIdNamesNE modified), commitBody preamble (toList modified))++commit :: DepChanges -> Maybe (Text, [Text])+commit changes =+ commitModified [] <$> nonEmpty changes.modified++formatCommit :: DepChanges -> Maybe Text formatCommit output = commit output <&> \ (msg, body) -> Text.intercalate "\n" ([msg, ""] ++ body)
lib/Hix/Managed/BuildOutput/GithubActionsPr.hs view
@@ -3,27 +3,13 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as Text import Exon (exon)-import Path (parseAbsFile)-import System.Environment (getEnv) import System.Posix (epochTime) -import Hix.Data.Error (Error (Client, Fatal)) import Hix.Data.Monad (M)-import Hix.Data.OutputTarget (OutputTarget) import Hix.Managed.BuildOutput.CommitMsg (commit)-import Hix.Managed.Data.BuildOutput (BuildOutput)-import Hix.Monad (note, throwM, tryIOMAs)+import Hix.Managed.Data.BuildOutput (DepChanges) import qualified Hix.OutputWriter-import Hix.OutputWriter (OutputWriter, fileWriter, outputWriterM)--envVarWriter :: M OutputWriter-envVarWriter = do- var <- tryIOMAs envVarError (getEnv "GITHUB_OUTPUT")- outFile <- note envVarError (parseAbsFile var)- pure (fileWriter writeError outFile)- where- envVarError = Client "The variable $GITHUB_OUTPUT does not contain a file path"- writeError err = throwM (Fatal [exon|Couldn't write to $GITHUB_OUTPUT: #{err.msg}|])+import Hix.OutputWriter (OutputWriter) formatOutput :: Text -> [Text] -> [Text] formatOutput key = \case@@ -50,9 +36,8 @@ ("delete-branch", ["true"]) ] -githubActionsPr :: BuildOutput -> OutputTarget -> M ()-githubActionsPr output target =- for_ (commit output) \ (msg, body) -> do+githubActionsPr :: DepChanges -> M (Maybe (Map Text [Text]))+githubActionsPr changes =+ for (commit changes) \ (msg, body) -> do date <- liftIO epochTime- writer <- outputWriterM envVarWriter target- writeOutputs writer (modifiedOutputs (show date) msg body)+ pure (modifiedOutputs (show date) msg body)
lib/Hix/Managed/Bump/App.hs view
@@ -1,18 +1,18 @@ module Hix.Managed.Bump.App where -import Hix.Data.Error (Error (Client)) import Hix.Data.Monad (M) import qualified Hix.Data.Options-import Hix.Data.Options (BumpOptions (BumpOptions))-import Hix.Json (jsonConfigE)+import Hix.Data.Options (BumpOptions, ManagedOptions)+import Hix.Managed.App (managedApp) import Hix.Managed.Bump.Optimize (bumpOptimizeMain)-import qualified Hix.Managed.Data.ProjectContextProto-import Hix.Managed.Handlers.Build.Test (chooseHandlers)-import Hix.Managed.ProjectContext (withProjectContext)+import Hix.Managed.Data.ProjectResult (ProjectResult)+import Hix.Managed.Handlers.Context (ContextKey (ContextManaged), jsonOrQueryProd)+import Hix.Managed.ProjectContext (processProjectResult) +bumpApp :: ManagedOptions -> M ProjectResult+bumpApp opts = do+ context <- jsonOrQueryProd ContextManaged opts.context+ managedApp opts context bumpOptimizeMain+ bumpCli :: BumpOptions -> M ()-bumpCli BumpOptions {common = opts} = do- context <- jsonConfigE Client opts.context- handlers <- liftIO $- chooseHandlers opts.stateFile context.envs context.buildOutputsPrefix opts.project.build opts.cabal opts.handlers- withProjectContext handlers opts.project context (bumpOptimizeMain handlers)+bumpCli opts = processProjectResult =<< bumpApp opts.common
lib/Hix/Managed/Bump/Candidates.hs view
@@ -10,6 +10,7 @@ import Hix.Managed.Data.Mutation (DepMutation (DepMutation)) import qualified Hix.Managed.Data.QueryDep import Hix.Managed.Data.QueryDep (QueryDep (QueryDep))+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers (..)) import qualified Hix.Managed.Handlers.Build import Hix.Managed.Handlers.Build (BuildHandlers) import Hix.Version (nextMajor)@@ -37,7 +38,7 @@ QueryDep -> M (Maybe (DepMutation Bump)) candidatesBump handlers QueryDep {package, current} = do- fmap mutation <$> handlers.latestVersion (depName package)+ fmap mutation <$> handlers.versions.latest (depName package) where mutation version = DepMutation {
lib/Hix/Managed/Bump/Optimize.hs view
@@ -2,15 +2,16 @@ import Exon (exon) -import Hix.Class.Map (nMap)+import Hix.Class.Map (nMap, nTransformMaybe, (!?))+import Hix.Data.Bounds (Ranges) import Hix.Data.Monad (M) import qualified Hix.Data.Overrides-import Hix.Data.VersionBounds (fromLower)+import Hix.Data.VersionBounds (fromLower, majorRange) import Hix.Managed.Build (processQuery) import Hix.Managed.Bump.Candidates (candidatesBump) import qualified Hix.Managed.Cabal.Data.SolverState import Hix.Managed.Cabal.Data.SolverState (SolverFlags (SolverFlags), solverState)-import Hix.Managed.Constraints (fromVersions, preferInstalled, preferVersions)+import Hix.Managed.Constraints (fromVersions, preferInstalled, preferRanges, preferVersions) import qualified Hix.Managed.Data.BuildConfig import Hix.Managed.Data.BuildConfig (BuildConfig) import Hix.Managed.Data.Bump (Bump (..))@@ -18,13 +19,12 @@ import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvDeps) import Hix.Managed.Data.Initial (Initial (Initial))-import Hix.Managed.Data.Mutable (MutableDep)+import Hix.Managed.Data.Mutable (MutableBounds, MutableDep, MutableVersions, depName) import qualified Hix.Managed.Data.MutableId import Hix.Managed.Data.MutableId (MutableId (MutableId)) import Hix.Managed.Data.Mutation (DepMutation (..)) import qualified Hix.Managed.Data.MutationState import Hix.Managed.Data.MutationState (MutationState)-import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext) import Hix.Managed.Data.ProjectResult (ProjectResult) import Hix.Managed.Data.Query (Query (Query))@@ -37,10 +37,21 @@ import Hix.Managed.Handlers.Build (BuildHandlers) import Hix.Managed.Handlers.Cabal (CabalHandlers, installedVersions) import Hix.Managed.Handlers.Mutation.Bump (handlersBump)-import Hix.Managed.Process (processProject)+import Hix.Managed.Process (processProjectSimple) import Hix.Managed.Report (describeIterations) import Hix.Managed.StageResult (stageResult) +-- TODO this is still janky because it uses reified bound changes (@initialBounds@), which means a loss of precision.+-- If the user specified <=1.2.3, we end up with <1.2.3.+-- Better to drag the actual ranges through from the start.+stateBoundsForNonInstalled :: MutableBounds -> MutableVersions -> Ranges+stateBoundsForNonInstalled initialBounds =+ nTransformMaybe \ package -> \case+ Nothing -> do+ bounds <- initialBounds !? package+ pure (depName package, majorRange bounds)+ Just _ -> Nothing+ -- | Solver params for Bump consist of, in decreasing order of precedence: -- -- - User-specified bounds (added by the constructor 'solverState').@@ -51,25 +62,40 @@ -- -- - Installed versions from the package db, used as lower bounds. --+-- - Initial bounds from the state (and potentially from the user config if @--read-upper-bounds@ was used) for packages+-- without an installed version.+-- This applies to dependencies on local packages that have not been published to central Hackage (but have versions+-- available on a custom Hackage) and pulled into the project's nixpkgs, and which are targets of a separate managed+-- env (which means that they are not included in the env's GHC package set as local derivations like targets are).+-- If this was the first run, so that no previously determined overrides are present in the state, then these deps+-- would not have installed versions that could be preferred for stability.+-- While the user could specify solver bounds to mitigate this, it's likely that an existing regular bound will be the+-- safest bet.+-- Otherwise the solver would choose the latest version from the custom Hackage, which may mean breakage.+-- -- - The preference for using the installed version for mutable deps, which is a fallback for packages without overrides -- (since their chosen versions are installed). bumpSolverParams :: EnvDeps -> CabalHandlers -> Initial MutationState ->+ MutableBounds -> EnvConstraints-bumpSolverParams deps cabal (Initial state) =+bumpSolverParams deps cabal (Initial state) initialBounds = preferVersions (nMap (.version) state.overrides) <>- fromVersions fromLower (installedVersions cabal deps.mutable) <>+ fromVersions fromLower installed <>+ preferRanges (stateBoundsForNonInstalled initialBounds installed) <> preferInstalled deps.mutable+ where+ installed = installedVersions cabal deps.mutable -success :: Map MutableDep BuildSuccess -> Natural -> Text+success :: Map MutableDep BuildSuccess -> Word -> Text success _ iterations = [exon|Found working latest versions for all deps after #{iter}.|] where iter = describeIterations iterations -failure :: Natural -> Text+failure :: Word -> Text failure iterations = [exon|Couldn't find working latest versions for some deps after #{describeIterations iterations}.|] @@ -78,11 +104,11 @@ BuildConfig -> StageContext -> M StageResult-bumpBuild handlers conf stage@StageContext {env, builder, state} = do+bumpBuild handlers conf stage@StageContext {env, builder, state, initialBounds} = do result <- processQuery (candidatesBump handlers) handlersBump conf stage ext pure (stageResult success failure result) where- ext = solverState env.solverBounds env.deps (bumpSolverParams env.deps builder.cabal state) flags+ ext = solverState env.solverBounds env.deps (bumpSolverParams env.deps builder.cabal state initialBounds) flags flags = SolverFlags {allowNewer = True, forceRevisions = False} bumpBuildStage ::@@ -118,9 +144,5 @@ | otherwise = bumpBuildStage handlers conf -bumpOptimizeMain ::- BuildHandlers ->- ProjectContext ->- M ProjectResult-bumpOptimizeMain handlers project =- processProject handlers project (void (bumpStages handlers project.build))+bumpOptimizeMain :: BuildHandlers -> ProjectContext -> M ProjectResult+bumpOptimizeMain = processProjectSimple bumpStages
lib/Hix/Managed/Cabal/Changes.hs view
@@ -56,12 +56,14 @@ data SolverChanges = SolverChanges { versions :: Versions,- overrides :: [PackageId],- projectDeps :: Versions+ overrides :: [PackageId]+ -- ,+ -- projectDeps :: Versions } deriving stock (Eq, Show, Generic) instance Pretty SolverChanges where pretty SolverChanges {..} =- hang "overrides:" 2 (prettyL overrides) $+$- hang "projectDeps:" 2 (pretty projectDeps)+ hang "overrides:" 2 (prettyL overrides)+ -- $+$+ -- hang "projectDeps:" 2 (pretty projectDeps)
lib/Hix/Managed/Cabal/Config.hs view
@@ -1,11 +1,41 @@ module Hix.Managed.Cabal.Config where +import Control.Exception (displayException)+import Control.Monad (foldM)+import qualified Data.ByteString.Lazy as LByteString+import qualified Data.Map.Strict as Map+import Data.Map.Strict ((!?)) import qualified Data.Set as Set+import qualified Data.Text as Text+import Exon (exon)+import qualified Path+import Path (SomeBase (..), toFilePath)+import qualified Path.IO as Path+import System.Environment (lookupEnv)+import System.Exit (ExitCode (..))+import System.IO.Error (tryIOError)+import qualified System.Process.Typed as Process +import qualified Hix.Color as Color+import Hix.Data.Monad (M)+import Hix.Data.Options (CabalOptions (..)) import qualified Hix.Data.PackageId import Hix.Data.PackageId (PackageId) import Hix.Data.PackageName (PackageName)+import qualified Hix.Log as Log+import Hix.Managed.Cabal.Data.Config (CabalConfig (..))+import Hix.Managed.Cabal.Data.ContextHackageRepo (+ ContextHackageLocation (..),+ ContextHackagePassword (..),+ ContextHackageRepo (..),+ )+import qualified Hix.Managed.Cabal.Data.HackageLocation as HackageLocation+import Hix.Managed.Cabal.Data.HackageLocation (HackageLocation (auth), HackagePassword (HackagePassword), HackageUser)+import Hix.Managed.Cabal.Data.HackageRepo (HackageName, HackageRepo (..), centralName)+import Hix.Managed.Cabal.HackageLocation (parseLocation)+import Hix.Managed.Cabal.HackageRepo (hackageDescription) import Hix.Managed.Data.Mutable (MutableDep, depName)+import Hix.Monad (appContextVerbose, clientError, eitherClient, noteClient, tryIOM) nonReinstallableNames :: Set PackageName nonReinstallableNames =@@ -33,3 +63,101 @@ isNonReinstallableDep :: MutableDep -> Bool isNonReinstallableDep = isNonReinstallable . depName++resolvePasswordEnvVar :: Text -> M HackagePassword+resolvePasswordEnvVar name =+ lookup >>= \case+ [] -> clientError (message "is empty")+ value -> pure (HackagePassword (toText value))+ where+ lookup = noteClient (message "does not exist") =<< tryIOM (lookupEnv (toString name))++ message problem = [exon|The specified environment variable #{Color.cyan name} #{problem}|]++resolvePasswordExec :: Text -> M HackagePassword+resolvePasswordExec spec =+ noteClient (message "is not a valid path") (Path.parseSomeFile (toString spec)) >>= \case+ Abs path -> checkPath path+ Rel rel ->+ liftIO (tryIOError (Path.findExecutable rel)) >>= \case+ Right (Just path) -> checkPath path+ _ -> failure [exon|could not be found in #{Color.cyan ("$PATH" :: Text)}|]+ where+ checkPath path =+ liftIO (tryIOError (Path.getPermissions path)) >>= \case+ Right perms | Path.executable perms -> exec path+ | otherwise -> failure "is not an executable file"+ Left _ -> failure "could not be read"++ exec path =+ liftIO (tryIOError (Process.readProcessStdout (Process.proc (toFilePath path) []))) >>= \case+ Right (ExitSuccess, output)+ | LByteString.null output -> failure "printed nothing on stdout"+ | [pw] <- Text.lines (decodeUtf8 output) -> pure (HackagePassword pw)+ | otherwise -> failure "printed multiple lines"+ Right (ExitFailure code, _) -> failure [exon|exited with code #{show @_ @Int code}|]+ Left err -> do+ Log.debug [exon|Subprocess error: #{toText (displayException err)}|]+ failure [exon|caused an exception (pass #{Color.cyan @Text "--debug"} to see it)|]++ failure = clientError . message++ message problem = [exon|The specified executable #{Color.path spec} #{problem}|]++resolvePassword :: ContextHackagePassword -> M HackagePassword+resolvePassword =+ appContextVerbose ctx . \case+ PasswordUnobscured pw -> pure pw+ PasswordPlain pw -> pure pw+ PasswordEnvVar name -> resolvePasswordEnvVar name+ PasswordExec path -> resolvePasswordExec path+ where+ ctx = "resolving the password"++withAuth ::+ HackageLocation ->+ Maybe HackageUser ->+ Maybe ContextHackagePassword ->+ M HackageLocation+withAuth location = \cases+ (Just user) Nothing ->+ onlyOne [exon|user (##{user})|] "password"+ Nothing (Just _) ->+ onlyOne "password" "user"+ Nothing Nothing ->+ pure location+ (Just user) (Just passwordSpec) -> do+ password <- resolvePassword passwordSpec+ pure location {auth = Just (user, password)}+ where+ onlyOne present absent = clientError [exon|Specified a #{present}, but no #{absent}|]++validateContextRepo :: ContextHackageRepo -> M HackageRepo+validateContextRepo ContextHackageRepo {location = location0, ..} = do+ appContextVerbose [exon|validating the Hackage config #{Color.yellow name}|] do+ location1 <- for location0 \ (ContextHackageLocation spec) ->+ eitherClient (first toText (parseLocation (toString spec)))+ location <- withAuth (fromMaybe HackageLocation.central location1) user password+ pure HackageRepo {+ name,+ description = fromMaybe (hackageDescription location) description,+ enable = fromMaybe True enable,+ location,+ solver = fromMaybe True solver,+ publish = fromMaybe False publish,+ ..+ }++-- | Merge Hackage repos from different sources, prioritizing CLI arguments over flake config.+cabalConfig :: Map HackageName ContextHackageRepo -> CabalOptions -> M CabalConfig+cabalConfig contextRepos CabalOptions {hackage = cliOverrides} = do+ amended <- foldM applyOverride contextRepos cliOverrides+ valid <- traverse validateContextRepo amended+ pure CabalConfig {+ hackageMain = valid !? centralName,+ hackageExtra = Map.elems (Map.delete centralName valid)+ }+ where+ applyOverride repos (name :: HackageName, override) = do+ repo <- noteClient [exon|Invalid Hackage repo name: ##{name}|] (repos !? name)+ pure (Map.insert name (override repo) repos)
+ lib/Hix/Managed/Cabal/ContextHackageRepo.hs view
@@ -0,0 +1,75 @@+module Hix.Managed.Cabal.ContextHackageRepo where++import Control.Lens (Lens', (.~))+import Data.Char (toLower)+import Data.Map.Strict ((!?))+import qualified Data.Text as Text+import Distribution.Parsec (simpleParsec)+import Exon (exon)+import Prelude hiding (bool)++import Hix.CabalParsec (unsafeParsec)+import qualified Hix.Color as Color+import Hix.Managed.Cabal.Data.ContextHackageRepo (+ ContextHackageLocation (..),+ ContextHackagePassword (..),+ ContextHackageRepo (..),+ contextHackageRepo,+ )+import Hix.Managed.Cabal.Data.HackageLocation (HackagePassword (..), HackageUser (..))+import Hix.Managed.Cabal.Data.HackageRepo (HackageName, centralName)++update' ::+ Bool ->+ Lens' ContextHackageRepo (Maybe a) ->+ (String -> Maybe a) ->+ String ->+ String ->+ Either String (ContextHackageRepo -> ContextHackageRepo)+update' redact lens parse field spec = do+ value <- maybeToRight [exon|Invalid value for Hackage field #{toString (Color.blue field)}: #{display}|] (parse spec)+ pure (lens .~ Just value)+ where+ display | redact = "<redacted>"+ | otherwise = spec++update ::+ Lens' ContextHackageRepo (Maybe a) ->+ (String -> Maybe a) ->+ String ->+ String ->+ Either String (ContextHackageRepo -> ContextHackageRepo)+update = update' False++text :: (Text -> a) -> String -> Maybe a+text cons = Just . cons . toText++bool :: String -> Maybe Bool+bool value =+ case toLower <$> value of+ "true" -> Just True+ "false" -> Just False+ _ -> Nothing++fields :: Map String (String -> String -> Either String (ContextHackageRepo -> ContextHackageRepo))+fields =+ [+ ("enable", update #enable bool),+ ("location", update #location (text ContextHackageLocation)),+ ("user", update #user (text HackageUser)),+ ("password", update' True #password (text (PasswordPlain . HackagePassword))),+ ("secure", update #secure bool),+ ("keys", update #keys (nonEmpty . Text.splitOn "," . toText)),+ ("indexState", update #indexState simpleParsec),+ ("solver", update #solver bool),+ ("publish", update #publish bool)+ ]++fieldUpdater :: String -> String -> Either String (ContextHackageRepo -> ContextHackageRepo)+fieldUpdater field value = do+ f <- maybeToRight [exon|Invalid Hackage repo field: #{field}|] (fields !? field)+ f field value++unsafeCentralHackageContextFixed :: (HackageName, ContextHackageRepo)+unsafeCentralHackageContextFixed =+ (centralName, (contextHackageRepo centralName) {indexState = Just (unsafeParsec ("2025-01-01T00:00:00Z" :: String))})
lib/Hix/Managed/Cabal/Data/Config.hs view
@@ -1,24 +1,26 @@ module Hix.Managed.Cabal.Data.Config where import Data.Aeson (FromJSON (parseJSON))-import Distribution.Client.IndexUtils.Timestamp (Timestamp)+import qualified Data.List.NonEmpty as NonEmpty+import Distribution.Pretty (Pretty (pretty)) import Distribution.Verbosity (Verbosity, verbose) import Path (Abs, Dir, Path)+import qualified Text.PrettyPrint as PrettyPrint+import Text.PrettyPrint (hang, text, (<+>)) +import Hix.Data.Monad (M)+import Hix.Managed.Cabal.Data.HackageLocation ()+import Hix.Managed.Cabal.Data.HackageRepo (HackageRepo (..)) import Hix.Managed.Cabal.Data.Packages (GhcPackages)--newtype HackageRepoName =- HackageRepoName Text- deriving stock (Eq, Show, Generic)- deriving newtype (IsString, Ord)--instance Default HackageRepoName where- def = "hackage.haskell.org"+import Hix.Managed.Cabal.HackageRepo (centralHackage, unsafeCentralHackageFixed)+import Hix.Maybe (fromMaybeA)+import Hix.Monad (fatalError)+import Hix.Pretty (HPretty (..), fieldOr, fieldWith, prettyMap, prettyV) newtype GhcPath = GhcPath (Path Abs Dir) deriving stock (Eq, Show, Generic)- deriving newtype (FromJSON)+ deriving newtype (FromJSON, HPretty) data GhcDb = GhcDbSystem (Maybe GhcPath)@@ -29,23 +31,77 @@ instance FromJSON GhcDb where parseJSON = fmap GhcDbSystem . parseJSON -newtype HackageIndexState =- HackageIndexState Timestamp- deriving stock (Eq, Show, Generic)+instance Pretty GhcDb where+ pretty = \case+ GhcDbSystem (Just path) -> hpretty path+ GhcDbSystem Nothing -> "no GHC"+ GhcDbSynthetic pkgs -> hpretty pkgs +data HackagePurpose =+ ForVersions+ |+ ForSolver+ |+ ForPublish+ deriving stock (Eq, Show)++describePurpose :: IsString a => HackagePurpose -> a+describePurpose = \case+ ForVersions -> "fetching versions"+ ForSolver -> "resolving dependencies"+ ForPublish -> "publishing packages"+ data CabalConfig = CabalConfig {- indexState :: Maybe HackageIndexState+ hackageMain :: Maybe HackageRepo,+ hackageExtra :: [HackageRepo] } deriving stock (Eq, Show, Generic) +instance Pretty CabalConfig where+ pretty CabalConfig {..} =+ prettyMap "cabal" [+ fieldOr "main" "default" hackageMain,+ fieldWith "extra" (nonEmpty hackageExtra) prettyV+ ]+ instance Default CabalConfig where- def =- CabalConfig {indexState = Nothing}+ def = CabalConfig {hackageMain = Nothing, hackageExtra = []} +-- | This forces at least the default repo to be available.+-- If this is not desired, the repo should be included with the 'enable' flag unset.+allHackages :: CabalConfig -> NonEmpty HackageRepo+allHackages CabalConfig {..} =+ fromMaybe centralHackage hackageMain :| hackageExtra++hackagesFor :: HackagePurpose -> CabalConfig -> M (NonEmpty HackageRepo)+hackagesFor purpose config =+ fromMaybeA noMatches $+ nonEmpty $+ NonEmpty.filter match repos+ where+ match repo =+ repo.enable && case purpose of+ ForVersions -> True+ ForSolver -> repo.solver+ ForPublish -> repo.publish++ noMatches =+ fatalError $ show $+ hang (text "None of the configured Hackage repos are allowed for" <+> text desc PrettyPrint.<> text ":") 2 $+ prettyV repos++ repos = allHackages config++ desc = describePurpose purpose++withHackageFixed :: CabalConfig -> CabalConfig+withHackageFixed config =+ config {hackageMain = config.hackageMain <|> Just unsafeCentralHackageFixed}+ data SolveConfig = SolveConfig {- hackageRepoName :: HackageRepoName,+ hackageRepos :: NonEmpty HackageRepo, verbosity :: Verbosity, ghc :: Maybe GhcPath, allowBoot :: Bool,@@ -56,7 +112,7 @@ instance Default SolveConfig where def = SolveConfig {- hackageRepoName = def,+ hackageRepos = [centralHackage], verbosity = verbose, ghc = Nothing, allowBoot = False,
+ lib/Hix/Managed/Cabal/Data/ContextHackageRepo.hs view
@@ -0,0 +1,133 @@+module Hix.Managed.Cabal.Data.ContextHackageRepo where++import Data.Aeson (FromJSON (parseJSON), withObject, withText, (.:))+import Distribution.Pretty (Pretty (pretty))+import Exon (exon)+import Text.PrettyPrint++import Hix.Class.EncodeNix (EncodeNix (encodeNix))+import Hix.Data.NixExpr (Expr (..), ExprAttr (..))+import Hix.Managed.Cabal.Data.HackageLocation (HackagePassword (HackagePassword), HackageUser)+import Hix.Managed.Cabal.Data.HackageRepo (HackageDescription, HackageIndexState, HackageName)+import Hix.NixExpr (mkAttrs, single, singleOpt)+import Hix.Pretty (field, prettyFieldsV, prettyText)++newtype ContextHackageLocation =+ ContextHackageLocation Text+ deriving stock (Eq, Show)+ deriving newtype (IsString, Ord, FromJSON, EncodeNix)++instance Pretty ContextHackageLocation where+ pretty = prettyText . coerce++data ContextHackagePassword =+ -- | Password was intended to be printed, most likely in a test.+ PasswordUnobscured HackagePassword+ |+ PasswordPlain HackagePassword+ |+ PasswordEnvVar Text+ |+ PasswordExec Text+ deriving stock (Eq, Show)++instance Pretty ContextHackagePassword where+ pretty = \case+ PasswordUnobscured (HackagePassword pw) -> prettyText pw+ PasswordPlain _ -> "<password>"+ PasswordEnvVar var -> prettyText var <+> brackets (text "env-var")+ PasswordExec exe -> prettyText exe <+> brackets (text "exec")++instance EncodeNix ContextHackagePassword where+ encodeNix = \case+ PasswordUnobscured (HackagePassword pw) -> ExprString pw+ PasswordPlain _ -> ExprString "<password>"+ PasswordEnvVar var -> structured "env-var" var+ PasswordExec exe -> structured "exec" exe+ where+ structured t value =+ ExprAttrs [+ ExprAttr "type" (ExprString t),+ ExprAttr {name = "value", value = ExprString value}+ ]++instance FromJSON ContextHackagePassword where+ parseJSON v =+ withText "ContextHackagePassword" plain v+ <|>+ withObject "ContextHackagePassword" typed v+ where+ typed o = do+ value <- o .: "value"+ o .: "type" >>= \case+ ("plain" :: Text) -> plain value+ "env-var" -> pure (PasswordEnvVar value)+ "exec" -> pure (PasswordExec value)+ t -> fail [exon|Invalid value for Hackage password type: ##{t}|]++ plain = pure . PasswordPlain . HackagePassword++data ContextHackageRepo =+ ContextHackageRepo {+ name :: HackageName,+ description :: Maybe HackageDescription,+ enable :: Maybe Bool,+ location :: Maybe ContextHackageLocation,+ user :: Maybe HackageUser,+ password :: Maybe ContextHackagePassword,+ secure :: Maybe Bool,+ keys :: Maybe (NonEmpty Text),+ indexState :: Maybe HackageIndexState,+ solver :: Maybe Bool,+ publish :: Maybe Bool+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (FromJSON)++instance Pretty ContextHackageRepo where+ pretty ContextHackageRepo {..} =+ prettyFieldsV [+ field "name" name,+ field "description" description,+ field "enable" enable,+ field "location" location,+ field "user" user,+ field "password" password,+ field "secure" secure,+ field "keys" keys,+ field "indexState" indexState,+ field "solver" solver,+ field "publish" publish+ ]++instance EncodeNix ContextHackageRepo where+ encodeNix =+ ExprAttrs . mkAttrs [+ single "name" (.name),+ singleOpt "description" (.description),+ singleOpt "enable" (.enable),+ singleOpt "location" (.location),+ singleOpt "user" (.user),+ singleOpt "password" (.password),+ singleOpt "secure" (.secure),+ singleOpt "keys" (.keys),+ singleOpt "indexState" (.indexState),+ singleOpt "solver" (.solver),+ singleOpt "publish" (.publish)+ ]++contextHackageRepo :: HackageName -> ContextHackageRepo+contextHackageRepo name =+ ContextHackageRepo {+ name,+ description = Nothing,+ enable = Nothing,+ location = Nothing,+ user = Nothing,+ password = Nothing,+ secure = Nothing,+ keys = Nothing,+ indexState = Nothing,+ solver = Nothing,+ publish = Nothing+ }
+ lib/Hix/Managed/Cabal/Data/HackageLocation.hs view
@@ -0,0 +1,99 @@+module Hix.Managed.Cabal.Data.HackageLocation where++import Data.Aeson (FromJSON)+import Distribution.Pretty (Pretty (pretty))+import Exon (exon)++import Hix.Class.EncodeNix (EncodeNix)+import Hix.Pretty (hpretty, prettyNt)++newtype HackageHost =+ HackageHost Text+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Ord, FromJSON)++instance Pretty HackageHost where+ pretty = prettyNt++data HackageTls =+ TlsOn+ |+ TlsOff+ deriving stock (Eq, Show)++instance Pretty HackageTls where+ pretty = \case+ TlsOn -> "on"+ TlsOff -> "off"++hackageTls :: Bool -> HackageTls+hackageTls = \case+ True -> TlsOn+ False -> TlsOff++hackageTlsBool :: HackageTls -> Bool+hackageTlsBool = \case+ TlsOn -> True+ TlsOff -> False++hackageTlsScheme :: IsString a => HackageTls -> a+hackageTlsScheme = \case+ TlsOn -> "https"+ TlsOff -> "http"++newtype HackagePort =+ HackagePort Word16+ deriving stock (Eq, Show)+ deriving newtype (Num, Real, Enum, Integral, Ord)++instance Pretty HackagePort where+ pretty (HackagePort p) = hpretty p++parseHackagePort :: String -> Maybe HackagePort+parseHackagePort = fmap HackagePort . readMaybe++newtype HackageUser =+ HackageUser Text+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Ord, FromJSON, EncodeNix)++instance Pretty HackageUser where+ pretty = prettyNt++newtype HackagePassword =+ HackagePassword Text+ deriving stock (Eq)+ deriving newtype (IsString, Ord, FromJSON)++instance Show HackagePassword where+ showsPrec d _ = showParen (d > 10) (showString "HackagePassword <password>")++instance Pretty HackagePassword where+ pretty _ = "<password>"++data HackageLocation =+ HackageLocation {+ host :: HackageHost,+ tls :: HackageTls,+ port :: Maybe HackagePort,+ auth :: Maybe (HackageUser, HackagePassword)+ }+ deriving stock (Eq, Show, Generic)++hackageLocation :: HackageHost -> HackageTls -> HackageLocation+hackageLocation host tls =+ HackageLocation {+ host,+ tls,+ port = Nothing,+ auth = Nothing+ }++central :: HackageLocation+central = hackageLocation "hackage.haskell.org" TlsOn++instance Pretty HackageLocation where+ pretty HackageLocation {..} =+ [exon|#{hackageTlsScheme tls}://#{hpretty host}#{foldMap renderPort port}|]+ where+ renderPort p = [exon|:#{pretty p}|]
+ lib/Hix/Managed/Cabal/Data/HackageRepo.hs view
@@ -0,0 +1,78 @@+module Hix.Managed.Cabal.Data.HackageRepo where++import Data.Aeson (FromJSON (parseJSON), FromJSONKey)+import Distribution.Client.IndexUtils.Timestamp (Timestamp)+import Distribution.Parsec (Parsec (parsec))+import Distribution.Pretty (Pretty (pretty))+import Exon (exon)+import Text.PrettyPrint (brackets, text, (<+>))++import Hix.Class.EncodeNix (EncodeNix (encodeNix))+import Hix.Data.Json (jsonParsec)+import Hix.Data.NixExpr (Expr (ExprString))+import Hix.Managed.Cabal.Data.HackageLocation (HackageLocation)+import Hix.Pretty (prettyL1, prettyText, showP)++newtype HackageName =+ HackageName Text+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Ord, FromJSON, FromJSONKey, EncodeNix)++instance Pretty HackageName where+ pretty = prettyText . coerce++centralName :: HackageName+centralName = "hackage.haskell.org"++newtype HackageDescription =+ HackageDescription Text+ deriving stock (Eq, Show)+ deriving newtype (IsString, Ord, FromJSON, EncodeNix)++instance Pretty HackageDescription where+ pretty = prettyText . coerce++newtype HackageIndexState =+ HackageIndexState Timestamp+ deriving stock (Eq, Show, Generic)++instance Parsec HackageIndexState where+ parsec = HackageIndexState <$> parsec++instance FromJSON HackageIndexState where+ parseJSON = fmap jsonParsec . parseJSON++instance Pretty HackageIndexState where+ pretty (HackageIndexState ts) = pretty ts++instance EncodeNix HackageIndexState where+ encodeNix (HackageIndexState ts) = ExprString (showP ts)++data HackageRepo =+ HackageRepo {+ name :: HackageName,+ description :: HackageDescription,+ location :: HackageLocation,+ enable :: Bool,+ secure :: Maybe Bool,+ keys :: Maybe (NonEmpty Text),+ solver :: Bool,+ publish :: Bool,+ indexState :: Maybe HackageIndexState+ }+ deriving stock (Eq, Show, Generic)++instance Pretty HackageRepo where+ pretty HackageRepo {..} =+ [exon|#{pretty name}:#{pretty location}|] <+> flags+ where+ flags = foldMap (brackets . prettyL1) (nonEmpty (catMaybes flagValues))++ flagValues = [+ flag "disable" (not enable),+ flag "secure" (fromMaybe False secure),+ flag "solver" solver,+ flag "publish" publish+ ]++ flag desc state = if state then Just (text desc) else Nothing
+ lib/Hix/Managed/Cabal/Data/InstalledOverrides.hs view
@@ -0,0 +1,11 @@+module Hix.Managed.Cabal.Data.InstalledOverrides where++import Hix.Data.PackageId (PackageId)++-- | Package IDs that are present in the 'GhcDb' provided to the Cabal resources initialization, but that should not be+-- treated as installed because they had to be added as overrides when resolving the package set.+-- This is necessary to avoid having to resolve these overrides again when building mutations.+newtype InstalledOverrides =+ InstalledOverrides { ids :: Set PackageId }+ deriving stock (Eq, Show)+ deriving newtype (Semigroup, Monoid)
lib/Hix/Managed/Cabal/Data/Packages.hs view
@@ -1,14 +1,16 @@ module Hix.Managed.Cabal.Data.Packages where +import Distribution.Pretty (Pretty (..)) import GHC.Exts (IsList) import Hix.Data.PackageId (PackageId) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages)+import Hix.Pretty (HPretty (..), field, prettyMap) newtype InstalledPackages = InstalledPackages [(PackageId, [PackageId])] deriving stock (Eq, Show, Generic)- deriving newtype (IsList, Semigroup, Monoid)+ deriving newtype (IsList, Semigroup, Monoid, HPretty) -- | Mock data for package indexes for the solver. --@@ -21,3 +23,10 @@ available :: SourcePackages } deriving stock (Eq, Show, Generic)++instance Pretty GhcPackages where+ pretty GhcPackages {..} =+ prettyMap "Mock packages" [+ field "installed" (hpretty installed),+ field "available" (hpretty available)+ ]
+ lib/Hix/Managed/Cabal/Data/Revision.hs view
@@ -0,0 +1,23 @@+module Hix.Managed.Cabal.Data.Revision where++import Data.Aeson (FromJSON)+import Data.Time (UTCTime)++import Hix.Managed.Cabal.Data.HackageRepo (HackageDescription)++data Revision =+ Revision {+ number :: Word,+ sha256 :: Text,+ time :: UTCTime,+ user :: Text+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (FromJSON)++data RevisionPublished =+ RevisionPublished {+ revision :: Revision,+ destination :: HackageDescription+ }+ deriving stock (Eq, Show)
lib/Hix/Managed/Cabal/Data/SolverState.hs view
@@ -13,7 +13,6 @@ import Hix.Class.Map (nGenWith) import Hix.Data.Bounds (Ranges)-import Hix.Data.PackageName (LocalPackage (LocalPackage)) import Hix.Managed.Constraints (explicitBounds, noBounds) import Hix.Managed.Data.Constraints (EnvConstraints) import qualified Hix.Managed.Data.EnvContext@@ -56,11 +55,6 @@ instance HasField "flags" SolverState SolverFlags where getField (UnsafeSolverState _ p) = p --- TODO What's the point of this now that there's no @local@ flag in the constraints anymore?-localDepConstraints :: Set LocalPackage -> EnvConstraints-localDepConstraints =- nGenWith \ (LocalPackage package) -> (package, noBounds)- mutableDepConstraints :: Set MutableDep -> EnvConstraints mutableDepConstraints = nGenWith \ package -> (depName package, noBounds)@@ -77,7 +71,6 @@ constraints = modeConstraints <> explicitBounds user <>- localDepConstraints deps.local <> mutableDepConstraints deps.mutable updateSolverState :: (EnvConstraints -> EnvConstraints) -> SolverState -> SolverState
+ lib/Hix/Managed/Cabal/HackageLocation.hs view
@@ -0,0 +1,99 @@+module Hix.Managed.Cabal.HackageLocation where++import Data.List (dropWhileEnd, isInfixOf)+import Exon (Exon, exon)+import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)++import Hix.Managed.Cabal.Data.HackageLocation (+ HackageHost (..),+ HackageLocation (..),+ HackagePort (..),+ HackageTls (..),+ hackageTls,+ hackageTlsScheme,+ parseHackagePort,+ )+import Hix.Pretty (showP)++renderScheme ::+ Exon a =>+ IsString a =>+ HackageLocation ->+ a+renderScheme HackageLocation {tls} = [exon|#{hackageTlsScheme tls}:|]++renderPort ::+ Exon a =>+ IsString a =>+ HackageLocation ->+ a+renderPort HackageLocation {port}+ | Just p <- port = [exon|:##{showP p}|]+ | otherwise = ""++-- | No auth, omit default port.+-- TODO add a test with a hackage server that requires basic auth for everything (e.g. when querying with+-- nix-prefetch-url)+renderMinimal ::+ Exon a =>+ IsString a =>+ HackageLocation ->+ a+renderMinimal loc@HackageLocation {..} =+ [exon|#{renderScheme loc}//##{coerce @_ @Text host}#{renderPort loc}|]++hackageLocationUri :: HackageLocation -> URI+hackageLocationUri loc@HackageLocation {..} =+ URI {+ uriScheme = renderScheme loc,+ uriAuthority = Just URIAuth {+ uriPort = renderPort loc,+ uriRegName = toString (coerce @HackageHost @Text host),+ uriUserInfo = ""+ },+ uriPath = "/",+ uriQuery = "",+ uriFragment = ""+ }++hackagePort :: HackageLocation -> HackagePort+hackagePort HackageLocation {tls, port}+ | Just p <- port = p+ | TlsOn <- tls = 443+ | otherwise = 80++locationFromUri :: String -> URIAuth -> Either String HackageLocation+locationFromUri scheme URIAuth {..}+ | let stripped = dropWhileEnd ('@' ==) uriUserInfo+ , not (null stripped)+ = Left "User fragment not supported - please use the explicit option 'user'"+ | otherwise+ = do+ port <- if null uriPort+ then pure Nothing+ else maybeToRight [exon|Invalid port segment '#{uriPort}'|] (Just <$> parseHackagePort (drop 1 uriPort))+ pure HackageLocation {+ host = fromString uriRegName,+ tls = hackageTls (scheme == "https:"),+ port,+ auth = Nothing+ }++noSchemeMessage :: String -> String+noSchemeMessage spec =+ [exon|The Hackage URL '#{spec}' is missing a scheme, like 'https://'|]++parseLocation :: String -> Either String HackageLocation+parseLocation spec = do+ (uri, uriAuth) <- maybeToRight uriError do+ uri <- parseAbsoluteURI spec+ uriAuth <- uriAuthority uri+ pure (uri, uriAuth)+ first badLocation (locationFromUri (uriScheme uri) uriAuth)+ where+ uriError | hasScheme = [exon|Parse error in Hackage URL: #{spec}|]+ | otherwise = noSchemeMessage spec++ hasScheme = isInfixOf "://" spec++ badLocation err = [exon|Bad hackage repo location: #{err}|]
+ lib/Hix/Managed/Cabal/HackageRepo.hs view
@@ -0,0 +1,39 @@+module Hix.Managed.Cabal.HackageRepo where++import Exon (exon)++import Hix.CabalParsec (unsafeParsec)+import qualified Hix.Managed.Cabal.Data.HackageLocation as HackageLocation+import Hix.Managed.Cabal.Data.HackageLocation (HackageLocation (HackageLocation, host), central)+import Hix.Managed.Cabal.Data.HackageRepo (HackageDescription (..), HackageName, HackageRepo (..), centralName)++hackageDescription :: HackageLocation -> HackageDescription+hackageDescription HackageLocation {host} =+ if host == central.host+ then "central Hackage"+ else HackageDescription [exon|Hackage at ##{host}|]++hackageRepo :: HackageName -> HackageLocation -> HackageRepo+hackageRepo name location =+ HackageRepo {+ name,+ description = hackageDescription location,+ location,+ enable = True,+ secure = Just True,+ keys = Nothing,+ solver = True,+ publish = False,+ indexState = Nothing+ }++centralHackage :: HackageRepo+centralHackage =+ (hackageRepo centralName HackageLocation.central) {+ description = "central Hackage",+ publish = True+ }++unsafeCentralHackageFixed :: HackageRepo+unsafeCentralHackageFixed =+ centralHackage {indexState = Just (unsafeParsec ("2025-01-01T00:00:00Z" :: String))}
lib/Hix/Managed/Cabal/Init.hs view
@@ -6,19 +6,21 @@ import Distribution.Client.GlobalFlags (GlobalFlags (..), defaultGlobalFlags) import Distribution.Client.NixStyleOptions (NixStyleFlags (..), defaultNixStyleFlags) import Distribution.Client.ProjectFlags (flagIgnoreProject)-import Distribution.Client.Types (RemoteRepo (..))-import Distribution.Parsec (eitherParsec)+import Distribution.Client.Types (RemoteRepo (..), RepoName (RepoName)) import Distribution.Simple.Program (defaultProgramDb) import Distribution.Simple.Setup (ConfigFlags (..), defaultConfigFlags, maybeToFlag, toFlag) import Distribution.Utils.NubList (toNubList) import Exon (exon) import Path (reldir, relfile, toFilePath, (</>)) -import Hix.Data.Error (Error (Fatal))+import Hix.Data.Error (ErrorMessage (Fatal)) import qualified Hix.Managed.Cabal.Data.Config-import Hix.Managed.Cabal.Data.Config (GhcPath (GhcPath), HackageRepoName, SolveConfig)+import Hix.Managed.Cabal.Data.Config (GhcPath (GhcPath), SolveConfig)+import Hix.Managed.Cabal.Data.HackageLocation (HackageLocation (..), hackageTlsBool)+import Hix.Managed.Cabal.Data.HackageRepo (HackageName (..), HackageRepo (..))+import Hix.Managed.Cabal.HackageLocation (hackageLocationUri) import Hix.Managed.Cabal.Repo (ensureHackageIndex)-import Hix.Monad (M, throwM, tryIOMWith)+import Hix.Monad (M, tryIOMWith) #if MIN_VERSION_Cabal(3,14,0) import Distribution.Simple.Setup (CommonSetupFlags (..))@@ -37,24 +39,27 @@ main = defaultNixStyleFlags () } -hackageRepo ::- HackageRepoName ->- M RemoteRepo-hackageRepo repoName =- case eitherParsec [exon|##{repoName}:http://hackage.haskell.org/|] of- Right repo -> pure repo {remoteRepoSecure = Just True}- Left err -> throwM (Fatal [exon|Parse error: #{toText err}|])+remoteRepo :: HackageRepo -> RemoteRepo+remoteRepo HackageRepo {name, location, secure, keys} =+ RemoteRepo {+ remoteRepoName = RepoName (toString @Text (coerce name)),+ remoteRepoURI = hackageLocationUri location,+ remoteRepoSecure = secure,+ remoteRepoRootKeys = foldMap (fmap toString . toList) keys,+ remoteRepoKeyThreshold = 0,+ remoteRepoShouldTryHttps = hackageTlsBool location.tls+ } -globalFlags :: RemoteRepo -> FilePath -> GlobalFlags-globalFlags hackage cacheDir =+globalFlags :: NonEmpty RemoteRepo -> FilePath -> GlobalFlags+globalFlags repos cacheDir = defaultGlobalFlags { -- Cabal *always* reads ~/.cabal/config if no file is specified, and crashes if the file doesn't exist globalConfigFile = toFlag "/dev/null", globalCacheDir = toFlag cacheDir,- globalRemoteRepos = toNubList [hackage]+ globalRemoteRepos = toNubList (toList repos) } -badCacheDir :: Text -> Error+badCacheDir :: Text -> ErrorMessage badCacheDir err = Fatal [exon|Cannot access Cabal cache dir: #{err}|] mainFlags ::@@ -93,13 +98,20 @@ ghcPath exe (GhcPath dir) = toFilePath (dir </> [reldir|bin|] </> exe) -initialize ::+solveFlags ::+ NonEmpty RemoteRepo -> SolveConfig -> M SolveFlags-initialize conf = do- hackage <- hackageRepo conf.hackageRepoName+solveFlags repos conf = do cacheDir <- tryIOMWith badCacheDir defaultCacheDir- let global = globalFlags hackage cacheDir+ let global = globalFlags repos cacheDir let main = mainFlags conf- ensureHackageIndex conf global main pure SolveFlags {global, main}++initialize ::+ SolveConfig ->+ M SolveFlags+initialize conf = do+ flags <- solveFlags (remoteRepo <$> conf.hackageRepos) conf+ ensureHackageIndex conf flags.global flags.main+ pure flags
lib/Hix/Managed/Cabal/Mock.hs view
@@ -7,6 +7,7 @@ import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..)) import Distribution.System (Arch (X86_64), OS (Linux), Platform (Platform)) +import Hix.Data.PackageName (LocalPackage) import qualified Hix.Managed.Cabal.Data.Packages import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages)) import qualified Hix.Managed.Cabal.Data.SolveResources@@ -21,19 +22,24 @@ mockSolveResources :: Packages ManagedPackage -> GhcPackages ->- SolveResources-mockSolveResources packages GhcPackages {installed, available} = do- SolveResources {- conf = def,- flags = emptySolveFlags,- platform = Platform X86_64 Linux,- compiler = unknownCompilerInfo buildCompilerId NoAbiTag,-#if MIN_VERSION_Cabal(3,14,0)- pkgConfigDb = PkgConfigDb mempty,+ (SolveResources, Set LocalPackage)+mockSolveResources packages GhcPackages {installed, available} =+ (resources, localUnavailable)+ where+ resources =+ SolveResources {+ conf = def,+ flags = emptySolveFlags,+ platform = Platform X86_64 Linux,+ compiler = unknownCompilerInfo buildCompilerId NoAbiTag,+#if MIN_VERSION_cabal_install_solver(3,14,0)+ pkgConfigDb = PkgConfigDb mempty, #else- pkgConfigDb = NoPkgConfigDb,+ pkgConfigDb = NoPkgConfigDb, #endif- installedPkgIndex = mockInstalledPackageIndex installed,- sourcePkgDb = SourcePackage.dbWithManaged packages (mockSourcePackageDb available),- solverParams = id- }+ installedPkgIndex = mockInstalledPackageIndex installed,+ sourcePkgDb,+ solverParams = id+ }++ (sourcePkgDb, localUnavailable) = SourcePackage.dbWithManaged packages (mockSourcePackageDb available)
lib/Hix/Managed/Cabal/Mock/SourcePackage.hs view
@@ -1,7 +1,7 @@ module Hix.Managed.Cabal.Mock.SourcePackage where -import qualified Data.Map.Strict as Map import Distribution.Client.Types (PackageLocation (LocalTarballPackage), SourcePackageDb (..), UnresolvedSourcePackage)+import Distribution.Client.Types.SourcePackageDb (lookupPackageName) import Distribution.PackageDescription ( BuildInfo (targetBuildDepends), CondTree (..),@@ -17,25 +17,23 @@ import qualified Distribution.Solver.Types.SourcePackage as Cabal import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..), emptyGenericPackageDescription) import Distribution.Types.Library (libVisibility)-import Exon (exon) -import Hix.Class.Map (nGet, nKeys, nMap, nTo1, nTransform, (!!))+import Hix.Class.Map (nElems, nFilter, nKeys, nKeysSet, nMap, nTo1, nTransform, (!!)) import qualified Hix.Data.Dep as Dep import Hix.Data.Dep (Dep) import Hix.Data.Monad (M) import qualified Hix.Data.PackageId as PackageId import Hix.Data.PackageId (PackageId (PackageId))+import qualified Hix.Data.PackageName as PackageName import Hix.Data.PackageName (LocalPackage (LocalPackage), PackageName, localPackageName) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackage, SourcePackageId (..), SourcePackageVersions, SourcePackages) import qualified Hix.Managed.Data.ManagedPackage as ManagedPackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage)+import Hix.Managed.Data.ManagedPackage (ManagedPackage (ManagedPackage)) import Hix.Managed.Data.Packages (Packages)-import Hix.Monad (noteClient) allDeps :: [Dep] -> SourcePackage -> SourcePackage allDeps deps = nMap \ p -> p {deps = deps ++ p.deps}- where allDep :: Dep -> SourcePackage -> SourcePackage allDep = allDeps . pure@@ -44,7 +42,9 @@ sourcePackageVersions = nMap (sort . nKeys) queryVersions :: SourcePackageVersions -> PackageName -> M [Version]-queryVersions packages query = noteClient [exon|No such package in the source db: ##{query}|] (packages !! query)+queryVersions packages query =+ -- noteClient [exon|No such package in the source db: ##{query}|]+ pure (fold (packages !! query)) queryPackages :: SourcePackages -> PackageName -> M [Version] queryPackages packages =@@ -100,17 +100,24 @@ managedSourcePackage :: ManagedPackage -> UnresolvedSourcePackage managedSourcePackage package =- mockSourcePackage (localPackageName package.package) package.version pid+ mockSourcePackage (localPackageName package.name) package.version pid where- pid = SourcePackageId {deps = ManagedPackage.deps package, description = Nothing}+ pid = SourcePackageId {deps = package.deps, description = Nothing} managedPackageIndex :: Packages ManagedPackage -> PackageIndex UnresolvedSourcePackage managedPackageIndex packages =- PackageIndex.fromList (managedSourcePackage <$> Map.elems (nGet packages))+ PackageIndex.fromList (managedSourcePackage <$> nElems packages) -dbWithManaged :: Packages ManagedPackage -> SourcePackageDb -> SourcePackageDb-dbWithManaged packages SourcePackageDb {packageIndex, packagePreferences} =- SourcePackageDb {- packageIndex = PackageIndex.merge packageIndex (managedPackageIndex packages),- packagePreferences- }+dbWithManaged :: Packages ManagedPackage -> SourcePackageDb -> (SourcePackageDb, Set LocalPackage)+dbWithManaged packages db@SourcePackageDb {packageIndex, packagePreferences} =+ (merged, nKeysSet unavailable)+ where+ merged =+ SourcePackageDb {+ packageIndex = PackageIndex.merge packageIndex (managedPackageIndex unavailable),+ packagePreferences+ }++ unavailable =+ flip nFilter packages \ ManagedPackage {name = LocalPackage package} ->+ null (lookupPackageName db (PackageName.toCabal package))
+ lib/Hix/Managed/Cabal/PackageDescription.hs view
@@ -0,0 +1,28 @@+module Hix.Managed.Cabal.PackageDescription where++import qualified Data.ByteString as ByteString+import qualified Data.Text as Text+import Distribution.Fields (runParseResult)+import Distribution.PackageDescription (GenericPackageDescription)+import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)+import Distribution.Parsec (showPError)+import Exon (exon)+import Path (Abs, File, Path, toFilePath)++import Hix.Data.Monad (M)+import Hix.Monad (eitherFatal, tryIOM)++parseCabal :: String -> ByteString -> Either Text GenericPackageDescription+parseCabal source content =+ first formatError $+ snd $+ runParseResult $+ parseGenericPackageDescription content+ where+ formatError (_, errs) =+ [exon|Cabal file invalid: #{Text.unlines (toList (toText . showPError source <$> errs))}|]++parseCabalFile :: Path Abs File -> M GenericPackageDescription+parseCabalFile path = do+ content <- tryIOM $ ByteString.readFile (toFilePath path)+ eitherFatal (parseCabal (toFilePath path) content)
lib/Hix/Managed/Cabal/Repo.hs view
@@ -18,47 +18,47 @@ import Distribution.Client.IndexUtils.Timestamp (Timestamp, timestampToUTCTime) import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) import Distribution.Client.Setup (RepoContext, withRepoContext)-import Distribution.Client.Types (RemoteRepo (..), Repo (RepoSecure), RepoName (RepoName))+import Distribution.Client.Types (RemoteRepo (..), Repo (RepoRemote, RepoSecure), RepoName (RepoName)) import qualified Distribution.Client.Types.Repo import Distribution.Verbosity (Verbosity) import Exon (exon) import Path (Abs, File, Path, addExtension, parseAbsFile) -import Hix.Data.Error (Error (Fatal))+import Hix.Data.Error (ErrorMessage (Fatal)) import Hix.Error (pathText) import qualified Hix.Log as Log import qualified Hix.Managed.Cabal.Data.Config-import Hix.Managed.Cabal.Data.Config (- CabalConfig (CabalConfig),- HackageIndexState (HackageIndexState),- HackageRepoName (HackageRepoName),- SolveConfig (SolveConfig),- )+import Hix.Managed.Cabal.Data.Config (SolveConfig (SolveConfig))+import Hix.Managed.Cabal.Data.HackageRepo (HackageIndexState (..), HackageName (..), HackageRepo (..)) import Hix.Monad (M, catchIOM, eitherFatalShow, noteFatal, tryIOM, tryIOMWith, withLower)-import Hix.Pretty (showP)+import Hix.Pretty (prettyV, showP) -#if MIN_VERSION_Cabal(3,14,0)+#if MIN_VERSION_cabal_install(3,12,0) import Distribution.Client.IndexUtils (Index (RepoIndex)) #endif withRepoContextM ::- SolveConfig ->+ Verbosity -> GlobalFlags -> (RepoContext -> M a) -> M a-withRepoContextM conf flags f =- withLower \ lower -> withRepoContext conf.verbosity flags \ ctx -> lower (f ctx)+withRepoContextM verbosity flags f =+ withLower \ lower -> withRepoContext verbosity flags \ ctx -> lower (f ctx) -fullHackageRepo ::+fullHackageRepos :: SolveConfig -> RepoContext ->- M Repo-fullHackageRepo SolveConfig {hackageRepoName = HackageRepoName (toString -> hackage)} ctx =- noteFatal err $ flip find ctx.repoContextRepos \case- RepoSecure {repoRemote = RemoteRepo {remoteRepoName = RepoName name}} -> name == hackage- _ -> False+ M (NonEmpty (HackageRepo, Repo))+fullHackageRepos SolveConfig {hackageRepos} ctx =+ for hackageRepos \ repo@HackageRepo {name = HackageName (toString -> name)} -> do+ let matchName RemoteRepo {remoteRepoName = RepoName cabalName} = cabalName == name+ cabalRepo <- noteFatal (err name) $ flip find ctx.repoContextRepos \case+ RepoSecure {repoRemote} -> matchName repoRemote+ RepoRemote {repoRemote} -> matchName repoRemote+ _ -> False+ pure (repo, cabalRepo) where- err = "Bad Hackage repo config"+ err name = [exon|Configured repo '#{toText name}' not found in Cabal flags|] data IndexProblem = IndexMissing@@ -77,17 +77,15 @@ deriving stock (Eq, Show, Generic) updateRequest ::- SolveConfig ->+ HackageRepo -> String-updateRequest SolveConfig {hackageRepoName, cabal = CabalConfig {indexState}} =- [exon|#{hackage}#{extra}|]+updateRequest HackageRepo {name, indexState} =+ [exon|##{name}#{extra}|] where extra = foldMap stateField (timestampToUTCTime . coerce =<< indexState) stateField UTCTime {..} = [exon|,#{showGregorian utctDay}T#{show (timeToTimeOfDay utctDayTime)}Z|] - HackageRepoName (toString -> hackage) = hackageRepoName- maxIndexAgeDays :: Int maxIndexAgeDays = 7 @@ -95,15 +93,15 @@ maxIndexAge = nominalDay * fromIntegral maxIndexAgeDays updateIndex ::- SolveConfig ->+ HackageRepo -> GlobalFlags -> NixStyleFlags () -> IndexProblem -> M ()-updateIndex conf global main problem = do- Log.verbose [exon|Hackage snapshot #{message}, fetching...|]+updateIndex repo@HackageRepo {name} global main problem = do+ Log.verbose [exon|Hackage snapshot for '##{name}' #{message}, fetching...|] tryIOMWith (\ err -> Fatal [exon|Fetching Hackage snapshot failed: #{err}|]) do- updateAction main [updateRequest conf] global+ updateAction main [updateRequest repo] global where message = case problem of IndexMissing -> "doesn't exist"@@ -117,7 +115,7 @@ base <- parseAbsFile (indexBaseName repo) addExtension ".tar" base where- err = "Bad Hackage repo config"+ err = "Bad Hackage index file name" currentIndexState :: Verbosity ->@@ -125,7 +123,7 @@ Repo -> M (Maybe HackageIndexState) currentIndexState verbosity ctx repo =-#if MIN_VERSION_Cabal(3,14,0)+#if MIN_VERSION_cabal_install(3,12,0) catchIOM (Just . HackageIndexState <$> currentIndexTimestamp verbosity (RepoIndex ctx repo)) (const (pure Nothing)) #else catchIOM (Just . HackageIndexState <$> currentIndexTimestamp verbosity ctx repo) (const (pure Nothing))@@ -134,19 +132,20 @@ indexProblem :: SolveConfig -> RepoContext ->+ HackageRepo -> Repo -> Path Abs File -> M (Either IndexProblem ValidIndex)-indexProblem SolveConfig {verbosity, cabal} ctx repo path = do+indexProblem SolveConfig {verbosity} ctx repo cabalRepo path = do now <- tryIOM getCurrentTime Log.debug [exon|Checking Hackage snapshot at #{pathText path}|]- currentIndexState verbosity ctx repo <&> \case+ currentIndexState verbosity ctx cabalRepo <&> \case -- There is no index, so the target is irrelevant. Nothing -> Left IndexMissing Just currentState -- If a target index state was specified, we only care whether it matches exactly. -- The later conditions are irrelevant.- | Just target <- cabal.indexState+ | Just target <- repo.indexState -> if currentState == target then Right (IndexMatch target) else Left IndexMismatch@@ -154,7 +153,7 @@ -- The guard expresses that the timestamp could be parsed. | Just current <- currentUTC , let age = diffUTCTime now current- -> if diffUTCTime now current > maxIndexAge+ -> if age > maxIndexAge then Left (IndexOutdated age) else Right (IndexRecent age) -- If the current state's timestamp can't be converted to UTCTime, it may be corrupt, so we update.@@ -182,8 +181,9 @@ GlobalFlags -> NixStyleFlags () -> M ()-ensureHackageIndex conf global main =- withRepoContextM conf global \ ctx -> do- repo <- fullHackageRepo conf ctx- path <- indexPath repo- either (updateIndex conf global main) logValid =<< indexProblem conf ctx repo path+ensureHackageIndex conf global main = do+ Log.debug [exon|Ensuring Hackage indexes for repos: #{showP (prettyV conf.hackageRepos)}|]+ withRepoContextM conf.verbosity global \ ctx -> do+ fullHackageRepos conf ctx >>= traverse_ \ (repo, cabalRepo) -> do+ path <- indexPath cabalRepo+ either (updateIndex repo global main) logValid =<< indexProblem conf ctx repo cabalRepo path
lib/Hix/Managed/Cabal/Resources.hs view
@@ -2,35 +2,42 @@ module Hix.Managed.Cabal.Resources where -import Control.Monad.Trans.Reader (asks) import Distribution.Client.IndexUtils (getInstalledPackages, getSourcePackages) import qualified Distribution.Client.NixStyleOptions import Distribution.Client.Setup (configCompilerAux', withRepoContext) import Distribution.Simple (pattern GlobalPackageDB, compilerInfo) import Distribution.Solver.Types.PkgConfigDb (readPkgConfigDb)-import Distribution.Verbosity (lessVerbose, silent, verbose)+import Distribution.Verbosity (Verbosity, lessVerbose, silent, verbose) import qualified Hix.Data.Monad-import Hix.Data.Monad (M (M))+import Hix.Data.Monad (M, appRes)+import Hix.Data.PackageName (LocalPackage) import qualified Hix.Log as Log-import Hix.Managed.Cabal.Data.Config (CabalConfig, GhcDb (GhcDbSynthetic, GhcDbSystem), SolveConfig (..))+import Hix.Managed.Cabal.Data.Config (+ CabalConfig (..),+ GhcDb (GhcDbSynthetic, GhcDbSystem),+ SolveConfig (..),+ allHackages,+ ) import qualified Hix.Managed.Cabal.Data.SolveResources import Hix.Managed.Cabal.Data.SolveResources (SolveResources (SolveResources)) import qualified Hix.Managed.Cabal.Init import Hix.Managed.Cabal.Init (initialize) import Hix.Managed.Cabal.Mock (mockSolveResources) import qualified Hix.Managed.Cabal.Mock.SourcePackage as SourcePackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages (..)) import Hix.Monad (tryIOM) #if MIN_VERSION_Cabal(3,14,0) import Distribution.Simple (PackageDBStackCWD)-import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..)) #else import Distribution.Simple (PackageDBStack) #endif +#if MIN_VERSION_cabal_install_solver(3,14,0)+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..))+#endif+ #if MIN_VERSION_Cabal(3,14,0) packageDbs :: PackageDBStackCWD #else@@ -38,55 +45,61 @@ #endif packageDbs = [GlobalPackageDB] --- | This adds the 'ManagedPackage's to the source package DB, which is the set of available package IDs.+-- | This adds 'ManagedPackage's to the source package DB (the set of available package IDs) if there is no available+-- candidate in Cabal's snapshots for a given local package.+-- This may happen when the package hasn't been published to Hackage yet.+-- -- This means that the solver will find our local packages (for targets that depend on packages in other envs) like it--- finds Hackage packages, and therefore local deps will be included in the plan.+-- finds Hackage packages, and therefore non-target local deps will be included in the plan. -- -- Because we don't want local packages in the plan (as they are not mutable, but static in the Nix build), it would be -- tempting to add 'ManagedPackage's to the installed package index instead, which would exclude them from the plan's -- overrides.--- However, their metadata must include concrete unit IDs for their dependencies with fixed versions, which would--- require us to choose versions for them and might interfere with solving.------ Maybe the basic installed package index could be queried to determine the dep versions.--- Not sure this would be better than just filtering the plan.-resources ::- Packages ManagedPackage ->+-- However, the metadata of installed packages must include concrete unit IDs for their dependencies with fixed+-- versions, which would require us to choose versions for them and might interfere with solving.+solveResources ::+ ProjectPackages -> SolveConfig ->- M SolveResources-resources packages conf = do+ M (SolveResources, Set LocalPackage)+solveResources packages conf = do flags <- initialize conf Log.debug "Acquiring Cabal resources." tryIOM $ withRepoContext conf.verbosity flags.global \ repoContext -> do (compiler, platform, progdb) <- configCompilerAux' flags.main.configFlags pkgConfigDb <- readPkgConfigDb conf.verbosity progdb installedPkgIndex <- getInstalledPackages conf.verbosity compiler packageDbs progdb- sourcePkgDb <- getSourcePackages conf.verbosity repoContext- pure SolveResources {- compiler = compilerInfo compiler,- installedPkgIndex = installedPkgIndex,- sourcePkgDb = SourcePackage.dbWithManaged packages sourcePkgDb,- solverParams = id,-#if MIN_VERSION_Cabal(3,14,0)- pkgConfigDb = fromMaybe (PkgConfigDb []) pkgConfigDb,+ remoteSourcePkgDb <- getSourcePackages conf.verbosity repoContext+ let+ (sourcePkgDb, localUnavailable) = SourcePackage.dbWithManaged (coerce packages) remoteSourcePkgDb+ resources = SolveResources {+ compiler = compilerInfo compiler,+ installedPkgIndex = installedPkgIndex,+ solverParams = id,+#if MIN_VERSION_cabal_install_solver(3,14,0)+ pkgConfigDb = fromMaybe (PkgConfigDb []) pkgConfigDb, #endif- ..- }+ ..+ }+ pure (resources, localUnavailable) --- TODO The Packages ManagedPackage are added in 'resources' as well as in 'mockSolveResources', which is probably ok since they--- now come from @processProject@ and not from the tests, I think. still would be better to unify those+cabalVerbosity :: M Verbosity+cabalVerbosity =+ appRes.cabalVerbose <&> \case+ True -> verbose+ False -> lessVerbose silent++-- TODO The Packages ManagedPackage are added in 'resources' as well as in 'mockSolveResources', which is probably ok+-- since they now come from @processProject@ and not from the tests, I think. still would be better to unify those -- -- just add the managed packages to the result. acquire ::- Packages ManagedPackage ->+ ProjectPackages -> CabalConfig -> GhcDb ->- M SolveResources+ M (SolveResources, Set LocalPackage) acquire packages cabal = \case GhcDbSystem ghc -> do- verbosity <- M (asks (.debug)) <&> \case- True -> verbose- False -> lessVerbose silent- resources packages def {verbosity, ghc, cabal}+ verbosity <- cabalVerbosity+ solveResources packages SolveConfig {hackageRepos = allHackages cabal, verbosity, ghc, allowBoot = False, cabal} GhcDbSynthetic db ->- pure (mockSolveResources packages db)+ pure (mockSolveResources (coerce packages) db)
+ lib/Hix/Managed/Cabal/Sdist.hs view
@@ -0,0 +1,41 @@+module Hix.Managed.Cabal.Sdist where++import Control.Monad.Trans.Reader (ask)+import Distribution.Client.CmdSdist (OutputFormat (TarGzArchive), packageToSdist)+import Distribution.Client.Types (PackageLocation (LocalUnpackedPackage))+import Distribution.Solver.Types.SourcePackage (SourcePackage (..))+import Exon (exon)+import Path (Abs, Dir, File, Path, parseRelFile, toFilePath, (</>))++import Hix.Data.Monad (AppResources (..), M (M))+import qualified Hix.Data.PackageId as PackageId+import Hix.Data.PackageId (PackageId (..))+import Hix.Managed.Cabal.PackageDescription (parseCabalFile)+import Hix.Managed.Cabal.Resources (cabalVerbosity)+import Hix.Monad (noteFatal)+import Hix.Pretty (showP)++sourceDistribution ::+ Path Abs Dir ->+ PackageId ->+ M (Path Abs File)+sourceDistribution root package = do+ verbosity <- cabalVerbosity+ AppResources {tmp} <- M ask+ cabalFilename <- parseFilename "cabal" cabalFileString+ filename <- parseFilename "sdist output" fileString+ srcpkgDescription <- parseCabalFile (root </> cabalFilename)+ let outfile = tmp </> filename+ sourcePkg =+ SourcePackage {+ srcpkgPackageId = PackageId.toCabal package,+ srcpkgDescription,+ srcpkgSource = LocalUnpackedPackage (toFilePath root),+ srcpkgDescrOverride = Nothing+ }+ liftIO $ packageToSdist verbosity (toFilePath root) TarGzArchive (toFilePath outfile) sourcePkg+ pure outfile+ where+ cabalFileString = [exon|#{showP package.name}.cabal|]+ fileString = [exon|#{showP package}.tar.gz|]+ parseFilename desc s = noteFatal [exon|Couldn't parse #{desc} file name: #{toText s}|] (parseRelFile s)
lib/Hix/Managed/Cabal/Solve.hs view
@@ -19,7 +19,7 @@ import Distribution.Verbosity (Verbosity) import Exon (exon) -import Hix.Data.Error (Error (Fatal))+import Hix.Data.Error (ErrorMessage (Fatal)) import qualified Hix.Log as Log import Hix.Managed.Cabal.Changes (SolverPlan, solverPlan) import qualified Hix.Managed.Cabal.Data.Config@@ -32,7 +32,7 @@ import Hix.Managed.Cabal.Targets (solveTargets) import Hix.Monad (M, tryIOMAs) -#if ! MIN_VERSION_Cabal(3,14,0)+#if ! MIN_VERSION_cabal_install(3,12,0) import Distribution.Client.Dependency.Types (Solver (Modular)) #endif @@ -53,8 +53,10 @@ IO (Either String SolverInstallPlan) solveSpecifiers res mapParams pkgSpecifiers prefs = foldProgress (logMsg res.conf.verbosity) (pure . Left) (pure . Right) $-#if MIN_VERSION_Cabal(3,14,0)+#if MIN_VERSION_cabal_install(3,14,0) resolveDependencies res.platform res.compiler (Just res.pkgConfigDb) params+#elif MIN_VERSION_cabal_install(3,12,0)+ resolveDependencies res.platform res.compiler res.pkgConfigDb params #else resolveDependencies res.platform res.compiler res.pkgConfigDb Modular params #endif
+ lib/Hix/Managed/Cabal/Upload.hs view
@@ -0,0 +1,182 @@+{-# language CPP #-}++module Hix.Managed.Cabal.Upload where++import Control.Lens (IndexedTraversal', ix, (%~), (^.))+import Control.Lens.Regex.Text (Match, groups, regex)+import Data.List.Extra (unescapeHTML)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as Text+import Distribution.Client.Setup (IsCandidate (IsPublished), RepoContext)+import qualified Distribution.Client.Types.Credentials as Cabal+import qualified Distribution.Client.Upload as Upload+import Distribution.PackageDescription (GenericPackageDescription)+import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription)+import Distribution.Types.Lens (customFieldsPD, packageDescription)+import Distribution.Verbosity (Verbosity)+import Exon (exon)+import Path (Abs, File, Path, filename, toFilePath)++import Hix.Cabal (catchExitCodeM)+import qualified Hix.Color as Color+import Hix.Data.Monad (M)+import Hix.Data.PackageId (PackageId (..))+import Hix.Error (pathText)+import Hix.Hackage (fatalHackageRequest, hackageGet, hackagePostForm)+import qualified Hix.Log as Log+import Hix.Managed.Cabal.Data.Revision (Revision (..))+import Hix.Managed.Cabal.Init (SolveFlags (..))+import Hix.Managed.Cabal.PackageDescription (parseCabalFile)+import Hix.Managed.Cabal.Repo (withRepoContextM)+import Hix.Managed.Handlers.HackageClient (HackageClient (..), HackageError (..), HackageResponse (..))+import Hix.Monad (appContext, fatalError, noteFatal)+import Hix.Pretty (showP)++type Regex = IndexedTraversal' Int Text Match++newtype User =+ User { value :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Ord)++newtype Password =+ Password { value :: Text }+ deriving stock (Eq, Show, Generic)+ deriving newtype (IsString, Ord)++data UploadConfig =+ UploadConfig {+ verbosity :: Verbosity,+ user :: User,+ password :: Password+ }+ deriving stock (Eq, Show, Generic)++upload ::+ UploadConfig ->+ RepoContext ->+ Maybe Cabal.Username ->+ Maybe Cabal.Password ->+ IsCandidate ->+ [FilePath] ->+ IO ()+upload conf ctx =+#if MIN_VERSION_cabal_install(3,12,0)+ Upload.upload conf.verbosity ctx Nothing+#else+ Upload.upload conf.verbosity ctx+#endif++-- TODO When candidates are uploaded, versions don't have to be written to the repo.+-- Since we're gonna add automatic semver incrementing, we can do that in memory and manipulate the cabal files in a+-- temp dir somewhere, even without asking the user for a version, since there's no danger in publishing candidates.+--+-- TODO Allow token authentication+publishPackage ::+ UploadConfig ->+ SolveFlags ->+ Path Abs File ->+ M ()+publishPackage conf flags sourceTar =+ withRepoContextM conf.verbosity flags.global \ ctx ->+ catchExitCodeM "Upload failed" do+ upload conf ctx (Just user) (Just password) candidate [toFilePath sourceTar]+ where+ user = Cabal.Username (toString conf.user.value)++ password = Cabal.Password (toString conf.password.value)++ candidate = IsPublished++revisions ::+ HackageClient ->+ PackageId ->+ M [Revision]+revisions client package =+ appContext [exon|fetching revisions for #{showP package}|] do+ result <- hackageGet Right client [exon|package/##{showP package}/revisions/|] HackageResponseJson+ fatalHackageRequest result++latestRevision ::+ HackageClient ->+ PackageId ->+ M Revision+latestRevision client package = do+ revs <- revisions client package+ noteFatal "Package has no revisions" (maximumBy (comparing (.number)) revs)++updateRevision :: Word -> GenericPackageDescription -> GenericPackageDescription+updateRevision newRevision =+ packageDescription . customFieldsPD %~ \ old -> new : filter (not . (revKey ==) . fst) old+ where+ new = (revKey, show newRevision)+ revKey = "x-revision"++revisionCabalFile ::+ HackageClient ->+ PackageId ->+ Word ->+ M Text+revisionCabalFile client package rev =+ appContext [exon|fetching revision #{Color.number rev} for #{Color.package package}|] do+ result <- hackageGet Right client [exon|package/##{showP package}/revision/#{show rev}.cabal|] HackageResponseHtml+ fatalHackageRequest result++tagRegex :: Regex+tagRegex = [regex|<[^>]+>([^<]*)</[^>]+>|]++checkPublishErrorMessage :: Text -> M ()+checkPublishErrorMessage html =+ for_ (nonEmpty (takeMessages afterErrorHeadline)) \ err ->+ fatalError [exon|Publishing revision failed: #{Text.intercalate " | " (toList err)}|]+ where+ takeMessages = filter (not . Text.null) . fmap sanitize . takeWhile isParagraph+ sanitize = toText . unescapeHTML . toString . stripTags+ afterErrorHeadline = drop 1 (dropWhile (not . errorHeadline) (Text.lines html))+ isParagraph = Text.isPrefixOf "<p>"+ errorHeadline line = line == "<h2>Errors</h2>"+ stripTags line = line ^. tagRegex . groups . ix 0++publishRevisionTo ::+ HackageClient ->+ PackageId ->+ Path Abs File ->+ M Revision+publishRevisionTo client package cabalFile = do+ pkgDesc <- parseCabalFile cabalFile+ prev <- latestRevision client package+ let newRevision = prev.number + 1+ withRevision =+ toText $+ showGenericPackageDescription (updateRevision newRevision pkgDesc)+ payload =+ [+ ("pkgid", slug),+ ("cabalfile", withRevision),+ ("publish", "true")+ ]+ Log.info [exon|Publishing revision #{show newRevision} for #{showP package} to #{showP client.description}|]+ hackagePostForm Right client [exon|package/#{slug}/#{cabalName}/edit|] payload HackageResponseHtml >>= \case+ Right response -> checkPublishErrorMessage response+ Left reason -> case reason of+ HackageFatal msg -> err msg+ HackageNotFound -> err [exon|Hackage couldn't find the package '#{slug}'|]+ HackageParseError msg -> err msg+ new <- latestRevision client package+ when (new.number <= prev.number) do+ fatalError "Revision wasn't published"+ pure new+ where+ cabalName = pathText (filename cabalFile)+ slug = showP package+ err msg = fatalError [exon|Publishing revision failed: #{msg}|]++-- TODO better return value+publishRevision ::+ NonEmpty HackageClient ->+ PackageId ->+ Path Abs File ->+ M Revision+publishRevision clients package cabalFile =+ appContext [exon|publishing revision for #{Color.package package} from #{Color.path cabalFile}|] do+ NonEmpty.head <$> for clients \ client -> publishRevisionTo client package cabalFile
lib/Hix/Managed/Data/BuildConfig.hs view
@@ -1,12 +1,23 @@ module Hix.Managed.Data.BuildConfig where -import Hix.Managed.Handlers.Build (BuildTimeout)+import Data.Aeson (FromJSON) +newtype BuildTimeout =+ BuildTimeout Int+ deriving stock (Eq, Show, Generic)+ deriving newtype (Num, Real, Enum, Integral, Ord, FromJSON)++data SpecialBuildHandlers =+ BuildHandlersTestBump+ |+ BuildHandlersTestMaint+ deriving stock (Eq, Show)+ data BuildConfig = BuildConfig {- maxIterations :: Natural,- maxFailedPre :: Natural,- maxFailedPost :: Natural,+ maxIterations :: Word,+ maxFailedPre :: Word,+ maxFailedPost :: Word, lookup :: Bool, validate :: Bool, buildOutput :: Bool,
lib/Hix/Managed/Data/BuildOutput.hs view
@@ -1,9 +1,10 @@ module Hix.Managed.Data.BuildOutput where -import Data.Aeson (ToJSON (toJSON), object, (.=))+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, withObject, (.:), (.:?), (.=), Value (Object)) import Distribution.Pretty (Pretty (pretty)) import Text.PrettyPrint (brackets, (<+>)) +import Hix.Data.Json (JsonParsec (JsonParsec)) import Hix.Data.Version (Version) import Hix.Data.VersionBounds (VersionBounds) import Hix.Managed.Data.Mutable (MutableDep)@@ -15,6 +16,7 @@ ModifiedId { package :: MutableDep, version :: Version,+ -- TODO why is this not named @bounds@? json? range :: Maybe VersionBounds } deriving stock (Eq, Show, Generic)@@ -31,14 +33,47 @@ "range" .= toJSON (showP <$> range :: Maybe Text) ] -data BuildOutput =- BuildOutput {+instance FromJSON ModifiedId where+ parseJSON =+ withObject "ModifiedId" \ o -> do+ package <- o .: "package"+ JsonParsec version <- o .: "version"+ range <- o .:? "range"+ pure ModifiedId {..}++data DepChanges =+ DepChanges { modified :: [ModifiedId], unmodified :: [MutableDep],- failed :: [MutableDep],+ failed :: [MutableDep]+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (ToJSON, FromJSON)++data DepChangesNames =+ DepChangesNames { modifiedNames :: Maybe Text, unmodifiedNames :: Maybe Text, failedNames :: Maybe Text } deriving stock (Eq, Show, Generic)- deriving anyclass (ToJSON)+ deriving anyclass (ToJSON, FromJSON)++data BuildOutput =+ BuildOutput {+ changes :: DepChanges,+ names :: DepChangesNames+ }+ deriving stock (Eq, Show)++instance FromJSON BuildOutput where+ parseJSON v = do+ changes <- parseJSON v+ names <- parseJSON v+ pure BuildOutput {..}++instance ToJSON BuildOutput where+ toJSON BuildOutput {..} =+ case (toJSON changes, toJSON names) of+ (Object c, Object n) -> Object (c <> n)+ _ -> Object [("error", "ToJSON BuildOutput invariant")]
lib/Hix/Managed/Data/Constraints.hs view
@@ -55,6 +55,7 @@ pref v = "~" <+> pretty v spec v = "+" <+> pretty v +-- TODO maybe try creating something lawful, or at least intuitive? instance Semigroup MutationConstraints where l <> r = MutationConstraints {
lib/Hix/Managed/Data/EnvConfig.hs view
@@ -4,11 +4,19 @@ import Hix.Data.PackageName (LocalPackage) import Hix.Managed.Cabal.Data.Config (GhcDb)+import Hix.Pretty (HPretty (hpretty), field, prettyFieldsV) data EnvConfig = EnvConfig { targets :: [LocalPackage],- ghc :: GhcDb+ ghc :: Maybe GhcDb } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON)++instance HPretty EnvConfig where+ hpretty EnvConfig {..} =+ prettyFieldsV [+ field "targets" targets,+ field "ghc" ghc+ ]
lib/Hix/Managed/Data/EnvContext.hs view
@@ -1,21 +1,15 @@ module Hix.Managed.Data.EnvContext where -import GHC.Generics (Generically (Generically))- import Hix.Data.Bounds (Ranges) import Hix.Data.EnvName (EnvName)-import Hix.Data.PackageName (LocalPackage) import Hix.Managed.Cabal.Data.Config (GhcDb) import Hix.Managed.Data.Mutable (MutableDep) import Hix.Managed.Data.Targets (Targets) -data EnvDeps =- EnvDeps {- mutable :: Set MutableDep,- local :: Set LocalPackage- }+newtype EnvDeps =+ EnvDeps { mutable :: Set MutableDep } deriving stock (Eq, Show, Generic)- deriving (Semigroup, Monoid) via (Generically EnvDeps)+ deriving newtype (Semigroup, Monoid) -- | Static data defining a managed bounds job for an environment. data EnvContext =@@ -23,12 +17,13 @@ -- | The name of the Hix environment used to build this job. env :: EnvName, - -- | The package database containing installed packages, corresponding to the set returned by @ghcWithPackages@ in- -- Nix, with all nonlocal project dependencies.- -- In production, this points to the dir containing the GHC executables in the Nix store, which Cabal executes to- -- interact with the database.- -- In tests, this is a pure set of manually constructed packages.- ghc :: GhcDb,+ -- | Override for the package database, which is usually obtained by context query.+ -- In tests, this can be used to supply an in-memory set of packages.+ --+ -- The Nix package DB consists of a GHC directory in the store created by @ghcWithPackages@.+ -- Cabal interacts with this DB by executing the wrapper scripts for @ghc-pkg@ and @ghc@, which are hardwired to use+ -- the directory @package.conf.d@ in the same store path.+ ghc :: Maybe GhcDb, -- | The set of local packages associated with this environment. -- Sorted topologically by smart constructor.
lib/Hix/Managed/Data/EnvState.hs view
@@ -19,11 +19,14 @@ -- | The precise version determined to be working for the env's target bound. versions :: MutableDeps VersionChange, + -- | Copied from 'versions' at the end of an env flow whenever the final value for a dep is @DiffAdded@.+ initial :: MutableDeps VersionChange,+ -- | Overrides from the persisted state may be empty initially. overrides :: Overrides, - -- | Copied from 'versions' at the end of an env flow whenever the final value for a dep is @DiffAdded@.- initial :: MutableDeps VersionChange+ -- | Solver overrides from the persisted state may be empty initially.+ solver :: Overrides } deriving stock (Eq, Show, Generic) deriving (Semigroup, Monoid) via (Generically EnvState)@@ -32,5 +35,6 @@ pretty EnvState {..} = hang "bounds:" 2 (pretty bounds) $+$ hang "versions:" 2 (pretty versions) $+$+ hang "initial:" 2 (pretty initial) $+$ hang "overrides:" 2 (pretty overrides) $+$- hang "initial:" 2 (pretty initial)+ hang "solver:" 2 (pretty solver)
lib/Hix/Managed/Data/Envs.hs view
@@ -7,6 +7,7 @@ import Hix.Class.EncodeNix (EncodeNix) import Hix.Class.Map (LookupMonoid, NMap, nPretty1) import Hix.Data.EnvName (EnvName)+import Hix.Pretty (HPretty (..), hnPretty) newtype Envs a = Envs (Map EnvName a)@@ -17,3 +18,6 @@ instance Pretty a => Pretty (Envs a) where pretty = nPretty1++instance HPretty a => HPretty (Envs a) where+ hpretty = hnPretty
lib/Hix/Managed/Data/Initial.hs view
@@ -6,7 +6,7 @@ import Hix.Class.EncodeNix (EncodeNix) newtype Initial a =- Initial a+ Initial { value :: a } deriving stock (Eq, Show, Generic, Functor) deriving newtype (Semigroup, Monoid, FromJSON, ToJSON, EncodeNix)
+ lib/Hix/Managed/Data/MaintConfig.hs view
@@ -0,0 +1,33 @@+module Hix.Managed.Data.MaintConfig where++import Hix.Data.PackageName (PackageName)++data MaintConfig =+ MaintConfig {+ targets :: Maybe (NonEmpty PackageName),+ noFailures :: Bool,+ commit :: Bool,+ push :: Bool,+ -- | Create commits on new, timestamped, branches; so that a CI workflow may create pull requests.+ -- Omit publishing revisions.+ pr :: Bool,+ revision :: Bool,+ -- | Fetch tags and branches.+ fetch :: Bool,+ -- | Use the global git config rather than a synthetic committer ID (hix@tryp.io).+ globalGit :: Bool+ }+ deriving stock (Eq, Show)++instance Default MaintConfig where+ def =+ MaintConfig {+ targets = Nothing,+ noFailures = False,+ commit = False,+ push = False,+ pr = False,+ revision = False,+ fetch = False,+ globalGit = False+ }
+ lib/Hix/Managed/Data/MaintContext.hs view
@@ -0,0 +1,42 @@+module Hix.Managed.Data.MaintContext where++import Data.Aeson (FromJSON)+import Path (Dir, Path, Rel)+import Text.PrettyPrint (($+$))++import Hix.Data.PackageName (LocalPackage)+import Hix.Managed.Cabal.Data.ContextHackageRepo (ContextHackageRepo)+import Hix.Managed.Cabal.Data.HackageRepo (HackageName)+import Hix.Managed.Data.Envs (Envs)+import Hix.Managed.Data.ManagedPackage (ManagedPackage)+import Hix.Managed.Data.Packages (Packages)+import Hix.Pretty (HPretty (hpretty), prettyMap, field)++data MaintPackage =+ MaintPackage {+ package :: ManagedPackage,+ path :: Path Rel Dir+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (FromJSON)++instance HPretty MaintPackage where+ hpretty MaintPackage {..} =+ hpretty package $+$ hpretty path++data MaintContext =+ MaintContext {+ packages :: Packages MaintPackage,+ hackage :: Map HackageName ContextHackageRepo,+ envs :: Envs [LocalPackage]+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (FromJSON)++instance HPretty MaintContext where+ hpretty MaintContext {..} =+ prettyMap "maint" [+ field "packages" packages,+ field "hackage" hackage,+ field "envs" envs+ ]
lib/Hix/Managed/Data/ManagedPackage.hs view
@@ -1,40 +1,65 @@ module Hix.Managed.Data.ManagedPackage where +import Data.Aeson (FromJSON (parseJSON), withObject, (.:))+import Data.List.Extra (nubOrdOn)+import qualified Data.Map.Strict as Map import Distribution.Pretty (Pretty (pretty))-import Text.PrettyPrint (hang, ($+$))+import GHC.IsList (IsList)+import Text.PrettyPrint (brackets, (<+>)) -import Hix.Class.Map (nTo, nTransform)-import Hix.Data.Bounds (Ranges)+import Hix.Class.Map (LookupMaybe, NMap, nFromList) import qualified Hix.Data.Dep-import Hix.Data.Dep (Dep (Dep))+import Hix.Data.Dep (Dep)+import Hix.Data.Json (jsonParsec) import qualified Hix.Data.PackageId import Hix.Data.PackageId (PackageId (PackageId))-import Hix.Data.PackageName (LocalPackage (LocalPackage), localPackageName)+import Hix.Data.PackageName (LocalPackage (LocalPackage)) import Hix.Data.Version (Version)-import Hix.Managed.Data.Mutable (LocalRanges, MutableRanges, depName)+import Hix.Managed.Data.Packages (Packages (..))+import Hix.Managed.Data.Targets (Targets)+import Hix.Managed.Targets (onlyTargets)+import Hix.Pretty (HPretty, prettyL) data ManagedPackage = ManagedPackage {- package :: LocalPackage,+ name :: LocalPackage, version :: Version,- local :: LocalRanges,- mutable :: MutableRanges+ deps :: [Dep] } deriving stock (Eq, Show, Generic) instance Pretty ManagedPackage where- pretty ManagedPackage {..} =- hang (pretty package) 2 (pretty local $+$ pretty mutable)+ pretty ManagedPackage {..} = pretty PackageId {name = coerce name, version} <+> brackets (prettyL deps) -ranges :: ManagedPackage -> Ranges-ranges ManagedPackage {local, mutable} =- nTransform (\ k v -> (localPackageName k, v)) local <>- nTransform (\ k v -> (depName k, v)) mutable+instance FromJSON ManagedPackage where+ parseJSON =+ withObject "ManagedPackage" \ o -> do+ name <- o .: "name"+ version <- jsonParsec <$> o .: "version"+ deps <- nubOrdOn (.package) <$> o .: "deps"+ pure ManagedPackage {..} -packageId :: ManagedPackage -> PackageId-packageId ManagedPackage {package = LocalPackage name, version} =- PackageId {..}+newtype ProjectPackages =+ ProjectPackages (Packages ManagedPackage)+ deriving stock (Eq, Show, Generic)+ deriving newtype (FromJSON, Semigroup, Monoid, IsList, Pretty, HPretty) -deps :: ManagedPackage -> [Dep]-deps mp =- nTo (ranges mp) \ package version -> Dep {..}+instance NMap ProjectPackages LocalPackage ManagedPackage LookupMaybe where++newtype EnvPackages =+ EnvPackages (Packages ManagedPackage)+ deriving stock (Eq, Show, Generic)+ deriving newtype (FromJSON, Semigroup, Monoid, IsList, Pretty, HPretty)++instance NMap EnvPackages LocalPackage ManagedPackage LookupMaybe where++managedPackages :: Map (LocalPackage, Version) [Dep] -> ProjectPackages+managedPackages spec =+ nFromList (pkg <$> Map.toList spec)+ where+ pkg ((name, version), deps) =+ (name, ManagedPackage {name, version, deps})++forEnv :: Targets -> ProjectPackages -> EnvPackages+forEnv targets =+ coerce @(Packages ManagedPackage) . onlyTargets targets . coerce @_ @(Packages ManagedPackage)
− lib/Hix/Managed/Data/ManagedPackageProto.hs
@@ -1,44 +0,0 @@-module Hix.Managed.Data.ManagedPackageProto where--import Data.Aeson (FromJSON (parseJSON), withObject, (.:))-import Data.List.Extra (nubOrdOn)-import qualified Data.Map.Strict as Map-import Distribution.Pretty (Pretty (pretty))-import Text.PrettyPrint (brackets, (<+>))--import Hix.Class.Map (nFromList)-import qualified Hix.Data.Dep-import Hix.Data.Dep (Dep)-import Hix.Data.Json (jsonParsec)-import qualified Hix.Data.PackageId-import Hix.Data.PackageId (PackageId (PackageId))-import Hix.Data.PackageName (LocalPackage (LocalPackage))-import Hix.Data.Version (Version)-import Hix.Managed.Data.Packages (Packages)-import Hix.Pretty (prettyL)--data ManagedPackageProto =- ManagedPackageProto {- name :: LocalPackage,- version :: Version,- deps :: [Dep]- }- deriving stock (Eq, Show, Generic)--instance Pretty ManagedPackageProto where- pretty ManagedPackageProto {..} = pretty PackageId {name = coerce name, version} <+> brackets (prettyL deps)--instance FromJSON ManagedPackageProto where- parseJSON =- withObject "ManagedPackageProto" \ o -> do- name <- o .: "name"- version <- jsonParsec <$> o .: "version"- deps <- nubOrdOn (.package) <$> o .: "deps"- pure ManagedPackageProto {..}--managedPackages :: Map (LocalPackage, Version) [Dep] -> Packages ManagedPackageProto-managedPackages spec =- nFromList (pkg <$> Map.toList spec)- where- pkg ((name, version), deps) =- (name, ManagedPackageProto {name, version, deps})
lib/Hix/Managed/Data/Mutable.hs view
@@ -4,6 +4,7 @@ unsafeMutableDep, depName, isMutableDep,+ validate, MutableVersions, MutableBounds, MutableRanges,@@ -21,9 +22,11 @@ addBuildVersions, mutFromSet, mutRelaxVersions,+ mutNonTargets,+ forTargets, ) where -import Data.Aeson (ToJSON, ToJSONKey)+import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) import qualified Data.Set as Set import Distribution.Pretty (Pretty (pretty)) import Exon (ToSegment (toSegment))@@ -38,6 +41,7 @@ nFromKeys, nMap, nMapKeys,+ nPartitionByKey, nPretty, nPrettyWith, nRestrictKeys,@@ -50,12 +54,15 @@ import Hix.Data.Version (Version, VersionRange, Versions) import Hix.Data.VersionBounds (VersionBounds) import Hix.Managed.Data.Packages (Deps, Packages)-import Hix.Managed.Data.Targets (Targets, overTargets)+import Hix.Managed.Data.Targets (Targets)+import qualified Hix.Managed.Targets as Targets+import Hix.Managed.Targets (onlyTargets, overTargets)+import Hix.Maybe (justIf) newtype MutableDep = UnsafeMutableDep PackageName deriving stock (Eq, Show)- deriving newtype (Ord, ToJSON, ToJSONKey, Pretty, EncodeNixKey)+ deriving newtype (Ord, ToJSON, ToJSONKey, Pretty, EncodeNixKey, FromJSON, FromJSONKey) pattern MutableDep :: PackageName -> MutableDep pattern MutableDep name <- UnsafeMutableDep name@@ -71,6 +78,10 @@ isMutableDep :: Set MutableDep -> PackageName -> Bool isMutableDep mut p = Set.member (UnsafeMutableDep p) mut +validate :: Set MutableDep -> PackageName -> Maybe MutableDep+validate pool candidate =+ justIf (isMutableDep pool candidate) (UnsafeMutableDep candidate)+ instance IsString a => ToSegment MutableDep a where toSegment (UnsafeMutableDep name) = toSegment name @@ -107,16 +118,6 @@ instance Pretty MutableBounds where pretty = nPretty -newtype LocalBounds =- LocalBounds (Map LocalPackage VersionBounds)- deriving stock (Eq, Show, Generic)- deriving newtype (Semigroup, Monoid, IsList, EncodeNix)--instance NMap LocalBounds LocalPackage VersionBounds LookupMaybe where--instance Pretty LocalBounds where- pretty = nPretty- newtype MutableRanges = MutableRanges (Map MutableDep VersionRange) deriving stock (Eq, Show, Generic)@@ -144,7 +145,7 @@ map -> l mutLookup k m =- m !! (UnsafeMutableDep k)+ m !! UnsafeMutableDep k mutRestrictKeys :: NMap map MutableDep v sort =>@@ -249,3 +250,26 @@ map mutFromSet = nFromKeys++-- TODO remove+mutNonTargets ::+ Targets ->+ LocalRanges ->+ (MutableRanges, LocalRanges)+mutNonTargets targets =+ nPartitionByKey \case+ package | Targets.member package targets -> Right package+ LocalPackage package -> Left (UnsafeMutableDep package)++forTargets ::+ NMap map1 PackageName a sort1 =>+ NMap map2 MutableDep a sort2 =>+ Targets ->+ Packages map1 ->+ Packages map2+forTargets targets =+ onlyTargets targets . nMap transformOne+ where+ transformOne =+ nTransformMaybe \ package a ->+ justIf (not (Targets.member (LocalPackage package) targets)) (UnsafeMutableDep package, a)
lib/Hix/Managed/Data/Mutation.hs view
@@ -4,7 +4,6 @@ import qualified Text.PrettyPrint as PrettyPrint import Text.PrettyPrint (parens, (<+>)) -import Hix.Data.PackageId (PackageId) import Hix.Data.Version (Version) import Hix.Data.VersionBounds (VersionBounds) import Hix.Managed.Cabal.Data.SolverState (SolverState)@@ -41,7 +40,6 @@ candidate :: MutableId, changed :: Bool, state :: MutationState,- revisions :: Set PackageId, ext :: s } |
lib/Hix/Managed/Data/MutationState.hs view
@@ -15,8 +15,8 @@ MutationState { bounds :: MutableBounds, versions :: MutableVersions,- overrides :: Overrides,- initial :: MutableVersions+ initial :: MutableVersions,+ overrides :: Overrides } deriving stock (Eq, Show, Generic) deriving (Semigroup, Monoid) via (Generically MutationState)@@ -25,8 +25,8 @@ pretty MutationState {..} = hang "bounds:" 2 (pretty bounds) $+$ hang "versions:" 2 (pretty versions) $+$- hang "overrides:" 2 (pretty overrides) $+$- hang "initial:" 2 (pretty initial)+ hang "initial:" 2 (pretty initial) $+$+ hang "overrides:" 2 (pretty overrides) updateBoundsWith :: (Version -> VersionBounds -> VersionBounds) -> MutationState -> MutationState updateBoundsWith update MutationState {bounds, versions, ..} =@@ -36,5 +36,5 @@ .. } where- addBound = mapMaybeMissing \ _ -> fmap (flip update mempty)+ addBound = mapMaybeMissing \ _ -> fmap (`update` mempty) updateBound = zipWithMatched \ _ -> maybe id update
+ lib/Hix/Managed/Data/NixOutput.hs view
@@ -0,0 +1,49 @@+module Hix.Managed.Data.NixOutput where++import Distribution.Pretty (Pretty (..))++import Hix.Data.PackageId (PackageId)++data Derivation =+ Derivation {+ path :: Text,+ log :: (Seq Text, Seq Text)+ }+ deriving stock (Eq, Show, Generic)++data PackageDerivation =+ PackageDerivation {+ package :: PackageId,+ success :: Bool,+ log :: [Text]+ }+ deriving stock (Eq, Show, Generic)++instance Pretty PackageDerivation where+ pretty PackageDerivation {package} = pretty package++data BuildsState =+ BuildsState {+ id :: Integer,+ done :: Int,+ failed :: Int,+ unassigned :: [Bool]+ }+ deriving stock (Eq, Show, Generic)++data OutputState =+ OutputState {+ builds :: Maybe BuildsState,+ running :: Map Integer Derivation,+ finished :: [PackageDerivation],+ messages :: [Text]+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (Default)++data OutputResult =+ OutputResult {+ failedPackages :: Maybe (NonEmpty PackageDerivation),+ unknownMessages :: [Text]+ }+ deriving stock (Eq, Show, Generic)
lib/Hix/Managed/Data/Packages.hs view
@@ -7,6 +7,7 @@ import Hix.Class.EncodeNix (EncodeNix) import Hix.Class.Map (LookupMaybe, LookupMonoid, NMap, nPretty, nPretty1) import Hix.Data.PackageName (LocalPackage, PackageName)+import Hix.Pretty (HPretty (..), hnPretty) newtype Packages a = Packages (Map LocalPackage a)@@ -17,6 +18,9 @@ instance Pretty a => Pretty (Packages a) where pretty = nPretty1++instance HPretty a => HPretty (Packages a) where+ hpretty = hnPretty newtype Deps a = Deps (Map PackageName a)
lib/Hix/Managed/Data/ProcessState.hs view
@@ -1,49 +1,48 @@ module Hix.Managed.Data.ProcessState where -import Control.Lens ((%~)) import Data.Generics.Labels () import Distribution.Pretty (Pretty (pretty))-import Distribution.Version (removeLowerBound) import Text.PrettyPrint (hang, ($+$)) -import Hix.Class.Map (nAmend, nMap)+import Hix.Class.Map (nAmend, nMap, (!!))+import Hix.Data.Bounds (Bounds) import Hix.Data.VersionBounds (majorRange)-import qualified Hix.Managed.Data.ManagedPackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage (ManagedPackage))-import Hix.Managed.Data.Mutable (MutableBounds)+import Hix.Managed.Data.ManagedPackage (ProjectPackages) import Hix.Managed.Data.Packages (Packages) import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext)-import qualified Hix.Managed.Data.ProjectState-import Hix.Managed.Data.ProjectState (ProjectState)+import Hix.Managed.Data.ProjectState (ProjectState (..))+import Hix.Managed.ManagedPackage (removeLowerBounds, updateRanges) data ProcessState = ProcessState {- packages :: Packages ManagedPackage,+ packages :: ProjectPackages, state :: ProjectState } deriving stock (Eq, Show, Generic) instance Pretty ProcessState where pretty ProcessState {..} =- hang "packages:" 2 (pretty packages) $+$ hang "state:" 2 (pretty state)+ hang "packages:" 2 (pretty packages)+ $+$+ hang "state:" 2 (pretty state) --- TODO Check that this is sound.--- We simply replace the deps in the packages with the updated bounds.--- These are used only for the installed-package-db, so the solver can propagate bounds from local deps.--- However, before conversion from ManagedPackageProto, these deps are completely unrelated, and supposed to be used as--- additional solver bounds.--- So we have to extract those into a separate bin at that point, and wipe the bounds when constructing ManagedPackage,--- and then replacing them by the managed bounds if they already exist.-updateManagedPackages :: Packages MutableBounds -> Packages ManagedPackage -> Packages ManagedPackage+updateManagedPackages :: Packages Bounds -> ProjectPackages -> ProjectPackages updateManagedPackages =- nAmend \ bounds ManagedPackage {..} -> ManagedPackage {mutable = nMap majorRange bounds, ..}--removeLowerBounds :: ManagedPackage -> ManagedPackage-removeLowerBounds =- #mutable %~ nMap removeLowerBound+ nAmend \ bounds ->+ updateRanges \ package original ->+ maybe original majorRange (bounds !! package) --- | We remove lower bounds because they are likely to interfere with LowerInit, but upper bounds are useful.+-- | 1. Remove lower bounds from the package configs, leave the upper bounds.+-- These are from the flake's unmanaged dependencies, so they should only be used when there is no better+-- information available, i.e. managed dependencies from prior runs.+-- 2. Replace bounds in the package configs entirely with managed bounds if they exist.+-- This ensures that Cabal sees managed bounds for local packages instead of stray flake config bounds.+--+-- The package configs are used to populate Cabal's source package DB with fallbacks for local packages in case they+-- don't exist in other DBs.+--+-- TODO Review – this may be obsolete. initProcessState :: ProjectContext -> ProcessState initProcessState context = ProcessState {
lib/Hix/Managed/Data/ProjectContext.hs view
@@ -1,17 +1,18 @@ module Hix.Managed.Data.ProjectContext where import Hix.Data.EnvName (EnvName)+import Hix.Managed.Cabal.Data.Config (CabalConfig) import Hix.Managed.Data.BuildConfig (BuildConfig) import Hix.Managed.Data.EnvContext (EnvContext)-import Hix.Managed.Data.ManagedPackage (ManagedPackage)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages) import Hix.Managed.Data.ProjectState (ProjectState) data ProjectContext = ProjectContext { build :: BuildConfig, state :: ProjectState,- packages :: Packages ManagedPackage,- envs :: NonEmpty (Either EnvName EnvContext)+ packages :: ProjectPackages,+ envs :: NonEmpty (Either EnvName EnvContext),+ cabal :: CabalConfig } deriving stock (Eq, Show)
lib/Hix/Managed/Data/ProjectContextProto.hs view
@@ -2,19 +2,21 @@ import Data.Aeson (FromJSON) +import Hix.Class.Map (nGet)+import Hix.Managed.Cabal.Data.ContextHackageRepo (ContextHackageRepo)+import Hix.Managed.Cabal.Data.HackageRepo (HackageName) import Hix.Managed.Data.EnvConfig (EnvConfig) import Hix.Managed.Data.Envs (Envs)-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages) import Hix.Managed.Data.ProjectStateProto (ProjectStateProto)-import Hix.Managed.Handlers.Build (BuildOutputsPrefix)+import Hix.Pretty (HPretty (hpretty), field, prettyMap) data ProjectContextProto = ProjectContextProto {- packages :: Packages ManagedPackageProto,+ packages :: ProjectPackages, state :: ProjectStateProto, envs :: Envs EnvConfig,- buildOutputsPrefix :: Maybe BuildOutputsPrefix+ hackage :: Map HackageName ContextHackageRepo } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON)@@ -25,5 +27,14 @@ packages = mempty, state = def, envs = mempty,- buildOutputsPrefix = Nothing+ hackage = mempty }++instance HPretty ProjectContextProto where+ hpretty ProjectContextProto {..} =+ prettyMap "project context" [+ field "packages" packages,+ field "state" state,+ field "envs" (nGet envs),+ field "hackage" hackage+ ]
lib/Hix/Managed/Data/ProjectState.hs view
@@ -4,17 +4,19 @@ import Text.PrettyPrint (hang, ($+$)) import Hix.Class.EncodeNix (EncodeNix)+import Hix.Data.Bounds (Bounds) import Hix.Data.Overrides (Overrides) import Hix.Managed.Data.Envs (Envs)-import Hix.Managed.Data.Mutable (MutableBounds, MutableVersions)+import Hix.Managed.Data.Mutable (MutableVersions) import Hix.Managed.Data.Packages (Packages) data ProjectState = ProjectState {- bounds :: Packages MutableBounds,+ bounds :: Packages Bounds, versions :: Envs MutableVersions, initial :: Envs MutableVersions, overrides :: Envs Overrides,+ solver :: Envs Overrides, resolving :: Bool } deriving stock (Eq, Show, Generic)@@ -25,7 +27,16 @@ hang "bounds:" 2 (pretty bounds) $+$ hang "versions:" 2 (pretty versions) $+$ hang "initial:" 2 (pretty initial) $+$- hang "overrides:" 2 (pretty overrides)+ hang "overrides:" 2 (pretty overrides) $+$+ hang "solver:" 2 (pretty solver) instance Default ProjectState where- def = ProjectState {bounds = mempty, versions = mempty, overrides = mempty, initial = mempty, resolving = False}+ def =+ ProjectState {+ bounds = mempty,+ versions = mempty,+ initial = mempty,+ overrides = mempty,+ solver = mempty,+ resolving = False+ }
lib/Hix/Managed/Data/ProjectStateProto.hs view
@@ -16,8 +16,9 @@ ProjectStateProto { bounds :: Packages Bounds, versions :: Envs Versions,- overrides :: Envs Overrides, initial :: Envs Versions,+ overrides :: Envs Overrides,+ solver :: Envs Overrides, resolving :: Bool } deriving stock (Eq, Show, Generic)@@ -27,15 +28,17 @@ pretty ProjectStateProto {..} = hang "bounds:" 2 (pretty bounds) $+$ hang "versions:" 2 (pretty versions) $+$+ hang "initial:" 2 (pretty initial) $+$ hang "overrides:" 2 (pretty overrides) $+$- hang "initial:" 2 (pretty initial)+ hang "solver:" 2 (pretty solver) instance FromJSON ProjectStateProto where parseJSON = withObject "ProjectStateProto" \ o -> do bounds <- foldMissing o "bounds" versions <- foldMissing o "versions"- overrides <- foldMissing o "overrides" initial <- foldMissing o "initial"+ overrides <- foldMissing o "overrides"+ solver <- foldMissing o "solver" resolving <- fromMaybe False <$> o .:? "resolving" pure ProjectStateProto {..} @@ -44,7 +47,8 @@ ProjectStateProto { bounds = mempty, versions = mempty,- overrides = mempty, initial = mempty,+ overrides = mempty,+ solver = mempty, resolving = False }
+ lib/Hix/Managed/Data/RevisionConfig.hs view
@@ -0,0 +1,22 @@+module Hix.Managed.Data.RevisionConfig where++import Hix.Data.PackageName (PackageName)+import Hix.Managed.Git (BranchName)++data RevisionConfig =+ RevisionConfig {+ targets :: Maybe (NonEmpty (Either PackageName BranchName)),+ -- | Fetch tags and branches.+ fetch :: Bool,+ -- | Use the global git config rather than a synthetic committer ID (hix@tryp.io).+ globalGit :: Bool+ }+ deriving stock (Eq, Show)++instance Default RevisionConfig where+ def =+ RevisionConfig {+ targets = Nothing,+ fetch = False,+ globalGit = False+ }
+ lib/Hix/Managed/Data/SpecialMaintHandlers.hs view
@@ -0,0 +1,5 @@+module Hix.Managed.Data.SpecialMaintHandlers where++data SpecialMaintHandlers =+ MaintHandlersTestMaint+ deriving stock (Eq, Show)
lib/Hix/Managed/Data/StageContext.hs view
@@ -2,7 +2,7 @@ import Hix.Managed.Data.EnvContext (EnvContext) import Hix.Managed.Data.Initial (Initial)-import Hix.Managed.Data.Mutable (MutableVersions)+import Hix.Managed.Data.Mutable (MutableBounds, MutableVersions) import Hix.Managed.Data.MutationState (MutationState) import Hix.Managed.Data.Query (Query) import Hix.Managed.Handlers.Build (EnvBuilder)@@ -13,5 +13,6 @@ builder :: EnvBuilder, state :: Initial MutationState, query :: Query,- initial :: MutableVersions+ initialVersions :: MutableVersions,+ initialBounds :: MutableBounds }
lib/Hix/Managed/Data/StageState.hs view
@@ -1,13 +1,18 @@ module Hix.Managed.Data.StageState where +import Distribution.Pretty (Pretty (pretty))+import Text.PrettyPrint (brackets, hang, vcat, (<+>))++import Hix.Data.Error (Error) import Hix.Data.PackageId (PackageId)-import Hix.Managed.Build.NixOutput (PackageDerivation) import Hix.Managed.Data.Initial (Initial (Initial)) import Hix.Managed.Data.Mutable (MutableDep) import qualified Hix.Managed.Data.MutableId import Hix.Managed.Data.MutableId (MutableId (MutableId)) import Hix.Managed.Data.Mutation (DepMutation) import Hix.Managed.Data.MutationState (MutationState)+import Hix.Managed.Data.NixOutput (PackageDerivation)+import Hix.Pretty (prettyL, prettyText) data BuildStatus = Success@@ -21,32 +26,50 @@ Failure -> Nothing data BuildFailure =+ AppFailure Error+ | UnknownFailure |+ UnexpectedFailure (NonEmpty Text)+ | PackageFailure (NonEmpty PackageDerivation) | TimeoutFailure [PackageId] deriving stock (Eq, Show, Generic) +instance Pretty BuildFailure where+ pretty = \case+ AppFailure err -> "App failure:" <+> pretty err+ UnknownFailure -> "Unknown failure"+ UnexpectedFailure msgs -> hang "Unexpected failure:" 2 (vcat (prettyText <$> toList msgs))+ PackageFailure drvs -> "Package failures in" <+> prettyL drvs+ TimeoutFailure pkgs -> "Timeout failure, active builds:" <+> prettyL pkgs+ data BuildResult =- BuildSuccess+ BuildSuccess [Text] | BuildFailure BuildFailure deriving stock (Eq, Show, Generic) +instance Pretty BuildResult where+ pretty = \case+ BuildSuccess [line] -> "Success" <+> brackets (prettyText line)+ BuildSuccess _ -> "Success"+ BuildFailure f -> pretty f+ buildUnsuccessful :: BuildResult -> Bool buildUnsuccessful = \case- BuildSuccess -> False+ BuildSuccess _ -> False BuildFailure _ -> True buildStatus :: BuildResult -> BuildStatus buildStatus = \case- BuildSuccess -> Success+ BuildSuccess _ -> Success BuildFailure _ -> Failure resultFromStatus :: BuildStatus -> BuildResult resultFromStatus = \case- Success -> BuildSuccess+ Success -> BuildSuccess [] Failure -> BuildFailure UnknownFailure data BuildSuccess =@@ -71,12 +94,11 @@ success :: Map MutableDep BuildSuccess, failed :: [DepMutation a], state :: MutationState,- revisions :: Set PackageId,- iterations :: Natural,+ iterations :: Word, ext :: s } deriving stock (Eq, Show) initStageState :: Initial MutationState -> s -> StageState a s initStageState (Initial state) ext =- StageState {success = [], failed = [], revisions = [], iterations = 0, ..}+ StageState {success = [], failed = [], iterations = 0, ..}
lib/Hix/Managed/Data/StateFileConfig.hs view
@@ -1,17 +1,24 @@ module Hix.Managed.Data.StateFileConfig where -import Path (Abs, Dir, File, Path, Rel, relfile)+import Path (File, Path, Rel, relfile) +import Distribution.Pretty (Pretty (pretty))+import Hix.Pretty (prettyMap, field)+ data StateFileConfig = StateFileConfig {- file :: Path Rel File,- projectRoot :: Maybe (Path Abs Dir)+ file :: Path Rel File } deriving stock (Eq, Show, Generic) +instance Pretty StateFileConfig where+ pretty StateFileConfig {..} =+ prettyMap "state file" [+ field "file" file+ ]+ instance Default StateFileConfig where def = StateFileConfig {- file = [relfile|ops/managed.nix|],- projectRoot = Nothing+ file = [relfile|ops/managed.nix|] }
lib/Hix/Managed/Data/Targets.hs view
@@ -1,31 +1,21 @@ module Hix.Managed.Data.Targets ( Targets (Targets), unsafeTargets,- getTargets,- targetsSet, singleTarget,+ unsortedTargets, sortTargets,- allMTargets, firstMTargets,- overTargets, ) where -import Data.Aeson (FromJSON, FromJSONKey)-import Data.Foldable.Extra (allM) import Data.Graph (Graph, Vertex, graphFromEdges, reverseTopSort) import qualified Data.Map.Strict as Map import qualified Data.Set as Set-import Distribution.Pretty (Pretty)+import Distribution.Pretty (Pretty (pretty)) -import Hix.Class.EncodeNix (EncodeNixKey)-import Hix.Class.Map (nGet, nMap, nMapWithKey, nRestrictKeys)-import Hix.Data.PackageName (LocalPackage (LocalPackage))+import Hix.Class.Map (nGet, nMap, nRestrictKeys)+import Hix.Data.PackageName (LocalPackage, PackageName, toLocalPackage) import Hix.Managed.Data.Packages (Packages)--newtype EnvMember =- EnvMember LocalPackage- deriving stock (Eq, Show, Generic)- deriving newtype (IsString, Ord, FromJSON, FromJSONKey, Pretty, EncodeNixKey)+import Hix.Pretty (prettyL) newtype Targets = UnsafeTargets [LocalPackage]@@ -45,46 +35,47 @@ instance IsString Targets where fromString = singleTarget . fromString -getTargets :: Targets -> [LocalPackage]-getTargets (Targets pkgs) = pkgs+instance Pretty Targets where+ pretty (Targets ps) = prettyL ps -targetsSet :: Targets -> Set LocalPackage-targetsSet (Targets targets) =- Set.fromList targets+unsortedTargets :: Targets -> Set LocalPackage+unsortedTargets (Targets targets) = Set.fromList targets graph :: Map LocalPackage [LocalPackage] -> (Graph, Vertex -> (LocalPackage, LocalPackage, [LocalPackage]), LocalPackage -> Maybe Vertex) graph deps =- graphFromEdges keyAssoc- where- keyAssoc = Map.toList deps <&> \ (p, ds) -> (p, p, ds)+ graphFromEdges [(p, p, ds) | (p, ds) <- Map.toList deps] -onlyFrom :: Set LocalPackage -> [LocalPackage] -> [LocalPackage]-onlyFrom targets deps =- mapMaybe isTarget deps- where- isTarget = \case- dep | Set.member dep targets -> Just dep- _ -> Nothing+onlyFrom :: Set LocalPackage -> [PackageName] -> [LocalPackage]+onlyFrom targets = mapMaybe (toLocalPackage targets) sortTargets ::- Packages [LocalPackage] ->+ Packages [PackageName] -> [LocalPackage] -> Targets sortTargets deps targets = UnsafeTargets (reverseTopSort g <&> \ v -> let (n, _, _) = get v in n) where (g, get, _) = graph (nGet simple)+ simple :: Packages [LocalPackage] simple = nMap (onlyFrom targetSet) (nRestrictKeys targetSet deps)+ targetSet = Set.fromList targets +-- | Run the computation for each target in topological order, aborting and returning the computation's result if it+-- meets the error condition.+-- If all computations succeed, return the success value. firstMTargets :: Monad m =>+ -- | Success value. a ->+ -- | Error condition. (a -> Bool) ->+ -- | Computation. (LocalPackage -> m a) ->+ -- | Iteration sequence targets. Targets -> m a firstMTargets success cond f (Targets targets) =@@ -95,21 +86,3 @@ if cond res then pure res else z--allMTargets ::- Monad m =>- (LocalPackage -> m Bool) ->- Targets ->- m Bool-allMTargets f (Targets targets) =- allM f targets--overTargets :: Targets -> (a -> a) -> Packages a -> Packages a-overTargets (targetsSet -> targets) f =- nMapWithKey checked- where- checked package a- | Set.member package targets- = f a- | otherwise- = a
lib/Hix/Managed/Diff.hs view
@@ -3,7 +3,7 @@ import Hix.Class.Map (NMap, nAmend, nMap) import Hix.Data.Version (Version) import qualified Hix.Data.VersionBounds-import Hix.Data.VersionBounds (anyBounds, VersionBounds)+import Hix.Data.VersionBounds (VersionBounds, anyBounds, updateWithCorrection) import Hix.Managed.Data.Diff (BoundsChange, BoundsDiffDetail (..), Change (..), Diff (..), VersionChange) import Hix.Managed.Data.Mutable (MutableBounds, MutableDep, MutableDeps, MutableVersions) import Hix.These (maybeThese)@@ -97,7 +97,7 @@ where diffL = versionDiff original.lower combined.lower diffU = versionDiff original.upper combined.upper- combined = new <> original+ combined = updateWithCorrection new original boundsChange :: VersionBounds -> VersionBounds -> BoundsChange boundsChange = diff boundsDiffDetail@@ -113,7 +113,7 @@ diffMaybe boundsDiffDetail original (Just combined) where (original, combined) = case changeOriginal d of- Just o -> (Just o, new <> o)+ Just o -> (Just o, updateWithCorrection new o) Nothing -> (Nothing, new) updateVersionChanges ::
lib/Hix/Managed/EnvContext.hs view
@@ -1,7 +1,5 @@ module Hix.Managed.EnvContext where -import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Set as Set import Exon (exon) import Hix.Class.Map (nKeysSet, nMapWithKey)@@ -9,15 +7,15 @@ import Hix.Data.Monad (M) import qualified Hix.Data.Options import Hix.Data.Options (ProjectOptions)-import Hix.Data.PackageName (LocalPackage)+import Hix.Data.PackageName (LocalPackage, PackageName) import qualified Hix.Managed.Data.EnvConfig import Hix.Managed.Data.EnvConfig (EnvConfig) import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvContext (EnvContext), EnvDeps (EnvDeps)) import Hix.Managed.Data.Envs (Envs)-import Hix.Managed.Data.ManagedPackage (ManagedPackage)-import Hix.Managed.Data.Mutable (MutableDep, mutRelax)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages)+import qualified Hix.Managed.Data.Mutable as Mutable+import Hix.Managed.Data.Mutable (mutRelax) import qualified Hix.Managed.ManagedPackage as ManagedPackage import Hix.Monad (clientError) import Hix.Pretty (showPL)@@ -33,10 +31,13 @@ (number, verb) | [_] <- missing = ("a package", "isn't") | otherwise = ("several packages", "aren't") +-- | If @envQuery@ is empty, return @Left EnvDeps@, so subsequent steps can be skipped.+-- This happens when the env has no mutable dependencies or if the user restricted the packages to be processed to+-- consist solely of dependencies of other managed sets. envContext :: ProjectOptions ->- Packages ManagedPackage ->- Maybe (NonEmpty MutableDep) ->+ ProjectPackages ->+ Maybe (NonEmpty PackageName) -> EnvName -> EnvConfig -> Either EnvDeps EnvContext@@ -45,24 +46,25 @@ where create query = EnvContext {ghc = envConfig.ghc, query, deps, ..} - deps = EnvDeps {local, mutable}+ deps = EnvDeps {mutable} solverBounds | opts.mergeBounds = mutRelax mutableDeps | otherwise = mempty - envQuery = maybe (toList mutable) (NonEmpty.filter (flip Set.member mutable)) querySpec-- local = nKeysSet localDeps+ -- If the user hasn't specified explicit restrictions, process all dependencies.+ -- Otherwise, filter out dependencies that aren't part of this env.+ envQuery = maybe (toList mutable) (mapMaybe (Mutable.validate mutable) . toList) querySpec mutable = nKeysSet mutableDeps - (targets, localDeps, mutableDeps) = ManagedPackage.forTargets packages envConfig.targets+ (targets, mutableDeps) = ManagedPackage.forTargets packages envConfig.targets +-- TODO at some point we might wanna check that the target sets are disjoint envContexts :: ProjectOptions ->- Packages ManagedPackage ->+ ProjectPackages -> Envs EnvConfig ->- Maybe (NonEmpty MutableDep) ->- M (Envs (Either EnvDeps EnvContext))-envContexts opts packages envConfigs query = do- pure (nMapWithKey (envContext opts packages query) envConfigs)+ Maybe (NonEmpty PackageName) ->+ Envs (Either EnvDeps EnvContext)+envContexts opts packages envConfigs query =+ nMapWithKey (envContext opts packages query) envConfigs
lib/Hix/Managed/EnvRequest.hs view
@@ -1,15 +1,15 @@ module Hix.Managed.EnvRequest where -import Control.Lens ((%~)) import Distribution.Pretty (pretty) import Exon (exon) -import Hix.Class.Map (nFlatten, nMap, nRestrictKeys, (!!))+import Hix.Class.Map (nFlatten, nMap, (!!))+import Hix.Data.Bounds (Ranges) import Hix.Data.EnvName (EnvName) import Hix.Data.Monad (M) import Hix.Data.VersionBounds (majorRange) import qualified Hix.Log as Log-import Hix.Managed.Data.Diff (Change (Unchanged))+import Hix.Managed.Data.Diff (BoundsChange, Change (Unchanged)) import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvContext) import qualified Hix.Managed.Data.EnvRequest@@ -19,15 +19,18 @@ import qualified Hix.Managed.Data.EnvState import Hix.Managed.Data.EnvState (EnvState (EnvState)) import Hix.Managed.Data.Initial (Initial (Initial))-import Hix.Managed.Data.Mutable (mutReplace)+import qualified Hix.Managed.Data.Mutable as Mutable+import Hix.Managed.Data.Mutable (MutableBounds, MutableDeps, MutableRanges, mutRelax)+import Hix.Managed.Data.Packages (Packages) import qualified Hix.Managed.Data.ProcessState import Hix.Managed.Data.ProcessState (ProcessState (ProcessState)) import qualified Hix.Managed.Data.ProjectState import Hix.Managed.Data.ProjectState (ProjectState)-import Hix.Managed.Data.Targets (overTargets, targetsSet) import Hix.Managed.Diff (initChanges, reifyBoundsChange) import qualified Hix.Managed.Handlers.Build-import Hix.Managed.Handlers.Build (BuildHandlers, Builder, runBuilder)+import Hix.Managed.Handlers.Build (BuildHandlers, Builder, EnvBuilderContext (..), runBuilder)+import Hix.Managed.ManagedPackage (updateRanges)+import Hix.Managed.Targets (overTargets) import Hix.Managed.UpdateState (projectStateWithEnv) initialEnvState ::@@ -37,9 +40,21 @@ initialEnvState context projectState = Initial EnvState {..} where- bounds = nFlatten (Unchanged . Just) (nRestrictKeys (targetsSet context.targets) projectState.bounds)+ bounds :: MutableDeps BoundsChange+ bounds = nFlatten (Unchanged . Just) mutableBounds++ -- TODO this has the consequence that after this env is done, only the mutable bounds will be written to the state,+ -- deleting any local deps.+ -- This is due to the principle I established at some point that the state should _always_ contain all dependencies.+ mutableBounds :: Packages MutableBounds+ mutableBounds = Mutable.forTargets context.targets projectState.bounds+ versions = initChanges (projectState.versions !! context.env)+ overrides = projectState.overrides !! context.env++ solver = projectState.solver !! context.env+ initial = initChanges (projectState.initial !! context.env) updateProcessState ::@@ -48,14 +63,15 @@ EnvResult -> ProcessState -> ProcessState-updateProcessState context (Initial initialState) envResult ProcessState {state = projectState, packages} = do+updateProcessState context (Initial initialState) envResult ProcessState {packages, state = projectState} = do ProcessState { packages = overTargets context.targets replaceBounds packages, state = projectStateWithEnv context final projectState } where- replaceBounds = #mutable %~ mutReplace ranges- ranges = nMap (majorRange . reifyBoundsChange) final.bounds+ replaceBounds = updateRanges \ package original -> fromMaybe original (ranges !! package)+ ranges :: Ranges+ ranges = mutRelax (nMap (majorRange . reifyBoundsChange) final.bounds :: MutableRanges) final = fromMaybe initialState envResult.state withEnvRequest ::@@ -65,13 +81,16 @@ Builder -> (EnvRequest -> M EnvResult) -> M (ProcessState, EnvResult)-withEnvRequest build state context builder use = do- cabal <- build.cabal state.packages context.ghc- envResult <- runBuilder builder cabal context initialState \ envBuilder ->- use EnvRequest {context, builder = envBuilder, state = initialState}- let newState = updateProcessState context initialState envResult state+withEnvRequest build processState context@env builder use = do+ envResult <- runBuilder builder envBuilderContext \ envBuilder state ->+ use EnvRequest {context, builder = envBuilder, state}+ let newState = updateProcessState context initialState envResult processState Log.debug [exon|Finished '##{context.env :: EnvName}' with final state:|] Log.debugP (pretty newState) pure (newState, envResult) where- initialState = initialEnvState context state.state+ envBuilderContext = EnvBuilderContext {..}++ initCabal = build.cabal processState.packages++ initialState = initialEnvState context processState.state
+ lib/Hix/Managed/Flake.hs view
@@ -0,0 +1,102 @@+module Hix.Managed.Flake where++import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON)+import qualified Data.ByteString.Char8 as ByteString+import Exon (exon)+import Path (Abs, Dir, Path, toFilePath)+import System.Exit (ExitCode (ExitFailure, ExitSuccess))+import System.Process.Typed (ProcessConfig, proc, readProcess, setWorkingDir)++import Hix.Data.Monad (M)+import qualified Hix.Log as Log+import Hix.Monad (eitherFatal)+import qualified Hix.Color as Color++outLines :: ([ByteString] -> a) -> ByteString -> a+outLines f bs = f (ByteString.lines bs)++runFlakeFor ::+ ∀ a stdin stdout stderr .+ (ByteString -> Either Text a) ->+ (ByteString -> Either Text a) ->+ Text ->+ Path Abs Dir ->+ [Text] ->+ (ProcessConfig () () () -> ProcessConfig stdin stdout stderr) ->+ M a+runFlakeFor processOutput processError desc cwd args confProc = do+ Log.debug [exon|Running flake: #{Color.shellCommand (unwords args)}|]+ readProcess conf >>= \case+ (ExitSuccess, stdout, _) ->+ eitherFatal (first decodeError (processOutput (toStrict stdout)))+ (ExitFailure {}, _, stderr) ->+ eitherFatal (first failureError (processError (toStrict stderr)))+ where+ conf =+ confProc $+ setWorkingDir (toFilePath cwd) $+ proc "nix" (toString <$> args)++ decodeError msg = [exon|#{desc} produced invalid output: #{msg}|]+ failureError msg = [exon|#{desc} terminated with error: #{msg}|]++flakeFailure :: ByteString -> Either Text a+flakeFailure stderr = Left [exon|stderr: #{decodeUtf8 stderr}|]++runFlake ::+ ∀ a stdin stdout stderr .+ FromJSON a =>+ Text ->+ Path Abs Dir ->+ [Text] ->+ (ProcessConfig () () () -> ProcessConfig stdin stdout stderr) ->+ M a+runFlake =+ runFlakeFor success flakeFailure+ where+ success stdout = first toText (Aeson.eitherDecodeStrict' stdout)++runFlakeForSingleLine ::+ ∀ stdin stdout stderr .+ Text ->+ Path Abs Dir ->+ [Text] ->+ (ProcessConfig () () () -> ProcessConfig stdin stdout stderr) ->+ M ByteString+runFlakeForSingleLine =+ runFlakeFor success flakeFailure+ where+ success stdout = case ByteString.lines stdout of+ [ln] -> Right ln+ lns -> Left [exon|Expected a single line of output, got #{show (length lns)}|]++runFlakeRaw ::+ ∀ stdin stdout stderr .+ Text ->+ Path Abs Dir ->+ [Text] ->+ (ProcessConfig () () () -> ProcessConfig stdin stdout stderr) ->+ M ByteString+runFlakeRaw =+ runFlakeFor Right flakeFailure++runFlakeSimple ::+ Text ->+ Path Abs Dir ->+ [Text] ->+ M ()+runFlakeSimple desc cwd args =+ runFlakeFor (const unit) (const unit) desc cwd (["--quiet", "--quiet", "--quiet"] ++ args) id++runFlakeLock :: Path Abs Dir -> M ()+runFlakeLock cwd =+ runFlakeSimple "create lock file" cwd ["flake", "lock"]++runFlakeGen :: Path Abs Dir -> M ()+runFlakeGen cwd =+ runFlakeSimple "generate Cabal and overrides" cwd ["run", ".#gen"]++runFlakeGenCabal :: Path Abs Dir -> M ()+runFlakeGenCabal cwd =+ runFlakeSimple "generate Cabal" cwd ["run", ".#gen-cabal-quiet"]
lib/Hix/Managed/Flow.hs view
@@ -20,9 +20,8 @@ import qualified Data.Text as Text import Exon (exon) -import Hix.Data.Error (Error (Fatal))+import Hix.Data.Error (ErrorMessage (Fatal)) import Hix.Data.Monad (M)-import qualified Hix.Log as Log import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvContext (EnvContext)) import qualified Hix.Managed.Data.EnvRequest@@ -36,7 +35,7 @@ import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) import Hix.Managed.StageContext (stageContext) import Hix.Managed.UpdateState (envStateWithMutations)-import Hix.Monad (throwM)+import Hix.Monad (appContext, throwM) data FlowState = FlowState {@@ -79,11 +78,13 @@ (StageContext -> M (StageResult, o)) -> Flow (BuildStatus, o) runStage description stage = do- unless (Text.null description) do- EnvRequest {context = EnvContext {env}} <- Flow (gets (.env))- liftM (Log.debug [exon|Executing stage '#{description}' for '##{env}'|])+ EnvRequest {context = EnvContext {env}} <- Flow (gets (.env))+ let+ desc = if Text.null description then "unnamed stage" else [exon|stage '#{description}'|]+ contextMessage = [exon|executing #{desc} for '##{env}'|] context <- newContext- (result, o) <- liftM (stage context)+ (result, o) <- liftM $ appContext contextMessage do+ stage context status <- addResult result pure (status, o)
+ lib/Hix/Managed/Git.hs view
@@ -0,0 +1,267 @@+module Hix.Managed.Git where++import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Text as Text+import Distribution.Compat.CharParsing (string, try)+import Distribution.Parsec (Parsec (parsec))+import Distribution.Pretty (Pretty, pretty)+import Exon (exon)+import GHC.IsList (IsList (..))+import Path (Abs, Dir, Path, toFilePath)+import System.Exit (ExitCode (ExitFailure, ExitSuccess))+import System.Process.Typed (proc, readProcess, setEnv, setWorkingDir)+import Text.PrettyPrint (text)++import Hix.Class.Map (LookupMaybe, NMap, nTo)+import qualified Hix.Color as Color+import Hix.Data.Monad (M)+import Hix.Data.PackageId (PackageId (..))+import qualified Hix.Data.PackageName as PackageName+import Hix.Data.PackageName (LocalPackage (..))+import Hix.Data.Version (Version)+import Hix.Error (pathText)+import Hix.Monad (appContextDebug, fatalError, tryIOM, withTempDir)+import Hix.Pretty (prettyNt)++data ProcessResult =+ ProcessResult {+ code :: ExitCode,+ stdout :: [Text],+ stderr :: [Text]+ }+ deriving stock (Eq, Show, Generic)++newtype EnvKey =+ EnvKey Text+ deriving stock (Eq, Show)+ deriving newtype (IsString, ToString, Ord)++instance Pretty EnvKey where+ pretty = text . toString++newtype EnvVal =+ EnvVal Text+ deriving stock (Eq, Show)+ deriving newtype (IsString, ToString, Ord)++instance Pretty EnvVal where+ pretty = text . toString++newtype EnvVars =+ EnvVars (Map EnvKey EnvVal)+ deriving stock (Eq, Show)+ deriving newtype (IsList, Semigroup, Monoid)++instance NMap EnvVars EnvKey EnvVal LookupMaybe where++data GitCmd =+ GitCmd {+ repo :: Path Abs Dir,+ args :: [Text]+ }+ deriving stock (Eq, Show)++data GitResult =+ GitSuccess { stdout :: [Text] }+ |+ GitFailure { code :: Int, stdout :: [Text], stderr :: [Text] }+ deriving stock (Eq, Show)++gitProcess :: EnvVars -> GitCmd -> M ProcessResult+gitProcess env GitCmd {repo, args} = do+ appContextDebug [exon|running process #{Color.shellCommand cmdline}|] do+ result <$> tryIOM (readProcess conf)+ where+ conf = setEnv envString $ setWorkingDir (toFilePath repo) (proc "git" (toString <$> args))+ result (code, stdout, stderr) =+ ProcessResult {+ code,+ stdout = Text.lines (decodeUtf8 stdout),+ stderr = Text.lines (decodeUtf8 stderr)+ }++ envString = nTo env \ k v -> (toString k, toString v)++ cmdline = [exon|git #{Text.unwords args}|]++gitExec :: EnvVars -> GitCmd -> M GitResult+gitExec env cmd =+ gitProcess env cmd <&> \case+ ProcessResult {code, stdout, stderr}+ | ExitSuccess <- code+ -> GitSuccess stdout+ | ExitFailure number <- code+ -> GitFailure {code = number, stdout, stderr}++data GitBackend =+ GitBackend {+ exec :: GitCmd -> M GitResult+ }++data GitEnv =+ GitEnv {+ backend :: GitBackend,+ repo :: Path Abs Dir+ }++newtype GitApi api =+ GitApi { run :: ∀ a . Path Abs Dir -> (api -> M a) -> M a }++runGitApi ::+ GitApi api ->+ Path Abs Dir ->+ Text ->+ (api -> M a) ->+ M a+runGitApi (GitApi run) repo ctx use =+ run repo \ api ->+ appContextDebug [exon|operating on a git repo (#{ctx}) at #{Color.path (pathText repo)}|] do+ use api++gitCmdResult :: GitEnv -> [Text] -> M GitResult+gitCmdResult GitEnv {backend, repo} args =+ backend.exec GitCmd {repo, args}++gitCmd' :: GitEnv -> [Text] -> M (Either ([Text], [Text]) [Text])+gitCmd' env args = do+ gitCmdResult env args <&> \case+ GitSuccess {stdout} -> Right stdout+ GitFailure {stdout, stderr} -> Left (stdout, stderr)++gitError ::+ [Text] ->+ [Text] ->+ [Text] ->+ Text+gitError args stdout stderr =+ [exon|Git command failed: git #{Text.unwords args}+stdout:+#{Text.intercalate "\n" stdout}+stderr:+#{Text.intercalate "\n" stderr}|]++gitCmd :: GitEnv -> [Text] -> M [Text]+gitCmd env args =+ gitCmd' env args >>= \case+ Right stdout ->+ pure stdout+ Left (stderr, stdout) ->+ fatalError (gitError args stdout stderr)++gitCmd_ :: GitEnv -> [Text] -> M ()+gitCmd_ env = void . gitCmd env++data GitNative =+ GitNative {+ cmdResult :: [Text] -> M GitResult,+ cmd' :: [Text] -> M (Either ([Text], [Text]) [Text]),+ cmd :: [Text] -> M [Text],+ cmd_ :: [Text] -> M (),+ repo :: Path Abs Dir+ }++gitNative :: GitEnv -> GitNative+gitNative env =+ GitNative {+ cmdResult = gitCmdResult env,+ cmd' = gitCmd' env,+ cmd = gitCmd env,+ cmd_ = gitCmd_ env,+ repo = env.repo+ }++gitApiWithNativeEnv :: (GitEnv -> api) -> GitApi api+gitApiWithNativeEnv api =+ GitApi \ repo f -> f (api GitEnv {backend = GitBackend {exec = gitExec mempty}, repo})++gitApi :: (GitNative -> api) -> GitApi api+gitApi api =+ GitApi \ repo f -> f (api (gitNative GitEnv {backend = GitBackend {exec = gitExec mempty}, repo}))++gitApiNative :: GitApi GitNative+gitApiNative = gitApi id++-- TODO allow configuring the user data, especially for CI+gitEnvHermetic :: Path Abs Dir -> Path Abs Dir -> GitEnv+gitEnvHermetic home repo =+ GitEnv {backend = GitBackend {exec = gitExec env}, repo}+ where+ env =+ [+ ("HOME", coerce (pathText home)),+ ("GIT_CONFIG_NOSYSTEM", "1"),+ ("GIT_AUTHOR_NAME", "hix"),+ ("GIT_AUTHOR_EMAIL", "hix@tryp.io"),+ ("GIT_COMMITTER_NAME", "hix"),+ ("GIT_COMMITTER_EMAIL", "hix@tryp.io")+ ]++gitHermetic :: Path Abs Dir -> Path Abs Dir -> GitNative+gitHermetic home repo = gitNative (gitEnvHermetic home repo)++gitApiHermetic :: (GitNative -> api) -> GitApi api+gitApiHermetic consApi =+ GitApi \ repo f ->+ withTempDir "git-home" \ home ->+ f (consApi (gitNative (gitEnvHermetic home repo)))++gitApiNativeHermetic :: GitApi GitNative+gitApiNativeHermetic = gitApiHermetic id++runGitNative :: Path Abs Dir -> Text -> (GitNative -> M a) -> M a+runGitNative = runGitApi gitApiNative++runGitNativeHermetic :: Path Abs Dir -> Text -> (GitNative -> M a) -> M a+runGitNativeHermetic = runGitApi gitApiNativeHermetic++data Tag =+ Tag {+ package :: Maybe LocalPackage,+ version :: Version+ }+ deriving stock (Eq, Show, Generic)++instance Ord Tag where+ compare Tag {package = pl, version = vl} Tag {package = pr, version = vr} =+ compare pl pr <> compare vl vr++instance Parsec Tag where+ parsec =+ try (withPackage <$> parsec) <|> (Tag Nothing <$> parsec)+ where+ withPackage PackageId {..} = Tag (Just (LocalPackage name)) version++instance Pretty Tag where+ pretty Tag {package, version}+ | Just p <- package+ = [exon|#{pretty p}-#{pretty version}|]+ | otherwise+ = pretty version++-- TODO rename or refactor this.+data MaintBranch =+ MaintBranch {+ package :: LocalPackage,+ version :: Version+ }+ deriving stock (Eq, Show, Generic)++instance Parsec MaintBranch where+ parsec = do+ string "release/"+ package <- LocalPackage . PackageName.fromCabal <$> parsec+ string "/"+ version <- parsec+ pure MaintBranch {package = package, version}++instance Pretty MaintBranch where+ pretty MaintBranch {package = LocalPackage name, ..} =+ pretty PackageId {..}++newtype BranchName =+ BranchName Text+ deriving stock (Eq, Show)+ deriving newtype (IsString, Ord, ToJSON, FromJSON, Semigroup, Monoid)++instance Pretty BranchName where+ pretty = prettyNt
+ lib/Hix/Managed/Handlers/AvailableVersions.hs view
@@ -0,0 +1,32 @@+module Hix.Managed.Handlers.AvailableVersions where++import Hix.Data.Monad (M)+import Hix.Data.PackageName (PackageName)+import Hix.Data.Version (Version)++data AvailableVersionsHandlers =+ AvailableVersionsHandlers {+ all :: PackageName -> M [Version],+ latest :: PackageName -> M (Maybe Version)+ }++handlersNull :: AvailableVersionsHandlers+handlersNull =+ AvailableVersionsHandlers {+ all = const (pure []),+ latest = const (pure Nothing)+ }++handlersActionAll :: (PackageName -> M [Version]) -> AvailableVersionsHandlers+handlersActionAll fetch =+ AvailableVersionsHandlers {+ all = fetch,+ latest = fmap (head . sortOn Down) . fetch+ }++handlersActionOne :: (PackageName -> M (Maybe Version)) -> AvailableVersionsHandlers+handlersActionOne fetch =+ AvailableVersionsHandlers {+ all = fmap toList . fetch,+ latest = fetch+ }
+ lib/Hix/Managed/Handlers/AvailableVersions/Prod.hs view
@@ -0,0 +1,12 @@+module Hix.Managed.Handlers.AvailableVersions.Prod where++import Hix.Hackage.Versions (latestVersionHackage, versionsHackage)+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers (..))+import Hix.Managed.Handlers.HackageClient (HackageClient)++handlersProd :: NonEmpty HackageClient -> AvailableVersionsHandlers+handlersProd hackages =+ AvailableVersionsHandlers {+ all = versionsHackage hackages,+ latest = latestVersionHackage hackages+ }
+ lib/Hix/Managed/Handlers/AvailableVersions/Test.hs view
@@ -0,0 +1,12 @@+module Hix.Managed.Handlers.AvailableVersions.Test where++import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages)+import Hix.Managed.Cabal.Mock.SourcePackage (queryPackages, queryPackagesLatest)+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers (..))++handlersTest :: SourcePackages -> AvailableVersionsHandlers+handlersTest packages =+ AvailableVersionsHandlers {+ latest = queryPackagesLatest packages,+ all = queryPackages packages+ }
lib/Hix/Managed/Handlers/Build.hs view
@@ -1,94 +1,96 @@ module Hix.Managed.Handlers.Build where -import Data.Aeson (FromJSON) import Data.IORef (IORef, newIORef) import Hix.Data.Monad (M) import Hix.Data.Overrides (Overrides) import Hix.Data.PackageId (PackageId)-import Hix.Data.PackageName (PackageName)-import Hix.Data.Version (Version, Versions)+import Hix.Data.PackageName (LocalPackage)+import Hix.Data.Version (Versions) import Hix.Managed.Cabal.Changes (SolverPlan)-import Hix.Managed.Cabal.Data.Config (GhcDb)+import Hix.Managed.Cabal.Data.Config (GhcDb (..))+import Hix.Managed.Cabal.Data.InstalledOverrides (InstalledOverrides) import Hix.Managed.Data.Constraints (EnvConstraints)-import Hix.Managed.Data.EnvContext (EnvContext)+import Hix.Managed.Data.EnvContext (EnvContext (..)) import Hix.Managed.Data.EnvState (EnvState)-import Hix.Managed.Data.Initial (Initial)-import Hix.Managed.Data.ManagedPackage (ManagedPackage)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.Initial (Initial (..))+import Hix.Managed.Data.ManagedPackage (ProjectPackages) import Hix.Managed.Data.StageState (BuildFailure (UnknownFailure), BuildResult (BuildFailure))+import qualified Hix.Managed.Handlers.AvailableVersions as AvailableVersions+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers) import qualified Hix.Managed.Handlers.Cabal as Solve import qualified Hix.Managed.Handlers.Cabal as Cabal import Hix.Managed.Handlers.Cabal (CabalHandlers)-import Hix.Managed.Handlers.Hackage (HackageHandlers)-import qualified Hix.Managed.Handlers.Report as Report-import Hix.Managed.Handlers.Report (ReportHandlers)-import qualified Hix.Managed.Handlers.StateFile as StateFileHandlers-import Hix.Managed.Handlers.StateFile (StateFileHandlers)+import qualified Hix.Managed.Handlers.Project as Project+import Hix.Managed.Handlers.Project (ProjectHandlers)+import Hix.Managed.Handlers.SourceHash (SourceHashHandlers) import Hix.Managed.Overrides (packageOverrides)+import Hix.Monad (noteClient) -newtype BuildOutputsPrefix =- BuildOutputsPrefix Text- deriving stock (Eq, Show, Generic)- deriving newtype (IsString, Ord, FromJSON)+newtype InitCabal =+ InitCabal { run :: InstalledOverrides -> GhcDb -> M (CabalHandlers, Set LocalPackage) } -newtype BuildTimeout =- BuildTimeout Int- deriving stock (Eq, Show, Generic)- deriving newtype (Num, Real, Enum, Integral, Ord, FromJSON)+data EnvBuilderContext =+ EnvBuilderContext {+ initCabal :: InitCabal,+ env :: EnvContext,+ initialState :: Initial EnvState+ } data EnvBuilder = EnvBuilder {+ state :: EnvState, cabal :: CabalHandlers,- buildWithState :: Bool -> Versions -> [PackageId] -> M (BuildResult, (Overrides, Set PackageId))+ buildTargets :: Bool -> Versions -> [PackageId] -> M (BuildResult, Overrides) } data Builder = Builder {- withEnvBuilder :: ∀ a . CabalHandlers -> EnvContext -> Initial EnvState -> (EnvBuilder -> M a) -> M a+ withEnvBuilder :: ∀ a . EnvBuilderContext -> (EnvBuilder -> Initial EnvState -> M a) -> M a } -runBuilder :: Builder -> CabalHandlers -> EnvContext -> Initial EnvState -> (EnvBuilder -> M a) -> M a+runBuilder :: Builder -> EnvBuilderContext -> (EnvBuilder -> Initial EnvState -> M a) -> M a runBuilder Builder {withEnvBuilder} = withEnvBuilder data BuildHandlers = BuildHandlers {- stateFile :: StateFileHandlers,- report :: ReportHandlers,- cabal :: Packages ManagedPackage -> GhcDb -> M CabalHandlers,+ project :: ProjectHandlers,+ cabal :: ProjectPackages -> InitCabal, withBuilder :: ∀ a . (Builder -> M a) -> M a,- versions :: PackageName -> M [Version],- latestVersion :: PackageName -> M (Maybe Version)+ versions :: AvailableVersionsHandlers } testBuilder ::- (Bool -> Versions -> [PackageId] -> M (BuildResult, (Overrides, Set PackageId))) ->+ (Bool -> Versions -> [PackageId] -> M (BuildResult, Overrides)) -> (Builder -> M a) -> M a-testBuilder buildWithState use =- use Builder {withEnvBuilder = \ cabal _ _ useE -> useE EnvBuilder {cabal, buildWithState}}+testBuilder buildTargets use =+ use Builder {+ withEnvBuilder = \ EnvBuilderContext {initCabal, env = EnvContext {ghc}, initialState = Initial state} useE -> do+ ghcDb <- noteClient "Test builder needs an explicit GHC DB" ghc+ (cabal, _) <- initCabal.run mempty ghcDb+ useE EnvBuilder {..} (Initial state)+ } -versionsBuilder :: HackageHandlers -> (Versions -> M BuildResult) -> (Builder -> M a) -> M a+versionsBuilder :: SourceHashHandlers -> (Versions -> M BuildResult) -> (Builder -> M a) -> M a versionsBuilder hackage build = testBuilder \ _ versions overrideVersions -> do- overrides <- packageOverrides hackage overrideVersions+ overrides <- packageOverrides hackage mempty overrideVersions status <- build versions- pure (status, (overrides, mempty))+ pure (status, overrides) handlersNull :: BuildHandlers handlersNull = BuildHandlers {- stateFile = StateFileHandlers.handlersNull,- report = Report.handlersNull,- cabal = \ _ _ -> pure Solve.handlersNull,+ project = Project.handlersNull,+ cabal = \ _ -> InitCabal \ _ _ -> pure (Solve.handlersNull, mempty), withBuilder = testBuilder \ _ _ _ -> pure (BuildFailure UnknownFailure, mempty),- versions = \ _ -> pure [],- latestVersion = \ _ -> pure Nothing+ versions = AvailableVersions.handlersNull } wrapCabal :: (CabalHandlers -> CabalHandlers) -> BuildHandlers -> BuildHandlers wrapCabal f BuildHandlers {..} =- BuildHandlers {cabal = \ p d -> f <$> cabal p d, ..}+ BuildHandlers {cabal = \ p -> InitCabal (\ d o -> first f <$> (cabal p).run d o), ..} logCabal :: MonadIO m =>@@ -97,7 +99,3 @@ logCabal handlers = do ref <- liftIO (newIORef []) pure (ref, wrapCabal (Cabal.logCabal ref) handlers)--data SpecialBuildHandlers =- TestBumpHandlers- deriving stock (Eq, Show)
lib/Hix/Managed/Handlers/Build/Prod.hs view
@@ -1,100 +1,51 @@ module Hix.Managed.Handlers.Build.Prod where import Control.Monad.Catch (catch)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ask, asks)-import Control.Monad.Trans.State.Strict (StateT (runStateT), gets, modify')-import qualified Data.ByteString.Char8 as ByteString-import Data.List.Extra (firstJust) import qualified Data.Set as Set-import Exon (exon)-import Network.HTTP.Client (newManager)-import Network.HTTP.Client.TLS (tlsManagerSettings)-import Path (Abs, Dir, Path, toFilePath)+import Path (Abs, Dir, Path) import Path.IO (copyDirRecur')-import System.IO (BufferMode (LineBuffering), Handle, hSetBuffering)-import System.IO.Error (IOError, tryIOError)-import System.Process.Typed (- ExitCode (ExitFailure, ExitSuccess),- ProcessConfig,- createPipe,- getStderr,- inherit,- nullStream,- proc,- setStderr,- setStdout,- setWorkingDir,- waitExitCode,- withProcessTerm,- )-import System.Timeout (timeout)+import System.IO.Error (IOError) -import Hix.Class.Map (nInsert, nMember)-import Hix.Data.EnvName (EnvName)-import Hix.Data.Error (Error (Fatal))+import Hix.Class.Map (nToMaybe)+import Hix.Data.Error (ErrorMessage (Fatal)) import qualified Hix.Data.Monad-import Hix.Data.Monad (M (M))-import Hix.Data.Overrides (Overrides)-import qualified Hix.Data.PackageId-import Hix.Data.PackageId (PackageId)-import Hix.Data.PackageName (LocalPackage)-import Hix.Data.Version (Versions)-import Hix.Error (pathText)-import Hix.Hackage (latestVersionHackage, versionsHackage)-import qualified Hix.Log as Log-import Hix.Managed.Build.NixOutput (OutputResult (OutputResult), PackageDerivation (..), outputParse, runOutputState)-import Hix.Managed.Build.NixOutput.Analysis (analyzeLog)-import Hix.Managed.Cabal.Data.Config (CabalConfig)-import qualified Hix.Managed.Data.BuildConfig+import Hix.Data.Monad (M, appRes)+import Hix.Data.Overrides (Override (..), Overrides)+import Hix.Data.PackageId (PackageId (..))+import Hix.Http (httpManager)+import Hix.Managed.Build.SolverPackages (solverGhc)+import Hix.Managed.Build.Target (BuilderResources (..), EnvBuilderResources (..), buildTargets)+import qualified Hix.Managed.Cabal.Data.Config as CabalConfig+import Hix.Managed.Cabal.Data.Config (CabalConfig (..), HackagePurpose (ForVersions), allHackages)+import Hix.Managed.Cabal.Data.InstalledOverrides (InstalledOverrides (..)) import Hix.Managed.Data.BuildConfig (BuildConfig)-import Hix.Managed.Data.EnvConfig (EnvConfig)-import qualified Hix.Managed.Data.EnvContext-import Hix.Managed.Data.EnvContext (EnvContext)-import Hix.Managed.Data.EnvState (EnvState)-import Hix.Managed.Data.Envs (Envs)-import Hix.Managed.Data.Initial (Initial)-import Hix.Managed.Data.StageState (BuildFailure (..), BuildResult (..), buildUnsuccessful)-import qualified Hix.Managed.Data.StateFileConfig-import Hix.Managed.Data.StateFileConfig (StateFileConfig)-import Hix.Managed.Data.Targets (firstMTargets)-import qualified Hix.Managed.Handlers.Build-import Hix.Managed.Handlers.Build (BuildHandlers (..), BuildOutputsPrefix, Builder (Builder), EnvBuilder (EnvBuilder))-import Hix.Managed.Handlers.Cabal (CabalHandlers)+import Hix.Managed.Data.EnvContext (EnvContext (..))+import Hix.Managed.Data.EnvState (EnvState (..))+import Hix.Managed.Data.Initial (Initial (..))+import Hix.Managed.Data.ManagedPackage (ProjectPackages)+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers)+import qualified Hix.Managed.Handlers.AvailableVersions.Prod as AvailableVersions+import Hix.Managed.Handlers.Build (+ BuildHandlers (..),+ Builder (..),+ EnvBuilder (..),+ EnvBuilderContext (..),+ InitCabal (..),+ ) import qualified Hix.Managed.Handlers.Cabal.Prod as CabalHandlers-import Hix.Managed.Handlers.Hackage (HackageHandlers)-import qualified Hix.Managed.Handlers.Hackage.Prod as HackageHandlers-import qualified Hix.Managed.Handlers.Report.Prod as ReportHandlers+import qualified Hix.Managed.Handlers.HackageClient.Prod as HackageClient+import Hix.Managed.Handlers.Project (ProjectHandlers (..))+import Hix.Managed.Handlers.SourceHash (SourceHashHandlers)+import qualified Hix.Managed.Handlers.SourceHash.Prod as SourceHashHandlers import Hix.Managed.Handlers.StateFile (StateFileHandlers)-import qualified Hix.Managed.Handlers.StateFile.Prod as StateFileHandlers-import Hix.Managed.Overrides (packageOverride, packageOverrides)-import Hix.Managed.Path (rootOrCwd)-import Hix.Managed.StateFile (writeBuildStateFor, writeInitialEnvState)-import Hix.Monad (runMUsing, throwM, tryIOM, withTempDir)-import Hix.Pretty (showP)--data BuilderResources =- BuilderResources {- hackage :: HackageHandlers,- stateFileHandlers :: StateFileHandlers,- envsConf :: Envs EnvConfig,- buildOutputsPrefix :: Maybe BuildOutputsPrefix,- root :: Path Abs Dir,- buildConfig :: BuildConfig- }--data EnvBuilderResources =- EnvBuilderResources {- global :: BuilderResources,- context :: EnvContext- }+import Hix.Managed.StateFile (writeInitialEnvState)+import Hix.Monad (throwM, withTempDir) withTempProject ::- Maybe (Path Abs Dir) -> (Path Abs Dir -> M a) -> M a-withTempProject rootOverride use = do- projectRoot <- rootOrCwd rootOverride+withTempProject use = do+ projectRoot <- appRes.root catch do withTempDir "managed-build" \ tmpRoot -> do@@ -102,235 +53,100 @@ use tmpRoot \ (err :: IOError) -> throwM (Fatal (show err)) -data OutputConfig =- OutputDebug- |- OutputParse- |- OutputIgnore--data NixProcResult =- NixProcSuccess [Text]- |- NixProcFailure Text- deriving stock (Eq, Show, Generic)--outputLines ::- MonadIO m =>- (ByteString -> m ()) ->- Handle ->- m (Maybe Text)-outputLines parse handle = do- liftIO (hSetBuffering handle LineBuffering)- spin mempty- where- spin buf = do- liftIO (tryIOError (ByteString.hGet handle 4096)) >>= \case- Left err -> pure (Just (show err))- Right new ->- join <$> for (completeLines buf new) \ (lns, newBuf) -> do- for_ lns parse- spin newBuf-- completeLines = \cases- -- Empty output means the handle was closed, empty buffer means we can terminate- "" "" ->- Nothing- -- First iteration after handle was closed, need to emit the last line- buf "" ->- Just ([buf], "")- buf new ->- Just (breakNl [] (buf <> new))-- breakNl acc s =- case ByteString.break (== '\n') s of- (rest, "") -> (reverse acc, rest)- (ln, rest) -> breakNl (ln : acc) (ByteString.drop 1 rest)--nixProc ::- OutputConfig ->- Path Abs Dir ->- [Text] ->- Text ->- [Text] ->- M (ProcessConfig () () (Maybe Handle))-nixProc output root cmd installable extra = do- Log.debug [exon|Running nix at '#{pathText root}' with args #{show args}|]- pure conf- where- conf = err (setWorkingDir (toFilePath root) (proc "nix" args))-- err = case output of- OutputParse -> setStderr (Just <$> createPipe)- OutputDebug -> setStdout inherit . setStderr (Nothing <$ inherit)- OutputIgnore -> setStderr (Nothing <$ nullStream)-- args = toString <$> cmd ++ [exon|path:#{".#"}#{installable}|] : extra ++ logArgs-- logArgs = case output of- OutputParse -> ["--log-format", "internal-json"]- OutputDebug -> ["-L"]- OutputIgnore -> []--runProc ::- BuildConfig ->- (Handle -> IO a) ->- ProcessConfig () () (Maybe Handle) ->- M (Maybe (Maybe a, ExitCode))-runProc buildConf pipeHandler conf =- tryIOM (withProcessTerm conf interact)- where- interact prc =- limit do- output <- traverse pipeHandler (getStderr prc)- res <- waitExitCode prc- pure (output, res)-- limit | Just t <- buildConf.timeout- , t > 0- = timeout (coerce t * 1_000_000)- | otherwise = fmap Just--outputResult ::- Maybe (Either Error (Maybe Text, OutputResult)) ->- ExitCode ->- M BuildResult-outputResult result = \case- ExitSuccess -> pure BuildSuccess- ExitFailure _ -> pure (BuildFailure (maybe UnknownFailure PackageFailure failedPackage))- where- failedPackage =- result >>= \case- Right (_, OutputResult pkg) -> pkg- Left _ -> Nothing--buildTarget ::- BuildConfig ->- Path Abs Dir ->- EnvName ->- LocalPackage ->- M BuildResult-buildTarget buildConf root env target = do- appRes <- M ask- debug <- M (asks (.debug))- conf <- nixProc (outputHandler debug) root ["build"] [exon|env.##{env}.##{target}|] []- runProc buildConf (runOutput appRes) conf >>= \case- Just (output, code) ->- outputResult output code- Nothing -> pure (BuildFailure (TimeoutFailure []))- where- runOutput appRes handle =- runMUsing appRes (runOutputState (outputLines outputParse handle))-- outputHandler debug- | buildConf.buildOutput || (buildConf.disableNixMonitor && debug)- = OutputDebug- | buildConf.disableNixMonitor- = OutputIgnore- | otherwise- = OutputParse--buildAdaptive ::- EnvBuilderResources ->- Bool ->- LocalPackage ->- StateT (Overrides, Set PackageId) M BuildResult-buildAdaptive EnvBuilderResources {global, context} allowRevisions target = do- build- where- build = do- overrides <- gets fst- result <- lift do- writeBuildStateFor "current build" global.stateFileHandlers global.root context overrides- buildTarget global.buildConfig global.root context.env target- checkResult overrides result-- checkResult overrides result- | allowRevisions- , BuildFailure (PackageFailure pkgs) <- result- , Just package <- firstJust logFailure (toList pkgs)- , not (nMember package.name overrides)- = retry package- | otherwise- = pure result-- logFailure PackageDerivation {package, log} =- package <$ analyzeLog log-- retry broken = do- lift $ Log.verbose [exon|Installed package failed with bounds error, retrying with override: #{showP broken}|]- (package, newOverride) <- lift $ packageOverride global.hackage broken- modify' \ (overrides, revisions) -> (nInsert package newOverride overrides, Set.insert broken revisions)- build--buildWithState ::- EnvBuilderResources ->- Bool ->- Versions ->- [PackageId] ->- M (BuildResult, (Overrides, Set PackageId))-buildWithState builder allowRevisions _ overrideVersions = do- overrides <- packageOverrides builder.global.hackage overrideVersions- let build = buildAdaptive builder allowRevisions- s0 = (overrides, Set.empty)- runStateT (firstMTargets BuildSuccess buildUnsuccessful build builder.context.targets) s0+storeSolverOverrides :: Overrides -> Initial EnvState -> EnvState+storeSolverOverrides new (Initial EnvState {..}) =+ EnvState {solver = new, ..} --- | This used to have the purpose of reading an updated GHC package db using the current managed state, but this has--- become obsolete.+-- | Determine the set of package IDs that should not be treated as installed in the solver package set when Cabal+-- selects dependencies. ----- TODO Decide whether to keep this for abstraction purposes.+-- This is simply the set of regular overrides, which usually should use versions that deviate from what's in the+-- nixpkgs GHC set.+-- Removing them will cause Cabal to emit overrides for these packages again in mutation builds, potentially with+-- different versions depending on the build plan.+-- If this wasn't done, the mutation build would try to use the actually installed versions, which are broken (the+-- reason for them getting overridden in the solver package set in the first place).+-- Since mutation builds can only restart with revisions of the same version on failure, the build will fail, and the+-- user would have to add those to the flake overrides manually (which was the procedure until this feature was+-- introduced).+--+-- Jailbroken packages, however, do not have to be removed – mutation builds are capable of fixing those themselves.+--+-- Local overrides do not need to be handled here because they cannot exist in solver package sets.+-- The Nix logic that constructs those sets excludes any local packages, even if they are dependencies of other local+-- packages, so checking the solver set will never result in an override of this sort.+-- Instead, these are only created when no Hackage upload exists (yet), as part of a mutation build, in+-- 'Hix.Managed.Overrides.packageOverride'.+installedOverrides :: EnvState -> InstalledOverrides+installedOverrides EnvState {solver} =+ InstalledOverrides $ Set.fromList $ nToMaybe solver \ name -> \case+ Override {..} -> Just PackageId {..}+ Jailbreak -> Nothing+ Local -> Nothing+ withEnvBuilder :: ∀ a . BuilderResources ->- CabalHandlers ->- EnvContext ->- Initial EnvState ->- (EnvBuilder -> M a) ->+ EnvBuilderContext ->+ (EnvBuilder -> Initial EnvState -> M a) -> M a-withEnvBuilder global cabal context initialState use = do- writeInitialEnvState global.stateFileHandlers global.root context initialState- use builder- where- builder =- EnvBuilder {- cabal,- buildWithState = buildWithState resources- }-- resources = EnvBuilderResources {..}+withEnvBuilder global EnvBuilderContext {initCabal, env = EnvContext {env, targets, ghc}, initialState} use = do+ (resolvedGhc, solverOverrides) <- solverGhc global env ((.solver) <$> initialState) ghc+ let state = maybe (.value) storeSolverOverrides solverOverrides initialState+ (cabal, localUnavailable) <- initCabal.run (installedOverrides state) resolvedGhc+ writeInitialEnvState global.stateFile global.root env initialState+ use EnvBuilder {buildTargets = buildTargets EnvBuilderResources {..}, ..} (Initial state) withBuilder ::- HackageHandlers ->+ SourceHashHandlers -> StateFileHandlers ->- StateFileConfig ->- Envs EnvConfig ->- Maybe BuildOutputsPrefix ->+ AvailableVersionsHandlers -> BuildConfig -> (Builder -> M a) -> M a-withBuilder hackage stateFileHandlers stateFileConf envsConf buildOutputsPrefix buildConfig use =- withTempProject stateFileConf.projectRoot \ root -> do+withBuilder hackage stateFile versions buildConfig use =+ withTempProject \ root -> do let resources = BuilderResources {..} use Builder {withEnvBuilder = withEnvBuilder resources} +handlersProdResources ::+ CabalConfig ->+ M (SourceHashHandlers, AvailableVersionsHandlers)+handlersProdResources cabalConf = do+ manager <- httpManager+ sourceHash <- SourceHashHandlers.handlersProd (allHackages cabalConf)+ hackage <- HackageClient.handlersProdFor (Just manager) ForVersions cabalConf+ let versions = AvailableVersions.handlersProd hackage+ pure (sourceHash, versions)++initCabalProd :: CabalConfig -> ProjectPackages -> InitCabal+initCabalProd cabalConfig packages =+ InitCabal \ overrides -> CabalHandlers.handlersProd overrides cabalConfig False packages+ handlersProd ::- MonadIO m =>- StateFileConfig ->- Envs EnvConfig ->- Maybe BuildOutputsPrefix ->+ ProjectHandlers -> BuildConfig -> CabalConfig ->- Bool ->- m BuildHandlers-handlersProd stateFileConf envsConf buildOutputsPrefix buildConfig cabalConf oldest = do- manager <- liftIO (newManager tlsManagerSettings)- hackage <- HackageHandlers.handlersProd- let stateFile = StateFileHandlers.handlersProd stateFileConf+ M BuildHandlers+handlersProd project buildConfig cabalConfig = do+ (sourceHash, versions) <- handlersProdResources cabalConfig pure BuildHandlers {- stateFile,- report = ReportHandlers.handlersProd,- cabal = CabalHandlers.handlersProd cabalConf oldest,- withBuilder = withBuilder hackage stateFile stateFileConf envsConf buildOutputsPrefix buildConfig,- versions = versionsHackage manager,- latestVersion = latestVersionHackage manager+ project,+ cabal = initCabalProd cabalConfig,+ withBuilder = withBuilder sourceHash project.stateFile versions buildConfig,+ versions }++handlersFixedResources ::+ CabalConfig ->+ M (SourceHashHandlers, AvailableVersionsHandlers)+handlersFixedResources config =+ handlersProdResources (CabalConfig.withHackageFixed config)++handlersFixed ::+ ProjectHandlers ->+ BuildConfig ->+ CabalConfig ->+ M BuildHandlers+handlersFixed project build cabal =+ handlersProd project build (CabalConfig.withHackageFixed cabal)
lib/Hix/Managed/Handlers/Build/Test.hs view
@@ -2,36 +2,28 @@ import Data.IORef (IORef) import Data.Map.Strict ((!?))-import Exon (exon) import Hix.Data.Monad (M) import Hix.Data.NixExpr (Expr) import qualified Hix.Data.PackageId+import Hix.Data.PackageId (PackageId) import Hix.Data.PackageName (PackageName)-import Hix.Data.Version (Version, Versions)+import Hix.Data.Version (Versions) import Hix.Managed.Cabal.Data.Config (CabalConfig) import qualified Hix.Managed.Cabal.Data.Packages import Hix.Managed.Cabal.Data.Packages (GhcPackages)-import Hix.Managed.Cabal.Mock.SourcePackage (queryVersions, queryVersionsLatest, sourcePackageVersions)-import Hix.Managed.Data.BuildConfig (BuildConfig)-import Hix.Managed.Data.EnvConfig (EnvConfig)-import Hix.Managed.Data.Envs (Envs)+import Hix.Managed.Data.BuildConfig (BuildConfig, SpecialBuildHandlers (..)) import Hix.Managed.Data.Mutation (FailedMutation) import Hix.Managed.Data.StageState (BuildResult)-import Hix.Managed.Data.StateFileConfig (StateFileConfig)-import Hix.Managed.Handlers.Build (- BuildHandlers (..),- BuildOutputsPrefix,- SpecialBuildHandlers (TestBumpHandlers),- versionsBuilder,- )-import Hix.Managed.Handlers.Build.Prod (handlersProd)-import qualified Hix.Managed.Handlers.Cabal.Prod as CabalHandlers-import Hix.Managed.Handlers.Cabal.Prod (testPackagesBump)-import qualified Hix.Managed.Handlers.Hackage as HackageHandlers+import qualified Hix.Managed.Handlers.AvailableVersions as AvailableVersions+import qualified Hix.Managed.Handlers.AvailableVersions.Test as AvailableVersions+import Hix.Managed.Handlers.Build (BuildHandlers (..), versionsBuilder)+import Hix.Managed.Handlers.Build.Prod (handlersProd, initCabalProd)+import Hix.Managed.Handlers.Cabal.Prod (testPackagesBump, testPackagesMaint)+import Hix.Managed.Handlers.Project (ProjectHandlers (..)) import qualified Hix.Managed.Handlers.Report.Test as ReportHandlers+import qualified Hix.Managed.Handlers.SourceHash as SourceHashHandlers import qualified Hix.Managed.Handlers.StateFile.Test as StateFile-import Hix.Monad (clientError) handlersUnitTest :: MonadIO m =>@@ -44,52 +36,44 @@ let handlers = BuildHandlers {- stateFile,- report,- cabal,- withBuilder = versionsBuilder HackageHandlers.handlersNull builder,- versions = queryVersions versions,- latestVersion = queryVersionsLatest versions+ project = ProjectHandlers {+ stateFile,+ report+ },+ cabal = initCabalProd def,+ withBuilder = versionsBuilder SourceHashHandlers.handlersNull builder,+ versions = AvailableVersions.handlersTest ghcPackages.available } pure (handlers, stateFileRef, mutationsRef)- where- cabal = CabalHandlers.handlersProd def False- versions = sourcePackageVersions ghcPackages.available -latestVersionNixTestBump :: PackageName -> M (Maybe Version)-latestVersionNixTestBump name =- maybe invalid found (testPackagesBump !? name)- where- invalid = clientError [exon|Invalid package for latestVersion: ##{name}|]- found = pure . Just . (.version)--handlersBumpTest ::- MonadIO m =>- StateFileConfig ->- Envs EnvConfig ->- Maybe BuildOutputsPrefix ->+handlersTest ::+ Map PackageName PackageId ->+ ProjectHandlers -> BuildConfig -> CabalConfig ->- Bool ->- m BuildHandlers-handlersBumpTest stateFileConf envsConf buildOutputsPrefix buildConf cabalConf oldest = do- handlers <- handlersProd stateFileConf envsConf buildOutputsPrefix buildConf cabalConf oldest+ M BuildHandlers+handlersTest packages project buildConf cabalConf = do+ handlers <- handlersProd project buildConf cabalConf pure handlers {- cabal = CabalHandlers.handlersTest cabalConf oldest,- latestVersion = latestVersionNixTestBump+ cabal = initCabalProd cabalConf,+ versions = AvailableVersions.handlersActionOne \ name -> pure ((.version) <$> packages !? name) } -chooseHandlers ::- MonadIO m =>- StateFileConfig ->- Envs EnvConfig ->- Maybe BuildOutputsPrefix ->+handlersBumpTest ::+ ProjectHandlers -> BuildConfig -> CabalConfig ->+ M BuildHandlers+handlersBumpTest =+ handlersTest testPackagesBump++chooseHandlers :: Maybe SpecialBuildHandlers ->- m BuildHandlers-chooseHandlers stateFileConf envsConf buildOutputsPrefix buildConf cabalConf = \case- Just TestBumpHandlers -> handlersBumpTest stateFileConf envsConf buildOutputsPrefix buildConf cabalConf oldest- Nothing -> handlersProd stateFileConf envsConf buildOutputsPrefix buildConf cabalConf oldest- where- oldest = False+ ProjectHandlers ->+ BuildConfig ->+ CabalConfig ->+ M BuildHandlers+chooseHandlers = \case+ Just BuildHandlersTestBump -> handlersBumpTest+ Just BuildHandlersTestMaint -> handlersTest testPackagesMaint+ Nothing -> handlersProd
lib/Hix/Managed/Handlers/Cabal/Prod.hs view
@@ -4,25 +4,26 @@ import Distribution.Client.Dependency (PackagesPreferenceDefault (PreferAllOldest), setPreferenceDefault) import qualified Distribution.Client.Types import Distribution.Client.Types (SourcePackageDb (SourcePackageDb), UnresolvedSourcePackage)+import Distribution.Simple.PackageIndex (deleteSourcePackageId) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.PackageIndex (PackageIndex) import Distribution.Version (laterVersion) import Hix.Data.Monad (M) import qualified Hix.Data.PackageId+import qualified Hix.Data.PackageId as PackageId import Hix.Data.PackageId (PackageId (PackageId)) import qualified Hix.Data.PackageName as PackageName-import Hix.Data.PackageName (PackageName)+import Hix.Data.PackageName (LocalPackage, PackageName) import Hix.Managed.Cabal.Data.Config (CabalConfig, GhcDb)-import qualified Hix.Managed.Cabal.Data.SolveResources as SolveResources-import Hix.Managed.Cabal.Data.SolveResources (SolveResources (SolveResources, solverParams))+import Hix.Managed.Cabal.Data.InstalledOverrides (InstalledOverrides (..))+import Hix.Managed.Cabal.Data.SolveResources (SolveResources (..)) import Hix.Managed.Cabal.Installed (installedVersion) import qualified Hix.Managed.Cabal.Resources as SolveResources import Hix.Managed.Cabal.Solve (solveWithCabal) import Hix.Managed.Cabal.Sort (sortMutations) import Hix.Managed.Cabal.Source (sourcePackage)-import Hix.Managed.Data.ManagedPackage (ManagedPackage)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages) import Hix.Managed.Handlers.Cabal (CabalHandlers (..)) import Hix.Zip (zipApplyL) @@ -30,29 +31,52 @@ (SolveResources -> SolveResources) -> CabalConfig -> Bool ->- Packages ManagedPackage ->+ ProjectPackages -> GhcDb ->- M CabalHandlers+ M (CabalHandlers, Set LocalPackage) handlersWith trans cabalConf oldest packages ghc = do- solveResources <- trans <$> SolveResources.acquire packages cabalConf ghc- pure CabalHandlers {+ (solveResources, localUnavailable) <- first trans <$> SolveResources.acquire packages cabalConf ghc+ let handlers = CabalHandlers { solveForVersion = solveWithCabal solveResources {solverParams}, installedVersion = installedVersion solveResources.installedPkgIndex, sourcePackage = sourcePackage solveResources.sourcePkgDb, sortMutations = sortMutations solveResources }+ pure (handlers, localUnavailable) where solverParams | oldest = setPreferenceDefault PreferAllOldest | otherwise = id +-- | Remove the given overrides from the @InstalledPackageIndex@.+--+-- The solver overrides are a necessity that allows us to resolve dependencies and start builds with multiple broken+-- packages in the nixpkgs GHC set, but they obscure what is actually installed, so that the same overrides have to be+-- determined again when running mutation builds (which isn't possible except for revisions).+--+-- Therefore, we remove the solver overrides from the installed package DB here, causing Cabal to see only their+-- counterparts from Hackage.+--+-- Note that we do absolutely need the remaining installed packages to be recognized, since we can instruct Cabal to+-- prefer those versions in order to avoid having to use overrides for every dependency (and build all of those+-- packages despite them being available in the cache).+removeInstalledOverrides ::+ InstalledOverrides ->+ SolveResources ->+ SolveResources+removeInstalledOverrides (InstalledOverrides ids) resources =+ resources {+ installedPkgIndex = foldr (deleteSourcePackageId . PackageId.toCabal) resources.installedPkgIndex ids+ }+ handlersProd ::+ InstalledOverrides -> CabalConfig -> Bool ->- Packages ManagedPackage ->+ ProjectPackages -> GhcDb ->- M CabalHandlers-handlersProd =- handlersWith id+ M (CabalHandlers, Set LocalPackage)+handlersProd overrides =+ handlersWith (removeInstalledOverrides overrides) testPackagesBump :: Map PackageName PackageId testPackagesBump =@@ -66,6 +90,14 @@ PackageId {name = "multi-fail2", version = [0, 1, 0]} ] +testPackagesMaint :: Map PackageName PackageId+testPackagesMaint =+ Map.fromList $ zipApplyL (.name) [+ PackageId {name = "base", version = [4, 19, 0, 0]},+ PackageId {name = "extra", version = [1, 8]},+ PackageId {name = "semigroups", version = [0, 20]}+ ]+ removeLaterVersions :: PackageId -> PackageIndex UnresolvedSourcePackage ->@@ -73,21 +105,21 @@ removeLaterVersions PackageId {..} = PackageIndex.deleteDependency (PackageName.toCabal name) (laterVersion version) -testResources :: SolveResources -> SolveResources-testResources SolveResources {..} =+testResourcesFor :: Map PackageName PackageId -> SolveResources -> SolveResources+testResourcesFor packages SolveResources {..} = SolveResources {sourcePkgDb = removeLaterTestPackageVersions sourcePkgDb, ..} where removeLaterTestPackageVersions SourcePackageDb {..} = SourcePackageDb {- packageIndex = Map.foldr' removeLaterVersions packageIndex testPackagesBump,+ packageIndex = Map.foldr' removeLaterVersions packageIndex packages, .. } handlersTest :: CabalConfig -> Bool ->- Packages ManagedPackage ->+ ProjectPackages -> GhcDb ->- M CabalHandlers+ M (CabalHandlers, Set LocalPackage) handlersTest =- handlersWith testResources+ handlersWith (testResourcesFor testPackagesBump)
+ lib/Hix/Managed/Handlers/Context.hs view
@@ -0,0 +1,119 @@+{-# language CPP #-}++#if __GLASGOW_HASKELL__ >= 908+{-# language TypeAbstractions #-}+#endif++module Hix.Managed.Handlers.Context where++import qualified Data.Aeson as Aeson+import Data.Aeson (FromJSON)+import Distribution.Pretty (Pretty (pretty))+import Exon (exon)+import Text.PrettyPrint (hang, text, (<+>))++import qualified Hix.Color as Color+import Hix.Data.Json (JsonConfig)+import Hix.Data.Monad (AppResources (..), M, appRes)+import Hix.Json (jsonConfig)+import qualified Hix.Log as Log+import Hix.Managed.Data.MaintContext (MaintContext)+import Hix.Managed.Data.ProjectContextProto (ProjectContextProto)+import Hix.Managed.Flake (runFlakeForSingleLine)+import Hix.Monad (appContext, eitherFatal, noteFatal, tryIOM)+import Hix.Pretty (HPretty (hpretty), showP)++type ContextKey :: Symbol -> Type -> Type+data ContextKey name a where+ ContextMaint :: ContextKey "maint" MaintContext+ ContextManaged :: ContextKey "managed" ProjectContextProto++instance KnownSymbol name => Pretty (ContextKey name a) where+ pretty _ = text (symbolVal (Proxy @name))++type ContextQuery :: Type -> Type+data ContextQuery a where+ ContextQuery :: ∀ name a . (FromJSON a, KnownSymbol name) => ContextKey name a -> ContextQuery a++contextKeySlug ::+ ∀ a b .+ IsString b =>+ ContextQuery a ->+ b+contextKeySlug (ContextQuery @name _) =+ fromString (symbolVal (Proxy @name))++instance Pretty (ContextQuery a) where+ pretty = text . contextKeySlug++data ContextHandlers =+ ContextHandlers {+ query :: ∀ a . ContextQuery a -> M a+ }++queryContextNoLog ::+ FromJSON a =>+ KnownSymbol name =>+ ContextHandlers ->+ ContextKey name a ->+ M a+queryContextNoLog ContextHandlers {query} key =+ query (ContextQuery key)++queryContext ::+ HPretty a =>+ FromJSON a =>+ KnownSymbol name =>+ ContextHandlers ->+ ContextKey name a ->+ M a+queryContext handlers key = do+ result <- queryContextNoLog handlers key+ Log.debugP $ hang (text "Context for" <+> pretty key) 2 (hpretty result)+ pure result++internalScope :: IsString a => a+internalScope = "__hix-internal__"++queryFlake :: ContextQuery a -> M a+queryFlake key@ContextQuery {} = do+ appContext [exon|querying the flake for the context #{Color.cyan name}|] do+ root <- appRes.root+ file <- decodeUtf8 <$> runFlakeForSingleLine desc root args id+ eitherFatal . first toText =<< tryIOM (Aeson.eitherDecodeFileStrict' file)+ where+ args = ["build", "--print-out-paths", [exon|.#{"#"}#{internalScope}.cli-context.json.#{name}|]]++ desc = [exon|Context query for '#{name}'|]++ name = contextKeySlug key++handlersProd :: ContextHandlers+handlersProd = ContextHandlers {query = queryFlake}++handlersTest :: (∀ a . ContextQuery a -> M (Maybe a)) -> ContextHandlers+handlersTest testContext =+ ContextHandlers {+ query = \ key -> check key =<< testContext key+ }+ where+ check key = noteFatal [exon|The context '#{showP key}' is not defined for this test.|]++jsonOrQuery ::+ FromJSON a =>+ KnownSymbol name =>+ ContextHandlers ->+ ContextKey name a ->+ Either a (Maybe JsonConfig) ->+ M a+jsonOrQuery ContextHandlers {query} confQuery =+ either pure (maybe (query (ContextQuery confQuery)) jsonConfig)++jsonOrQueryProd ::+ FromJSON a =>+ KnownSymbol name =>+ ContextKey name a ->+ Either a (Maybe JsonConfig) ->+ M a+jsonOrQueryProd =+ jsonOrQuery handlersProd
− lib/Hix/Managed/Handlers/Hackage.hs
@@ -1,17 +0,0 @@-module Hix.Managed.Handlers.Hackage where--import Hix.Data.Monad (M)-import Hix.Data.PackageId (PackageId)-import Hix.Data.Version (SourceHash (SourceHash))-import Hix.Pretty (showP)--data HackageHandlers =- HackageHandlers {- fetchHash :: PackageId -> M SourceHash- }--handlersNull :: HackageHandlers-handlersNull =- HackageHandlers {- fetchHash = \ package -> pure (SourceHash (showP package))- }
− lib/Hix/Managed/Handlers/Hackage/Prod.hs
@@ -1,23 +0,0 @@-module Hix.Managed.Handlers.Hackage.Prod where--import Data.IORef (newIORef)--import Hix.Data.Version (SourceHash)-import Hix.Hackage (fetchHashHackageCached)-import qualified Hix.Managed.Handlers.Hackage-import Hix.Managed.Handlers.Hackage (HackageHandlers (HackageHandlers))--handlersProdWith ::- MonadIO m =>- Map Text SourceHash ->- m HackageHandlers-handlersProdWith initial = do- hashCache <- liftIO (newIORef initial)- pure HackageHandlers {- fetchHash = fetchHashHackageCached hashCache- }--handlersProd ::- MonadIO m =>- m HackageHandlers-handlersProd = handlersProdWith mempty
+ lib/Hix/Managed/Handlers/HackageClient.hs view
@@ -0,0 +1,56 @@+module Hix.Managed.Handlers.HackageClient where++import Data.Aeson (FromJSON)+import Exon (exon)+import Type.Reflection (typeRep)++import Hix.Data.Monad (M)+import Hix.Managed.Cabal.Data.Config (HackagePurpose)+import Hix.Managed.Cabal.Data.HackageRepo (HackageDescription)++type HackageResponse :: Type -> Type+data HackageResponse a where+ HackageResponseJson :: (FromJSON a, Typeable a) => HackageResponse a+ HackageResponseHtml :: HackageResponse Text+ HackageNoResponse :: HackageResponse ()++instance Eq (HackageResponse a) where+ HackageResponseJson == HackageResponseJson = True+ HackageResponseHtml == HackageResponseHtml = True+ HackageNoResponse == HackageNoResponse = True+ _ == _ = False++instance Show (HackageResponse a) where+ showsPrec d = \case+ HackageResponseJson -> showParen (d > 10) [exon|HackageResponseJson #{showsPrec 11 (typeRep @a)}|]+ HackageResponseHtml -> showString "HackageResponseHtml"+ HackageNoResponse -> showString "HackageNoResponse"++data HackageRequest a =+ HackageRequest {+ method :: Text,+ path :: Text,+ body :: Maybe (Either (NonEmpty (Text, Text)) LByteString),+ query :: Maybe (NonEmpty (ByteString, ByteString)),+ accept :: HackageResponse a+ }+ deriving stock (Eq, Show, Generic)++data HackageError =+ HackageNotFound+ |+ HackageFatal Text+ |+ HackageParseError Text+ deriving stock (Eq, Show, Generic)++data HackageClient =+ HackageClient {+ description :: HackageDescription,+ request :: ∀ a . HackageRequest a -> M (Either HackageError a)+ }++data HackageApi =+ HackageApi {+ request :: ∀ a . HackagePurpose -> HackageRequest a -> M (NonEmpty (Either HackageError a))+ }
+ lib/Hix/Managed/Handlers/HackageClient/Prod.hs view
@@ -0,0 +1,185 @@+{-# language MonadComprehensions #-}++module Hix.Managed.Handlers.HackageClient.Prod where++import Data.Aeson (Value, eitherDecodeStrict')+import Exon (exon)+import Network.HTTP.Client (+ Manager,+ Request (..),+ RequestBody (RequestBodyLBS),+ Response (..),+ applyBasicAuth,+ defaultRequest,+ httpLbs,+ setQueryString,+ )+import Network.HTTP.Client.MultipartFormData (formDataBody, partBS)+import Network.HTTP.Types (+ Status (statusCode, statusMessage),+ hAccept,+ hContentType,+ statusIsClientError,+ statusIsServerError,+ statusIsSuccessful,+ )++import qualified Hix.Color as Color+import Hix.Data.Monad (M)+import Hix.Hackage (hackagePostQuery, hackagePut)+import Hix.Http (httpManager)+import qualified Hix.Log as Log+import Hix.Managed.Cabal.Data.Config (CabalConfig, HackagePurpose, hackagesFor)+import Hix.Managed.Cabal.Data.HackageLocation (+ HackageHost (..),+ HackageLocation (..),+ HackagePassword (HackagePassword),+ HackageTls (..),+ HackageUser (..),+ hackageTlsBool,+ )+import qualified Hix.Managed.Cabal.Data.HackageRepo as HackageRepo+import Hix.Managed.Cabal.Data.HackageRepo (HackageDescription, HackageRepo (HackageRepo))+import Hix.Managed.Cabal.HackageLocation (hackagePort)+import Hix.Managed.Handlers.HackageClient (+ HackageClient (..),+ HackageError (..),+ HackageRequest (..),+ HackageResponse (..),+ )+import Hix.Maybe (fromMaybeA)+import Hix.Monad (appContextDebug)+import Hix.Network (Port)++data HackageResources =+ HackageResources {+ manager :: Manager,+ description :: HackageDescription,+ location :: HackageLocation+ }++parseResult ::+ LByteString ->+ HackageResponse a ->+ Either HackageError a+parseResult body = \case+ HackageResponseJson ->+ first wrapError (eitherDecodeStrict' (toStrict body))+ HackageResponseHtml ->+ Right (decodeUtf8 body)+ HackageNoResponse ->+ unit+ where+ wrapError err = HackageFatal [exon|Hackage response parse error: #{toText err}|]++baseRequest :: HackageLocation -> HackageRequest a -> Request+baseRequest location@HackageLocation {host = HackageHost host, tls} HackageRequest {..} =+ defaultRequest {+ host = encodeUtf8 host,+ port = fromIntegral (hackagePort location),+ secure = hackageTlsBool tls,+ method = encodeUtf8 method,+ path = encodeUtf8 path,+ requestHeaders = acceptHeader : maybeToList contentHeader+ }+ where+ acceptHeader+ | HackageResponseJson <- accept = (hAccept, "application/json")+ | otherwise = (hAccept, "text/html")++ contentHeader+ | Just (Right _) <- body = Just (hContentType, "application/json")+ | Just _ <- query = Just (hContentType, "application/x-www-form-urlencoded")+ | otherwise = Nothing++nativeRequest :: HackageLocation -> HackageRequest a -> M Request+nativeRequest location request@HackageRequest {..} = do+ addBody body (addAuth location.auth (addQuery query (baseRequest location request)))+ where+ addBody = maybe pure \case+ Right bs -> \ r -> pure r { requestBody = RequestBodyLBS bs }+ Left fields -> formDataBody [partBS key (encodeUtf8 value) | (key, value) <- toList fields]++ addAuth =+ maybe id \ (HackageUser user, HackagePassword password) ->+ applyBasicAuth (encodeUtf8 user) (encodeUtf8 password)++ addQuery = maybe id \ q -> setQueryString (second Just <$> toList q)++makeNativeRequest ::+ ∀ a .+ HackageResources ->+ HackageRequest a ->+ M (Either HackageError a)+makeNativeRequest HackageResources {manager, location} request = do+ appContextDebug [exon|sending request to Hackage at #{Color.url location.host} (#{request.path})|] do+ nrequest <- nativeRequest location request+ response <- liftIO (httpLbs nrequest manager)+ let+ status = responseStatus response++ errorStatus category = requestFailed [exon|#{category} (#{decodeUtf8 (statusMessage status)})|]++ result = if+ | statusIsSuccessful status -> parseResult (responseBody response) request.accept+ | statusCode status == 404 -> Left HackageNotFound+ | statusIsClientError status -> errorStatus "Client error"+ | statusIsServerError status -> errorStatus "Server error"+ | otherwise -> errorStatus "Weird error"++ checkResult result+ pure result+ where+ requestFailed = Left . HackageFatal++ checkResult = \case+ Left (HackageFatal msg) ->+ Log.error [exon|Hackage request for #{Color.path request.path} at #{Color.green location.host} failed: #{msg}|]+ _ -> unit++handlersProd :: HackageResources -> HackageClient+handlersProd resources =+ HackageClient {+ description = resources.description,+ request = makeNativeRequest resources+ }++handlersProdFor ::+ Maybe Manager ->+ HackagePurpose ->+ CabalConfig ->+ M (NonEmpty HackageClient)+handlersProdFor sharedManager purpose conf = do+ manager <- fromMaybeA httpManager sharedManager+ matching <- hackagesFor purpose conf+ pure (repoHandlers manager <$> matching)+ where+ repoHandlers manager HackageRepo {description, location} =+ handlersProd (HackageResources {manager, description, location})++mockUser :: NonEmpty (Text, Text)+mockUser =+ [+ ("username", "test"),+ ("password", "test"),+ ("repeat-password", "test")+ ]++handlersMock :: Manager -> Port -> M HackageClient+handlersMock manager port = do+ _ <- hackagePostQuery Right adminClient "users/" mockUser HackageNoResponse+ _ <- hackagePut @Value Right adminClient "packages/uploaders/user/test"+ pure (handlersProd userRes)+ where+ res = HackageResources {+ manager,+ description = "mock Hackage",+ location = HackageLocation {+ host = "localhost",+ tls = TlsOff,+ port = Just (fromIntegral port),+ auth = Just ("admin", "admin")+ }+ }+ userRes = res {location = res.location {auth = Just ("test", "test")}}+ adminClient = handlersProd res
+ lib/Hix/Managed/Handlers/Maint.hs view
@@ -0,0 +1,17 @@+module Hix.Managed.Handlers.Maint where++import Hix.Data.EnvName (EnvName)+import Hix.Data.Monad (M)+import Hix.Managed.Data.BuildOutput (DepChanges)+import Hix.Managed.Git (GitApi)+import Hix.Managed.Handlers.Context (ContextHandlers)+import Hix.Managed.Handlers.HackageClient (HackageClient)+import Hix.Managed.Maint.Git (GitMaint)++data MaintHandlers =+ MaintHandlers {+ git :: GitApi GitMaint,+ context :: ContextHandlers,+ publishHackages :: NonEmpty HackageClient,+ runBump :: EnvName -> M DepChanges+ }
+ lib/Hix/Managed/Handlers/Maint/Prod.hs view
@@ -0,0 +1,90 @@+module Hix.Managed.Handlers.Maint.Prod where++import qualified Data.List.NonEmpty as NonEmpty+import Exon (exon)++import Hix.Data.EnvName (EnvName)+import qualified Hix.Data.Monad+import Hix.Data.Monad (M, appRes)+import Hix.Data.Options (ManagedOptions (..), ProjectOptions (..))+import Hix.Http (httpManager)+import Hix.Managed.BuildOutput (depChanges)+import Hix.Managed.Bump.Optimize (bumpOptimizeMain)+import Hix.Managed.Cabal.Data.Config (CabalConfig, HackagePurpose (ForPublish))+import Hix.Managed.Data.BuildOutput (DepChanges)+import qualified Hix.Managed.Data.EnvContext+import Hix.Managed.Data.MaintConfig (MaintConfig (..))+import Hix.Managed.Data.ProjectContext (ProjectContext (..))+import Hix.Managed.Flake (flakeFailure, runFlakeFor)+import Hix.Managed.Handlers.Build (BuildHandlers (..))+import qualified Hix.Managed.Handlers.Build.Prod as Build+import qualified Hix.Managed.Handlers.Context as ContextHandlers+import Hix.Managed.Handlers.Context (ContextHandlers (..), ContextKey (ContextManaged), queryContext)+import qualified Hix.Managed.Handlers.HackageClient.Prod as HackageClient+import Hix.Managed.Handlers.Maint (MaintHandlers (..))+import qualified Hix.Managed.Handlers.Project.Prod as Project+import Hix.Managed.Maint.Git (gitApiMaintHermetic, gitApiMaintProd)+import Hix.Managed.ProjectContext (updateProject)+import qualified Hix.Managed.ProjectContextProto as ProjectContextProto+import Hix.Monad (noteFatal)++projectWithEnv :: EnvName -> ProjectContext -> M ProjectContext+projectWithEnv target ProjectContext {..} = do+ newEnvs <- noteFatal [exon|Couldn't find env '##{target}' in the project context|] (nonEmpty updated)+ pure ProjectContext {envs = newEnvs, ..}+ where+ updated = flip NonEmpty.filter envs \case+ Left name -> name == target+ Right context -> context.env == target++bumpHandlers ::+ ContextHandlers ->+ ManagedOptions ->+ EnvName ->+ M (BuildHandlers, ProjectContext)+bumpHandlers contexts options envName = do+ proto <- queryContext contexts ContextManaged+ project <- ProjectContextProto.validate options.project proto+ handlersProject <- Project.handlersProd options.stateFile+ handlers <- Build.handlersProd handlersProject options.project.build project.cabal+ bumpProject <- projectWithEnv envName project+ pure (handlers, bumpProject)++runBump ::+ BuildHandlers ->+ ProjectContext ->+ M DepChanges+runBump handlers project = do+ result <- bumpOptimizeMain handlers project+ updateProject handlers.project False result+ root <- appRes.root+ -- TODO maybe the called app should be aware of managed, and check the config to ensure that the right steps are+ -- taken.+ runFlakeFor (const unit) flakeFailure "Generate Cabal" root ["--quiet", "--quiet", "--quiet", "run", ".#gen-quiet"] id+ pure (depChanges result)++runBumpProd ::+ ContextHandlers ->+ ManagedOptions ->+ EnvName ->+ M DepChanges+runBumpProd context options envName = do+ (handlers, project) <- bumpHandlers context options envName+ runBump handlers project++handlersProd ::+ ManagedOptions ->+ MaintConfig ->+ CabalConfig ->+ M MaintHandlers+handlersProd options config cabal = do+ manager <- httpManager+ publishHackages <- HackageClient.handlersProdFor (Just manager) ForPublish cabal+ pure MaintHandlers {+ git = (if config.globalGit then gitApiMaintProd else gitApiMaintHermetic) config,+ context,+ runBump = runBumpProd context options,+ publishHackages+ }+ where+ context = ContextHandlers.handlersProd
+ lib/Hix/Managed/Handlers/Maint/Test.hs view
@@ -0,0 +1,62 @@+module Hix.Managed.Handlers.Maint.Test where++import Hix.Data.EnvName (EnvName)+import Hix.Data.Monad (M)+import qualified Hix.Data.Options+import Hix.Data.Options (ManagedOptions)+import Hix.Http (httpManager)+import Hix.Managed.Cabal.Data.Config (CabalConfig, HackagePurpose (ForPublish))+import Hix.Managed.Data.BuildConfig (SpecialBuildHandlers (BuildHandlersTestMaint))+import Hix.Managed.Data.BuildOutput (DepChanges)+import Hix.Managed.Data.MaintConfig (MaintConfig (..))+import Hix.Managed.Data.ProjectContext (ProjectContext (..))+import Hix.Managed.Handlers.Build (BuildHandlers)+import qualified Hix.Managed.Handlers.Build.Test as Build+import qualified Hix.Managed.Handlers.Context as ContextHandlers+import Hix.Managed.Handlers.Context (ContextHandlers (..), ContextKey (ContextManaged), ContextQuery (ContextQuery))+import qualified Hix.Managed.Handlers.HackageClient.Prod as HackageClient+import Hix.Managed.Handlers.Maint (MaintHandlers (..))+import Hix.Managed.Handlers.Maint.Prod (projectWithEnv, runBump)+import qualified Hix.Managed.Handlers.Project.Prod as Project+import Hix.Managed.Maint.Git (gitApiMaintProd)+import qualified Hix.Managed.ProjectContextProto as ProjectContextProto++bumpHandlers ::+ ContextHandlers ->+ ManagedOptions ->+ EnvName ->+ M (BuildHandlers, ProjectContext)+bumpHandlers ContextHandlers {query} options envName = do+ proto <- query (ContextQuery ContextManaged)+ project <- ProjectContextProto.validate options.project proto+ handlersProject <- Project.handlersProd options.stateFile+ handlers <-+ Build.chooseHandlers (Just BuildHandlersTestMaint) handlersProject options.project.build project.cabal+ bumpProject <- projectWithEnv envName project+ pure (handlers, bumpProject)++runBumpTest ::+ ContextHandlers ->+ ManagedOptions ->+ EnvName ->+ M DepChanges+runBumpTest config options envName = do+ (handlers, project) <- bumpHandlers config options envName+ runBump handlers project++handlersTest ::+ ManagedOptions ->+ MaintConfig ->+ CabalConfig ->+ M MaintHandlers+handlersTest options config cabal = do+ manager <- httpManager+ publishHackages <- HackageClient.handlersProdFor (Just manager) ForPublish cabal+ pure MaintHandlers {+ git = gitApiMaintProd config,+ context,+ runBump = runBumpTest context options,+ publishHackages+ }+ where+ context = ContextHandlers.handlersProd
lib/Hix/Managed/Handlers/Mutation.hs view
@@ -1,7 +1,6 @@ module Hix.Managed.Handlers.Mutation where import Hix.Data.Monad (M)-import Hix.Data.PackageId (PackageId) import Hix.Managed.Data.Mutation (BuildMutation, DepMutation, MutationResult) import Hix.Managed.Data.MutationState (MutationState) @@ -10,6 +9,6 @@ process :: s -> DepMutation a ->- (BuildMutation -> M (Maybe (MutationState, Set PackageId))) ->+ (BuildMutation -> M (Maybe MutationState)) -> M (MutationResult s) }
lib/Hix/Managed/Handlers/Mutation/Bump.hs view
@@ -35,12 +35,12 @@ processMutationBump :: SolverState -> DepMutation Bump ->- (BuildMutation -> M (Maybe (MutationState, Set PackageId))) ->+ (BuildMutation -> M (Maybe MutationState)) -> M (MutationResult SolverState) processMutationBump solver DepMutation {package, mutation = Bump {version, changed}} build = builder version <&> \case- Just (candidate, ext, state, revisions) ->- MutationSuccess {candidate, changed, state, revisions, ext}+ Just (candidate, ext, state) ->+ MutationSuccess {candidate, changed, state, ext} Nothing -> MutationFailed where
lib/Hix/Managed/Handlers/Mutation/Lower.hs view
@@ -38,12 +38,12 @@ (Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints) -> SolverState -> DepMutation Lower ->- (BuildMutation -> M (Maybe (MutationState, Set PackageId))) ->+ (BuildMutation -> M (Maybe MutationState)) -> M (MutationResult SolverState) processMutationLower conf mode update solver DepMutation {package, retract, mutation = Lower {majors}} build = do foldM buildMajor (Right 0, Nothing) majors <&> \case- (_, Just (candidate, ext, state, revisions)) ->- MutationSuccess {candidate, changed = True, state, revisions, ext}+ (_, Just (candidate, ext, state)) ->+ MutationSuccess {candidate, changed = True, state, ext} (_, Nothing) -> mode.noSuccess where
+ lib/Hix/Managed/Handlers/Project.hs view
@@ -0,0 +1,19 @@+module Hix.Managed.Handlers.Project where++import qualified Hix.Managed.Handlers.Report as Report+import Hix.Managed.Handlers.Report (ReportHandlers)+import qualified Hix.Managed.Handlers.StateFile as StateFile+import Hix.Managed.Handlers.StateFile (StateFileHandlers)++data ProjectHandlers =+ ProjectHandlers {+ stateFile :: StateFileHandlers,+ report :: ReportHandlers+ }++handlersNull :: ProjectHandlers+handlersNull =+ ProjectHandlers {+ stateFile = StateFile.handlersNull,+ report = Report.handlersNull+ }
+ lib/Hix/Managed/Handlers/Project/Prod.hs view
@@ -0,0 +1,24 @@+module Hix.Managed.Handlers.Project.Prod where++import Distribution.Pretty (pretty)+import Text.PrettyPrint (hang, vcat)++import Hix.Data.Monad (M)+import qualified Hix.Log as Log+import Hix.Managed.Data.StateFileConfig (StateFileConfig)+import Hix.Managed.Handlers.Project (ProjectHandlers (..))+import qualified Hix.Managed.Handlers.Report.Prod as Report+import qualified Hix.Managed.Handlers.StateFile.Prod as StateFile++handlersProd ::+ StateFileConfig ->+ M ProjectHandlers+handlersProd stateFileConf = do+ traceInputs+ pure ProjectHandlers {+ stateFile = StateFile.handlersProd stateFileConf,+ report = Report.handlersProd+ }+ where+ traceInputs =+ Log.traceP (hang "Creating project handlers from config:" 2 (vcat [pretty stateFileConf]))
lib/Hix/Managed/Handlers/Report/Prod.hs view
@@ -182,5 +182,4 @@ sequence_ (intersperse blankLine (envResult <$> toList results.envs)) handlersProd :: ReportHandlers-handlersProd =- ReportHandlers {mutations}+handlersProd = ReportHandlers {mutations}
+ lib/Hix/Managed/Handlers/Revision.hs view
@@ -0,0 +1,11 @@+module Hix.Managed.Handlers.Revision where++import Hix.Managed.Git (GitApi)+import Hix.Managed.Handlers.HackageClient (HackageClient)+import Hix.Managed.Maint.Git (GitRevision)++data RevisionHandlers =+ RevisionHandlers {+ git :: GitApi GitRevision,+ publishHackages :: NonEmpty HackageClient+ }
+ lib/Hix/Managed/Handlers/Revision/Prod.hs view
@@ -0,0 +1,21 @@+module Hix.Managed.Handlers.Revision.Prod where++import Hix.Data.Monad (M)+import Hix.Http (httpManager)+import Hix.Managed.Cabal.Data.Config (CabalConfig, HackagePurpose (ForPublish))+import Hix.Managed.Data.RevisionConfig (RevisionConfig (..))+import qualified Hix.Managed.Handlers.HackageClient.Prod as HackageClient+import Hix.Managed.Handlers.Revision (RevisionHandlers (..))+import Hix.Managed.Maint.Git (gitApiRevisionHermetic, gitApiRevisionProd)++handlersProd ::+ RevisionConfig ->+ CabalConfig ->+ M RevisionHandlers+handlersProd config cabal = do+ manager <- httpManager+ publishHackages <- HackageClient.handlersProdFor (Just manager) ForPublish cabal+ pure RevisionHandlers {+ git = (if config.globalGit then gitApiRevisionProd else gitApiRevisionHermetic) config,+ publishHackages+ }
+ lib/Hix/Managed/Handlers/SourceHash.hs view
@@ -0,0 +1,18 @@+module Hix.Managed.Handlers.SourceHash where++import Hix.Data.Monad (M)+import Hix.Data.PackageId (PackageId)+import Hix.Data.Version (SourceHash (SourceHash))+import Hix.Managed.Cabal.Data.HackageRepo (HackageName)+import Hix.Pretty (showP)++data SourceHashHandlers =+ SourceHashHandlers {+ fetchHash :: PackageId -> M (Either Text (SourceHash, Maybe HackageName))+ }++handlersNull :: SourceHashHandlers+handlersNull =+ SourceHashHandlers {+ fetchHash = \ package -> pure (Right (SourceHash (showP package), Nothing))+ }
+ lib/Hix/Managed/Handlers/SourceHash/Prod.hs view
@@ -0,0 +1,26 @@+module Hix.Managed.Handlers.SourceHash.Prod where++import Data.IORef (newIORef)++import Hix.Data.Version (SourceHash)+import Hix.Hackage.Hash (fetchHashHackageCached)+import Hix.Managed.Cabal.Data.HackageRepo (HackageName, HackageRepo)+import qualified Hix.Managed.Handlers.SourceHash+import Hix.Managed.Handlers.SourceHash (SourceHashHandlers (SourceHashHandlers))++handlersProdWith ::+ MonadIO m =>+ Map Text (SourceHash, HackageName) ->+ NonEmpty HackageRepo ->+ m SourceHashHandlers+handlersProdWith initial repos = do+ hashCache <- liftIO (newIORef initial)+ pure SourceHashHandlers {+ fetchHash = fetchHashHackageCached hashCache repos+ }++handlersProd ::+ MonadIO m =>+ NonEmpty HackageRepo ->+ m SourceHashHandlers+handlersProd = handlersProdWith mempty
lib/Hix/Managed/Handlers/StateFile/Prod.hs view
@@ -1,15 +1,17 @@ module Hix.Managed.Handlers.StateFile.Prod where import qualified Data.Text.IO as Text-import Path (Abs, File, Path, parent, toFilePath, (</>), Dir)+import Path (Abs, Dir, File, Path, parent, toFilePath, (</>)) import Path.IO (createDirIfMissing, doesDirExist, doesFileExist) import System.Posix (fileMode, getFileStatus, ownerWriteMode, setFileMode, unionFileModes) +import qualified Hix.Data.Monad+import Hix.Data.Monad (appRes) import Hix.Data.NixExpr (Expr) import qualified Hix.Managed.Data.StateFileConfig import Hix.Managed.Data.StateFileConfig (StateFileConfig) import Hix.Managed.Handlers.StateFile (StateFileHandlers (..))-import Hix.Managed.Path (rootOrCwd)+import Hix.Maybe (fromMaybeA) import Hix.Monad (M, tryIOM) import Hix.NixExpr (renderRootExpr) @@ -32,7 +34,7 @@ Maybe (Path Abs Dir) -> M (Path Abs File) initFile conf tmpRoot = do- root <- maybe (rootOrCwd conf.projectRoot) pure tmpRoot+ root <- fromMaybeA appRes.root tmpRoot let depsFile = root </> conf.file createDirIfMissing False (parent depsFile) setDepsFileWritable depsFile
lib/Hix/Managed/Lower/App.hs view
@@ -1,33 +1,34 @@ module Hix.Managed.Lower.App where -import Hix.Data.Error (Error (Client)) import Hix.Data.Monad (M) import qualified Hix.Data.Options-import Hix.Data.Options (LowerOptions (LowerOptions))-import Hix.Json (jsonConfigE)+import Hix.Data.Options (LowerOptions)+import Hix.Managed.App (managedApp) import Hix.Managed.Data.LowerConfig (LowerConfig, lowerConfig) import Hix.Managed.Data.ProjectContext (ProjectContext)-import qualified Hix.Managed.Data.ProjectContextProto import Hix.Managed.Data.ProjectResult (ProjectResult) import Hix.Managed.Handlers.Build (BuildHandlers)-import Hix.Managed.Handlers.Build.Test (chooseHandlers)+import Hix.Managed.Handlers.Context (ContextKey (ContextManaged), jsonOrQueryProd) import Hix.Managed.Lower.Auto (lowerAutoMain) import Hix.Managed.Lower.Init (lowerInitMain) import Hix.Managed.Lower.Optimize (lowerOptimizeMain) import Hix.Managed.Lower.Stabilize (lowerStabilizeMain)-import Hix.Managed.ProjectContext (withProjectContext)+import Hix.Managed.ProjectContext (processProjectResult) +lowerApp ::+ (LowerConfig -> BuildHandlers -> ProjectContext -> M ProjectResult) ->+ LowerOptions ->+ M ProjectResult+lowerApp main opts = do+ context <- jsonOrQueryProd ContextManaged opts.common.context+ managedApp opts.common context (main (lowerConfig opts))+ lowerCli :: (LowerConfig -> BuildHandlers -> ProjectContext -> M ProjectResult) -> LowerOptions -> M ()-lowerCli main opts@LowerOptions {common} = do- context <- jsonConfigE Client common.context- handlers <- chooseHandlers common.stateFile context.envs context.buildOutputsPrefix common.project.build common.cabal- common.handlers- withProjectContext handlers common.project context (main conf handlers)- where- conf = lowerConfig opts+lowerCli main opts =+ processProjectResult =<< lowerApp main opts lowerInitCli :: LowerOptions -> M () lowerInitCli = lowerCli lowerInitMain
lib/Hix/Managed/Lower/Auto.hs view
@@ -10,7 +10,6 @@ import qualified Hix.Managed.Data.LowerConfig import Hix.Managed.Data.LowerConfig (LowerConfig) import Hix.Managed.Data.Mutable (MutableVersions)-import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext) import Hix.Managed.Data.ProjectResult (ProjectResult) import Hix.Managed.Data.Query (Query (Query))@@ -23,7 +22,7 @@ import Hix.Managed.Lower.Init (lowerInitStage) import Hix.Managed.Lower.Optimize (lowerOptimize) import Hix.Managed.Lower.Stabilize (stabilizeIfPossible, stabilizeStage, validateCurrent)-import Hix.Managed.Process (processProject)+import Hix.Managed.Process (processProjectSimple) suggestStabilize :: Flow () suggestStabilize = stageError "Re-run with --stabilize to attempt to fix the bounds."@@ -91,12 +90,12 @@ | otherwise -> suggestStabilize lowerAutoStages ::- BuildHandlers -> LowerConfig ->+ BuildHandlers -> BuildConfig -> Flow ()-lowerAutoStages handlers conf buildConf =- lowerInitStage handlers conf buildConf >>= \case+lowerAutoStages conf handlers buildConf =+ lowerInitStage conf handlers buildConf >>= \case Success | conf.initOnly -> unit | otherwise -> postInit handlers conf buildConf Failure -> stabilizeInitFailure handlers conf buildConf@@ -106,5 +105,5 @@ BuildHandlers -> ProjectContext -> M ProjectResult-lowerAutoMain conf handlers project =- processProject handlers project (lowerAutoStages handlers conf project.build)+lowerAutoMain conf =+ processProjectSimple (lowerAutoStages conf)
lib/Hix/Managed/Lower/Candidates.hs view
@@ -7,9 +7,8 @@ import Exon (exon) import Hix.Class.Map ((!!))-import Hix.Data.Error (Error (Client))+import Hix.Data.Error (ErrorMessage (Client)) import Hix.Data.Monad (M)-import Hix.Data.PackageName (PackageName) import Hix.Data.Version (Major) import qualified Hix.Data.VersionBounds import Hix.Data.VersionBounds (VersionBounds)@@ -21,6 +20,7 @@ import Hix.Managed.Data.Mutation (DepMutation (DepMutation)) import qualified Hix.Managed.Data.QueryDep import Hix.Managed.Data.QueryDep (QueryDep)+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers (..)) import Hix.Monad (throwM) import Hix.Pretty (showP) import Hix.Version (allMajors, majorParts, majorsBefore, versionsBetween, versionsFrom)@@ -46,13 +46,13 @@ prefix s m = [exon|#{show s}.#{show m}|] candidates ::- (PackageName -> M [Version]) ->+ AvailableVersionsHandlers -> QueryDep -> Bool -> ([Version] -> Maybe (NonEmpty Major)) -> M (Maybe (DepMutation Lower))-candidates fetchVersions dep retract selection = do- allVersions <- fetchVersions (depName package)+candidates versions dep retract selection = do+ allVersions <- versions.all (depName package) let result = do majors <- selection (sort allVersions)@@ -92,17 +92,17 @@ nonEmpty . reverse . allMajors candidatesInit ::- (PackageName -> M [Version]) ->+ AvailableVersionsHandlers -> Set MutableDep -> QueryDep -> M (Maybe (DepMutation Lower))-candidatesInit fetchVersions pre dep+candidatesInit versions pre dep | Set.member dep.package pre = pure Nothing | otherwise = do logInitConfig dep.package conf- candidates fetchVersions dep False (selectionInit conf)+ candidates versions dep False (selectionInit conf) where conf = initConfig dep.bounds @@ -139,13 +139,13 @@ const Nothing candidatesOptimize ::- (PackageName -> M [Version]) ->+ AvailableVersionsHandlers -> MutableVersions -> QueryDep -> M (Maybe (DepMutation Lower))-candidatesOptimize fetchVersions initial dep = do+candidatesOptimize versions initial dep = do logOptimizeConfig dep.package conf- candidates fetchVersions dep False (selectionOptimize conf)+ candidates versions dep False (selectionOptimize conf) where conf = optimizeConfig (join (initial !! dep.package)) dep.bounds @@ -181,13 +181,13 @@ selectionInit conf candidatesStabilize ::- (PackageName -> M [Version]) ->+ AvailableVersionsHandlers -> QueryDep -> Maybe Version -> M (Maybe (DepMutation Lower))-candidatesStabilize fetchVersions dep initialBound = do+candidatesStabilize versions dep initialBound = do logStabilizeConfig dep.package conf- candidates fetchVersions dep (isRetract conf) (selectionStabilize conf)+ candidates versions dep (isRetract conf) (selectionStabilize conf) where conf = stabilizeConfig dep.bounds initialBound
lib/Hix/Managed/Lower/Init.hs view
@@ -19,7 +19,6 @@ import Hix.Managed.Data.LowerConfig (LowerConfig) import Hix.Managed.Data.Mutable (MutableDep, MutableDeps) import Hix.Managed.Data.MutableId (MutableId)-import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext) import Hix.Managed.Data.ProjectResult (ProjectResult) import qualified Hix.Managed.Data.StageContext@@ -32,7 +31,7 @@ import qualified Hix.Managed.Handlers.Mutation.Lower as Mutation import Hix.Managed.Lower.Candidates (candidatesInit) import Hix.Managed.Lower.Data.LowerMode (lowerInitMode)-import Hix.Managed.Process (processProject)+import Hix.Managed.Process (processProjectSimple) import Hix.Managed.Report (describeIterations) import Hix.Managed.StageResult (stageResultInit) @@ -40,13 +39,13 @@ lowerInitUpdate _ _ PackageId {version} MutationConstraints {..} = MutationConstraints {mutation = fromUpper version, ..} -success :: Map MutableDep BuildSuccess -> Natural -> Text+success :: Map MutableDep BuildSuccess -> Word -> Text success _ iterations = [exon|Found initial lower bounds for all deps after #{iter}.|] where iter = describeIterations iterations -failure :: Natural -> Text+failure :: Word -> Text failure iterations = [exon|Couldn't find working initial lower bounds for some deps after #{describeIterations iterations}.|] @@ -75,14 +74,14 @@ ext = solverState context.env.solverBounds context.env.deps (fromVersions fromUpper keep) def keep | conf.reset = mempty- | otherwise = context.initial+ | otherwise = context.initialVersions lowerInitStage ::- BuildHandlers -> LowerConfig ->+ BuildHandlers -> BuildConfig -> Flow BuildStatus-lowerInitStage handlers conf buildConf =+lowerInitStage conf handlers buildConf = execStage "lower-init" (lowerInit handlers conf buildConf) lowerInitMain ::@@ -90,5 +89,4 @@ BuildHandlers -> ProjectContext -> M ProjectResult-lowerInitMain conf handlers project =- processProject handlers project (void (lowerInitStage handlers conf project.build))+lowerInitMain conf = processProjectSimple (lowerInitStage conf)
lib/Hix/Managed/Lower/Optimize.hs view
@@ -18,7 +18,6 @@ import Hix.Managed.Data.MutableId (MutableId) import qualified Hix.Managed.Data.MutationState import Hix.Managed.Data.MutationState (MutationState (MutationState))-import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext) import Hix.Managed.Data.ProjectResult (ProjectResult) import qualified Hix.Managed.Data.StageContext@@ -31,7 +30,7 @@ import qualified Hix.Managed.Handlers.Mutation.Lower as Mutation import Hix.Managed.Lower.Candidates (candidatesOptimize) import Hix.Managed.Lower.Data.LowerMode (lowerOptimizeMode)-import Hix.Managed.Process (processProject)+import Hix.Managed.Process (processProjectSimple) import Hix.Managed.Report (describeIterations) import Hix.Managed.StageResult (stageResult) @@ -39,11 +38,11 @@ lowerOptimizeUpdate _ _ PackageId {version} MutationConstraints {..} = MutationConstraints {mutation = fromUpper version, ..} -success :: Map MutableDep BuildSuccess -> Natural -> Text+success :: Map MutableDep BuildSuccess -> Word -> Text success _ iterations = [exon|Found optimal lower bounds for all deps after #{describeIterations iterations}.|] -failure :: Natural -> Text+failure :: Word -> Text failure iterations = [exon|Couldn't find working lower bounds for some deps after #{describeIterations iterations}.|] @@ -55,7 +54,7 @@ lowerOptimize handlers conf context@StageContext {env, state = Initial MutationState {versions}} = stageResult success failure <$> processQuery candidates mutationHandlers conf context ext where- candidates = candidatesOptimize handlers.versions context.initial+ candidates = candidatesOptimize handlers.versions context.initialVersions mutationHandlers = Mutation.handlersLower conf lowerOptimizeMode lowerOptimizeUpdate @@ -68,9 +67,5 @@ lowerOptimizeStage handlers conf = runStage_ "optimize" (lowerOptimize handlers conf) -lowerOptimizeMain ::- BuildHandlers ->- ProjectContext ->- M ProjectResult-lowerOptimizeMain handlers project =- processProject handlers project (lowerOptimizeStage handlers project.build)+lowerOptimizeMain :: BuildHandlers -> ProjectContext -> M ProjectResult+lowerOptimizeMain = processProjectSimple lowerOptimizeStage
lib/Hix/Managed/Lower/Stabilize.hs view
@@ -2,7 +2,7 @@ import Exon (exon) -import Hix.Class.Map (nToMaybe, (!!))+import Hix.Class.Map ((!!)) import Hix.Data.Monad (M) import qualified Hix.Data.PackageId import Hix.Data.PackageId (PackageId (PackageId))@@ -17,12 +17,11 @@ import Hix.Managed.Data.Constraints (MutationConstraints (MutationConstraints)) import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.Initial (Initial (Initial))-import Hix.Managed.Data.Mutable (MutableDep, MutableVersions, depName)+import Hix.Managed.Data.Mutable (MutableDep, depName) import qualified Hix.Managed.Data.MutableId import Hix.Managed.Data.MutableId (MutableId) import qualified Hix.Managed.Data.MutationState import Hix.Managed.Data.MutationState (MutationState (MutationState))-import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext) import Hix.Managed.Data.ProjectResult (ProjectResult) import qualified Hix.Managed.Data.QueryDep@@ -40,25 +39,14 @@ import qualified Hix.Managed.Handlers.Mutation.Lower as Mutation import Hix.Managed.Lower.Candidates (candidatesStabilize) import Hix.Managed.Lower.Data.LowerMode (lowerStabilizeMode)-import Hix.Managed.Process (processProject)+import Hix.Managed.Process (processProjectSimple) import Hix.Managed.Report (describeIterations) import Hix.Managed.StageResult (stageResult) --- TODO When some initial versions are missing, e.g. because the user added deps and the project broke at the same time,--- it is up to luck that the solver chooses working versions.--- Unlikely that there's a useful heuristic though.-initialVersions ::- MutableVersions ->- [PackageId]-initialVersions state =- nToMaybe state \ name -> fmap (initVersion name)- where- initVersion name version = PackageId {name = depName name, ..}- buildLowerInit :: Flow BuildStatus buildLowerInit = do- execStatelessStage "stabilize-initial" \ StageContext {env, initial, builder} ->- buildVersions builder env "initial lower bounds" initial <&> \case+ execStatelessStage "stabilize-initial" \ StageContext {env, initialVersions, builder} ->+ buildVersions builder env "initial lower bounds" initialVersions Nothing <&> \case Success -> StageNoAction (Just "Env builds successfully with the initial bounds.") Failure -> StageFailure (FailedPrecondition msg) where@@ -78,13 +66,13 @@ | otherwise = MutationConstraints {mutation = fromUpper version, ..} -success :: Map MutableDep BuildSuccess -> Natural -> Text+success :: Map MutableDep BuildSuccess -> Word -> Text success _ iterations = [exon|Found stable lower bounds for all deps after #{iter}.|] where iter = describeIterations iterations -failure :: Natural -> Text+failure :: Word -> Text failure iterations = [exon|Couldn't find working lower bounds for some deps after #{describeIterations iterations}.|] @@ -99,11 +87,11 @@ lowerStabilize handlers conf context = stageResult success failure <$> processQuery candidates mutationHandlers conf context ext where- candidates query = candidatesStabilize handlers.versions query (join (context.initial !! query.package))+ candidates query = candidatesStabilize handlers.versions query (join (context.initialVersions !! query.package)) mutationHandlers = Mutation.handlersLower conf lowerStabilizeMode lowerStabilizeUpdate - ext = solverState context.env.solverBounds context.env.deps (fromVersions fromUpper context.initial) def+ ext = solverState context.env.solverBounds context.env.deps (fromVersions fromUpper context.initialVersions) def stabilizeStage :: BuildHandlers ->@@ -123,10 +111,11 @@ validateCurrent :: Flow BuildStatus validateCurrent =- execStatelessStage "stabilize-current" \ StageContext {env, state = Initial MutationState {versions}, builder} ->- buildVersions builder env "current lower bounds" versions <&> \case- Success -> StageNoAction (Just "Env builds successfully with the current bounds.")- Failure -> StageFailure (FailedPrecondition ["Env does not build successfully with the current bounds."])+ execStatelessStage "stabilize-current" \+ StageContext {env, state = Initial MutationState {versions, overrides}, builder} ->+ buildVersions builder env "current lower bounds" versions (Just overrides) <&> \case+ Success -> StageNoAction (Just "Env builds successfully with the current bounds.")+ Failure -> StageFailure (FailedPrecondition ["Env does not build successfully with the current bounds."]) lowerStabilizeStages :: BuildHandlers ->@@ -135,11 +124,7 @@ lowerStabilizeStages handlers conf = validateCurrent >>= \case Success -> unit- _ -> stabilizeIfPossible handlers conf+ Failure -> stabilizeIfPossible handlers conf -lowerStabilizeMain ::- BuildHandlers ->- ProjectContext ->- M ProjectResult-lowerStabilizeMain handlers project =- processProject handlers project (lowerStabilizeStages handlers project.build)+lowerStabilizeMain :: BuildHandlers -> ProjectContext -> M ProjectResult+lowerStabilizeMain = processProjectSimple lowerStabilizeStages
+ lib/Hix/Managed/Maint/Data/MaintEnv.hs view
@@ -0,0 +1,14 @@+module Hix.Managed.Maint.Data.MaintEnv where++import Hix.Managed.Data.MaintConfig (MaintConfig)+import Hix.Managed.Handlers.Maint (MaintHandlers)+import Hix.Managed.Maint.Data.MaintTarget (MaintTarget)+import Hix.Managed.Maint.Git (GitMaint)++data MaintEnv =+ MaintEnv {+ target :: MaintTarget,+ handlers :: MaintHandlers,+ git :: GitMaint,+ config :: MaintConfig+ }
+ lib/Hix/Managed/Maint/Data/MaintPlan.hs view
@@ -0,0 +1,16 @@+module Hix.Managed.Maint.Data.MaintPlan where++import Distribution.Pretty (Pretty (pretty))++import Hix.Class.Map (nPretty)+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Maint.Data.MaintTarget (MaintTarget (..))++data MaintPlan =+ MaintPlan {+ targets :: Packages MaintTarget+ }+ deriving stock (Eq, Show)++instance Pretty MaintPlan where+ pretty MaintPlan {targets} = nPretty targets
+ lib/Hix/Managed/Maint/Data/MaintPrep.hs view
@@ -0,0 +1,12 @@+module Hix.Managed.Maint.Data.MaintPrep where++import Hix.Managed.Git (BranchName, MaintBranch)++data MaintPrep =+ PrepBranch {+ targetBranch :: MaintBranch,+ workBranch :: BranchName+ }+ |+ PrepNoTags+ deriving stock (Eq, Show)
+ lib/Hix/Managed/Maint/Data/MaintResult.hs view
@@ -0,0 +1,125 @@+module Hix.Managed.Maint.Data.MaintResult where++import Data.Aeson (ToJSON (toJSON))+import Distribution.Pretty (Pretty (pretty))+import Exon (exon)+import Text.PrettyPrint (brackets, hang, parens, text, vcat, (<+>))++import Hix.Data.PackageName (LocalPackage (..))+import Hix.Managed.Cabal.Data.Revision (Revision (..))+import Hix.Managed.Data.BuildOutput (ModifiedId (..))+import Hix.Managed.Git (BranchName)+import Hix.Pretty (hpretty)++data NoPublishReason =+ NoDirectDepUpdates+ |+ NoRangeUpdates+ |+ PublishDisabled+ deriving stock (Eq, Show)++instance Pretty NoPublishReason where+ pretty = \case+ NoDirectDepUpdates -> text "no direct dep updates"+ NoRangeUpdates -> text "no range updates"+ PublishDisabled -> text "publishing disabled by config"++data UpdateAction =+ OnlyCommit NoPublishReason+ |+ PublishRevision+ deriving stock (Eq, Show)++instance Pretty UpdateAction where+ pretty = \case+ OnlyCommit reason -> text "only commit" <+> parens (pretty reason)+ PublishRevision -> text "publish revision"++data MaintStatus =+ BumpFailure+ |+ NoChanges+ |+ UpdatedVersions UpdateAction (NonEmpty ModifiedId)+ deriving stock (Eq, Show)++instance Pretty MaintStatus where+ pretty = \case+ BumpFailure -> text "bump failure"+ NoChanges -> text "no changes"+ UpdatedVersions action modified ->+ hang (text "updated versions:") 2 (vcat [text "action:" <+> pretty action, "modified:" <+> hpretty modified])++data UnchangedReason =+ NoTags+ |+ NoUpdates+ |+ CannotProceed Text+ deriving stock (Eq, Show)++instance Pretty UnchangedReason where+ pretty = \case+ NoTags -> "No release tags found for this package"+ NoUpdates -> "All dependencies are up to date"+ CannotProceed msg -> [exon|Error: #{text (toString msg)}|]++data MaintChanged =+ Modified NoPublishReason+ |+ Published Revision+ deriving stock (Eq, Show, Generic)++instance ToJSON MaintChanged where+ toJSON = \case+ Modified _ -> toJSON ("modified" :: Text)+ Published _ -> toJSON ("published" :: Text)++instance Pretty MaintChanged where+ pretty = \case+ Modified reason -> text "Modified:" <+> pretty reason+ Published Revision {number} -> text "Published revision" <+> hpretty number++data MaintResult =+ Unchanged UnchangedReason+ |+ Changed {+ branch :: BranchName,+ baseBranch :: BranchName,+ resolution :: MaintChanged+ }+ deriving stock (Eq, Show, Generic)++instance Pretty MaintResult where+ pretty = \case+ Unchanged reason ->+ text "Unchanged:" <+> pretty reason+ Changed {..} ->+ pretty resolution <+> brackets (pretty branch)++data ChangedPackage =+ ChangedPackage {+ package :: LocalPackage,+ branch :: BranchName,+ baseBranch :: BranchName,+ message :: Text+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (ToJSON)++data FailedPackage =+ FailedPackage {+ package :: LocalPackage,+ message :: Text+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (ToJSON)++data MaintOutput =+ MaintOutput {+ changes :: [ChangedPackage],+ failures :: [FailedPackage]+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (ToJSON)
+ lib/Hix/Managed/Maint/Data/MaintTarget.hs view
@@ -0,0 +1,31 @@+module Hix.Managed.Maint.Data.MaintTarget where++import Distribution.Pretty (Pretty (pretty))+import Exon (exon)+import Path (Dir, Path, Rel)++import Hix.Data.EnvName (EnvName)+import Hix.Data.PackageId (PackageId (..))+import Hix.Data.PackageName (LocalPackage (..), PackageName, localPackageName)+import Hix.Data.Version (Version)+import Hix.Managed.Git (MaintBranch (..))++-- TODO prune unused fields+data MaintTarget =+ MaintTarget {+ package :: LocalPackage,+ version :: Version,+ deps :: Set PackageName,+ -- TODO this should just be for manual override+ branch :: Maybe MaintBranch,+ path :: Path Rel Dir,+ env :: EnvName+ }+ deriving stock (Eq, Show)++instance Pretty MaintTarget where+ pretty MaintTarget {..} =+ [exon|#{pretty pid}#{foldMap prettyBranch branch}|]+ where+ prettyBranch name = [exon| (#{pretty name})|]+ pid = PackageId {name = localPackageName package ,..}
+ lib/Hix/Managed/Maint/Git.hs view
@@ -0,0 +1,155 @@+module Hix.Managed.Maint.Git where++import Control.Monad.Catch (finally)+import qualified Data.Text as Text+import Distribution.Parsec (simpleParsec)+import Exon (exon)+import System.Posix (epochTime)++import Hix.Data.Monad (M)+import Hix.Data.PackageName (LocalPackage)+import Hix.Managed.BuildOutput.CommitMsg (commitModified)+import Hix.Managed.Data.BuildOutput (ModifiedId)+import Hix.Managed.Data.MaintConfig (MaintConfig (..))+import Hix.Managed.Data.RevisionConfig (RevisionConfig (..))+import Hix.Managed.Git (+ BranchName (..),+ GitApi,+ GitNative (..),+ GitResult (..),+ MaintBranch (..),+ Tag,+ gitApi,+ gitApiHermetic,+ gitError,+ )+import Hix.Monad (clientError, fatalError)+import Hix.Pretty (showP)++data GitMaint =+ GitMaint {+ bracket :: ∀ a . M a -> M a,+ readTags :: M [Tag],+ listTargetBranches :: LocalPackage -> M [MaintBranch],+ branchOffTag :: MaintBranch -> Tag -> M (),+ switchBranch :: MaintBranch -> M BranchName,+ commitBump :: MaintBranch -> LocalPackage -> NonEmpty ModifiedId -> M BranchName+ }++data GitRevision =+ GitRevision {+ bracket :: ∀ a . M a -> M a,+ listTargetBranches :: LocalPackage -> M [MaintBranch],+ switchBranch :: MaintBranch -> M BranchName+ }++formatReleaseBranch :: MaintBranch -> Text+formatReleaseBranch MaintBranch {..} =+ [exon|release/##{package}/#{showP version}|]++releaseBranchName :: MaintBranch -> BranchName+releaseBranchName = BranchName . formatReleaseBranch++-- TODO make switching back to main configurable+cleanup :: GitNative -> Bool -> Maybe Text -> Maybe Text -> M ()+cleanup git push initialBranch mainRemote = do+ git.cmd_ ["reset", "--hard"]+ for_ initialBranch \ branch -> git.cmd_ ["switch", "-f", branch]+ when push do+ for_ mainRemote \ remote -> git.cmd_ ["push", "--all", remote]++branchRemote :: GitNative -> Text -> M (Maybe Text)+branchRemote git branch =+ git.cmdResult args >>= \case+ GitSuccess remotes -> pure (head remotes)+ GitFailure {code = 1} -> pure Nothing+ GitFailure {..} -> fatalError (gitError args stdout stderr)+ where+ args = ["config", [exon|branch.#{branch}.remote|]]++listTargetBranches :: GitNative -> LocalPackage -> M [MaintBranch]+listTargetBranches git target = do+ allBranches <- git.cmd ["branch", "--list", "--format=%(refname:short)", [exon|release/##{target}/*|]]+ pure (mapMaybe (simpleParsec . toString) allBranches)++switchBranch :: GitNative -> MaintBranch -> M BranchName+switchBranch git branch = do+ let branchName = releaseBranchName branch+ git.cmd_ ["switch", showP branchName]+ pure branchName++gitMaintNative :: MaintConfig -> GitNative -> GitMaint+gitMaintNative MaintConfig {push, fetch, pr} git =+ GitMaint {+ listTargetBranches = listTargetBranches git,+ switchBranch = switchBranch git,+ ..+ }+ where+ bracket :: ∀ a . M a -> M a+ bracket ma = do+ git.cmd' ["diff", "--exit-code"] >>= leftA \ (out, err) ->+ clientError [exon|Git tree is dirty:+stdout: #{Text.unlines out}+stderr: #{Text.unlines err}|]+ when fetch do+ git.cmd_ ["fetch", "--tags", "origin", "release/*:release/*"]+ initialBranch <- head <$> git.cmd ["symbolic-ref", "--short", "HEAD"]+ mainRemote <- traverse (branchRemote git) initialBranch+ finally ma (cleanup git push initialBranch (join mainRemote))++ readTags = mapMaybe (simpleParsec . toString) <$> git.cmd ["tag", "--list", "--format=%(refname:short)"]++ branchOffTag branch tag = do+ let branchName = formatReleaseBranch branch+ git.cmd_ ["switch", "--create", branchName, showP tag]++ commitBump branch package modified = do+ prBranch <- ensurePrBranch branch+ let (message, body) = commitModified [[exon|Maintenance for '##{package}'|]] modified+ git.cmd_ ["add", "--all"]+ git.cmd_ ["commit", "-m", message, "-m", Text.unlines body]+ pure prBranch++ ensurePrBranch branch+ | pr = do+ date <- liftIO epochTime+ let prBranch = [exon|#{releaseBranch}-#{show date}|]+ git.cmd_ ["switch", "--create", coerce prBranch]+ pure prBranch+ | otherwise+ = pure releaseBranch+ where+ releaseBranch = releaseBranchName branch++gitApiMaintProd :: MaintConfig -> GitApi GitMaint+gitApiMaintProd config = gitApi (gitMaintNative config)++gitApiMaintHermetic :: MaintConfig -> GitApi GitMaint+gitApiMaintHermetic config = gitApiHermetic (gitMaintNative config)++gitRevisionNative :: RevisionConfig -> GitNative -> GitRevision+gitRevisionNative RevisionConfig {fetch} git =+ GitRevision {+ listTargetBranches = listTargetBranches git,+ switchBranch = switchBranch git,+ ..+ }+ where+ bracket :: ∀ a . M a -> M a+ bracket ma = do+ git.cmd' ["diff", "--exit-code"] >>= leftA \ (out, err) ->+ clientError [exon|Git tree is dirty:+stdout: #{Text.unlines out}+stderr: #{Text.unlines err}|]+ when fetch do+ git.cmd_ ["fetch", "--tags", "origin", "release/*:release/*"]+ initialBranch <- head <$> git.cmd ["symbolic-ref", "--short", "HEAD"]+ mainRemote <- traverse (branchRemote git) initialBranch+ finally ma (cleanup git False initialBranch (join mainRemote))++gitApiRevisionProd :: RevisionConfig -> GitApi GitRevision+gitApiRevisionProd config = gitApi (gitRevisionNative config)++gitApiRevisionHermetic :: RevisionConfig -> GitApi GitRevision+gitApiRevisionHermetic config = gitApiHermetic (gitRevisionNative config)
+ lib/Hix/Managed/Maint/MaintPlan.hs view
@@ -0,0 +1,51 @@+module Hix.Managed.Maint.MaintPlan where++import qualified Data.Set as Set+import Exon (exon)++import Hix.Class.Map (nInsert, nTransformMulti, nViaA, (!?))+import Hix.Data.Dep (Dep (..))+import Hix.Data.EnvName (EnvName)+import Hix.Data.Monad (M)+import Hix.Data.PackageName (LocalPackage (..), PackageName)+import Hix.Managed.Data.MaintContext (MaintContext (..), MaintPackage (..))+import Hix.Managed.Data.ManagedPackage (ManagedPackage (..))+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Maint.Data.MaintPlan (MaintPlan (..))+import Hix.Managed.Maint.Data.MaintTarget (MaintTarget (..))+import Hix.Managed.Report (plural)+import Hix.Monad (eitherClient, noteClient)+import Hix.Pretty (showPL)++envForTarget :: Packages EnvName -> LocalPackage -> M EnvName+envForTarget envs package =+ noteClient noTargetEnv (envs !? package)+ where+ noTargetEnv = [exon|The package '##{package}' is not a target of any environment.|]++restrictTargets :: NonEmpty PackageName -> Packages MaintPackage -> M (Packages MaintPackage)+restrictTargets specified packages =+ eitherClient (first err (foldr step (Right []) locals))+ where+ step name z+ | Just mp <- packages !? name = nInsert name mp <$> z+ | otherwise = Left (Set.insert name (fromLeft [] z))++ err unknown = [exon|Unknown package#{plural (length unknown)}: #{showPL unknown}|]++ locals = LocalPackage <$> specified++maintPlan ::+ MaintContext ->+ Maybe (NonEmpty PackageName) ->+ M MaintPlan+maintPlan MaintContext {packages, envs} specified = do+ selected <- maybe pure restrictTargets specified packages+ targets <- nViaA (traverse target) selected+ pure MaintPlan {targets}+ where+ target MaintPackage {package = ManagedPackage {name, version, deps}, ..} = do+ env <- envForTarget targetEnvs name+ pure MaintTarget {package = name, version, branch = Nothing, deps = Set.fromList ((.package) <$> deps), ..}++ targetEnvs = flip nTransformMulti envs \ envName targets -> [(t, envName) | t <- targets]
+ lib/Hix/Managed/Maint/MaintResult.hs view
@@ -0,0 +1,75 @@+module Hix.Managed.Maint.MaintResult where++import qualified Data.Set as Set+import Exon (exon)++import Hix.Class.Map (nTo)+import qualified Hix.Color as Color+import Hix.Data.Monad (M)+import Hix.Data.OutputFormat (OutputFormat (..))+import Hix.Data.OutputTarget (OutputTarget)+import Hix.Managed.Data.BuildOutput (DepChanges (..), ModifiedId (..))+import Hix.Managed.Data.MaintConfig (MaintConfig (..))+import Hix.Managed.Data.Mutable (depName)+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Maint.Data.MaintEnv (MaintEnv (..))+import Hix.Managed.Maint.Data.MaintResult (+ ChangedPackage (..),+ FailedPackage (..),+ MaintOutput (..),+ MaintResult (..),+ MaintStatus (..),+ NoPublishReason (..),+ UnchangedReason (..),+ UpdateAction (..),+ )+import Hix.Managed.Maint.Data.MaintTarget (MaintTarget (..))+import Hix.Monad (clientError)+import Hix.OutputWriter (OutputSpecial (..), writeOutput)++bumpResult :: MaintEnv -> DepChanges -> MaintStatus+bumpResult env changes+ | not (null changes.failed)+ , env.config.noFailures+ = BumpFailure+ | Just modified <- nonEmpty changes.modified+ = UpdatedVersions updateAction modified+ | otherwise+ = NoChanges+ where+ updateAction | null directDeps = OnlyCommit NoDirectDepUpdates+ | not env.config.revision = OnlyCommit PublishDisabled+ | any hasRangeUpdate directDeps = PublishRevision+ | otherwise = OnlyCommit NoRangeUpdates++ directDeps =+ flip filter changes.modified \ ModifiedId {package} -> Set.member (depName package) env.target.deps++ hasRangeUpdate ModifiedId {range} = isJust range++maintOutput :: Packages MaintResult -> MaintOutput+maintOutput packages =+ MaintOutput {changes, failures}+ where+ (changes, failures) = fmap catMaybes $ partitionEithers $ nTo packages \ package -> \case+ Unchanged reason+ | CannotProceed message <- reason+ -> Right (Just FailedPackage {..})+ | otherwise+ -> Right Nothing+ Changed {branch, baseBranch} -> Left ChangedPackage {message = "changed", ..}++writeMaintOutput :: OutputTarget -> OutputFormat -> MaintOutput -> M ()+writeMaintOutput =+ writeOutput $ const \case+ OutputSpecialCommitMsg -> unsupported "commit-msg"+ OutputSpecialGaPr -> unsupported "ga-pr"+ OutputSpecialGithubOutputKey -> pure "maint"+ where+ unsupported :: ∀ a . Text -> M a+ unsupported format =+ clientError [exon|Output format #{Color.yellow format} isn't supported for #{Color.green @Text "maint"}|]++outputResults :: OutputTarget -> OutputFormat -> Packages MaintResult -> M ()+outputResults target format results =+ writeMaintOutput target format (maintOutput results)
+ lib/Hix/Managed/Maint/Package.hs view
@@ -0,0 +1,130 @@+module Hix.Managed.Maint.Package where++import Distribution.Pretty (Pretty (pretty))+import Exon (exon)+import Path (Abs, Dir, File, Path, Rel, addExtension, parseRelFile, (</>))+import Text.PrettyPrint (nest, text, ($$), (<+>))++import Hix.Data.Monad (AppResources (..), M, appRes)+import Hix.Data.PackageId (PackageId (..))+import Hix.Data.PackageName (LocalPackage (..), localPackageName)+import qualified Hix.Log as Log+import Hix.Managed.Cabal.Data.Revision (Revision (number), RevisionPublished (..))+import Hix.Managed.Cabal.PackageDescription (parseCabal, parseCabalFile)+import qualified Hix.Managed.Cabal.Upload as Upload+import Hix.Managed.Cabal.Upload (latestRevision, revisionCabalFile)+import Hix.Managed.Data.MaintConfig (MaintConfig (..))+import Hix.Managed.Git (BranchName, MaintBranch (..), Tag (..))+import Hix.Managed.Handlers.HackageClient (HackageClient (..))+import Hix.Managed.Handlers.Maint (MaintHandlers (..))+import Hix.Managed.Handlers.Revision (RevisionHandlers (..))+import Hix.Managed.Maint.Data.MaintEnv (MaintEnv (..))+import Hix.Managed.Maint.Data.MaintPrep (MaintPrep (..))+import Hix.Managed.Maint.Data.MaintResult (+ MaintChanged (..),+ MaintResult (..),+ MaintStatus (..),+ UnchangedReason (..),+ UpdateAction (..),+ )+import Hix.Managed.Maint.Data.MaintTarget (MaintTarget (..))+import Hix.Managed.Maint.Git (GitMaint (..))+import Hix.Managed.Maint.MaintResult (bumpResult)+import Hix.Managed.Maint.Prep (maintPrep)+import Hix.Managed.Maint.RevisionPlan (RevisionTarget (..))+import Hix.Monad (eitherFatal)+import Hix.Pretty (hpretty, showP)++packageCabalFile :: LocalPackage -> Path Rel Dir -> M (Path Abs File)+packageCabalFile package path = do+ root <- appRes.root+ cabalFileName <- eitherFatal $ first nameParseError do+ name <- parseRelFile (toString package)+ addExtension ".cabal" name+ pure (root </> path </> cabalFileName)+ where+ nameParseError err = [exon|Package name '##{package}' is not a valid file path: #{show err}|]++publishRevision ::+ MaintEnv ->+ M MaintChanged+publishRevision env = do+ cabalFile <- packageCabalFile env.target.package env.target.path+ revision <- Upload.publishRevision env.handlers.publishHackages pid cabalFile+ pure (Published revision)+ where+ pid = PackageId {name = localPackageName package, version}+ MaintTarget {package, version} = env.target++processUpdateAction :: MaintEnv -> UpdateAction -> M MaintChanged+processUpdateAction env = \case+ OnlyCommit reason -> pure (Modified reason)+ PublishRevision -> publishRevision env++processStatus ::+ MaintEnv ->+ MaintBranch ->+ BranchName ->+ MaintStatus ->+ M MaintResult+processStatus env maintBranch baseBranch = \case+ BumpFailure ->+ pure (Unchanged (CannotProceed "Some dependency updates failed to build."))+ NoChanges ->+ pure (Unchanged NoUpdates)+ UpdatedVersions action modified -> do+ traceBump modified+ branch <-+ if env.config.commit+ then env.git.commitBump maintBranch env.target.package modified+ else pure baseBranch+ resolution <- processUpdateAction env action+ pure Changed {..}+ where+ traceBump modified =+ Log.traceP $+ text "Bumped package:" <+> pretty env.target.package $$+ nest 2 (+ text "deps:" <+> hpretty env.target.deps $$+ text "modified:" <+> hpretty modified+ )++maintPackage ::+ MaintHandlers ->+ MaintConfig ->+ GitMaint ->+ [Tag] ->+ MaintTarget ->+ M MaintResult+maintPackage handlers config git tags target =+ maintPrep env tags target.package target.version >>= \case+ PrepBranch {..} -> do+ status <- bumpResult env <$> env.handlers.runBump env.target.env+ Log.debug [exon|Maint status: #{showP status}|]+ processStatus env targetBranch workBranch status+ PrepNoTags ->+ pure (Unchanged NoTags)+ where+ env = MaintEnv {handlers, target, git, config}++publishRevisionIfChangedTo :: RevisionHandlers -> RevisionTarget -> HackageClient -> M (Maybe RevisionPublished)+publishRevisionIfChangedTo handlers target hackage = do+ latest <- latestRevision hackage pid+ oldCabal <- revisionCabalFile hackage pid latest.number+ oldPkgDesc <- eitherFatal (parseCabal "hackage" (encodeUtf8 oldCabal))+ cabalFile <- packageCabalFile target.package target.path+ newPkgDesc <- parseCabalFile cabalFile+ if oldPkgDesc == newPkgDesc+ then pure Nothing+ else do+ revision <- Upload.publishRevision handlers.publishHackages pid cabalFile+ pure (Just RevisionPublished {revision, destination = hackage.description})+ where+ pid = PackageId {name = target.package.name, version = target.version}++publishRevisionIfChanged ::+ RevisionHandlers ->+ RevisionTarget ->+ M [RevisionPublished]+publishRevisionIfChanged handlers target =+ catMaybes . toList <$> traverse (publishRevisionIfChangedTo handlers target) handlers.publishHackages
+ lib/Hix/Managed/Maint/Prep.hs view
@@ -0,0 +1,90 @@+module Hix.Managed.Maint.Prep where++import Distribution.Pretty (Pretty (pretty))+import Exon (exon)++import Hix.Data.Monad (M)+import Hix.Data.PackageName (LocalPackage (..))+import Hix.Data.Version (Version)+import qualified Hix.Log as Log+import Hix.Managed.Git (MaintBranch (..), Tag (..))+import Hix.Managed.Maint.Data.MaintEnv (MaintEnv (..))+import Hix.Managed.Maint.Data.MaintPrep (MaintPrep (..))+import Hix.Managed.Maint.Data.MaintTarget (MaintTarget (..))+import Hix.Managed.Maint.Git (GitMaint (..))++-- | Return all tags that satisfy:+-- - Version not smaller than the target's.+-- - Either:+-- - Package segment absent (shared release of all packages).+-- Format: 1.4.3+-- - Package matches target.+-- Format: pname-1.4.3+matchTags :: LocalPackage -> Version -> [Tag] -> [Tag]+matchTags package version =+ filter \ (Tag tagPackage tagVersion) ->+ matchPackage tagPackage && tagVersion <= version+ where+ matchPackage = \case+ Just tp -> package == tp+ Nothing -> True++newtype TagPrio =+ TagPrio Tag+ deriving stock (Eq, Show)++instance Ord TagPrio where+ compare = coerce (comparing @_ @Tag (.version) <> comparing (.package))++-- | Pick the tag with the highest version for the given package.+-- Both package-specific and shared tags are eligible.+-- If the latest shared tag's version is higher than the latest specific tag's, pick the shared tag, and vice versa.+-- If the latest shared and specific tags have the same version, pick the specific tag.+selectTag :: LocalPackage -> Version -> [Tag] -> Maybe Tag+selectTag package version =+ head .+ sortOn (Down . TagPrio) .+ matchTags package version++useBranch ::+ MaintEnv ->+ MaintBranch ->+ M MaintPrep+useBranch env targetBranch = do+ workBranch <- env.git.switchBranch targetBranch+ pure PrepBranch {targetBranch, workBranch}++createBranch ::+ MaintEnv ->+ Tag ->+ M MaintPrep+createBranch env tag = do+ env.git.branchOffTag branch tag+ useBranch env branch+ where+ branch = MaintBranch {package = env.target.package, version = tag.version}++-- TODO this needs to fetch those branches as well – in CI they probably won't be present initially+--+-- TODO also it needs to check out an existing branch+selectBranch ::+ MaintEnv ->+ Tag ->+ M MaintPrep+selectBranch env tag = do+ traceInputs+ branches <- env.git.listTargetBranches env.target.package+ maybe (createBranch env tag) (useBranch env) (find matchBranch branches)+ where+ traceInputs = Log.debugP [exon|Using tag '#{pretty tag}' for '#{pretty env.target.package}'|]++ matchBranch MaintBranch {version = bv} = bv == tag.version++maintPrep ::+ MaintEnv ->+ [Tag] ->+ LocalPackage ->+ Version ->+ M MaintPrep+maintPrep env tags package version =+ maybe (pure PrepNoTags) (selectBranch env) (selectTag package version tags)
+ lib/Hix/Managed/Maint/RevisionPlan.hs view
@@ -0,0 +1,119 @@+module Hix.Managed.Maint.RevisionPlan where++import Control.Monad.Extra (mapMaybeM)+import Distribution.Client.Compat.Prelude (simpleParsec)+import Exon (exon)+import Path (Dir, Path, Rel)++import Hix.Class.Map (nElems, nTransformMulti, (!?))+import qualified Hix.Color as Color+import Hix.Data.EnvName (EnvName)+import Hix.Data.Monad (M)+import Hix.Data.PackageName (LocalPackage (..), PackageName)+import Hix.Data.Version (Version)+import Hix.Managed.Data.MaintContext (MaintContext (..), MaintPackage (..))+import Hix.Managed.Data.ManagedPackage (ManagedPackage (..))+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Git (BranchName (..), MaintBranch (..))+import Hix.Managed.Maint.Git (GitRevision (..), formatReleaseBranch)+import Hix.Managed.Maint.MaintPlan (envForTarget)+import Hix.Monad (appContext, noteClient)++data BadSpecs =+ BadSpecs {+ packages :: Maybe (NonEmpty PackageName),+ branches :: Maybe (NonEmpty BranchName)+ }+ deriving stock (Eq, Show)++data RevisionTarget =+ RevisionTarget {+ package :: LocalPackage,+ version :: Version,+ path :: Path Rel Dir,+ branch :: BranchName,+ env :: EnvName+ }+ deriving stock (Eq, Show)++newtype BranchPrio =+ BranchPrio MaintBranch+ deriving stock (Eq, Show)++instance Ord BranchPrio where+ compare = coerce (comparing @_ @MaintBranch (.version) <> comparing (.package))++newestBranch :: [MaintBranch] -> Maybe MaintBranch+newestBranch =+ head . sortOn (Down . BranchPrio)++revisionTarget ::+ ([MaintBranch] -> Maybe MaintBranch) ->+ GitRevision ->+ Packages EnvName ->+ MaintPackage ->+ M (Maybe RevisionTarget)+revisionTarget choose git targetEnvs MaintPackage {..} = do+ branches <- git.listTargetBranches package.name+ for (choose branches) \ branch@MaintBranch {version} -> do+ env <- envForTarget targetEnvs package.name+ pure RevisionTarget {branch = BranchName (formatReleaseBranch branch), package = package.name, ..}++allCandidates ::+ GitRevision ->+ Packages EnvName ->+ Packages MaintPackage ->+ M [RevisionTarget]+allCandidates git targetEnvs packages =+ mapMaybeM (revisionTarget newestBranch git targetEnvs) (nElems packages)++resolveTargets ::+ NonEmpty (Either PackageName BranchName) ->+ GitRevision ->+ Packages EnvName ->+ Packages MaintPackage ->+ M [RevisionTarget]+resolveTargets spec git targetEnvs packages =+ for (toList spec) \case+ Right (BranchName branch) ->+ appContext [exon|validating the target branch spec #{Color.path branch}|] do+ specBranch <- noteClient (badBranch branch) (simpleParsec (toString branch))+ maintPackage <- noteClient (noPackage specBranch.package) (packages !? specBranch.package)+ noteClient (nonexistentBranch branch) =<< revisionTarget (find (specBranch ==)) git targetEnvs maintPackage+ Left package ->+ appContext [exon|validating the target package spec #{Color.package package}|] do+ maintPackage <- noteClient (noPackage package) (packages !? LocalPackage package)+ noteClient (noBranch package) =<< revisionTarget newestBranch git targetEnvs maintPackage+ where+ badBranch branch =+ let fmt = Color.path @Text "release/<package>/<version>"+ in [exon|Not a valid release branch: #{Color.path branch} (must be #{fmt})|]++ noPackage package =+ [exon|The project does not define a package named #{Color.package package}.|]++ nonexistentBranch branch =+ [exon|The branch #{Color.path branch} does not exist. #{explanation}|]++ noBranch package =+ let fmt = Color.path @Text [exon|release/##{package :: PackageName}/<version>|]+ in [exon|No release branch for the package #{Color.package package} exists (#{fmt}). #{explanation}|]++ explanation =+ let cmd = Color.shellCommand @Text ".#maint"+ in [exon|This command is intended to be run only on branches that were created by #{cmd}.|]++-- TODO probably better to split this, keeping the pure part resolving specs to packages here, and adding some analogue+-- to MaintPrep.+-- This function should then return (Specified package branch) for specs and (Candidate package) for each package when+-- no specs were given.+revisionPlan ::+ GitRevision ->+ MaintContext ->+ Maybe (NonEmpty (Either PackageName BranchName)) ->+ M (Maybe (NonEmpty RevisionTarget))+revisionPlan git MaintContext {packages, envs} specified = do+ appContext "resolving target specifications" do+ nonEmpty <$> maybe allCandidates resolveTargets specified git targetEnvs packages+ where+ targetEnvs = flip nTransformMulti envs \ envName targets -> [(t, envName) | t <- targets]
lib/Hix/Managed/ManagedPackage.hs view
@@ -1,27 +1,51 @@ module Hix.Managed.ManagedPackage where -import Hix.Class.Map (nFlatten, nKeys, nMap, nRestrictKeys, nWithoutKeys)-import Hix.Data.PackageName (LocalPackage)+import Control.Lens (each, (%~))+import Distribution.Version (VersionRange, removeLowerBound)++import Hix.Class.Map (nFlatten, nGenWith, nKeys, nMap, nOver)+import Hix.Data.Bounds (Ranges)+import Hix.Data.Dep (Dep (..))+import Hix.Data.PackageName (LocalPackage, PackageName) import qualified Hix.Managed.Data.ManagedPackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage)-import Hix.Managed.Data.Mutable (LocalRanges, MutableRanges)+import Hix.Managed.Data.ManagedPackage (ManagedPackage, ProjectPackages)+import qualified Hix.Managed.Data.Mutable as Mutable+import Hix.Managed.Data.Mutable (MutableRanges) import Hix.Managed.Data.Packages (Packages)-import Hix.Managed.Data.Targets (Targets, sortTargets, targetsSet)+import Hix.Managed.Data.Targets (Targets, sortTargets) -forTargets :: Packages ManagedPackage -> [LocalPackage] -> (Targets, LocalRanges, MutableRanges)+forTargets ::+ ProjectPackages ->+ [LocalPackage] ->+ (Targets, MutableRanges) forTargets packages targetNames =- (targets, local, mutable)+ (targets, nFlatten id targetRanges) where- mutable = nFlatten id (nMap (.mutable) targetPackages :: Packages MutableRanges)+ targetRanges :: Packages MutableRanges+ targetRanges = Mutable.forTargets targets allRanges - -- Remove the targets from the local deps- local = nWithoutKeys tset (nFlatten id (nMap (.local) targetPackages :: Packages LocalRanges))+ targets = sortTargets onlyDepNames targetNames - targetPackages = nRestrictKeys tset packages+ onlyDepNames :: Packages [PackageName]+ onlyDepNames = nMap nKeys allRanges - tset = targetsSet targets+ allRanges :: Packages Ranges+ allRanges =+ nOver onlyDeps $ nGenWith \ Dep {package, version} -> (package, version) - targets = sortTargets (nMap nKeys allLocal) targetNames+ onlyDeps :: Packages [Dep]+ onlyDeps = nMap (.deps) packages - allLocal :: Packages LocalRanges- allLocal = nMap (.local) packages+updateRanges ::+ (PackageName -> VersionRange -> VersionRange) ->+ ManagedPackage ->+ ManagedPackage+updateRanges f =+ #deps . each %~ \ Dep {version = original, ..} ->+ Dep {version = f package original, ..}++overRanges :: (VersionRange -> VersionRange) -> ManagedPackage -> ManagedPackage+overRanges f = #deps . each . #version %~ f++removeLowerBounds :: ManagedPackage -> ManagedPackage+removeLowerBounds = overRanges removeLowerBound
− lib/Hix/Managed/ManagedPackageProto.hs
@@ -1,27 +0,0 @@-module Hix.Managed.ManagedPackageProto where--import Hix.Class.Map (nFromList, nKeysSet, nMap)-import qualified Hix.Managed.Data.ManagedPackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage (ManagedPackage))-import qualified Hix.Managed.Data.ManagedPackageProto-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto (ManagedPackageProto))-import Hix.Managed.Data.Mutable (classifyPackageDep)-import Hix.Managed.Data.Packages (Packages)--validate ::- Packages ManagedPackageProto ->- Packages ManagedPackage-validate proto =- nMap package proto- where- package ManagedPackageProto {..} =- ManagedPackage {- package = name,- version,- local = nFromList localDeps,- mutable = nFromList mutableDeps- }- where- (localDeps, mutableDeps) = partitionEithers (classifyPackageDep locals <$> deps)-- locals = nKeysSet proto
lib/Hix/Managed/Overrides.hs view
@@ -1,26 +1,52 @@ module Hix.Managed.Overrides where -import qualified Data.Map.Strict as Map-+import Hix.Class.Map (nForAssoc) import Hix.Data.Monad (M)-import Hix.Data.Overrides (Override (..), Overrides (Overrides))+import Hix.Data.Overrides (IsRevision (..), Override (..), Overrides) import qualified Hix.Data.PackageId import Hix.Data.PackageId (PackageId (PackageId))-import Hix.Data.PackageName (PackageName)-import qualified Hix.Managed.Handlers.Hackage-import Hix.Managed.Handlers.Hackage (HackageHandlers)+import Hix.Data.PackageName (LocalPackage, isLocalPackage)+import qualified Hix.Managed.Handlers.SourceHash+import Hix.Managed.Handlers.SourceHash (SourceHashHandlers)+import Hix.Monad (fatalError) +-- | Fetch an override's hash from the given sources, which is the set of configured Hackages in production.+-- If the package wasn't found anywhere, and it is part of the local build, assume that it hasn't been published yet and+-- force it to be built from local sources by returning 'Local'. packageOverride ::- HackageHandlers ->+ Maybe IsRevision ->+ SourceHashHandlers ->+ Set LocalPackage -> PackageId ->- M (PackageName, Override)-packageOverride handlers package@PackageId {name, version} = do- hash <- handlers.fetchHash package- pure (name, Override {..})+ M Override+packageOverride revision handlers localUnavailable package@PackageId {version} = do+ handlers.fetchHash package >>= \case+ Right (hash, repo) -> pure Override {revision, ..}+ Left err | isLocalPackage localUnavailable package.name -> pure Local+ | otherwise -> fatalError err +packageOverrideRegular ::+ SourceHashHandlers ->+ Set LocalPackage ->+ PackageId ->+ M Override+packageOverrideRegular =+ packageOverride Nothing++packageRevision ::+ SourceHashHandlers ->+ Set LocalPackage ->+ PackageId ->+ M Override+packageRevision =+ packageOverride (Just IsRevision)+ packageOverrides ::- HackageHandlers ->+ SourceHashHandlers ->+ Set LocalPackage -> [PackageId] -> M Overrides-packageOverrides handlers versions =- Overrides . Map.fromList <$> traverse (packageOverride handlers) versions+packageOverrides handlers localUnavailable versions =+ nForAssoc versions \ package -> do+ o <- packageOverrideRegular handlers localUnavailable package+ pure (package.name, o)
− lib/Hix/Managed/Path.hs
@@ -1,14 +0,0 @@-module Hix.Managed.Path where--import Path (Abs, Dir, Path)-import Path.IO (getCurrentDir)--import Hix.Data.Monad (M)-import Hix.Monad (tryIOM)---- TODO find better home-rootOrCwd ::- Maybe (Path Abs Dir) ->- M (Path Abs Dir)-rootOrCwd =- maybe (tryIOM getCurrentDir) pure
lib/Hix/Managed/Process.hs view
@@ -7,6 +7,7 @@ import Hix.Data.EnvName (EnvName) import Hix.Data.Monad (M) import qualified Hix.Log as Log+import Hix.Managed.Data.BuildConfig (BuildConfig) import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvContext) import qualified Hix.Managed.Data.EnvRequest@@ -64,7 +65,13 @@ ProjectContext -> Flow () -> M ProjectResult-processProject build project process =- withBuilder \ builder -> foldEnvs project (processEnv build process builder)- where- BuildHandlers {withBuilder} = build+processProject build@BuildHandlers {withBuilder} project flow =+ withBuilder \ builder -> foldEnvs project (processEnv build flow builder)++processProjectSimple ::+ (BuildHandlers -> BuildConfig -> Flow a) ->+ BuildHandlers ->+ ProjectContext ->+ M ProjectResult+processProjectSimple flow handlers project =+ processProject handlers project (void (flow handlers project.build))
lib/Hix/Managed/ProjectContext.hs view
@@ -1,51 +1,44 @@ module Hix.Managed.ProjectContext where -import Control.Monad.Trans.Reader (ask)- import qualified Hix.Data.Monad-import Hix.Data.Monad (AppResources (AppResources), M (M))+import Hix.Data.Monad (AppResources (AppResources), M) import qualified Hix.Data.Options import Hix.Data.Options (ProjectOptions)-import Hix.Managed.BuildOutput (buildOutput, outputResult)+import Hix.Managed.BuildOutput (buildOutput, depChanges, outputResult) import qualified Hix.Managed.Data.BuildConfig-import Hix.Managed.Data.BuildConfig (BuildConfig) import Hix.Managed.Data.ProjectContext (ProjectContext) import Hix.Managed.Data.ProjectContextProto (ProjectContextProto) import qualified Hix.Managed.Data.ProjectResult import Hix.Managed.Data.ProjectResult (ProjectResult)-import qualified Hix.Managed.Handlers.Build-import Hix.Managed.Handlers.Build (BuildHandlers)+import Hix.Managed.Handlers.Project (ProjectHandlers (..)) import qualified Hix.Managed.Handlers.Report import qualified Hix.Managed.ProjectContextProto as ProjectContextProto import Hix.Managed.StateFile (writeProjectState)+import Hix.Monad (ask) updateProject ::- BuildHandlers ->- BuildConfig ->- ProjectResult ->- M ()-updateProject handlers buildConf results = do- unless buildConf.validate do- writeProjectState handlers.stateFile results.state- handlers.report.mutations results--processBuildResults ::- BuildHandlers ->- BuildConfig ->+ ProjectHandlers ->+ Bool -> ProjectResult -> M ()-processBuildResults handlers buildConf results = do- updateProject handlers buildConf results- AppResources {output = format, target} <- M ask- outputResult (buildOutput results) target format+updateProject handlers validate result = do+ unless validate do+ writeProjectState handlers.stateFile result.state+ handlers.report.mutations result withProjectContext ::- BuildHandlers ->+ ProjectHandlers -> ProjectOptions -> ProjectContextProto -> (ProjectContext -> M ProjectResult) ->- M ()+ M ProjectResult withProjectContext handlers opts proto use = do project <- ProjectContextProto.validate opts proto result <- use project- processBuildResults handlers opts.build result+ updateProject handlers opts.build.validate result+ pure result++processProjectResult :: ProjectResult -> M ()+processProjectResult result = do+ AppResources {output = format, target} <- ask+ outputResult target format (buildOutput (depChanges result))
lib/Hix/Managed/ProjectContextProto.hs view
@@ -1,20 +1,23 @@ module Hix.Managed.ProjectContextProto where +import qualified Data.Set as Set import Exon (exon) -import Hix.Class.Map (nBy, nKeys, nKeysSet, nMap, nTo, (!!), (!?))+import Hix.Class.Map (nConcat, nGen, nKeys, nKeysSet, nMap, nOver, (!?))+import Hix.Data.Dep (Dep (..)) import Hix.Data.EnvName (EnvName)+import Hix.Data.Error (ErrorMessage (Client)) import Hix.Data.Monad (M) import qualified Hix.Data.Options import Hix.Data.Options (ProjectOptions)+import Hix.Data.PackageName (PackageName)+import Hix.Managed.Cabal.Config (cabalConfig)+import Hix.Managed.Cabal.Data.Config (CabalConfig) import Hix.Managed.Data.BuildConfig (BuildConfig) import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvContext, EnvDeps) import Hix.Managed.Data.Envs (Envs)-import qualified Hix.Managed.Data.ManagedPackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage (ManagedPackage))-import Hix.Managed.Data.Mutable (MutableDep, depName)-import Hix.Managed.Data.Packages (Deps, Packages)+import Hix.Managed.Data.ManagedPackage (ManagedPackage (..), ProjectPackages) import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext (ProjectContext)) import qualified Hix.Managed.Data.ProjectContextProto@@ -22,23 +25,20 @@ import Hix.Managed.Data.ProjectState (ProjectState) import Hix.Managed.Data.Query (RawQuery (RawQuery)) import Hix.Managed.EnvContext (envContexts)-import qualified Hix.Managed.ManagedPackageProto as ManagedPackageProto import qualified Hix.Managed.ProjectStateProto as ProjectStateProto-import Hix.Monad (clientError, noteClient)+import Hix.Monad (fromEither, noteClient) validateQuery ::- Packages ManagedPackage ->+ Set PackageName -> RawQuery ->- M (Maybe (NonEmpty MutableDep))-validateQuery packages (RawQuery deps) =- nonEmpty <$> traverse check deps+ Either ErrorMessage (Maybe (NonEmpty PackageName))+validateQuery projectDeps (RawQuery query) =+ maybeToLeft (nonEmpty query) (err <$> find invalid query) where- check dep | Just m <- mutables !! dep = pure m- | otherwise = clientError [exon|'##{dep}' is not a dependency of any package.|]+ err :: PackageName -> ErrorMessage+ err dep = Client [exon|'##{dep}' is not a dependency of any package.|] - mutables :: Deps MutableDep- mutables = nBy mutablesSet depName- mutablesSet = mconcat (nTo packages \ _ ManagedPackage {mutable} -> nKeysSet mutable)+ invalid dep = not (Set.member dep projectDeps) noEnvs :: Text noEnvs =@@ -63,27 +63,36 @@ projectContext :: BuildConfig -> ProjectState ->- Packages ManagedPackage ->+ ProjectPackages -> NonEmpty (Either EnvName EnvContext) ->+ CabalConfig -> ProjectContext-projectContext build state packages envs =- ProjectContext {- build,- state,- packages,- envs- }+projectContext build state packages envs cabal =+ ProjectContext {..} validate :: ProjectOptions -> ProjectContextProto -> M ProjectContext validate opts proto = do- query <- validateQuery packages opts.query- contexts <- envContexts opts packages proto.envs query- let envDeps = nMap (either id (.deps)) contexts- state <- ProjectStateProto.validateProjectState opts packages envDeps proto.state+ query <- fromEither (validateQuery projectDeps opts.query)+ let contexts = envContexts opts proto.packages proto.envs query+ envDeps = nMap (either id (.deps)) contexts+ state <- ProjectStateProto.validateProjectState opts ranges envDeps proto.state envTargets <- selectEnvs contexts opts.envs- pure (projectContext opts.build state packages envTargets)+ cabal <- cabalConfig proto.hackage opts.cabal+ pure ProjectContext {+ build = opts.build,+ state,+ packages = proto.packages,+ envs = envTargets,+ cabal+ } where- packages = ManagedPackageProto.validate proto.packages+ projectDeps = nConcat ranges (const nKeysSet)++ ranges =+ nOver proto.packages \ ManagedPackage {deps} ->+ nGen deps \ Dep {package = depPackage, ..} ->+ (depPackage, version)+
lib/Hix/Managed/ProjectStateProto.hs view
@@ -4,21 +4,18 @@ import Exon (exon) import Hix.Class.Map (NMap, nBy, nElems, nFromKeys, nMap, nMergeA, nTransform)-import Hix.Data.Bounds (Bounds)+import Hix.Data.Bounds (Bounds, Ranges) import Hix.Data.EnvName (EnvName) import Hix.Data.Monad (M)-import qualified Hix.Data.Options-import Hix.Data.Options (ProjectOptions)+import Hix.Data.Options (ProjectOptions (..)) import Hix.Data.PackageName (LocalPackage, PackageName)-import Hix.Data.Version (Version, VersionRange, Versions)-import Hix.Data.VersionBounds (anyBounds, withUpper)+import Hix.Data.Version (Version, Versions)+import Hix.Data.VersionBounds (amendUpper, anyBounds) import qualified Hix.Log as Log import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvDeps (EnvDeps)) import Hix.Managed.Data.Envs (Envs)-import qualified Hix.Managed.Data.ManagedPackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage (ManagedPackage))-import Hix.Managed.Data.Mutable (MutableBounds, MutableDep, MutableRanges, depName)+import Hix.Managed.Data.Mutable (MutableDep, depName) import Hix.Managed.Data.Packages (Deps, Packages) import qualified Hix.Managed.Data.ProjectState import Hix.Managed.Data.ProjectState (ProjectState (ProjectState))@@ -35,10 +32,6 @@ invalidDep package dep _ = Nothing <$ Log.warn [exon|Discarding bound for invalid dep '##{dep}' of package '##{package}'|] -packageDepsForMerge :: MutableRanges -> Deps (MutableDep, VersionRange)-packageDepsForMerge =- nTransform \ name range -> (depName name, (name, range))- envDepsForMerge :: Envs EnvDeps -> Envs (Deps MutableDep) envDepsForMerge = nMap \ EnvDeps {mutable} -> nBy mutable depName@@ -49,35 +42,33 @@ map toMutable = nTransform \ _ -> id +invalidBoundsPackage :: LocalPackage -> a -> M (Maybe b)+invalidBoundsPackage package _ =+ Nothing <$ Log.warn [exon|Discarding bounds for unknown local package '##{package}'|]+ validateBounds :: Bool -> LocalPackage ->- ManagedPackage ->+ Ranges -> Bounds ->- M MutableBounds-validateBounds readUpper package ManagedPackage {mutable} bounds =- toMutable <$> nMergeA stateMissing depMissing convertBound deps bounds+ M Bounds+validateBounds readUpper package ranges stateBounds =+ nMergeA stateMissing depMissing convertBound ranges stateBounds where- deps = packageDepsForMerge mutable-- stateMissing = mapMissing \ _ (name, range) -> (name, handleUpper range anyBounds)+ stateMissing = mapMissing \ _ range -> handleUpper range anyBounds depMissing = traverseMaybeMissing (invalidDep package) - convertBound = zipWithMatched \ _ (name, range) bound -> (name, handleUpper range bound)+ convertBound = zipWithMatched (const handleUpper) - handleUpper range | readUpper, Just u <- upperVersion range = withUpper u+ handleUpper range | readUpper, Just u <- upperVersion range = amendUpper u | otherwise = id -invalidBoundsPackage :: LocalPackage -> a -> M (Maybe b)-invalidBoundsPackage package _ =- Nothing <$ Log.warn [exon|Discarding bounds for unknown local package '##{package}'|]- validateProjectBounds :: Bool ->- Packages ManagedPackage ->+ Packages Ranges -> Packages Bounds ->- M (Packages MutableBounds)+ M (Packages Bounds) validateProjectBounds readUpper = nMergeA boundsMissing (traverseMaybeMissing invalidBoundsPackage) (zipWithAMatched (validateBounds readUpper)) where@@ -128,14 +119,14 @@ validateProjectState :: ProjectOptions ->- Packages ManagedPackage ->+ Packages Ranges -> Envs EnvDeps -> ProjectStateProto -> M ProjectState-validateProjectState opts packages envDeps proto = do- bounds <- validateProjectBounds opts.readUpperBounds packages proto.bounds+validateProjectState opts ranges envDeps proto = do+ bounds <- validateProjectBounds opts.readUpperBounds ranges proto.bounds versions <- validateProjectVersions "bound versions" depSets proto.versions initial <- validateProjectVersions "initial versions" depSets proto.initial- pure ProjectState {overrides = proto.overrides, resolving = False, ..}+ pure ProjectState {overrides = proto.overrides, solver = proto.solver, resolving = False, ..} where depSets = envDepsForMerge envDeps
+ lib/Hix/Managed/ReleaseMaintenance.hs view
@@ -0,0 +1,88 @@+module Hix.Managed.ReleaseMaintenance where++import Distribution.Pretty (Pretty (pretty))+import Exon (exon)++import Hix.Class.Map (nTo, nViaA)+import qualified Hix.Color as Color+import Hix.Data.Monad (AppResources (..), M, appRes)+import Hix.Data.Options (ManagedOptions (..), ProjectOptions (..), ReleaseMaintOptions (..), RevisionOptions (..))+import Hix.Data.PackageName (LocalPackage (..))+import qualified Hix.Log as Log+import Hix.Managed.Cabal.Config (cabalConfig)+import Hix.Managed.Data.MaintConfig (MaintConfig (..))+import Hix.Managed.Data.MaintContext (MaintContext (..))+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.RevisionConfig (RevisionConfig (..))+import Hix.Managed.Data.SpecialMaintHandlers (SpecialMaintHandlers (..))+import Hix.Managed.Git (runGitApi)+import Hix.Managed.Handlers.Context (ContextKey (ContextMaint), jsonOrQueryProd)+import Hix.Managed.Handlers.Maint (MaintHandlers (..))+import qualified Hix.Managed.Handlers.Maint.Prod as Maint+import qualified Hix.Managed.Handlers.Maint.Test as Maint+import Hix.Managed.Handlers.Report.Prod (blankLine)+import Hix.Managed.Handlers.Revision (RevisionHandlers (..))+import qualified Hix.Managed.Handlers.Revision.Prod as Revision+import Hix.Managed.Maint.Data.MaintPlan (MaintPlan (..))+import Hix.Managed.Maint.Data.MaintResult (MaintResult (..))+import Hix.Managed.Maint.Git (GitMaint (..), GitRevision (..))+import Hix.Managed.Maint.MaintPlan (maintPlan)+import Hix.Managed.Maint.MaintResult (outputResults)+import Hix.Managed.Maint.Package (maintPackage, publishRevisionIfChanged)+import Hix.Managed.Maint.RevisionPlan (revisionPlan)+import Hix.Monad (appContext, ask)+import Hix.Pretty (showP, showPL)++packageReport :: LocalPackage -> MaintResult -> M ()+packageReport (LocalPackage name) result = do+ Log.info (Color.package name)+ Log.infoP (pretty result)++report :: Packages MaintResult -> M ()+report packages = do+ blankLine+ sequence_ (intersperse blankLine (nTo packages packageReport))++releaseMaintenance ::+ MaintHandlers ->+ MaintConfig ->+ MaintContext ->+ M (Packages MaintResult)+releaseMaintenance handlers config context =+ appContext "performing release maintenance" do+ root <- appRes.root+ plan <- maintPlan context config.targets+ Log.trace [exon|Maintenance plan: #{showP plan}|]+ results <- runGitApi handlers.git root "release maintenance" \ git@GitMaint {bracket} -> bracket do+ tags <- git.readTags+ Log.trace [exon|Found tags: #{showPL tags}|]+ nViaA (traverse (maintPackage handlers config git tags)) plan.targets+ AppResources {output = format, target} <- ask+ report results+ outputResults target format results+ pure results++releaseMaintenanceCli :: ReleaseMaintOptions -> M ()+releaseMaintenanceCli options = do+ context <- jsonOrQueryProd ContextMaint options.context+ cabal <- cabalConfig context.hackage options.managed.project.cabal+ handlers <- case options.handlers of+ Just MaintHandlersTestMaint -> Maint.handlersTest options.managed options.config cabal+ Nothing -> Maint.handlersProd options.managed options.config cabal+ void $ releaseMaintenance handlers options.config context++publishRevisions :: RevisionHandlers -> RevisionConfig -> MaintContext -> M ()+publishRevisions handlers config context =+ appContext "processing pending revisions" do+ root <- appRes.root+ runGitApi handlers.git root "revisions" \ git@GitRevision {bracket} -> bracket do+ revisionPlan git context config.targets >>= \case+ Nothing -> Log.info "No packages are eligible for publishing a revision."+ Just targets -> traverse_ (publishRevisionIfChanged handlers) targets++revisionCli :: RevisionOptions -> M ()+revisionCli options = do+ context <- jsonOrQueryProd ContextMaint options.context+ cabal <- cabalConfig context.hackage options.cabal+ handlers <- Revision.handlersProd options.config cabal+ publishRevisions handlers options.config context
lib/Hix/Managed/Report.hs view
@@ -2,14 +2,26 @@ import Exon (exon) +pluralWith ::+ Eq a =>+ Num a =>+ Text ->+ a ->+ Text+pluralWith suffix num+ | num == 1 = ""+ | otherwise = suffix+ plural :: Eq a => Num a => a -> Text-plural num | num == 1 = ""- | otherwise = "s"+plural = pluralWith "s" -describeIterations :: Natural -> Text+pluralLength :: Foldable t => t a -> Text+pluralLength ta = pluralWith "s" (length ta)++describeIterations :: Word -> Text describeIterations iterations = [exon|#{show iterations} iteration#{plural iterations}|]
lib/Hix/Managed/StageContext.hs view
@@ -30,10 +30,11 @@ stageContext :: EnvRequest -> EnvState -> StageContext stageContext EnvRequest {context = env, builder} envState = StageContext {- query = Query (queryDep builder.cabal state bounds <$> env.query),- initial = reifyVersionChanges envState.initial,+ query = Query (queryDep builder.cabal state initialBounds <$> env.query),+ initialVersions = reifyVersionChanges envState.initial,+ initialBounds, .. } where- bounds = reifyBoundsChanges envState.bounds+ initialBounds = reifyBoundsChanges envState.bounds state = mutationState envState
lib/Hix/Managed/StageResult.hs view
@@ -21,8 +21,8 @@ stageResultWith :: Pretty a => (Map MutableDep BuildSuccess -> MutationState -> MutationState) ->- (Map MutableDep BuildSuccess -> Natural -> Text) ->- (Natural -> Text) ->+ (Map MutableDep BuildSuccess -> Word -> Text) ->+ (Word -> Text) -> StageState a s -> StageResult stageResultWith finalize successMessage failureMessage StageState {success, failed, state, iterations} =@@ -36,8 +36,8 @@ stageResult :: Pretty a =>- (Map MutableDep BuildSuccess -> Natural -> Text) ->- (Natural -> Text) ->+ (Map MutableDep BuildSuccess -> Word -> Text) ->+ (Word -> Text) -> StageState a s -> StageResult stageResult =@@ -45,8 +45,8 @@ stageResultInit :: Pretty a =>- (Map MutableDep BuildSuccess -> Natural -> Text) ->- (Natural -> Text) ->+ (Map MutableDep BuildSuccess -> Word -> Text) ->+ (Word -> Text) -> StageState a s -> StageResult stageResultInit =
lib/Hix/Managed/StageState.hs view
@@ -1,7 +1,6 @@ module Hix.Managed.StageState where import qualified Data.Map.Strict as Map-import qualified Data.Set as Set import qualified Hix.Managed.Data.MutableId import qualified Hix.Managed.Data.Mutation@@ -18,7 +17,6 @@ old { success = Map.insert candidate.name buildSuccess old.success, state,- revisions = Set.union revisions old.revisions, ext } where
lib/Hix/Managed/StateFile.hs view
@@ -5,18 +5,18 @@ import Path (Abs, Dir, Path) import Hix.Class.EncodeNix (encodeNix)+import Hix.Data.EnvName (EnvName) import Hix.Data.Monad (M)-import Hix.Data.NixExpr (Expr (..), ExprAttr (..))+import Hix.Data.NixExpr (Expr (..), ExprAttr (..), ExprKey (..)) import Hix.Data.Overrides (Overrides) import qualified Hix.Log as Log-import Hix.Managed.Data.EnvContext (EnvContext) import qualified Hix.Managed.Data.EnvState import Hix.Managed.Data.EnvState (EnvState) import Hix.Managed.Data.Initial (Initial (Initial)) import Hix.Managed.Data.ProjectState (ProjectState) import qualified Hix.Managed.Handlers.StateFile import Hix.Managed.Handlers.StateFile (StateFileHandlers)-import Hix.Managed.UpdateState (envStateForBuild)+import Hix.Managed.UpdateState (envStateForBuild, envStateForSolver) import Hix.NixExpr (renderRootExpr) renderMap ::@@ -38,7 +38,7 @@ ProjectState -> M () writeStateFile purpose handlers tmpRoot state = do- Log.debug [exon|writing managed state file for #{purpose}: #{renderRootExpr expr}|]+ Log.trace [exon|writing managed state file for #{purpose}: #{renderRootExpr expr}|] handlers.writeFile tmpRoot expr where expr = encodeNix state@@ -54,17 +54,27 @@ Text -> StateFileHandlers -> Path Abs Dir ->- EnvContext ->+ EnvName -> Overrides -> M ()-writeBuildStateFor purpose handlers tmpRoot context overrides =- writeStateFile purpose handlers (Just tmpRoot) (envStateForBuild context overrides)+writeBuildStateFor purpose handlers tmpRoot env overrides =+ writeStateFile purpose handlers (Just tmpRoot) (envStateForBuild env overrides) +writeSolverStateFor ::+ Text ->+ StateFileHandlers ->+ Path Abs Dir ->+ EnvName ->+ Overrides ->+ M ()+writeSolverStateFor purpose handlers tmpRoot env overrides =+ writeStateFile purpose handlers (Just tmpRoot) (envStateForSolver env overrides)+ writeInitialEnvState :: StateFileHandlers -> Path Abs Dir ->- EnvContext ->+ EnvName -> Initial EnvState -> M ()-writeInitialEnvState handlers tmpRoot context (Initial state) =- writeBuildStateFor "env initialization" handlers tmpRoot context state.overrides+writeInitialEnvState handlers tmpRoot env (Initial state) =+ writeBuildStateFor "env initialization" handlers tmpRoot env state.overrides
+ lib/Hix/Managed/Targets.hs view
@@ -0,0 +1,30 @@+module Hix.Managed.Targets where++import qualified Data.Set as Set++import Hix.Class.Map (nMapWithKey, nRestrictKeys, NMap)+import Hix.Data.PackageName (LocalPackage)+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.Targets (Targets (..), unsortedTargets)++onlyTargets :: Targets -> Packages a -> Packages a+onlyTargets targets =+ nRestrictKeys (unsortedTargets targets)++overTargets ::+ NMap map LocalPackage a sort =>+ Targets ->+ (a -> a) ->+ map ->+ map+overTargets (unsortedTargets -> targets) f =+ nMapWithKey checked+ where+ checked package a+ | Set.member package targets+ = f a+ | otherwise+ = a++member :: LocalPackage -> Targets -> Bool+member package (unsortedTargets -> targets) = package `elem` targets
lib/Hix/Managed/UpdateState.hs view
@@ -1,17 +1,21 @@ module Hix.Managed.UpdateState where -import Hix.Class.Map (nAdjust, nAmend, nInsert)+import Hix.Class.Map (nAdjust, nAmend, nInsert, nMapKeys)+import Hix.Data.EnvName (EnvName) import Hix.Data.Overrides (Overrides)+import Hix.Managed.Data.Diff (BoundsChange) import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvContext) import qualified Hix.Managed.Data.EnvState import Hix.Managed.Data.EnvState (EnvState (EnvState))-import Hix.Managed.Data.Mutable (mutUpdateTargets)+import Hix.Managed.Data.Mutable (depName) import qualified Hix.Managed.Data.MutationState import Hix.Managed.Data.MutationState (MutationState)+import Hix.Managed.Data.Packages (Deps) import qualified Hix.Managed.Data.ProjectState import Hix.Managed.Data.ProjectState (ProjectState (ProjectState)) import Hix.Managed.Diff (applyBoundsChange, applyVersionChange, updateBoundsChanges, updateVersionChanges)+import Hix.Managed.Targets (overTargets) -- | Insert the transformed 'EnvState', which contains only the bounds for the current target set and the overrides -- for the current env.@@ -34,34 +38,56 @@ ProjectState projectStateWithEnv context new old = ProjectState {- bounds = mutUpdateTargets context.targets applyBoundsChange new.bounds old.bounds,+ -- TODO clean up+ -- bounds = mutUpdateTargets context.targets applyBoundsChange new.bounds old.bounds,+ bounds = overTargets context.targets (nAmend applyBoundsChange depsBounds) old.bounds, versions = nAdjust context.env old.versions (nAmend applyVersionChange new.versions),- overrides = nInsert context.env new.overrides old.overrides, initial = nAdjust context.env old.initial (nAmend applyVersionChange new.initial),+ overrides = nInsert context.env new.overrides old.overrides,+ solver = nInsert context.env new.solver old.solver, resolving = old.resolving }+ where+ depsBounds = nMapKeys depName new.bounds :: Deps BoundsChange envStateForBuild ::- EnvContext ->+ EnvName -> Overrides -> ProjectState-envStateForBuild context overrides =+envStateForBuild env overrides = ProjectState { bounds = mempty, versions = mempty,- overrides = [(context.env, overrides)], initial = [],+ overrides = [(env, overrides)],+ solver = [], resolving = True } +envStateForSolver ::+ EnvName ->+ Overrides ->+ ProjectState+envStateForSolver env overrides =+ ProjectState {+ bounds = mempty,+ versions = mempty,+ initial = [],+ overrides = [],+ solver = [(env, overrides)],+ resolving = True+ }++-- TODO can MutationState contain changes for @initial@? envStateWithMutations :: MutationState -> EnvState -> EnvState-envStateWithMutations new EnvState {bounds, versions, initial} =+envStateWithMutations new EnvState {bounds, versions, initial, solver} = EnvState { bounds = updateBoundsChanges new.bounds bounds, versions = updateVersionChanges new.versions versions,+ initial = updateVersionChanges new.initial initial, overrides = new.overrides,- initial = updateVersionChanges new.initial initial+ solver }
lib/Hix/Monad.hs view
@@ -4,65 +4,78 @@ M, ) where +import Control.Lens ((%~)) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (runExceptT, throwE, ExceptT (ExceptT))-import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask, asks)+import Control.Monad.Trans.Control (MonadTransControl, controlT)+import Control.Monad.Trans.Except (ExceptT (ExceptT), catchE, runExceptT, throwE)+import Control.Monad.Trans.Identity (IdentityT (..))+import qualified Control.Monad.Trans.Reader as Reader+import Control.Monad.Trans.Reader (ReaderT (runReaderT), asks) import Control.Monad.Trans.State.Strict (StateT, get, put, runStateT)+import Data.Char (toUpper) import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Exon (exon)-import Path (Abs, Dir, File, Path)+import Path (Abs, Dir, File, Path, SomeBase (Abs)) import qualified Path.IO as Path-import Path.IO (withSystemTempDir)+import Path.IO (resolveDir', withSystemTempDir) import System.IO (hClose) import System.IO.Error (tryIOError) import qualified Hix.Console as Console-import Hix.Data.Error (Error (BootstrapError, Client, EnvError, GhciError, NewError))+import Hix.Data.AppContext (AppContext (..))+import Hix.Data.Error (Error (..), ErrorContext (..), ErrorMessage (..)) import qualified Hix.Data.GlobalOptions as GlobalOptions import Hix.Data.GlobalOptions (GlobalOptions (GlobalOptions), defaultGlobalOptions)-import Hix.Data.Monad (AppResources (..), LogLevel, M (M), liftE)-import Hix.Error (Error (Fatal), tryIO, tryIOWith)+import Hix.Data.LogLevel (LogLevel (..))+import Hix.Data.Monad (AppResources (..), M (M), appRes, liftE)+import Hix.Data.PathSpec (PathSpec (PathConcrete), resolvePathSpec')+import qualified Hix.Error as Error+import Hix.Error (tryIOWith) import qualified Hix.Log as Log import Hix.Log (logWith)+import Hix.Maybe (fromMaybeA) -throwM :: Error -> M a-throwM = liftE . throwE+errorContext :: M ErrorContext+errorContext = ErrorContext <$> appRes.context -clientError :: Text -> M a-clientError msg = throwM (Client msg)+errorLevel ::+ LogLevel ->+ M a ->+ M a+errorLevel new (M ma) = do+ res <- ask+ M (lift (Error.errorLevel new (runReaderT ma res))) -fatalError :: Text -> M a-fatalError msg = throwM (Fatal msg)+throwMError :: Error -> M a+throwMError = liftE . throwE -note :: Error -> Maybe a -> M a-note err =- maybe (throwM err) pure+throwM :: ErrorMessage -> M a+throwM message = do+ context <- errorContext+ throwMError Error {level = Nothing, ..} -noteEnv :: Text -> Maybe a -> M a-noteEnv err =- note (EnvError err)+fromEitherError :: Either Error a -> M a+fromEitherError = leftA throwMError -noteGhci :: Text -> Maybe a -> M a-noteGhci err =- note (GhciError err)+fromEither :: Either ErrorMessage a -> M a+fromEither = leftA throwM -noteNew :: Text -> Maybe a -> M a-noteNew err =- note (NewError err)+clientError :: Text -> M a+clientError msg = throwM (Client msg) -noteBootstrap :: Text -> Maybe a -> M a-noteBootstrap err =- note (BootstrapError err)+fatalError :: Text -> M a+fatalError msg = throwM (Fatal msg) +note :: ErrorMessage -> Maybe a -> M a+note err = fromMaybeA (throwM err)+ noteClient :: Text -> Maybe a -> M a-noteClient err =- note (Client err)+noteClient = note . Client noteFatal :: Text -> Maybe a -> M a-noteFatal err =- note (Fatal err)+noteFatal = note . Fatal eitherClient :: Either Text a -> M a eitherClient = leftA clientError@@ -80,9 +93,25 @@ where mkMsg err = [exon|#{msg}: #{show err}|] +noteEnv :: Text -> Maybe a -> M a+noteEnv = noteFatal++noteGhci :: Text -> Maybe a -> M a+noteGhci = noteFatal++noteNew :: Text -> Maybe a -> M a+noteNew = noteFatal++noteBootstrap :: Text -> Maybe a -> M a+noteBootstrap = noteFatal++shouldLog :: LogLevel -> M Bool+shouldLog level =+ appRes.logLevel <&> \ logLevel -> level >= logLevel+ whenDebug :: M () -> M () whenDebug m =- whenM (M (asks (.debug))) do+ whenM (shouldLog LogDebug) do m logIORef :: IORef [Text] -> LogLevel -> Text -> IO ()@@ -102,8 +131,18 @@ runMLoggerWith :: (LogLevel -> Text -> IO ()) -> GlobalOptions -> M a -> IO (Either Error a) runMLoggerWith logger GlobalOptions {..} ma =- withSystemTempDir "hix-cli" \ tmp ->- runMUsing AppResources {logger = logWith logger, ..} ma+ withSystemTempDir "hix-cli" \ tmp -> runExceptT do+ resolvedCwd <- resolvePathSpec' resolveDir' cwd+ resolvedRoot <- resolvePathSpec' resolveDir' root+ let+ resources = AppResources {+ logger = logWith logger,+ context = [],+ cwd = resolvedCwd,+ root = resolvedRoot,+ ..+ }+ ExceptT (runMUsing resources ma) runMLogWith :: GlobalOptions -> M a -> IO ([Text], Either Error a) runMLogWith opts ma =@@ -120,7 +159,7 @@ runMDebug :: Path Abs Dir -> M a -> IO (Either Error a) runMDebug cwd =- runMWith (defaultGlobalOptions cwd) {GlobalOptions.verbose = True, GlobalOptions.debug = True}+ runMWith (defaultGlobalOptions cwd) {GlobalOptions.logLevel = LogDebug} tryIOMWithM :: (Text -> M a) -> IO a -> M a tryIOMWithM handleError ma =@@ -128,10 +167,12 @@ Right a -> pure a Left err -> handleError (show err) -tryIOMWith :: (Text -> Error) -> IO a -> M a-tryIOMWith mkErr ma = M (lift (tryIOWith mkErr ma))+tryIOMWith :: (Text -> ErrorMessage) -> IO a -> M a+tryIOMWith consMessage ma = do+ context <- errorContext+ M (lift (tryIOWith (\ msg -> Error {context, level = Nothing, message = consMessage msg}) ma)) -tryIOMAs :: Error -> IO a -> M a+tryIOMAs :: ErrorMessage -> IO a -> M a tryIOMAs err ma = do liftIO (tryIOError ma) >>= \case Right a -> pure a@@ -141,7 +182,7 @@ throwM err tryIOM :: IO a -> M a-tryIOM ma = M (lift (tryIO ma))+tryIOM = tryIOMWith Fatal catchIOM :: IO a -> (Text -> M a) -> M a catchIOM ma handle =@@ -149,19 +190,26 @@ Right a -> pure a Left err -> handle (show err) +withProjectRoot :: Path Abs Dir -> M a -> M a+withProjectRoot root = local \ res -> res {root}+ withTempDir :: String -> (Path Abs Dir -> M a) -> M a withTempDir name use = do- AppResources {tmp} <- M ask+ AppResources {tmp} <- ask Path.withTempDir tmp name use withTempFile :: String -> Maybe [Text] -> (Path Abs File -> M a) -> M a withTempFile name content use = do- AppResources {tmp} <- M ask+ AppResources {tmp} <- ask Path.withTempFile tmp name \ file handle -> do for_ content \ lns -> liftIO (Text.hPutStr handle (Text.unlines lns)) liftIO (hClose handle) use file +withTempRoot :: String -> (Path Abs Dir -> M a) -> M a+withTempRoot name use =+ withTempDir name \ root -> withProjectRoot root (use root)+ stateM :: Monad m => (s -> a -> m (s, b)) ->@@ -185,5 +233,82 @@ withLower :: (∀ b . (M a -> IO b) -> IO b) -> M a withLower f = do- res <- M ask- liftE (ExceptT (f \ (M ma) -> runExceptT (runReaderT ma res)))+ res <- ask+ liftE (ExceptT (f (runMUsing res)))++withLowerE :: ((∀ b . M b -> ExceptT Error IO b) -> ExceptT Error IO a) -> M a+withLowerE f = do+ res <- ask+ liftE (f \ (M ma) -> runReaderT ma res)++withLowerTry' :: ((∀ b . M b -> IO (Either Error b)) -> IO a) -> M a+withLowerTry' f = do+ res <- ask+ tryIOM (f (runMUsing res))++withLowerTry :: (∀ b . (M a -> IO b) -> IO b) -> M a+withLowerTry f = do+ res <- ask+ fromEitherError =<< tryIOM (f (runMUsing res))++globalOptions :: M GlobalOptions+globalOptions =+ M $ asks \ AppResources {..} -> GlobalOptions {+ cwd = PathConcrete (Abs cwd),+ root = PathConcrete (Abs root),+ ..+ }++local :: (AppResources -> AppResources) -> M a -> M a+local f (M ma) =+ M (Reader.local f ma)++ask :: M AppResources+ask = M Reader.ask++catchM :: M a -> (Error -> M a) -> M a+catchM ma handle =+ withLowerE \ lower -> catchE (lower ma) (lower . handle)++catchingM :: (Error -> M a) -> M a -> M a+catchingM = flip catchM++appContextAtT ::+ MonadTransControl t =>+ LogLevel ->+ LogLevel ->+ Text ->+ t M a ->+ t M a+appContextAtT logLevel level description ma = do+ controlT \ lower -> do+ Log.logDecorated logLevel logMsg+ local (#context %~ (AppContext {description, level} :)) (lower ma)+ where+ logMsg = case Text.uncons description of+ Just (h, t) -> Text.cons (toUpper h) t+ Nothing -> description++appContextT ::+ MonadTransControl t =>+ Text ->+ t M a ->+ t M a+appContextT =+ appContextAtT LogVerbose LogInfo++appContextAt :: LogLevel -> LogLevel -> Text -> M a -> M a+appContextAt logLevel level description ma =+ runIdentityT do+ appContextAtT logLevel level description (IdentityT ma)++appContext :: Text -> M a -> M a+appContext = appContextAt LogVerbose LogInfo++appContextVerbose :: Text -> M a -> M a+appContextVerbose desc ma = do+ appContextAt LogDebug LogVerbose desc ma++appContextDebug :: Text -> M a -> M a+appContextDebug desc ma = do+ appContextAt LogTrace LogDebug desc ma
+ lib/Hix/Network.hs view
@@ -0,0 +1,33 @@+module Hix.Network where++import Control.Exception (bracket)+import Network.Socket (+ addrAddress,+ addrFamily,+ addrProtocol,+ addrSocketType,+ bind,+ close,+ defaultHints,+ getAddrInfo,+ socket,+ socketPort,+ withSocketsDo,+ )++newtype Port =+ Port { value :: Int }+ deriving stock (Eq, Show, Generic)+ deriving newtype (Num, Real, Enum, Integral, Ord)++freePort ::+ MonadIO m =>+ m Port+freePort =+ liftIO $ withSocketsDo do+ addr : _ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")+ bracket (open addr) close (fmap fromIntegral . socketPort)+ where+ open addr = do+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ sock <$ bind sock (addrAddress addr)
lib/Hix/New.hs view
@@ -1,23 +1,38 @@ module Hix.New where import Exon (exon)-import Path (parseRelDir, parseRelFile, reldir, relfile, (</>))+import Path (+ dirname,+ fromRelDir,+ parseRelDir,+ parseRelFile,+ reldir,+ relfile,+ (</>),+ )+import qualified Data.Text as Text import Text.Casing (pascal) +import Hix.Bootstrap (initGitAndFlake)+import qualified Hix.Console as Console import qualified Hix.Data.NewProjectConfig import Hix.Data.NewProjectConfig ( Author,+ CreateProjectConfig (CreateProjectConfig), HixUrl (HixUrl),- NewProjectConfig (NewProjectConfig),- ProjectName (ProjectName),+ InitProjectConfig (InitProjectConfig),+ ProjectName (ProjectName), NewProjectConfig, )+import Hix.Data.Monad (AppResources (cwd)) import qualified Hix.Data.ProjectFile import Hix.Data.ProjectFile (ProjectFile (ProjectFile), createFile)-import Hix.Monad (M, noteEnv)+import Hix.Error (pathText)+import Hix.Monad (M, noteEnv, local)+import Hix.Path (PathSpecResolver (resolvePathSpec)) license :: Author -> Text license author =- [exon|Copyright (c) 2023 ##{author}+ [exon|Copyright (c) 2025 ##{author} Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:@@ -53,8 +68,11 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |] -flake :: NewProjectConfig -> Text-flake NewProjectConfig {name = ProjectName name, hixUrl = HixUrl url, ..} =+flake :: InitProjectConfig -> Text+flake InitProjectConfig {+ name = ProjectName name,+ config = CreateProjectConfig {hixUrl = HixUrl url, ..}+} = [exon|{ description = "A Haskell project"; @@ -92,7 +110,7 @@ ]; }; - };+ };#{if devCli then devCliOption else ""} }; } |]@@ -100,7 +118,11 @@ src | packages = [exon|packages/#{name}|] | otherwise = "." -libModule :: NewProjectConfig -> Text -> Text+ devCliOption = [exon|+ internal.hixCli.dev = true;+|]++libModule :: InitProjectConfig -> Text -> Text libModule conf modName = [exon|module #{modName} where @@ -137,7 +159,7 @@ main = defaultMain tests |] -nameTestModule :: NewProjectConfig -> Text -> Text+nameTestModule :: InitProjectConfig -> Text -> Text nameTestModule conf modName = [exon|module #{modName}.Test.NameTest where @@ -149,14 +171,14 @@ test_name = "#{conf.name.unProjectName}" === name |] -newProjectFiles :: NewProjectConfig -> M [ProjectFile]+newProjectFiles :: InitProjectConfig -> M [ProjectFile] newProjectFiles conf = do nameDir <- pathError (parseRelDir modNameS)- let packageDir = if conf.packages then [reldir|packages|] </> nameDir else [reldir|.|]+ let packageDir = if conf.config.packages then [reldir|packages|] </> nameDir else [reldir|.|] libFile <- pathError (parseRelFile [exon|#{modNameS}.hs|]) pure [ ProjectFile {path = [relfile|flake.nix|], content = flake conf},- ProjectFile {path = packageDir </> [relfile|LICENSE|], content = license conf.author},+ ProjectFile {path = packageDir </> [relfile|LICENSE|], content = license conf.config.author}, ProjectFile {path = packageDir </> [relfile|ops/version.nix|], content = [exon|"0.1.0.0"|]}, ProjectFile {path = packageDir </> [reldir|lib|] </> libFile, content = libModule conf modName}, ProjectFile {path = packageDir </> [relfile|app/Main.hs|], content = appMainModule modName},@@ -167,10 +189,24 @@ } ] where- pathError = noteEnv "Can't convert project name to file path" modName = toText modNameS modNameS = pascal (toString conf.name.unProjectName) -newProject :: NewProjectConfig -> M ()-newProject conf =+initProject :: InitProjectConfig -> M ()+initProject conf = do traverse_ createFile =<< newProjectFiles conf+ unless conf.config.noInitGitAndFlake initGitAndFlake++newProject :: NewProjectConfig -> M ()+newProject conf = do+ directory <- resolvePathSpec conf.directory+ let name =+ fromMaybe+ (ProjectName . Text.dropWhileEnd (== '/') . Text.pack . fromRelDir . dirname $ directory)+ conf.name+ local (\res -> res { cwd = directory }) $+ initProject $ InitProjectConfig {name = name, config = conf.config}+ when conf.printDirectory $ Console.out (pathText directory)++pathError :: Maybe a -> M a+pathError = noteEnv "Can't convert project name to file path"
+ lib/Hix/NixCode.hs view
@@ -0,0 +1,21 @@+module Hix.NixCode where++import Exon (ToSegment (..), exonWith)+import Language.Haskell.TH.Quote (QuasiQuoter)++import Hix.Class.EncodeNix (EncodeNix (encodeNix))+import Hix.NixExpr (renderRootExpr)++newtype NixCode =+ NixCode { code :: Text }+ deriving stock (Eq, Show)+ deriving newtype (IsString, Ord, Semigroup, Monoid)++nixCode :: NixCode -> Text+nixCode NixCode {code} = code++nixon :: QuasiQuoter+nixon = exonWith (Just ([e|NixCode|], [e|id|])) True False++instance EncodeNix a => ToSegment a NixCode where+ toSegment = NixCode . renderRootExpr . encodeNix
lib/Hix/NixExpr.hs view
@@ -5,7 +5,7 @@ import Exon (exon) import Hix.Class.EncodeNix (EncodeNix (encodeNix))-import Hix.Data.NixExpr (Expr (..), ExprAttr (ExprAttr, ExprAttrNil))+import Hix.Data.NixExpr (Expr (..), ExprAttr (ExprAttr, ExprAttrNil), ExprKey (..)) indent :: Functor t =>@@ -24,7 +24,7 @@ renderAttrs :: Int -> [ExprAttr] -> [Text] renderAttrs ind attrs = attrs >>= \case- ExprAttr k v ->+ ExprAttr (ExprKey k) v -> case renderExpr ind v of e :| [] -> [[exon|#{k} = #{e};|]] h :| (h1 : t) -> [exon|#{k} = #{h}|] : toList (withSemicolon (h1 :| t))@@ -48,7 +48,7 @@ Text.unlines . toList . renderExpr 0 checkEmpty ::- Text ->+ ExprKey -> Expr -> ExprAttr checkEmpty key = \case@@ -61,7 +61,7 @@ singleOpt :: EncodeNix a =>- Text ->+ ExprKey -> (e -> Maybe a) -> e -> ExprAttr@@ -70,7 +70,7 @@ single :: EncodeNix a =>- Text ->+ ExprKey -> (e -> a) -> e -> ExprAttr@@ -79,7 +79,7 @@ multiOpt :: EncodeNix a =>- Text ->+ ExprKey -> (e -> Maybe [a]) -> e -> ExprAttr@@ -88,7 +88,7 @@ multi :: EncodeNix a =>- Text ->+ ExprKey -> (e -> [a]) -> e -> ExprAttr@@ -98,7 +98,7 @@ multiOrSingle :: ∀ a e . EncodeNix a =>- Text ->+ ExprKey -> (e -> [a]) -> e -> ExprAttr@@ -119,7 +119,7 @@ ExprAttrNil -> False _ -> True -nonEmptyAttrs :: Text -> [ExprAttr] -> ExprAttr+nonEmptyAttrs :: ExprKey -> [ExprAttr] -> ExprAttr nonEmptyAttrs key = filter notNil >>> \case [] -> ExprAttrNil
lib/Hix/Options.hs view
@@ -2,15 +2,16 @@ import Exon (exon) import Options.Applicative (+ ArgumentFields, CommandFields, Mod, Parser,- ReadM,+ argument, auto,- bashCompleter, command,- completer, customExecParser,+ flag',+ forwardOptions, fullDesc, header, help,@@ -32,7 +33,7 @@ switch, value, )-import Path (Abs, Dir, File, Path, SomeBase, parseRelDir, parseSomeDir)+import Path (Abs, Dir, Path, SomeBase (Abs), parseRelDir, parseSomeDir, relfile) import Path.IO (getCurrentDir) import Prelude hiding (Mod, mod) @@ -42,13 +43,22 @@ import Hix.Data.EnvName (EnvName) import Hix.Data.GhciConfig (ChangeDir (ChangeDir), RunnerName) import Hix.Data.GlobalOptions (GlobalOptions (..))+import Hix.Data.Json (JsonConfig)+import Hix.Data.LogLevel (LogLevel (..)) import qualified Hix.Data.NewProjectConfig-import Hix.Data.NewProjectConfig (NewProjectConfig (NewProjectConfig))+import Hix.Data.NewProjectConfig (+ CreateProjectConfig (CreateProjectConfig),+ InitProjectConfig (InitProjectConfig),+ NewProjectConfig (NewProjectConfig),+ ProjectName,+ ) import qualified Hix.Data.Options import Hix.Data.Options ( BootstrapOptions (..), BumpOptions (..),+ CabalOptions (..), Command (..),+ CommandOptions (..), ComponentCoords (ComponentCoords), ComponentSpec (..), EnvRunnerCommandOptions (..),@@ -57,6 +67,9 @@ ExtraGhcidOptions, GhciOptions (..), GhcidOptions (..),+ HackageCommand (..),+ InfoCommand (..),+ InitOptions (..), LowerCommand (..), LowerOptions (LowerOptions), ManagedOptions (ManagedOptions),@@ -65,75 +78,62 @@ PackageSpec (..), PreprocOptions (PreprocOptions), ProjectOptions (ProjectOptions),+ ReleaseMaintOptions (..),+ RevisionOptions (..), TargetSpec (..), TestOptions (..), ) import Hix.Data.OutputFormat (OutputFormat (OutputNone)) import Hix.Data.OutputTarget (OutputTarget (OutputDefault)) import Hix.Data.PackageName (PackageName (PackageName))-import qualified Hix.Managed.Cabal.Data.Config-import Hix.Managed.Cabal.Data.Config (CabalConfig (CabalConfig))+import Hix.Data.PathSpec (PathSpec (PathConcrete)) import qualified Hix.Managed.Data.BuildConfig-import Hix.Managed.Data.BuildConfig (BuildConfig (BuildConfig))+import Hix.Managed.Data.BuildConfig (BuildConfig (BuildConfig), BuildTimeout (..))+import Hix.Managed.Data.MaintConfig (MaintConfig (..)) import Hix.Managed.Data.Query (RawQuery (RawQuery))+import Hix.Managed.Data.RevisionConfig (RevisionConfig (..)) import qualified Hix.Managed.Data.StateFileConfig import Hix.Managed.Data.StateFileConfig (StateFileConfig (StateFileConfig))-import Hix.Managed.Handlers.Build (BuildTimeout (BuildTimeout)) import Hix.Optparse (- JsonConfig,- absDirOption,- absFileOption,- absFileOrCwdOption, buildHandlersOption,- indexStateOption,+ hackageRepoFieldOption, jsonOption,+ maintHandlersOption,+ nonOption, outputFormatOption, outputTargetOption, relFileOption,- someFileOption, ) -fileParser ::- ReadM a ->- String ->- String ->- Parser a-fileParser readOption longName helpText =- option readOption (long longName <> completer (bashCompleter "file") <> help helpText)--absFileParser :: String -> String -> Parser (Path Abs File)-absFileParser = fileParser absFileOption--absFileOrCwdParser :: Path Abs Dir -> String -> String -> Parser (Path Abs File)-absFileOrCwdParser cwd = fileParser (absFileOrCwdOption cwd)+infoParser :: Parser Command+infoParser = do+ cmd <- flag' InfoVersion (long "version" <> short 'V' <> help "Print the app's version")+ pure (Info cmd) -someFileParser :: String -> String -> Parser (SomeBase File)-someFileParser = fileParser someFileOption+nonOptionArgument :: IsString a => Mod ArgumentFields a -> Parser a+nonOptionArgument = argument nonOption -rootParser :: Parser (Maybe (Path Abs Dir))+rootParser :: Parser (Maybe (PathSpec Dir)) rootParser =- optional (option absDirOption (long "root" <> help "The root directory of the project"))+ optional (strOption (long "root" <> help "The root directory of the project")) -jsonConfigParser ::- Parser JsonConfig+jsonConfigParser :: Parser JsonConfig jsonConfigParser = option jsonOption (long "config" <> help "The Hix-generated config, file or text") -preprocParser ::- Path Abs Dir ->- Parser PreprocOptions-preprocParser cwd =- PreprocOptions+preprocParser :: Parser PreprocOptions+preprocParser =+ PreprocOptions . fmap Right <$>- (fmap Right <$> optional jsonConfigParser)+ optional jsonConfigParser <*> rootParser <*>- absFileOrCwdParser cwd "source" "The original source file"+ strOption (long "source" <> help "The original source file") <*>- absFileOrCwdParser cwd "in" "The prepared input file"+ strOption (long "in" <> help "The prepared input file") <*>- absFileOrCwdParser cwd "out" "The path to the output file"+ strOption (long "out" <> help "The path to the output file") packageSpecParser :: Parser (Maybe PackageSpec) packageSpecParser = do@@ -155,19 +155,15 @@ <*> componentSpecParser -componentForFileParser ::- Path Abs Dir ->- Parser TargetSpec-componentForFileParser cwd =+componentForFileParser :: Parser TargetSpec+componentForFileParser = TargetForFile <$>- option (absFileOrCwdOption cwd) (long "file" <> short 'f' <> help "The absolute file path of the test module")+ strOption (long "file" <> short 'f' <> help "The absolute file path of the test module") -targetSpecParser ::- Path Abs Dir ->- Parser TargetSpec-targetSpecParser cwd =- componentForFileParser cwd+targetSpecParser :: Parser TargetSpec+targetSpecParser =+ componentForFileParser <|> TargetForComponent <$> componentCoordsParser @@ -213,66 +209,95 @@ extraGhcidParser = optional (strOption (long "ghcid-options" <> help "Additional command line options to pass to ghcid")) -envParser ::- Path Abs Dir ->- Parser EnvRunnerCommandOptions-envParser cwd = do- options <- do- config <- Right <$> jsonConfigParser- root <- rootParser- component <- optional (targetSpecParser cwd)- pure EnvRunnerOptions {..}+envRunnerParser :: Parser EnvRunnerOptions+envRunnerParser = do+ config <- Right <$> jsonConfigParser+ root <- rootParser+ component <- optional targetSpecParser+ pure EnvRunnerOptions {..}++envLegacyParser :: Parser EnvRunnerCommandOptions+envLegacyParser = do+ options <- envRunnerParser test <- testOptionsParser extraGhci <- extraGhciParser extraGhcid <- extraGhcidParser pure EnvRunnerCommandOptions {..} -ghciParser ::- Path Abs Dir ->- Parser GhciOptions-ghciParser cwd = do+ghciParser :: Parser GhciOptions+ghciParser = do config <- Right <$> jsonConfigParser root <- rootParser- component <- targetSpecParser cwd+ component <- targetSpecParser test <- testOptionsParser extra <- extraGhciParser+ args <- many (strArgument (metavar "ARG")) pure GhciOptions {..} -ghcidParser ::- Path Abs Dir ->- Parser GhcidOptions-ghcidParser cwd = do- ghci <- ghciParser cwd+ghcidParser :: Parser GhcidOptions+ghcidParser = do+ ghci <- ghciParser extra <- extraGhcidParser pure GhcidOptions {..} -newParser :: Parser NewOptions-newParser = do- name <- strOption (long "name" <> short 'n' <> help "The name of the new project and its main package")+commandParser :: Parser CommandOptions+commandParser = do+ env <- envRunnerParser+ exe <- strOption (long "exe" <> help "The command executable")+ args <- many (strArgument (metavar "ARG"))+ pure CommandOptions {..}++noInitGitAndFlakeParser :: Parser Bool+noInitGitAndFlakeParser = switch (long "basic" <> short 'b' <> help "Skip git repo initialisation and nix flake lock")++initCommonParser :: Parser CreateProjectConfig+initCommonParser = do packages <- switch (long "packages" <> short 'p' <> help "Store packages in the 'packages/' subdirectory") hixUrl <- strOption (long "hix-url" <> help "The URL to the Hix repository" <> value def) author <- strOption (long "author" <> short 'a' <> help "Your name" <> value "Author")- pure NewOptions {config = NewProjectConfig {..}}+ noInitGitAndFlake <- noInitGitAndFlakeParser+ devCli <- switch (long "dev-cli" <> help "Build the CLI tool from the flake input commit, for testing")+ pure CreateProjectConfig {..} +projectNameParser :: Parser ProjectName+projectNameParser = strOption (long "name" <> short 'n' <> help "The name of the new project and its main package")++initParser :: Parser InitOptions+initParser = do+ name <- projectNameParser+ config <- initCommonParser+ pure InitOptions {config = InitProjectConfig {..}}++newParser :: Parser NewOptions+newParser = do+ directory <- nonOptionArgument (metavar "DIR" <> help "Directory to create for the project, last component used as project name default")+ name <- optional projectNameParser+ printDirectory <- switch (long "print-dir" <> help "Print the created directory to stdout")+ config <- initCommonParser+ pure $ NewOptions {config = NewProjectConfig {..}}+ bootstrapParser :: Parser BootstrapOptions bootstrapParser = do hixUrl <- strOption (long "hix-url" <> help "The URL to the Hix repository" <> value def)+ noInitGitAndFlake <- noInitGitAndFlakeParser+ devCli <- switch (long "dev-cli" <> help "Build the CLI tool from the flake input commit, for testing") pure BootstrapOptions {config = BootstrapProjectConfig {..}} stateFileConfigParser :: Parser StateFileConfig stateFileConfigParser = do- file <- option relFileOption (long "file" <> short 'f' <> help "The relative path to the managed deps file")- -- TODO this isn't nice. maybe there should be two options, since the user might want to build bumps without modifying- -- the state.- projectRoot <- optional (option absDirOption (long "root" <> help "The root directory of the project"))+ -- TODO this needs to be moved to ProjectContextProto+ file <- option relFileOption (long "file" <> short 'f' <> help fileHelp <> value [relfile|ops/managed.nix|]) pure StateFileConfig {..}+ where+ fileHelp = "The relative path to the managed deps file" -cabalConfigParser :: Parser CabalConfig-cabalConfigParser = do- indexState <- optional (option indexStateOption (long "index-state" <> help indexStateHelp))- pure CabalConfig {..}+cabalOptionsParser :: Parser CabalOptions+cabalOptionsParser = do+ hackage <- many (option hackageRepoFieldOption (long "hackage" <> help hackageHelp))+ pure CabalOptions {..} where- indexStateHelp = "The index state for Hackage, Unix stamp or date string"+ hackageHelp = [exon|Override Hackage server options, formatted #{fmt}|]+ fmt = "'<name>:<key>:<value>'" buildConfigParser :: Parser BuildConfig buildConfigParser = do@@ -296,19 +321,20 @@ projectOptionsParser :: Parser ProjectOptions projectOptionsParser = do build <- buildConfigParser- query <- RawQuery <$> many (strArgument (help "Positional arguments select individual deps for processing"))- envs <- some (strOption (long "env" <> short 'e' <> help "Environments whose packages should be updated"))+ cabal <- cabalOptionsParser+ query <- RawQuery <$> many (nonOptionArgument (help "Positional arguments select individual deps for processing"))+ envs <- many (strOption (long "env" <> short 'e' <> help "Environments whose packages should be updated")) readUpperBounds <- switch (long "read-upper-bounds" <> help "Use the upper bounds from the flake for the first run") mergeBounds <- switch (long "merge-bounds" <> help "Always add the flake bounds to the managed bounds")+ localDeps <- switch (long "local-deps" <> help "Manage bounds of local deps belonging to separate sets") pure ProjectOptions {..} managedOptionsParser :: Parser ManagedOptions managedOptionsParser = do- context <- Right <$> jsonConfigParser+ context <- Right <$> optional jsonConfigParser project <- projectOptionsParser stateFile <- stateFileConfigParser handlers <- optional (option buildHandlersOption (long "handlers" <> help "Internal: Handlers for tests"))- cabal <- cabalConfigParser pure ManagedOptions {..} bumpParser :: Parser BumpOptions@@ -326,59 +352,123 @@ lowerCommands :: Mod CommandFields LowerCommand lowerCommands =- command "init" (LowerInitCmd <$> info lowerParser (progDesc "Initialize the lower bounds"))+ command "init" (LowerInit <$> info lowerParser (progDesc "Initialize the lower bounds")) <>- command "optimize" (LowerOptimizeCmd <$> info lowerParser (progDesc "Optimize the lower bounds"))+ command "optimize" (LowerOptimize <$> info lowerParser (progDesc "Optimize the lower bounds")) <>- command "stabilize" (LowerStabilizeCmd <$> info lowerParser (progDesc "Stabilize the lower bounds"))+ command "stabilize" (LowerStabilize <$> info lowerParser (progDesc "Stabilize the lower bounds")) <>- command "auto" (LowerAutoCmd <$> info lowerParser (progDesc "Process the lower bounds"))+ command "auto" (LowerAuto <$> info lowerParser (progDesc "Process the lower bounds")) lowerCommand :: Parser LowerCommand lowerCommand =- hsubparser lowerCommands <|> (LowerAutoCmd <$> lowerParser)+ hsubparser lowerCommands <|> (LowerAuto <$> lowerParser) -managedCommitMsgParser :: Parser (Path Abs File)-managedCommitMsgParser =- option absFileOption (long "file" <> help "The JSON file written by a managed deps app")+maintConfigParser :: Parser MaintConfig+maintConfigParser = do+ targets <- nonEmpty <$> many (strOption (long "package" <> help "Packages that should be processed"))+ noFailures <- switch (long "no-failures" <> help "Only commit or publish a package if no dependency update fails")+ commit <- switch (long "commit" <> help "Commit dependency updates")+ push <- switch (long "push" <> help "Commit and push dependency updates")+ pr <- switch (long "pr" <> help "Don't publish revisions and create branches with timestamps for PRs")+ revision <- switch (long "revision" <> help "Publish a revision to Hackage")+ globalGit <- switch (long "global-git" <> help "Use the global git ID rather than hix@tryp.io")+ fetch <- switch (long "fetch" <> help "Fetch tags and branches, useful in CI")+ pure MaintConfig {commit = commit || push || pr, push = push || pr, ..} -managedGithubPrParser :: Parser (Path Abs File)-managedGithubPrParser =- option absFileOption (long "file" <> help "The JSON file written by a managed deps app")+-- TODO Since this includes ManagedOptions, some options may be ineffective or counterproductive.+-- Needs to be adapted.+maintParser :: Parser ReleaseMaintOptions+maintParser = do+ context <- Right <$> optional jsonConfigParser+ managed <- managedOptionsParser+ handlers <- optional (option maintHandlersOption (long "handlers" <> help "Internal: Handlers for tests"))+ config <- maintConfigParser+ pure ReleaseMaintOptions {..} -commands ::- Path Abs Dir ->- Mod CommandFields Command-commands cwd =- command "preproc" (Preproc <$> info (preprocParser cwd) (progDesc "Preprocess a source file for use with ghcid"))+revisionConfigParser :: Parser RevisionConfig+revisionConfigParser = do+ packages <- fmap Left <$> many (strOption (long "package" <> help "Packages that should be processed"))+ branches <- fmap Right <$> many (strOption (long "branch" <> help "Release branches that should be processed"))+ globalGit <- switch (long "global-git" <> help "Use the global git ID rather than hix@tryp.io")+ fetch <- switch (long "fetch" <> help "Fetch tags and branches, useful in CI")+ pure RevisionConfig {targets = nonEmpty (packages ++ branches), ..}++revisionParser :: Parser RevisionOptions+revisionParser = do+ context <- Right <$> optional jsonConfigParser+ config <- revisionConfigParser+ cabal <- cabalOptionsParser+ pure RevisionOptions {..}++hackageCommands :: Mod CommandFields HackageCommand+hackageCommands =+ command "maint" (ReleaseMaint <$> info maintParser (progDesc maintDesc)) <>- command "env" (EnvRunner <$> info (envParser cwd) (progDesc "Print the env runner for a component or a named env"))+ command "revision" (Revision <$> info revisionParser (progDesc "Publish revisions of previous releases"))+ where+ maintDesc = "Maintain dependency bounds of previous releases"++hackageCommand :: Parser HackageCommand+hackageCommand = hsubparser hackageCommands++commands :: Mod CommandFields Command+commands =+ command "preproc" (Preproc <$> info preprocParser (progDesc "Preprocess a source file for use with ghcid")) <>- command "ghci-cmd" (GhciCmd <$> info (ghciParser cwd) (progDesc "Print a ghci cmdline to load a module in a Hix env"))+ command "env" (EnvRunner <$> info envLegacyParser (progDesc "Print the env runner for a component or a named env")) <>- command "ghcid-cmd" (GhcidCmd <$> info (ghcidParser cwd) (progDesc "Print a ghcid cmdline to run a function in a Hix env"))+ command "ghci-cmd" (GhciCmd <$> info ghciParser (progDesc "Print a ghci cmdline to load a module in a Hix env")) <>- command "new" (NewCmd <$> info newParser (progDesc "Create a new Hix project in the current directory"))+ command "ghcid-cmd" (GhcidCmd <$> info ghcidParser (progDesc "Print a ghcid cmdline to run a function in a Hix env")) <>- command "bootstrap" (BootstrapCmd <$> info bootstrapParser (progDesc bootstrapDesc))+ command "ghci" (RunGhci <$> info ghciParser (progDesc "Run ghci in a Hix env")) <>- command "bump" (BumpCmd <$> info bumpParser (progDesc "Bump the deps of a package"))+ command "ghcid" (RunGhcid <$> info ghcidParser (progDesc "Run ghcid in a Hix env")) <>- command "lower" (LowerCmd <$> info lowerCommand (progDesc "Modify the lower bounds of a package"))+ command "command" (RunCommand <$> info commandParser (progDesc "Run a command in a Hix env"))+ <>+ command "init" (Init <$> info initParser (progDesc "Create a new Hix project in the current directory"))+ <>+ command "new" (New <$> info newParser (progDesc "Create a new Hix project in the specified directory"))+ <>+ command "bootstrap" (Bootstrap <$> info bootstrapParser (progDesc bootstrapDesc))+ <>+ command "bump" (Bump <$> info bumpParser (progDesc "Bump the deps of a package"))+ <>+ command "lower" (Lower <$> info lowerCommand (progDesc "Modify the lower bounds of a package"))+ <>+ command "hackage" (Hackage <$> info hackageCommand (progDesc "Hackage related commands")) where bootstrapDesc = "Bootstrap an existing Cabal project in the current directory" +cliLogLevel ::+ Bool ->+ Bool ->+ Bool ->+ Bool ->+ LogLevel+cliLogLevel verbose debug trace quiet+ | trace = LogTrace+ | debug = LogDebug+ | verbose = LogVerbose+ | quiet = LogError+ | otherwise = LogInfo+ globalParser :: Path Abs Dir -> Parser GlobalOptions globalParser realCwd = do verbose <- switch (long "verbose" <> short 'v' <> help "Verbose output") debug <- switch (long "debug" <> help "Debug output")+ trace <- switch (long "trace" <> help "Trace debug output") quiet <- switch (long "quiet" <> help "Suppress info output")- cwd <- option absDirOption (long "cwd" <> help "Force a different working directory" <> value realCwd)+ cabalVerbose <- switch (long "cabal-verbose" <> help "Verbose output from Cabal")+ cwd <- strOption (long "cwd" <> help "Force a different working directory" <> value (PathConcrete (Abs realCwd)))+ rootOverride <- rootParser output <- option outputFormatOption (long "output" <> help formatHelp <> value OutputNone <> metavar "format") target <- option outputTargetOption (long "target" <> help targetHelp <> value OutputDefault <> metavar "target")- pure GlobalOptions {..}+ pure GlobalOptions {root = fromMaybe cwd rootOverride, logLevel = cliLogLevel verbose debug trace quiet, ..} where formatHelp = "Result output format, if commands support it" targetHelp = "Force output to a file or stdout"@@ -387,13 +477,13 @@ Path Abs Dir -> Parser Options appParser cwd =- Options <$> globalParser cwd <*> hsubparser (commands cwd)+ Options <$> globalParser cwd <*> (hsubparser commands <|> infoParser) parseCli :: IO Options parseCli = do realCwd <- getCurrentDir- customExecParser parserPrefs (info (appParser realCwd <**> helper) desc)+ customExecParser parserPrefs (info (appParser realCwd <**> helper) (desc <> forwardOptions)) where parserPrefs = prefs (showHelpOnEmpty <> showHelpOnError <> subparserInline)
lib/Hix/Optparse.hs view
@@ -1,31 +1,21 @@ -- |Combinators for @optparse-applicative@. module Hix.Optparse where -import Data.Aeson (Value, eitherDecodeFileStrict', eitherDecodeStrict')-import Distribution.Parsec (eitherParsec)+import Data.Aeson (eitherDecodeFileStrict', eitherDecodeStrict')+import Data.List.Extra (stripInfix)+import Distribution.Parsec (Parsec, eitherParsec) import Exon (exon) import Options.Applicative (ReadM, eitherReader)-import Path (- Abs,- Dir,- File,- Path,- Rel,- SomeBase (..),- parseAbsDir,- parseAbsFile,- parseRelDir,- parseRelFile,- parseSomeFile,- toFilePath,- (</>),- )-import qualified Text.Show as Show+import Path (File, Path, Rel, parseAbsFile, parseRelFile, toFilePath) +import Hix.Data.Json (JsonConfig (..)) import Hix.Data.OutputFormat (OutputFormat (..)) import Hix.Data.OutputTarget (OutputTarget (..))-import Hix.Managed.Cabal.Data.Config (HackageIndexState (HackageIndexState))-import Hix.Managed.Handlers.Build (SpecialBuildHandlers (TestBumpHandlers))+import Hix.Managed.Cabal.ContextHackageRepo (fieldUpdater)+import Hix.Managed.Cabal.Data.ContextHackageRepo (ContextHackageRepo)+import Hix.Managed.Cabal.Data.HackageRepo (HackageIndexState, HackageName)+import Hix.Managed.Data.BuildConfig (SpecialBuildHandlers (..))+import Hix.Managed.Data.SpecialMaintHandlers (SpecialMaintHandlers (..)) pathOption :: String ->@@ -35,61 +25,30 @@ eitherReader \ raw -> first (const [exon|not a valid #{desc} path: #{raw}|]) (parse raw) -absPathOrCwdOption ::- String ->- (String -> Either e (SomeBase t)) ->- Path Abs Dir ->- ReadM (Path Abs t)-absPathOrCwdOption desc parse cwd =- eitherReader \ raw ->- first (const [exon|not a valid #{desc} path: #{raw}|]) (parse raw) <&> \case- Abs p -> p- Rel p -> cwd </> p---- | An absolute file path option for @optparse-applicative@.-absFileOption :: ReadM (Path Abs File)-absFileOption = pathOption "absolute file" parseAbsFile---- | An absolute file path option for @optparse-applicative@.-absFileOrCwdOption :: Path Abs Dir -> ReadM (Path Abs File)-absFileOrCwdOption = absPathOrCwdOption "absolute or relative file" parseSomeFile- -- | A relative file path option for @optparse-applicative@. relFileOption :: ReadM (Path Rel File) relFileOption = pathOption "relative file" parseRelFile --- | A file path option for @optparse-applicative@.-someFileOption :: ReadM (SomeBase File)-someFileOption = pathOption "some file" parseSomeFile---- | A relative dir path option for @optparse-applicative@.-absDirOption :: ReadM (Path Abs Dir)-absDirOption = pathOption "absolute dir" parseAbsDir---- | A relative dir path option for @optparse-applicative@.-relDirOption :: ReadM (Path Rel Dir)-relDirOption = pathOption "relative dir" parseRelDir--newtype JsonConfig =- JsonConfig { unJsonConfig :: IO (Either String Value) }- deriving stock (Generic)--instance Show JsonConfig where- show (JsonConfig _) = "JsonConfig"- jsonOption :: ReadM JsonConfig jsonOption = eitherReader \ raw -> do- pure $ JsonConfig $ case parseAbsFile raw of+ pure $ JsonConfig case parseAbsFile raw of Just f -> eitherDecodeFileStrict' (toFilePath f) Nothing -> pure (eitherDecodeStrict' (encodeUtf8 raw)) buildHandlersOption :: ReadM SpecialBuildHandlers buildHandlersOption = eitherReader \case- "test" -> Right TestBumpHandlers+ "test" -> Right BuildHandlersTestBump+ "test-maint" -> Right BuildHandlersTestMaint h -> Left [exon|Invalid value for build handlers: #{h}|] +maintHandlersOption :: ReadM SpecialMaintHandlers+maintHandlersOption =+ eitherReader \case+ "test-maint" -> Right MaintHandlersTestMaint+ h -> Left [exon|Invalid value for maint handlers: #{h}|]+ outputFormatOption :: ReadM OutputFormat outputFormatOption = eitherReader \case@@ -104,12 +63,32 @@ eitherReader \case "default" -> Right OutputDefault "stdout" -> Right OutputStdout+ "github" -> Right OutputGithub other -> maybe (badFile other) (Right . OutputFile) (parseAbsFile other) where badFile f = Left [exon|Argument for --output is neither an absolute filepath nor 'default' or 'stdout': #{f}|] +parsecOption :: Parsec a => Text -> ReadM a+parsecOption desc =+ eitherReader \ raw -> first (err raw) (eitherParsec raw)+ where+ err raw msg = [exon|'#{raw}' is not a valid ##{desc}: #{msg}|]+ indexStateOption :: ReadM HackageIndexState-indexStateOption =- eitherReader \ raw -> bimap (err raw) HackageIndexState (eitherParsec raw)+indexStateOption = parsecOption "index state"++hackageRepoFieldOption :: ReadM (HackageName, ContextHackageRepo -> ContextHackageRepo)+hackageRepoFieldOption =+ eitherReader \ spec -> do+ (name, rest) <- takeField spec+ (field, value) <- takeField rest+ update <- fieldUpdater field value+ pure (fromString name, update) where- err raw msg = [exon|Invalid index state string '#{raw}': #{msg}|]+ takeField = maybeToRight "Invalid Hackage repo field specification" . stripInfix ":"++nonOption :: IsString a => ReadM a+nonOption =+ eitherReader \case+ option@('-' : _) -> Left [exon|Invalid option: #{option}|]+ a -> Right (fromString a)
lib/Hix/OutputWriter.hs view
@@ -3,13 +3,19 @@ import qualified Data.ByteString as ByteString import qualified Data.Text.IO as Text import Exon (exon)-import Path (Abs, File, Path, toFilePath)+import Path (Abs, File, Path, toFilePath, parseAbsFile) import qualified Hix.Console as Console import Hix.Data.Monad (M) import Hix.Data.OutputTarget (OutputTarget (..))-import Hix.Error (Error (Fatal), pathText)-import Hix.Monad (throwM, tryIOMWithM)+import Hix.Error (pathText, ErrorMessage (..))+import Hix.Monad (fatalError, tryIOMWithM, tryIOMAs, note, throwM)+import System.Environment (getEnv)+import Data.Aeson (ToJSON)+import qualified Data.Aeson as Aeson+import Hix.Data.OutputFormat (OutputFormat (..))+import qualified Data.Text as Text+import qualified Data.Map.Strict as Map data WriteError = WriteError {@@ -21,6 +27,7 @@ data OutputWriter = OutputWriter { bytes :: ByteString -> M (),+ bytesAppend :: ByteString -> M (), text :: Text -> M (), textAppend :: Text -> M () }@@ -29,6 +36,7 @@ fileWriter errorHandler file = OutputWriter { bytes = handleError . ByteString.writeFile fp,+ bytesAppend = handleError . ByteString.appendFile fp, text = handleError . Text.writeFile fp, textAppend = handleError . Text.appendFile fp }@@ -36,29 +44,130 @@ handleError = tryIOMWithM \ err -> errorHandler WriteError {msg = show err, file} fp = toFilePath file -writeError :: WriteError -> M ()-writeError err =- throwM (Fatal [exon|Couldn't write to #{pathText err.file}: #{err.msg}|])+defaultWriteError :: WriteError -> M ()+defaultWriteError err =+ fatalError [exon|Couldn't write to #{pathText err.file}: #{err.msg}|] stdoutWriter :: OutputWriter stdoutWriter = OutputWriter { bytes = Console.bytesOut,+ bytesAppend = Console.bytesOut, text = Console.out, textAppend = Console.out } -outputWriterM :: M OutputWriter -> OutputTarget -> M OutputWriter-outputWriterM defaultWriter = \case- OutputFile file -> pure (fileWriter writeError file)- OutputStdout -> pure stdoutWriter- OutputDefault -> defaultWriter+githubActionsWriter :: M OutputWriter+githubActionsWriter = do+ var <- tryIOMAs envVarError (getEnv "GITHUB_OUTPUT")+ outFile <- note envVarError (parseAbsFile var)+ pure (fileWriter writeError outFile)+ where+ envVarError = Client "The variable $GITHUB_OUTPUT does not contain a file path"+ writeError err = throwM (Fatal [exon|Couldn't write to $GITHUB_OUTPUT: #{err.msg}|]) -outputWriter :: OutputWriter -> OutputTarget -> OutputWriter+outputWriter :: M OutputWriter -> OutputTarget -> M OutputWriter outputWriter defaultWriter = \case- OutputFile file -> fileWriter writeError file- OutputStdout -> stdoutWriter+ OutputFile file -> pure (fileWriter defaultWriteError file)+ OutputStdout -> pure stdoutWriter OutputDefault -> defaultWriter+ OutputGithub -> githubActionsWriter -outputWriterGlobal :: OutputTarget -> OutputWriter-outputWriterGlobal = outputWriter stdoutWriter+outputWriterGlobal :: OutputTarget -> M OutputWriter+outputWriterGlobal = outputWriter (pure stdoutWriter)++-- TODO The Maybes have been ported from the previous implementation.+-- I think they ware supposed to encode that no changes were to be committed, but this should probably be abstracted+-- over by this new concept.+-- Also since maint does have a useful commit message output, there needs to be an error variant (although that could+-- just be an exception in the callback).+type OutputSpecial :: Type -> Type+data OutputSpecial a where+ OutputSpecialCommitMsg :: OutputSpecial (Maybe (Text, [Text]))+ OutputSpecialGaPr :: OutputSpecial (Maybe (Map Text [Text]))+ OutputSpecialGithubOutputKey :: OutputSpecial Text++newtype OutputAdapter a =+ OutputAdapter { write :: OutputWriter -> a -> M () }++instance Semigroup (OutputAdapter a) where+ OutputAdapter l <> OutputAdapter r = OutputAdapter \ writer a -> l writer a *> r writer a++adapterSpecial ::+ (∀ b . a -> OutputSpecial b -> M b) ->+ OutputSpecial c ->+ OutputAdapter c ->+ OutputAdapter a+adapterSpecial f special (OutputAdapter use) =+ OutputAdapter \ writer a -> do+ c <- f a special+ use writer c++adapterCommit :: OutputAdapter (Maybe (Text, [Text]))+adapterCommit =+ OutputAdapter \ writer -> traverse_ \ (msg, body) -> writer.text (Text.intercalate "\n" ([msg, ""] ++ body))++formatGaPrOutput :: Text -> [Text] -> [Text]+formatGaPrOutput key = \case+ [value] -> [[exon|#{key}=#{value}|]]+ value -> [exon|#{key}<<EOF|] : value ++ ["EOF"]++adapterGaPr :: OutputAdapter (Maybe (Map Text [Text]))+adapterGaPr =+ OutputAdapter \ writer -> traverse_ \ values -> writer.textAppend (Text.unlines (format values))+ where+ format = concatMap (uncurry formatGaPrOutput) . Map.toList++adapterGaKey :: OutputAdapter Text+adapterGaKey =+ OutputAdapter \ writer key -> do+ writer.textAppend key+ writer.textAppend "="++adapterJson :: ToJSON a => Bool -> OutputAdapter a+adapterJson append =+ OutputAdapter \ writer a -> write writer (toStrict (Aeson.encode a))+ where+ write = if append then (.bytesAppend) else (.bytes)++defaultAdapter ::+ ToJSON a =>+ (∀ b . a -> OutputSpecial b -> M b) ->+ OutputFormat ->+ OutputAdapter a+defaultAdapter special = \case+ OutputNone -> OutputAdapter \ _ _ -> unit+ OutputJson -> adapterJson False+ OutputCommitMsg -> adapterSpecial special OutputSpecialCommitMsg adapterCommit+ OutputGaPr -> adapterSpecial special OutputSpecialGaPr adapterGaPr++outputAdapter ::+ ToJSON a =>+ (∀ b . a -> OutputSpecial b -> M b) ->+ OutputTarget ->+ OutputFormat ->+ OutputAdapter a+outputAdapter special target format+ | OutputGithub <- target+ , OutputJson <- format+ = adapterSpecial special OutputSpecialGithubOutputKey adapterGaKey <> adapterJson True+ | otherwise+ = defaultAdapter special format++defaultWriterFor :: OutputFormat -> M OutputWriter+defaultWriterFor = \case+ OutputGaPr -> githubActionsWriter+ _ -> pure stdoutWriter++writeOutput ::+ ToJSON a =>+ (∀ b . a -> OutputSpecial b -> M b) ->+ OutputTarget ->+ OutputFormat ->+ a ->+ M ()+writeOutput special target format value = do+ writer <- outputWriter (defaultWriterFor format) target+ adapter.write writer value+ where+ adapter = outputAdapter special target format
lib/Hix/Path.hs view
@@ -1,12 +1,18 @@ module Hix.Path where import Control.Monad.Trans.Reader (ask)-import Path (Abs, Dir, Path, parent, toFilePath)+import Exon (exon)+import Path (Abs, Dir, File, Path, parent, toFilePath)+import Path.IO (resolveDir, resolveFile) import System.FilePattern.Directory (getDirectoryFiles) import System.IO.Error (tryIOError) import qualified Hix.Data.Monad-import Hix.Data.Monad (AppResources (AppResources), M (M))+import Hix.Data.Monad (AppResources (AppResources), M (M), liftE)+import qualified Hix.Data.PathSpec as PathSpec+import Hix.Data.PathSpec (PathSpec)+import Hix.Monad (appContext)+import Hix.Pretty (showHP) findFlake :: Path Abs Dir -> IO (Maybe (Path Abs Dir)) findFlake cur =@@ -23,3 +29,21 @@ rootDir :: Maybe (Path Abs Dir) -> M (Path Abs Dir) rootDir = maybe inferRoot pure++resolvePathSpecWith ::+ (Path Abs Dir -> FilePath -> IO (Path Abs t)) ->+ PathSpec t ->+ M (Path Abs t)+resolvePathSpecWith resolver pathSpec =+ appContext [exon|resolving path spec #{showHP pathSpec}|] $ do+ AppResources {cwd} <- M ask+ liftE $ PathSpec.resolvePathSpec resolver cwd pathSpec++class PathSpecResolver t where+ resolvePathSpec :: PathSpec t -> M (Path Abs t)++instance PathSpecResolver Dir where+ resolvePathSpec = resolvePathSpecWith resolveDir++instance PathSpecResolver File where+ resolvePathSpec = resolvePathSpecWith resolveFile
lib/Hix/Preproc.hs view
@@ -1,6 +1,6 @@ module Hix.Preproc where -import Control.Lens (IndexedTraversal', has, index, ix, preview, (%~), (.~), (^..))+import Control.Lens (IndexedTraversal', has, index, ix, preview, (%~), (.~), (^..), (?~)) import Control.Lens.Regex.ByteString (Match, group, groups, match, regex) import Control.Monad.Trans.Except (ExceptT, throwE) import qualified Data.ByteString as ByteString@@ -17,7 +17,7 @@ Extension (DisableExtension, EnableExtension, UnknownExtension), Language (UnknownLanguage), )-import Path (Abs, Dir, File, Path, toFilePath)+import Path (Abs, Dir, File, Path, SomeBase (Abs), toFilePath) import Prelude hiding (group) import System.Random (randomRIO) @@ -25,15 +25,17 @@ import Hix.Component (targetComponentOrError) import qualified Hix.Data.ComponentConfig import Hix.Data.ComponentConfig (PreludeConfig, PreludePackage (PreludePackageName, PreludePackageSpec))-import Hix.Data.Monad (M, liftE)+import Hix.Data.Json (JsonConfig)+import Hix.Data.Monad (LogLevel (LogVerbose), M, liftE) import Hix.Data.Options (PreprocOptions (..), TargetSpec (TargetForFile)) import Hix.Data.PackageName (PackageName (PackageName))+import Hix.Data.PathSpec (PathSpec (PathConcrete)) import qualified Hix.Data.PreprocConfig import Hix.Data.PreprocConfig (PreprocConfig)-import Hix.Error (Error (..), sourceError)+import Hix.Error (Error (..), ErrorMessage (Client), sourceError) import Hix.Json (jsonConfigE) import Hix.Monad (tryIOM)-import Hix.Optparse (JsonConfig)+import Hix.Path (PathSpecResolver (resolvePathSpec)) import qualified Hix.Prelude as Prelude import Hix.Prelude (Prelude (Prelude), findPrelude) @@ -64,7 +66,7 @@ noMatch :: Text -> Path b File -> ExceptT Error IO a noMatch reason source =- throwE (NoMatch (sourceError reason source))+ throwE (Error {message = Client (sourceError reason source), context = [], level = Just LogVerbose}) takeLine :: ByteString -> Maybe (ByteString, ByteString) takeLine bs =@@ -306,7 +308,7 @@ processLine ScanState {phase = PreModule, prelude = CustomPrelude p PreludeDefault, ..} l ls | containsNoImplicitPrelude l = pushModule ScanState {phase = PreModule, prelude = CustomPrelude p PreludeNoImplicit, ..} l ls processLine s@ScanState {phase = PreModule} l ls | Just name <- isModule l =- changePhase (s & #moduleName .~ Just name) ModuleStart l ls+ changePhase (s & #moduleName ?~ name) ModuleStart l ls processLine s@ScanState {phase = ModuleStart} l ls | has parenRegex l = changePhase s ModuleExports (insertExport l) ls processLine s@ScanState {phase = ModuleExports, moduleName = Just name, exportsSelf = False} l ls@@ -449,11 +451,13 @@ preprocessWith :: PreprocOptions -> CabalConfig -> M () preprocessWith opt conf = do- inLines <- tryIOM (ByteString.readFile (toFilePath opt.inFile))+ inLines <- tryIOM . ByteString.readFile . toFilePath =<< resolvePathSpec opt.inFile dummyNumber :: Int <- randomRIO (10000, 10000000) let dummyExportName = DummyExportName [exon|Hix_Dummy_#{show dummyNumber}|]- let result = preprocessModule opt.source conf dummyExportName inLines- tryIOM (ByteStringBuilder.writeFile (toFilePath opt.outFile) result)+ source <- resolvePathSpec opt.source+ let result = preprocessModule source conf dummyExportName inLines+ outFile <- resolvePathSpec opt.outFile+ tryIOM (ByteStringBuilder.writeFile (toFilePath outFile) result) fromConfig :: Maybe (Path Abs Dir) ->@@ -461,8 +465,8 @@ Either PreprocConfig JsonConfig -> M CabalConfig fromConfig cliRoot source pconf = do- conf <- jsonConfigE PreprocError pconf- target <- targetComponentOrError cliRoot Nothing conf.packages (TargetForFile source)+ conf <- jsonConfigE pconf+ target <- targetComponentOrError cliRoot Nothing conf.packages (TargetForFile $ PathConcrete (Abs source)) pure CabalConfig { extensions = stringUtf8 <$> target.component.language : target.component.extensions, ghcOptions = stringUtf8 <$> target.component.ghcOptions,@@ -489,5 +493,7 @@ -- TODO add common stanzas preprocess :: PreprocOptions -> M () preprocess opt = do- conf <- maybe (fromCabalFile opt.source) (fromConfig opt.root opt.source) opt.config+ source <- resolvePathSpec opt.source+ root <- traverse resolvePathSpec opt.root+ conf <- maybe (fromCabalFile source) (fromConfig root source) opt.config preprocessWith opt conf
lib/Hix/Pretty.hs view
@@ -1,8 +1,14 @@ module Hix.Pretty where +import qualified Data.Map.Strict as Map import Distribution.Pretty (Pretty, pretty)-import Text.PrettyPrint (Doc, comma, punctuate, sep, text)+import Path (Path, SomeBase (Abs, Rel), toFilePath)+import qualified Text.PrettyPrint as PrettyPrint+import Text.PrettyPrint (Doc, comma, hang, hcat, punctuate, sep, text, vcat, (<+>)) +import Hix.Class.Map (NMap, nGet)+import Hix.Data.PathSpec (PathSpec (PathConcrete, PathUser))+ showP :: ∀ b a . Pretty a =>@@ -27,6 +33,14 @@ Doc prettyL = sep . punctuate comma . fmap pretty . toList +prettyL1 ::+ ∀ t a .+ Pretty a =>+ Foldable t =>+ t a ->+ Doc+prettyL1 = hcat . punctuate comma . fmap pretty . toList+ showPL :: ∀ t b a . Pretty a =>@@ -38,3 +52,147 @@ prettyText :: Text -> Doc prettyText = text . toString++prettyNt :: Coercible a Text => a -> Doc+prettyNt = prettyText . coerce++class HPretty a where+ hpretty :: a -> Doc+ hprettyField :: a -> Maybe Doc+ hprettyField = Just . hpretty++instance {-# overlappable #-} Pretty a => HPretty a where+ hpretty = pretty++instance HPretty String where+ hpretty = text++instance HPretty Text where+ hpretty = prettyText++instance HPretty Int where+ hpretty = show++instance HPretty Word where+ hpretty = show++instance HPretty Word16 where+ hpretty = show++instance HPretty (Path b t) where+ hpretty = hpretty . toFilePath++instance HPretty a => HPretty (Maybe a) where+ hpretty = foldMap hpretty+ hprettyField = fmap hpretty++instance {-# overlappable #-} HPretty a => HPretty [a] where+ hpretty = showPL . fmap hpretty++instance HPretty a => HPretty (NonEmpty a) where+ hpretty = showPL . fmap hpretty++instance HPretty a => HPretty (Set a) where+ hpretty = showPL . fmap hpretty . toList++prettyFieldsKeys :: [(Doc, Maybe Doc)] -> [Doc]+prettyFieldsKeys =+ fmap (maybe mempty render . sequence)+ where+ render (desc, a) = desc PrettyPrint.<> ":" <+> pretty a++prettyFields :: [(Text, Maybe Doc)] -> [Doc]+prettyFields =+ prettyFieldsKeys . fmap (first prettyText)++prettyFieldsV :: [(Text, Maybe Doc)] -> Doc+prettyFieldsV = vcat . prettyFields++instance (Ord k, HPretty k, HPretty v) => HPretty (Map k v) where+ hpretty = hnPretty++prettyTuple :: [Doc] -> Doc+prettyTuple elems =+ prettyFieldsV [(show @_ @Word i, Just e) | (i, e) <- zip [1..] elems]++instance (+ HPretty a,+ HPretty b+ ) => HPretty (a, b) where+ hpretty (a, b) = prettyTuple [hpretty a, hpretty b]++instance (+ HPretty a,+ HPretty b,+ HPretty c+ ) => HPretty (a, b, c) where+ hpretty (a, b, c) = prettyTuple [hpretty a, hpretty b, hpretty c]++instance (+ HPretty a,+ HPretty b,+ HPretty c,+ HPretty d+ ) => HPretty (a, b, c, d) where+ hpretty (a, b, c, d) = prettyTuple [hpretty a, hpretty b, hpretty c, hpretty d]++instance HPretty (SomeBase t) where+ hpretty (Abs path) = hpretty path+ hpretty (Rel path) = hpretty path++instance HPretty (PathSpec t) where+ hpretty (PathConcrete path) = hpretty path+ hpretty (PathUser path) = hpretty path++prettyMap :: Text -> [(Text, Maybe Doc)] -> Doc+prettyMap desc = hang (prettyText desc) 2 . prettyFieldsV++field :: HPretty a => Text -> a -> (Text, Maybe Doc)+field desc value = (desc, hprettyField value)++fieldWith :: Text -> Maybe a -> (a -> Doc) -> (Text, Maybe Doc)+fieldWith desc value render = (desc, render <$> value)++fieldWithOr :: Text -> Text -> Maybe a -> (a -> Doc) -> (Text, Maybe Doc)+fieldWithOr desc alt value render =+ (desc, Just (maybe (hpretty alt) render value))++fieldOr :: HPretty a => Text -> Text -> Maybe a -> (Text, Maybe Doc)+fieldOr desc alt value =+ fieldWithOr desc alt value hpretty++prettyV ::+ HPretty a =>+ Foldable t =>+ t a ->+ Doc+prettyV =+ vcat . fmap hpretty . toList++hnPrettyWith ::+ HPretty k =>+ NMap map k v sort =>+ (v -> Doc) ->+ map ->+ Doc+hnPrettyWith prettyVal (nGet -> m) =+ sep (punctuate comma (assoc <$> Map.toList m))+ where+ assoc (k, v) = hpretty k <+> "->" <+> prettyVal v++hnPretty ::+ HPretty k =>+ HPretty v =>+ NMap map k v sort =>+ map ->+ Doc+hnPretty =+ hnPrettyWith hpretty++showHP ::+ HPretty a =>+ IsString b =>+ a ->+ b+showHP =+ show . hpretty
lib/Hix/Trace.hs view
@@ -1,25 +1,24 @@ module Hix.Trace where -import Distribution.Pretty (Pretty) import GHC.Stack (callStack) import System.IO.Unsafe (unsafePerformIO) -import Hix.Pretty (showP)+import Hix.Pretty (HPretty, showHP) trp :: ∀ b a .- Pretty b =>+ HPretty b => HasCallStack => b -> a -> a trp b a =- unsafePerformIO (a <$ debugPrint (srcLoc callStack) (showP b))+ unsafePerformIO (a <$ debugPrint (srcLoc callStack) (showHP b)) trpi ::- Pretty a =>+ HPretty a => HasCallStack => a -> a trpi a =- unsafePerformIO (a <$ debugPrint (srcLoc callStack) (showP a))+ unsafePerformIO (a <$ debugPrint (srcLoc callStack) (showHP a))
lib/Hix/Version.hs view
@@ -99,12 +99,14 @@ [s] -> [s, 1] s : m : _ -> [s, m + 1] +-- | For simplicity, we define the major before 1.0.0 to be 1.0. prevMajor :: Version -> Version prevMajor = alterVersion \case [s] | s > 0 -> [s - 1, 99]- s : 0 : _ | s > 0 -> [s - 1, 99]- s : m : _ | s > 0, m > 0 -> [s, m - 1]+ [s, 0] | s > 0 -> [s - 1, 99]+ s : 0 : _ : _ -> [s, 0]+ s : m : _ -> [s, m - 1] _ -> [0] currentMajor :: Version -> Version
test/Hix/Test/BootstrapTest.hs view
@@ -84,7 +84,7 @@ conf :: BootstrapProjectConfig conf =- BootstrapProjectConfig {hixUrl = def}+ BootstrapProjectConfig {hixUrl = def, noInitGitAndFlake = True, devCli = False} flakeTarget :: Text flakeTarget =
test/Hix/Test/GhciTest.hs view
@@ -1,13 +1,18 @@ module Hix.Test.GhciTest where import Control.Monad.Trans.Class (lift)+import qualified Data.Set as Set+import qualified Data.Text as Text+import Distribution.Simple (Dependency) import Exon (exon) import Hedgehog (evalEither, (===))-import Path (Abs, Dir, File, Path, Rel, SomeBase (Rel), absdir, absfile, reldir, relfile, (</>))+import Path (Abs, Dir, File, Path, Rel, SomeBase (Abs, Rel), absdir, absfile, reldir, relfile, (</>)) import Path.IO (withSystemTempDir)+import Test.Tasty (TestTree, testGroup) import Hix.Data.ComponentConfig ( ComponentConfig (..),+ ComponentDep (..), ComponentName, EnvRunner (EnvRunner), PackageConfig (..),@@ -15,8 +20,7 @@ SourceDir (SourceDir), SourceDirs (SourceDirs), )-import Hix.Error (pathText)-import Hix.Data.GhciConfig (ChangeDir (ChangeDir), EnvConfig (EnvConfig), GhciConfig (..))+import Hix.Data.GhciConfig (ChangeDir (ChangeDir), EnvConfig (..), GhciConfig (..)) import qualified Hix.Data.GhciTest as GhciTest import qualified Hix.Data.Options as Options import Hix.Data.Options (@@ -29,11 +33,12 @@ TargetSpec (TargetForComponent, TargetForFile), TestOptions (TestOptions), )+import Hix.Data.PathSpec (PathSpec (PathConcrete)) import Hix.Env (envRunner)-import Hix.Ghci (assemble, ghciCmdlineFromOptions, ghcidCmdlineFromOptions)+import Hix.Error (pathText)+import Hix.Ghci (argsGhciRun, assemble, ghciCmdlineFromOptions, ghcidCmdlineFromOptions) import Hix.Monad (runM) import Hix.Test.Utils (UnitTest, unitTest)-import Test.Tasty (TestTree, testGroup) root :: Path Abs Dir root =@@ -51,8 +56,8 @@ defaultRunner = EnvRunner [absfile|/default|] -component :: ComponentName -> Path Rel Dir -> EnvRunner -> ComponentConfig-component name dir runner =+component :: ComponentName -> Path Rel Dir -> Set Dependency -> EnvRunner -> ComponentConfig+component name dir deps runner = ComponentConfig { name, sourceDirs = SourceDirs [SourceDir dir],@@ -60,7 +65,8 @@ extensions = [], language = "GHC2021", ghcOptions = [],- prelude = Nothing+ prelude = Nothing,+ deps = Set.map ComponentDep deps } packages :: PackagesConfig@@ -70,17 +76,19 @@ name = "api", src = [reldir|packages/api|], components = [- ("library", component "api" [reldir|lib|] runner1),- ("server", component "server" [reldir|app|] runner1),- ("api-test", component "api-test" [reldir|test|] runner1)+ ("library", component "api" [reldir|lib|] ["core:tools"] runner1),+ ("testing", component "testing" [reldir|testing|] ["api:testing"] runner1),+ ("server", component "server" [reldir|app|] ["api"] runner1),+ ("api-test", component "api-test" [reldir|test|] ["api:testing", "api"] runner1) ] }), ("core", PackageConfig { name = "core", src = [reldir|packages/core|], components = [- ("library", component "core" [reldir|lib|] runner1),- ("core-test", component "core-test" [reldir|test|] runner2)+ ("library", component "core" [reldir|lib|] ["core"] runner1),+ ("tools", component "tools" [reldir|tools|] ["core"] runner2),+ ("core-test", component "core-test" [reldir|test|] ["core"] runner2) ] }) ]@@ -96,11 +104,15 @@ ghciOptions = GhciOptions { config = Left GhciConfig {- packages,- mainPackage = Nothing,+ env = EnvConfig {+ packages,+ defaultEnv = EnvRunner [absfile|/invalid|],+ mainPackage = Nothing+ }, setup = [("generic", "import Test.Tasty")], run = [("generic", "check . property . test")],- args = ["-Werror"]+ args = ["-Werror"],+ manualCabal = False }, root = Nothing, component = spec1,@@ -110,22 +122,30 @@ runner = Just "generic", cd = ChangeDir True },- extra = Nothing+ extra = Nothing,+ args = [] } options :: GhcidOptions options = GhcidOptions {ghci = ghciOptions, extra = Nothing} +searchPath :: Text -> [Text] -> Text+searchPath dir subs =+ Text.intercalate ":" [[exon|#{dir}packages/#{sub}/|] | sub <- subs]+ ghcidTarget :: Path Abs Dir -> Path Abs File ->- Text+ [Text] ghcidTarget cwd scriptFile =- [exon|ghcid --command="ghci -Werror -i#{path} -ghci-script=#{pathText scriptFile}" --test='#{test}'|]+ [+ [exon|--command=ghci -Werror -i#{path} -ghci-script=#{pathText scriptFile}|],+ [exon|--test=#{test}|]+ ] where test = "(check . property . test) test_server"- path = [exon|#{dir}packages/api/test/:#{dir}packages/api/lib/:#{dir}packages/core/lib/|]+ path = searchPath dir ["api/test", "api/lib", "api/testing", "core/lib", "core/tools"] dir = pathText cwd test_ghcid :: UnitTest@@ -133,17 +153,21 @@ res <- lift $ withSystemTempDir "hix-test" \ tmp -> runM root (ghcidCmdlineFromOptions tmp options) cmdline <- evalEither res- ghcidTarget root cmdline.ghci.scriptFile === cmdline.cmdline+ ghcidTarget root cmdline.ghci.scriptFile === toList cmdline.args mainOptions :: GhciOptions mainOptions = GhciOptions { config = Left GhciConfig {- packages,- mainPackage = Just "core",+ env = EnvConfig {+ packages,+ defaultEnv = EnvRunner [absfile|/invalid|],+ mainPackage = Just "core"+ }, setup = [("generic", "import Test.Tasty")], run = [("generic", "")],- args = []+ args = [],+ manualCabal = False }, root = Nothing, component = TargetForComponent (ComponentCoords Nothing Nothing),@@ -153,17 +177,21 @@ runner = Nothing, cd = ChangeDir True },- extra = Nothing+ extra = Nothing,+ args = [] } mainPackageTarget :: Path Abs Dir -> Path Abs File ->- Text+ [Text] mainPackageTarget cwd scriptFile =- [exon|ghci -i#{path} -ghci-script=#{pathText scriptFile}|]+ [+ [exon|-i#{path}|],+ [exon|-ghci-script=#{pathText scriptFile}|]+ ] where- path = [exon|#{dir}packages/core/test/:#{dir}packages/api/lib/:#{dir}packages/core/lib/|]+ path = searchPath dir ["core/test", "core/lib"] dir = pathText cwd test_mainPackage :: UnitTest@@ -171,11 +199,11 @@ res <- lift $ withSystemTempDir "hix-test" \ tmp -> runM root (ghciCmdlineFromOptions tmp mainOptions) cmdline <- evalEither res- mainPackageTarget root cmdline.scriptFile === cmdline.cmdline+ mainPackageTarget root cmdline.scriptFile === argsGhciRun cmdline spec2 :: TargetSpec spec2 =- TargetForFile (root </> [relfile|packages/core/test/Main.hs|])+ TargetForFile $ PathConcrete $ Abs (root </> [relfile|packages/core/test/Main.hs|]) spec3 :: TargetSpec spec3 =@@ -199,7 +227,7 @@ spec4 :: TargetSpec spec4 =- TargetForFile (root </> [relfile|packages/core/test/Core/Test/Main.hs|])+ TargetForFile $ PathConcrete $ Abs (root </> [relfile|packages/core/test/Core/Test/Main.hs|]) target_moduleName :: Text target_moduleName =
− test/Hix/Test/Hedgehog.hs
@@ -1,69 +0,0 @@-module Hix.Test.Hedgehog where--import Data.List.Extra (takeEnd, zipWithLongest)-import qualified Data.Text as Text-import Hedgehog (TestT, evalEither, (===))--eqLines ::- ∀ m .- Monad m =>- HasCallStack =>- Text ->- Text ->- TestT m ()-eqLines l r =- withFrozenCallStack do- take common linesL === take common linesR- if ll > lr- then trailing "missing lines: " linesL- else if lr > ll- then trailing "extra lines: " linesR- else unit- where- trailing desc ls = fail (toString (desc <> Text.unlines (drop common ls)))- common = min ll lr- ll = length linesL- lr = length linesR- linesL = Text.lines l- linesR = Text.lines r--assertRight ::- ∀ a m e .- Eq a =>- Show e =>- Show a =>- Monad m =>- HasCallStack =>- a ->- Either e a ->- TestT m ()-assertRight a =- withFrozenCallStack do- (===) a <=< evalEither--listEqZip ::- ∀ m a .- Monad m =>- HasCallStack =>- Eq a =>- Show a =>- [a] ->- [a] ->- TestT m ()-listEqZip target actual =- for_ (zip [0 :: Natural ..] (zipWithLongest (,) target actual)) \case- (i, (Just t, Just l)) -> (i, t) === (i, l)- _ | [] <- actual -> fail "Result list is empty."- _ -> target === actual--listEqTail ::- ∀ m a .- Monad m =>- HasCallStack =>- Eq a =>- Show a =>- [a] ->- [a] ->- TestT m ()-listEqTail target actual =- target === takeEnd (length target) actual
+ test/Hix/Test/Managed/AnalyzeTest.hs view
@@ -0,0 +1,22 @@+module Hix.Test.Managed.AnalyzeTest where++import Distribution.Parsec (eitherParsec)+import Distribution.Version (majorBoundVersion, orEarlierVersion)+import Hedgehog ((===))++import qualified Hix.Data.Dep as Dep+import Hix.Data.Dep (Dep (..))+import Hix.Managed.Build.NixOutput.Analysis (CommaSeparatedDeps (..))+import Hix.Test.Utils (UnitTest)++target :: CommaSeparatedDeps+target =+ CommaSeparatedDeps (Dep.toCabal <$> [+ Dep {package = "aaa", version = orEarlierVersion [1]},+ Dep {package = "bbb", version = majorBoundVersion [2]},+ Dep {package = "ccc", version = [[3], [4]]}+ ])++test_parseCommaSeparatedDeps :: UnitTest+test_parseCommaSeparatedDeps = do+ Right target === eitherParsec "aaa <=1, bbb ^>=2, ccc ==3.* (garbage)"
test/Hix/Test/Managed/BuildOutputTest.hs view
@@ -5,21 +5,21 @@ import Hedgehog ((===)) import Test.Tasty (TestTree, testGroup) -import Hix.Managed.BuildOutput (buildOutputFromLists)+import Hix.Managed.BuildOutput (buildOutput) import qualified Hix.Managed.Data.BuildOutput-import Hix.Managed.Data.BuildOutput (BuildOutput, ModifiedId (ModifiedId))+import Hix.Managed.Data.BuildOutput (BuildOutput, DepChanges (..), ModifiedId (ModifiedId)) import Hix.Test.Utils (UnitTest, unitTest) output :: BuildOutput output =- buildOutputFromLists [- ModifiedId {package = "direct1", version = [1, 0, 1], range = Just ">=1.1 && >0.8"},- ModifiedId {package = "direct2", version = [1, 0, 1], range = Nothing}- ] [- "direct3", "direct4"- ] [- "direct5", "direct6"- ]+ buildOutput DepChanges {+ modified = [+ ModifiedId {package = "direct1", version = [1, 0, 1], range = Just ">=1.1 && >0.8"},+ ModifiedId {package = "direct2", version = [1, 0, 1], range = Nothing}+ ],+ unmodified = ["direct3", "direct4"],+ failed = ["direct5", "direct6"]+ } target :: ByteString target =
test/Hix/Test/Managed/Bump/CandidatesTest.hs view
@@ -1,7 +1,7 @@ module Hix.Test.Managed.Bump.CandidatesTest (test_candidatesBump) where import Distribution.Version (Version)-import Hedgehog (evalEither, (===))+import Hedgehog ((===)) import Hix.Data.PackageName (PackageName) import Hix.Data.VersionBounds (VersionBounds)@@ -11,10 +11,12 @@ import Hix.Managed.Data.Mutable (MutableDep) import qualified Hix.Managed.Data.Mutation import Hix.Managed.Data.Mutation (DepMutation (DepMutation))-import Hix.Managed.Handlers.Build (BuildHandlers (latestVersion), handlersNull)+import qualified Hix.Managed.Handlers.AvailableVersions as AvailableVersions+import Hix.Managed.Handlers.Build (BuildHandlers (..), handlersNull) import Hix.Managed.QueryDep (simpleQueryDep) import Hix.Monad (M, clientError)-import Hix.Test.Utils (UnitTest, runMTest)+import Hix.Test.Run (runMTestDir)+import Hix.Test.Utils (UnitTest, toTestT) deps :: [(MutableDep, VersionBounds)] deps =@@ -62,7 +64,9 @@ handlersTest :: BuildHandlers handlersTest =- handlersNull {latestVersion}+ handlersNull {+ versions = AvailableVersions.handlersActionOne latestVersion+ } target :: [DepMutation Bump] target =@@ -98,8 +102,8 @@ test_candidatesBump :: UnitTest test_candidatesBump = do- mutations <- evalEither =<< liftIO do- runMTest False do+ mutations <- toTestT do+ runMTestDir def do catMaybes <$> traverse (candidatesBump handlersTest) query sortOn (.package) target === sortOn (.package) (toList mutations) where
test/Hix/Test/Managed/Bump/MutationTest.hs view
@@ -5,14 +5,15 @@ import Exon (exon) import Test.Tasty (TestTree, testGroup) -import Hix.Data.Error (Error (Fatal))+import Hix.Class.Map ((!!))+import Hix.Data.Error (ErrorMessage (Fatal))+import Hix.Data.Options (ProjectOptions (..)) import Hix.Data.Version (Versions) import Hix.Managed.Bump.Optimize (bumpOptimizeMain) import qualified Hix.Managed.Cabal.Data.Packages import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages), InstalledPackages) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackageId (description), SourcePackages)-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectStateProto import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import Hix.Managed.Data.StageState (BuildStatus (Failure, Success))@@ -21,21 +22,32 @@ import Hix.Pretty (showP) import Hix.Test.Hedgehog (eqLines, listEqTail) import qualified Hix.Test.Managed.Run-import Hix.Test.Managed.Run (Result (Result), TestParams (..), bumpTest, testParams)+import Hix.Test.Managed.Run (Result (Result), TestParams (..), bumpTest, nosortOptions, testParams) import Hix.Test.Utils (UnitTest, unitTest) -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages =- managedPackages [(("local1", "1.0"), [- "base",- "direct1",- "direct2",- "direct3",- "direct4",- "direct5",- "direct6",- "direct7"- ])]+ managedPackages [+ (("local1", "1.0"), [+ "base",+ "direct1",+ "direct2",+ "direct3",+ "direct4",+ "direct5",+ "direct6",+ "direct7",+ "local1",+ "local2 <0.9",+ "local3 <0.9",+ "local4 <0.9",+ "local5"+ ]),+ (("local2", "1.0"), []),+ (("local3", "1.0"), []),+ (("local4", "1.0"), []),+ (("local5", "1.0"), [])+ ] installed :: InstalledPackages installed =@@ -53,71 +65,203 @@ available :: SourcePackages available =- pkgs- where- pkgs =- [- ("base", [- ([4, 11, 0, 0], []),- ([4, 12, 0, 0], []),- ([4, 13, 0, 0], [])- ]),- ("direct1", [- ([1, 0, 1], []),- ([1, 1, 1], []),- ([1, 2, 1], ["direct2 ==1.2.1"])- ]),- ("direct2", [- ([1, 0, 1], []),- ([1, 1, 1], []),- ([1, 2, 1], [])- ]),- ("direct3", [- ([1, 0, 1], []),- ([1, 1, 1], []),- ([1, 2, 1], [])- ]),- ("direct4", [- ([1, 0, 1], []),- ([1, 1, 1], []),- ([1, 2, 1], [])- ]),- ("direct5", [- ([1, 0, 1], []),- ([1, 1, 1], []),- ([1, 2, 1], ["direct4 <1.2"])- ]),- ("direct6", [- ([1, 0, 1], []),- ([1, 1, 1], [])- ]),- ("direct7", [- ([1, 0, 1], ["transitive1 <1.1"])- ]),- ("transitive1", [- ([1, 0, 1], ["direct6 <1.2"] {- description = Just (emptyPackageDescription {customFieldsPD = [("x-revision", "2")]})- })- ])- ]+ [+ ("base", [+ ([4, 11, 0, 0], []),+ ([4, 12, 0, 0], []),+ ([4, 13, 0, 0], [])+ ]),+ ("direct1", [+ ([1, 0, 1], []),+ ([1, 1, 1], []),+ ([1, 2, 1], ["direct2 ==1.2.1"])+ ]),+ ("direct2", [+ ([1, 0, 1], []),+ ([1, 1, 1], []),+ ([1, 2, 1], [])+ ]),+ ("direct3", [+ ([1, 0, 1], []),+ ([1, 1, 1], []),+ ([1, 2, 1], [])+ ]),+ ("direct4", [+ ([1, 0, 1], []),+ ([1, 1, 1], []),+ ([1, 2, 1], [])+ ]),+ ("direct5", [+ ([1, 0, 1], []),+ ([1, 1, 1], []),+ ([1, 2, 1], ["direct4 <1.2"])+ ]),+ ("direct6", [+ ([1, 0, 1], []),+ ([1, 1, 1], [])+ ]),+ ("direct7", [+ ([1, 0, 1], ["transitive1 <1.1"])+ ]),+ ("transitive1", [+ ([1, 0, 1], ["direct6 <1.2"] {+ description = Just (emptyPackageDescription {customFieldsPD = [("x-revision", "2")]})+ })+ ]),+ ("local2", [+ ([0, 8, 0], []),+ ([0, 9, 0], [])+ ]),+ ("local3", [+ ([0, 8, 0], []),+ ([0, 9, 0], [])+ ]),+ ("local4", [+ ([0, 8, 0], []),+ ([0, 9, 0], []),+ ([0, 10, 0], [])+ ])+ ] ghcPackages :: GhcPackages ghcPackages = GhcPackages {installed, available} build :: Versions -> M BuildStatus build = \case- [("base", [4, 12, 0, 0]), ("direct1", [1, 2, 1]), ("direct2", [1, 2, 1]), ("direct3", [1, 0, 1]), ("direct4", [1, 0, 1]), ("direct5", [1, 1, 1]), ("direct6", [1, 0, 1]), ("direct7", [1, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Success+ versions+ | Just [0, 9, 0] <- versions !! "local2"+ -> pure Failure+ versions+ | Just [0, 9, 0] <- versions !! "local3"+ -> pure Failure+ [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 0, 1]),+ ("direct4", [1, 0, 1]),+ ("direct5", [1, 1, 1]),+ ("direct6", [1, 0, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 8, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Success - [("base", [4, 12, 0, 0]), ("direct1", [1, 2, 1]), ("direct2", [1, 2, 1]), ("direct3", [1, 2, 1]), ("direct4", [1, 0, 1]), ("direct5", [1, 1, 1]), ("direct6", [1, 0, 1]), ("direct7", [1, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Failure+ [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 2, 1]),+ ("direct4", [1, 0, 1]),+ ("direct5", [1, 1, 1]),+ ("direct6", [1, 0, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 8, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Failure - [("base", [4, 12, 0, 0]), ("direct1", [1, 2, 1]), ("direct2", [1, 2, 1]), ("direct3", [1, 0, 1]), ("direct4", [1, 2, 1]), ("direct5", [1, 1, 1]), ("direct6", [1, 0, 1]), ("direct7", [1, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Success+ [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 0, 1]),+ ("direct4", [1, 2, 1]),+ ("direct5", [1, 1, 1]),+ ("direct6", [1, 0, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 8, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Success - [("base", [4, 12, 0, 0]), ("direct1", [1, 2, 1]), ("direct2", [1, 2, 1]), ("direct3", [1, 0, 1]), ("direct4", [1, 2, 1]), ("direct5", [1, 2, 1]), ("direct6", [1, 0, 1]), ("direct7", [1, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Success+ [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 0, 1]),+ ("direct4", [1, 2, 1]),+ ("direct5", [1, 2, 1]),+ ("direct6", [1, 0, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 8, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Success - [("base", [4, 12, 0, 0]), ("direct1", [1, 2, 1]), ("direct2", [1, 2, 1]), ("direct3", [1, 0, 1]), ("direct4", [1, 2, 1]), ("direct5", [1, 2, 1]), ("direct6", [1, 1, 1]), ("direct7", [1, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Success+ [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 0, 1]),+ ("direct4", [1, 2, 1]),+ ("direct5", [1, 2, 1]),+ ("direct6", [1, 1, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 8, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Success + [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 0, 1]),+ ("direct4", [1, 2, 1]),+ ("direct5", [1, 2, 1]),+ ("direct6", [1, 1, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 8, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Success++ [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 0, 1]),+ ("direct4", [1, 2, 1]),+ ("direct5", [1, 2, 1]),+ ("direct6", [1, 1, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 10, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Success+ -- -- second iteration- [("base", [4, 12, 0, 0]), ("direct1", [1, 2, 1]), ("direct2", [1, 2, 1]), ("direct3", [1, 2, 1]), ("direct4", [1, 2, 1]), ("direct5", [1, 2, 1]), ("direct6", [1, 1, 1]), ("direct7", [1, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Failure+ [+ ("base", [4, 12, 0, 0]),+ ("direct1", [1, 2, 1]),+ ("direct2", [1, 2, 1]),+ ("direct3", [1, 2, 1]),+ ("direct4", [1, 2, 1]),+ ("direct5", [1, 2, 1]),+ ("direct6", [1, 1, 1]),+ ("direct7", [1, 0, 1]),+ ("local2", [0, 8, 0]),+ ("local3", [0, 8, 0]),+ ("local4", [0, 10, 0]),+ ("local5", [1, 0]),+ ("transitive1", [1, 0, 1])+ ] -> pure Failure versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) @@ -136,6 +280,7 @@ overrides = [ ("fancy", [("direct5", "direct5-1.1.1")]) ],+ solver = [], initial = [], resolving = False }@@ -177,7 +322,31 @@ lower = null; upper = "1.1"; };+ local1 = {+ lower = null;+ upper = null;+ };+ local2 = {+ lower = null;+ upper = "0.9";+ };+ local3 = {+ lower = null;+ upper = "0.9";+ };+ local4 = {+ lower = null;+ upper = "0.11";+ };+ local5 = {+ lower = null;+ upper = "1.1";+ }; };+ local2 = {};+ local3 = {};+ local4 = {};+ local5 = {}; }; versions = { fancy = {@@ -189,10 +358,16 @@ direct5 = "1.2.1"; direct6 = "1.1.1"; direct7 = "1.0.1";+ local2 = "0.8.0";+ local3 = "0.8.0";+ local4 = "0.10.0";+ local5 = "1.0"; };+ other = {}; }; initial = { fancy = {};+ other = {}; }; overrides = { fancy = {@@ -220,12 +395,31 @@ version = "1.0.1"; hash = "direct7-1.0.1"; };+ local2 = {+ version = "0.8.0";+ hash = "local2-0.8.0";+ };+ local3 = {+ version = "0.8.0";+ hash = "local3-0.8.0";+ };+ local4 = {+ version = "0.10.0";+ hash = "local4-0.10.0";+ };+ local5 = {+ version = "1.0";+ hash = "local5-1.0";+ }; transitive1 = { version = "1.0.1"; hash = "transitive1-1.0.1"; }; }; };+ solver = {+ fancy = {};+ }; resolving = false; } |]@@ -236,6 +430,8 @@ [35m[1m>>>[0m [33mfancy[0m [35m[1m>>>[0m Couldn't find working latest versions for some deps after 2 iterations. 📦 direct3+ 📦 local2+ 📦 local3 [35m[1m>>>[0m Added new versions: 📦 [34mbase[0m 4.12.0.0 ↕ [no bounds] -> <[32m4.13[0m 📦 [34mdirect1[0m 1.2.1 ↕ >=0.1 -> [0.1, [32m1.3[0m]@@ -244,6 +440,10 @@ 📦 [34mdirect5[0m 1.2.1 ↕ [no bounds] -> <[32m1.3[0m 📦 [34mdirect6[0m 1.1.1 ↕ <[31m1.1[0m -> <[32m1.2[0m 📦 [34mdirect7[0m 1.0.1 ↕ [no bounds] -> <[32m1.1[0m+ 📦 [34mlocal2[0m 0.8.0 ↕ <0.9+ 📦 [34mlocal3[0m 0.8.0 ↕ <0.9+ 📦 [34mlocal4[0m 0.10.0 ↕ <[31m0.9[0m -> <[32m0.11[0m+ 📦 [34mlocal5[0m 1.0 ↕ [no bounds] -> <[32m1.1[0m [35m[1m>>>[0m Updated versions: 📦 [34mdirect4[0m [31m1.0.1[0m -> [32m1.2.1[0m ↕ [1.0, [31m1.1[0m] -> [1.0, [32m1.3[0m] |]@@ -279,6 +479,23 @@ -- - @direct5@ has an existing override for version 1.1.1, which will be replaced by the successful candidate 1.2.1. -- It has a dependency on @direct4@ with an upper bound of <1.2, which would prevent it from being selected by the -- solver if we didn't use @AllowNewer@.+--+-- - @local2@ is in a different env, so it will be treated as a mutable dependency despite being a local package.+-- It also has no installed version, since it wasn't available on Hackage (yet) at the time of the nixpkgs snapshot+-- and therefore isn't present in nix;+-- and because packages from other envs aren't added as local derivations to the solver GHC.+-- It also has the bound @<0.9@ in the config (but not the existing state) that prevents other mutations from building+-- with @0.9.0@, which would break the build.+--+-- - @local3@ is like @local2@ and exists primarily to ensure that none of the two deps can be mutated without the+-- constraint that keeps the other below 0.9.+--+-- - @local4@ is like @local2@ and @local3@, with the slight variation that it has a buildable version 0.10.0, which+-- is not used for prior mutations (rather, like the other two, it uses 0.8.0), but its own mutation succeeds.+--+-- - @local5@ is like @local2@, with the variation that it also has no available versions.+-- This has the effect that when initializing the Cabal resources, a synthetic entry for this dep is inserted into the+-- source package DB that contains the available packages (in production, those would be from Hackage snapshots). test_bumpMutationBasic :: UnitTest test_bumpMutationBasic = do Result {stateFile, log} <- bumpTest params bumpOptimizeMain@@ -287,13 +504,14 @@ where params = (testParams False packages) { log = True,- envs = [("fancy", ["local1"])],+ envs = [("fancy", ["local1"]), ("other", ["local2", "local3", "local4", "local5"])], ghcPackages, state,+ projectOptions = nosortOptions {envs = ["fancy"], readUpperBounds = True, localDeps = True}, build } -packages_upToDate :: Packages ManagedPackageProto+packages_upToDate :: ProjectPackages packages_upToDate = managedPackages [(("local1", "1.0"), ["direct1"])] @@ -313,8 +531,9 @@ ProjectStateProto { bounds = [("local1", [("direct1", ">=0.1 && <1.1")])], versions = [],- overrides = [("latest", [("direct1", "direct1-1.0.1")])], initial = [],+ overrides = [("latest", [("direct1", "direct1-1.0.1")])],+ solver = [], resolving = False } @@ -349,6 +568,9 @@ hash = "direct1-1.0.1"; }; };+ };+ solver = {+ latest = {}; }; resolving = false; }
− test/Hix/Test/Managed/BumpNativeTest.hs
@@ -1,135 +0,0 @@-module Hix.Test.Managed.BumpNativeTest where--import Control.Monad.Trans.Reader (ask)-import qualified Data.Text.IO as Text-import Exon (exon)-import Hedgehog (evalEither)-import Path (Abs, Dir, File, Path, Rel, parent, reldir, relfile, toFilePath, (</>))-import Path.IO (createDirIfMissing, getCurrentDir)--import qualified Hix.Data.Monad-import Hix.Data.Monad (AppResources (AppResources), M (M))-import Hix.Data.Options (ProjectOptions (query), projectOptions)-import Hix.Error (pathText)-import Hix.Managed.Bump.Optimize (bumpOptimizeMain)-import Hix.Managed.Cabal.Data.Config (GhcDb (GhcDbSystem))-import qualified Hix.Managed.Data.EnvConfig-import Hix.Managed.Data.EnvConfig (EnvConfig (EnvConfig))-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)-import qualified Hix.Managed.Data.ProjectContext-import qualified Hix.Managed.Data.ProjectContextProto-import Hix.Managed.Data.ProjectContextProto (ProjectContextProto (ProjectContextProto))-import qualified Hix.Managed.Data.ProjectResult-import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto))-import qualified Hix.Managed.Data.StateFileConfig-import Hix.Managed.Data.StateFileConfig (StateFileConfig (StateFileConfig))-import qualified Hix.Managed.Handlers.Build.Prod as Build-import Hix.Managed.ProjectContext (updateProject)-import qualified Hix.Managed.ProjectContextProto as ProjectContextProto-import Hix.Test.Hedgehog (eqLines)-import Hix.Test.Utils (UnitTest, runMTest)--packages :: Packages ManagedPackageProto-packages =- managedPackages [- (("root", "1.0"), ["tasty <1.5", "criterion <1.7"])- ]--flake :: Path Abs Dir -> Text-flake hixRoot =- [exon|{- description = "hix test project";- inputs.hix.url = "path:#{pathText hixRoot}";- outputs = {self, hix, ...}: hix.lib.flake ({config, lib, ...}: {- managed = {- enable = true;- latest.compiler = "ghc98";- };- compat.enable = false;- ghcVersions = [];- packages = {- root = {- src = ./.;- library = {- enable = true;- dependencies = ["tasty" "criterion"];- };- };- };- envs.latest.localPackage = api: api.minimal;- });-}|]--libMod :: Text-libMod =- [exon|module Root where--- import Test.Tasty (blarkh)-string :: String-string = "hello"-|]--addFile :: Path Abs Dir -> Path Rel File -> Text -> M ()-addFile root path content = do- createDirIfMissing True (parent file)- liftIO (Text.writeFile (toFilePath file) content)- where- file = root </> path--setupProject :: M (Path Abs Dir)-setupProject = do- AppResources {tmp} <- M ask- cwd <- getCurrentDir- let projectRoot = tmp </> [reldir|project|]- let hixRoot = parent (parent cwd)- createDirIfMissing True projectRoot- addFile projectRoot [relfile|flake.nix|] (flake hixRoot)- addFile projectRoot [relfile|lib/Root.hs|] libMod- pure projectRoot--targetStateFile :: Text-targetStateFile =- [exon|{- resolving = false;-}-|]--bumpNativeTest :: M Text-bumpNativeTest = do- root <- setupProject- let- stateFileConf = StateFileConfig {- file = [relfile|ops/managed.nix|],- projectRoot = Just root- }- envsConfig = [("latest", EnvConfig {targets = ["root"], ghc = GhcDbSystem Nothing})]- buildConfig = def- handlers <- Build.handlersProd stateFileConf envsConfig Nothing buildConfig def False- let- opts = (projectOptions ["latest"]) {query = ["tasty"]}-- proto0 =- ProjectContextProto {- packages,- state = ProjectStateProto [] [] mempty mempty False,- envs = envsConfig,- buildOutputsPrefix = Nothing- }-- stateFile = root </> [relfile|ops/managed.nix|]-- run context process = do- result <- process handlers context- updateProject handlers context.build result- stateFileContent <- liftIO (Text.readFile (toFilePath stateFile))- pure (result.state, stateFileContent)-- context0 <- ProjectContextProto.validate opts proto0- (_, stateFileContent) <- run context0 bumpOptimizeMain- pure stateFileContent--test_bumpNative :: UnitTest-test_bumpNative = do- stateFileContent <- evalEither =<< liftIO do- runMTest True bumpNativeTest- eqLines targetStateFile stateFileContent
test/Hix/Test/Managed/DiffTest.hs view
@@ -1,13 +1,14 @@ module Hix.Test.Managed.DiffTest where +import Data.Maybe (fromJust) import Data.These (These (These, This)) import Exon (exon) import Hedgehog (evalMaybe, (===)) import Test.Tasty (TestTree, testGroup) -import Hix.Data.VersionBounds (versionBounds)-import Hix.Managed.Data.Diff (BoundsChange, VersionChange)-import Hix.Managed.Diff (boundsChange, versionChange)+import Hix.Data.VersionBounds (VersionBounds, fromLower, versionBounds)+import Hix.Managed.Data.Diff (BoundsChange, Change (..), Diff (..), VersionChange)+import Hix.Managed.Diff (boundsChange, boundsDiffDetail, updateBoundsChange, versionChange) import qualified Hix.Managed.EnvResult import Hix.Managed.EnvResult ( BoundsModification (BoundsModification),@@ -19,17 +20,17 @@ import Hix.Managed.Handlers.Report.Prod (formatDepResult) import Hix.Test.Utils (UnitTest, unitTest) -versionDiff1 :: VersionChange-versionDiff1 =+versionChange1 :: VersionChange+versionChange1 = versionChange (Just [1, 0]) (Just [1, 5]) -boundsDiff1 :: BoundsChange-boundsDiff1 =+boundsChange1 :: BoundsChange+boundsChange1 = boundsChange (versionBounds [1, 0] [2, 0]) (versionBounds [1, 5] [2, 0]) result1 :: Maybe DepResult result1 =- depResult "dep" versionDiff1 boundsDiff1+ depResult "dep" versionChange1 boundsChange1 target1 :: DepResult target1 =@@ -47,8 +48,34 @@ formatted <- evalMaybe (formatDepResult res) ([exon|📦 [34mdep[0m|], [exon|[31m1.0[0m -> [32m1.5[0m|], [exon|↕ [[31m1.0[0m, 2.0] -> [[32m1.5[0m, 2.0]|]) === formatted +bounds2 :: VersionBounds+bounds2 = versionBounds [1, 0] [2, 0]++boundsChange2 :: BoundsChange+boundsChange2 = Unchanged (Just bounds2)++updatedBoundsChange2 :: BoundsChange+updatedBoundsChange2 =+ updateBoundsChange (fromLower [3, 0]) boundsChange2++targetBounds2 :: VersionBounds+targetBounds2 = versionBounds [3, 0] [3, 1]++targetBoundsChange2 :: BoundsChange+targetBoundsChange2 =+ Changed DiffChanged {+ original = bounds2,+ new = targetBounds2,+ detail = fromJust (boundsDiffDetail bounds2 targetBounds2)+ }++test_diffUpdateOneEndWithoutOverlap :: UnitTest+test_diffUpdateOneEndWithoutOverlap =+ targetBoundsChange2 === updatedBoundsChange2+ test_diff :: TestTree test_diff = testGroup "Bounds and version diffs" [- unitTest "BoundsChange to DepResult" test_boundsDiffDepResult+ unitTest "BoundsChange to DepResult" test_boundsDiffDepResult,+ unitTest "update one bound with no overlap with the previous bounds" test_diffUpdateOneEndWithoutOverlap ]
+ test/Hix/Test/Managed/HackageTest.hs view
@@ -0,0 +1,69 @@+module Hix.Test.Managed.HackageTest where++import Exon (exon)+import Hedgehog ((===))+import Test.Tasty (TestTree, testGroup)++import Hix.CabalParsec (unsafeParsec)+import Hix.Class.EncodeNix (encodeNix)+import Hix.Managed.Cabal.Data.ContextHackageRepo (+ ContextHackageLocation (..),+ ContextHackagePassword (..),+ ContextHackageRepo (..),+ )+import Hix.Managed.Cabal.Data.HackageLocation (HackageLocation (..), HackageTls (TlsOff), hackageLocation)+import Hix.Managed.Cabal.HackageLocation (noSchemeMessage, parseLocation)+import Hix.NixExpr (renderRootExpr)+import Hix.Test.Utils (UnitTest, unitTest)++test_hackageRepo :: UnitTest+test_hackageRepo = do+ Left (noSchemeMessage "server.com") === parseLocation "server.com"+ Right ((hackageLocation "server.com" TlsOff) {port = Just 10}) === parseLocation "http://server.com:10"++target_encodeNix_ContextHackageRepo :: Text+target_encodeNix_ContextHackageRepo =+ [exon|{+ name = "test";+ description = "test";+ enable = false;+ location = "http://localhost:1234";+ user = "test";+ password = "test";+ secure = false;+ keys = [+ "key1"+ "key2"+ ];+ indexState = "2024-01-01T00:00:00Z";+ solver = true;+ publish = true;+}+|]++contextRepo :: ContextHackageRepo+contextRepo =+ ContextHackageRepo {+ name = "test",+ description = Just "test",+ enable = Just False,+ location = Just (ContextHackageLocation "http://localhost:1234"),+ user = Just "test",+ password = Just (PasswordUnobscured "test"),+ secure = Just False,+ keys = Just ["key1", "key2"],+ indexState = Just (unsafeParsec ("2024-01-01T00:00:00Z" :: String)),+ solver = Just True,+ publish = Just True+ }++test_encodeNix_ContextHackageRepo :: UnitTest+test_encodeNix_ContextHackageRepo =+ target_encodeNix_ContextHackageRepo === renderRootExpr (encodeNix contextRepo)++test_hackageData :: TestTree+test_hackageData =+ testGroup "hackage data" [+ unitTest "parse HackageRepo" test_hackageRepo,+ unitTest "nix-encode ContextHackageRepo" test_encodeNix_ContextHackageRepo+ ]
test/Hix/Test/Managed/LowerAuto/MutationOptimizeTest.hs view
@@ -4,16 +4,13 @@ import Test.Tasty (TestTree, testGroup) import Hix.Class.Map (nGen, (!!))-import Hix.Data.Error (Error (Fatal))-import qualified Hix.Data.Overrides-import Hix.Data.Overrides (Override (Override))-import Hix.Data.Version (SourceHash (SourceHash), Versions)+import Hix.Data.Error (ErrorMessage (Fatal))+import Hix.Data.Version (Versions) import qualified Hix.Managed.Cabal.Data.Packages import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages), InstalledPackages) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages) import Hix.Managed.Data.LowerConfig (LowerConfig (reset))-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectStateProto import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import Hix.Managed.Data.StageState (BuildStatus (Failure, Success))@@ -25,7 +22,7 @@ import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) import Hix.Test.Utils (UnitTest, unitTest) -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = managedPackages [ (("local1", "1.0"), [@@ -50,22 +47,23 @@ ("direct2", [1, 0]) ]) ],- overrides = [- ("lower", nGen @[] [1 .. 2] override)- ], initial = [ ("lower", [ ("direct1", [1, 5]), ("direct2", [1, 5]) ]) ],+ overrides = [+ ("lower", nGen @[] [1 .. 2] override)+ ],+ solver = [], resolving = False } where override (num :: Natural) = ( fromString [exon|direct#{show num}|],- Override {version = [1, 0], hash = SourceHash [exon|direct#{show num}-1.0|]}+ fromString [exon|direct#{show num}-1.0|] ) installed :: InstalledPackages@@ -183,6 +181,9 @@ }; }; };+ solver = {+ lower = {};+ }; resolving = false; } |]@@ -305,6 +306,9 @@ hash = "direct3-0.9"; }; };+ };+ solver = {+ lower = {}; }; resolving = false; }
test/Hix/Test/Managed/LowerAuto/MutationStabilizeTest.hs view
@@ -3,16 +3,13 @@ import Exon (exon) import Hix.Class.Map (nGen, (!!))-import Hix.Data.Error (Error (Fatal))-import qualified Hix.Data.Overrides-import Hix.Data.Overrides (Override (Override))-import Hix.Data.Version (SourceHash (SourceHash), Versions)+import Hix.Data.Error (ErrorMessage (Fatal))+import Hix.Data.Version (Versions) import qualified Hix.Managed.Cabal.Data.Packages import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages), InstalledPackages) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages) import Hix.Managed.Data.LowerConfig (LowerConfig (stabilize))-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectStateProto import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import Hix.Managed.Data.StageState (BuildStatus (Failure, Success))@@ -24,7 +21,7 @@ import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) import Hix.Test.Utils (UnitTest) -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = managedPackages [ (("local1", "1.0"), [@@ -79,9 +76,6 @@ ("direct3", [1, 0]) ]) ],- overrides = [- ("lower", nGen @[] [1 .. 3] override)- ], initial = [ ("lower", [ ("direct1", [1, 5]),@@ -89,13 +83,17 @@ ("direct3", [1, 5]) ]) ],+ overrides = [+ ("lower", nGen @[] [1 .. 3] override)+ ],+ solver = [], resolving = False } where override (num :: Natural) = ( fromString [exon|direct#{show num}|],- Override {version = [1, 0], hash = SourceHash [exon|direct#{show num}-1.0|]}+ fromString [exon|direct#{show num}-1.0|] ) build :: Versions -> M BuildStatus@@ -171,6 +169,9 @@ hash = "direct3-1.5"; }; };+ };+ solver = {+ lower = {}; }; resolving = false; }
test/Hix/Test/Managed/LowerInit/MutationTest.hs view
@@ -2,14 +2,11 @@ import qualified Data.Text as Text import Exon (exon)-import Hedgehog ((===)) import Hix.Class.Map ((!!))-import Hix.Data.Error (Error (Fatal))-import Hix.Data.Options (ProjectOptions (envs, readUpperBounds))-import qualified Hix.Data.Overrides-import Hix.Data.Overrides (Override (Override))-import Hix.Data.Version (SourceHash (SourceHash), Versions)+import Hix.Data.Error (ErrorMessage (Fatal))+import Hix.Data.Options (ProjectOptions (..))+import Hix.Data.Version (Versions) import qualified Hix.Managed.Cabal.Changes import Hix.Managed.Cabal.Changes (SolverPlan (SolverPlan)) import qualified Hix.Managed.Cabal.Data.Packages@@ -17,8 +14,7 @@ import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages) import Hix.Managed.Cabal.Mock.SourcePackage (allDep, allDeps) import Hix.Managed.Data.Constraints (EnvConstraints)-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectStateProto import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import Hix.Managed.Data.StageState (BuildStatus (Failure, Success))@@ -26,11 +22,11 @@ import Hix.Monad (M, throwM) import Hix.NixExpr (renderRootExpr) import Hix.Pretty (showP)-import Hix.Test.Hedgehog (eqLines, listEqZip)+import Hix.Test.Hedgehog (eqLines, listEqTail, listEqZip) import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, nosortOptions, testParams) import Hix.Test.Utils (UnitTest) -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = managedPackages [ (("local1", "1.0"), [@@ -44,13 +40,17 @@ (("local4", "1.0"), ["direct4"]), (("local5", "1.0"), ["direct5"]), (("local6", "1.0"), ["direct3"]),- (("local7", "1.0"), ["local6 <2", "direct2"]),+ (("local7", "1.0"), ["local6 <0.9", "direct2"]), (("local8", "1.0"), ["direct1", "direct6"]) ] available :: SourcePackages available = [+ ("local6", [+ ([0, 8], ["direct3 >=1.0.1 && <1.5"]),+ ([0, 9], ["direct3 >=1.0.1 && <1.5"])+ ]), ("direct1", [ ([1, 0, 3], ["transitive1 >=1"]), ([1, 0, 4], ["transitive1 >=1"]),@@ -93,7 +93,8 @@ ProjectStateProto { bounds = [ ("local1", [- ("direct2", [[4, 0], [4, 4]]),+ ("direct2", ">=4.0"),+ ("direct3", [[1, 0, 1], [1, 5]]) ]), ("local5", [("direct5", [[1, 5], [1, 6]])])@@ -109,11 +110,12 @@ ("direct6", [1, 0, 1]) ]) ],+ initial = [("lower-main", [("direct3", [1, 0, 1])])], overrides = [- ("latest", [("direct2", Override {version = [5, 0], hash = SourceHash "direct2-5.0"})]),- ("lower-main", [("direct3", Override {version = [1, 0, 1], hash = SourceHash "direct3-1.0.1"})])+ ("latest", [("direct2", "direct2-5.0")]),+ ("lower-main", [("direct3", "direct3-1.0.1")]) ],- initial = [("lower-main", [("direct3", [1, 0, 1])])],+ solver = [], resolving = False } @@ -139,12 +141,25 @@ [ ("direct2", [5, 0]), ("direct3", [1, 4]),+ ("local6", [0, 9]), ("transitive3", [1, 0, 1]) ] -> pure Success [ ("direct2", [5, 0]),+ ("direct3", [1, 4]),+ ("local6", [0, 8]), ("transitive3", [1, 0, 1]) ] -> pure Success+ [+ ("direct2", [5, 0]),+ ("direct3", [1, 4]),+ ("local6", [1, 0]),+ ("transitive3", [1, 0, 1])+ ] -> pure Success+ [+ ("direct2", [5, 0]),+ ("transitive3", [1, 0, 1])+ ] -> pure Success versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) -- | This uses a very bespoke @IsString@ instance for @(PackageName, MutationConstraints)@ that parses a @Dep@ and uses@@ -190,7 +205,11 @@ ([ "direct2 ==5.0", "local6"- ], plan ["direct2-5.0", "direct3-1.4", "local6-1.0", "transitive3-1.0.1"])+ ], plan ["direct2-5.0", "direct3-1.4", "local6-0.9", "transitive3-1.0.1"]),+ ([+ "direct2 <=5.0",+ "local6 ==0.8"+ ], plan ["direct2-5.0", "direct3-1.4", "local6-0.8", "transitive3-1.0.1"]) ] where item1 (v1 :: Natural) (nt :: Natural) =@@ -241,12 +260,25 @@ upper = null; }; };- local2 = {};+ local2 = {+ local1 = {+ lower = null;+ upper = null;+ };+ local3 = {+ lower = null;+ upper = null;+ };+ }; local3 = { direct1 = { lower = "1.0.5"; upper = null; };+ local1 = {+ lower = null;+ upper = null;+ }; }; local4 = { direct4 = {@@ -271,6 +303,10 @@ lower = "5.0"; upper = null; };+ local6 = {+ lower = "0.8";+ upper = "0.9";+ }; }; local8 = { direct1 = {@@ -292,6 +328,7 @@ }; lower-special = { direct2 = "5.0";+ local6 = "0.8"; }; lower-unused = { direct1 = "1.0.1";@@ -307,6 +344,7 @@ }; lower-special = { direct2 = "5.0";+ local6 = "0.8"; }; lower-unused = {}; };@@ -356,12 +394,20 @@ version = "1.4"; hash = "direct3-1.4"; };+ local6 = {+ version = "0.8";+ hash = "local6-0.8";+ }; transitive3 = { version = "1.0.1"; hash = "transitive3-1.0.1"; }; }; };+ solver = {+ lower-main = {};+ lower-special = {};+ }; resolving = false; } |]@@ -381,6 +427,7 @@ [35m[1m>>>[0m Found initial lower bounds for all deps after 1 iteration. [35m[1m>>>[0m Added new versions: 📦 [34mdirect2[0m 5.0 ↕ [no bounds] -> >=[32m5.0[0m+ 📦 [34mlocal6[0m 0.8 ↕ <0.9 -> [[32m0.8[0m, 0.9] |] -- | Goals for these deps:@@ -420,7 +467,7 @@ Result {..} <- lowerTest params (lowerInitMain def) listEqZip cabalTarget cabalLog eqLines stateFileTarget (renderRootExpr stateFile)- logTarget === drop 24 (reverse log)+ listEqTail logTarget (reverse log) where params = (testParams False packages) {@@ -433,6 +480,10 @@ log = True, ghcPackages, state,- projectOptions = nosortOptions {envs = ["lower-main", "lower-special"], readUpperBounds = True},+ projectOptions = nosortOptions {+ envs = ["lower-main", "lower-special"],+ readUpperBounds = True,+ localDeps = True+ }, build }
test/Hix/Test/Managed/LowerNativeTest.hs view
@@ -4,7 +4,7 @@ import qualified Data.Text.IO as Text import Exon (exon) import Hedgehog (evalEither)-import Path (Abs, Dir, File, Path, Rel, parent, reldir, relfile, toFilePath, (</>))+import Path (Abs, Dir, Path, parent, reldir, relfile, toFilePath, (</>)) import Path.IO (createDirIfMissing, getCurrentDir) import qualified Hix.Data.Monad@@ -14,29 +14,29 @@ import Hix.Managed.Cabal.Data.Config (GhcDb (GhcDbSystem)) import qualified Hix.Managed.Data.EnvConfig import Hix.Managed.Data.EnvConfig (EnvConfig (EnvConfig))-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectContext import qualified Hix.Managed.Data.ProjectContextProto import Hix.Managed.Data.ProjectContextProto (ProjectContextProto (ProjectContextProto)) import qualified Hix.Managed.Data.ProjectResult-import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import qualified Hix.Managed.Data.StateFileConfig import Hix.Managed.Data.StateFileConfig (StateFileConfig (StateFileConfig)) import qualified Hix.Managed.Handlers.Build.Prod as Build+import qualified Hix.Managed.Handlers.Project.Prod as Project import Hix.Managed.Lower.Init (lowerInitMain) import Hix.Managed.Lower.Optimize (lowerOptimizeMain) import Hix.Managed.ProjectContext (updateProject) import qualified Hix.Managed.ProjectContextProto as ProjectContextProto import Hix.Managed.ProjectContextProto (projectContext) import Hix.Test.Hedgehog (eqLines)-import Hix.Test.Utils (UnitTest, runMTest)+import Hix.Test.Run (logConfigDebug, runMTestDir)+import Hix.Test.Utils (UnitTest, addFile) -- TODO when aeson's lower bound is set to 2.2 here, the build of 2.1.0.0 fails with an infinite recursion in nix when -- reaching optimize. -- But when it is set to 2.1, the build succeeds during init. -- in the former case, there are a few more overrides added from the solver plan.-packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = managedPackages [ (("root", "1.0"), ["aeson >=2.2 && <2.3", "extra >=1.6 && <1.8"])@@ -70,19 +70,13 @@ libMod :: Text libMod = [exon|module Root where+ import Data.Aeson import Data.List.Extra string :: String string = "hello" |] -addFile :: Path Abs Dir -> Path Rel File -> Text -> M ()-addFile root path content = do- createDirIfMissing True (parent file)- liftIO (Text.writeFile (toFilePath file) content)- where- file = root </> path- setupProject :: M (Path Abs Dir) setupProject = do AppResources {tmp} <- M ask@@ -229,41 +223,41 @@ root <- setupProject let stateFileConf = StateFileConfig {- file = [relfile|ops/managed.nix|],- projectRoot = Just root+ file = [relfile|ops/managed.nix|] }- envsConfig = [("lower", EnvConfig {targets = ["root"], ghc = GhcDbSystem Nothing})]+ envsConfig = [("lower", EnvConfig {targets = ["root"], ghc = Just (GhcDbSystem Nothing)})] buildConfig = def- handlers <- Build.handlersProd stateFileConf envsConfig Nothing buildConfig def False+ handlersProject <- Project.handlersProd stateFileConf+ handlers <- Build.handlersFixed handlersProject buildConfig def let opts = projectOptions ["lower"] proto0 = ProjectContextProto { packages,- state = ProjectStateProto mempty mempty mempty mempty False,+ state = def, envs = envsConfig,- buildOutputsPrefix = Nothing+ hackage = [] } stateFile = root </> [relfile|ops/managed.nix|] run context process = do result <- process handlers context- updateProject handlers context.build result+ updateProject handlersProject True result stateFileContent <- liftIO (Text.readFile (toFilePath stateFile)) pure (result.state, stateFileContent) context0 <- ProjectContextProto.validate opts proto0 (state1, stateFileContentInit) <- run context0 (lowerInitMain def) -- TODO the packages here aren't updated with the result from the first run- let context1 = projectContext buildConfig state1 context0.packages context0.envs+ let context1 = projectContext buildConfig state1 packages context0.envs def (_, stateFileContentOptimize) <- run context1 lowerOptimizeMain pure (stateFileContentInit, stateFileContentOptimize) test_lowerNative :: UnitTest test_lowerNative = do (stateFileContentInit, stateFileContentOptimize) <- evalEither =<< liftIO do- runMTest True lowerNativeTest+ runMTestDir logConfigDebug lowerNativeTest eqLines targetStateFileInit stateFileContentInit eqLines targetStateFileOptimize stateFileContentOptimize
test/Hix/Test/Managed/LowerOptimize/CandidatesTest.hs view
@@ -4,7 +4,6 @@ import Distribution.Version (Version) import Hedgehog (evalEither, (===)) -import Hix.Data.PackageId (PackageId) import Hix.Data.PackageName (PackageName) import qualified Hix.Data.VersionBounds import Hix.Data.VersionBounds (fromLower, fromUpper)@@ -18,16 +17,19 @@ import Hix.Managed.Data.Mutation (BuildMutation (BuildMutation), MutationResult (MutationSuccess)) import qualified Hix.Managed.Data.MutationState import Hix.Managed.Data.MutationState (MutationState (MutationState))+import qualified Hix.Managed.Handlers.AvailableVersions as AvailableVersions+import Hix.Managed.Handlers.AvailableVersions (AvailableVersionsHandlers (..)) import Hix.Managed.Handlers.Mutation.Lower (processMutationLower) import Hix.Managed.Lower.Candidates (candidatesOptimize) import Hix.Managed.Lower.Data.LowerMode (lowerOptimizeMode) import Hix.Managed.Lower.Optimize (lowerOptimizeUpdate) import Hix.Managed.QueryDep (simpleQueryDep) import Hix.Monad (M, clientError)-import Hix.Test.Utils (UnitTest, runMTest)+import Hix.Test.Run (runMTestDir)+import Hix.Test.Utils (UnitTest) -availableVersions :: PackageName -> M [Version]-availableVersions = \case+fetchVersions :: PackageName -> M [Version]+fetchVersions = \case "dep" -> pure versions _ -> clientError "No such package" where@@ -35,6 +37,10 @@ s1 = [[1, m, n] | m <- [7 .. 9], n <- [1 .. 3]] s2 = [[2, m, n] | m <- [0 .. 4], n <- [1 .. 3]] +availableVersions :: AvailableVersionsHandlers+availableVersions =+ AvailableVersions.handlersActionAll fetchVersions+ targets :: [Version] targets = s1 ++ s2 ++ s3@@ -46,12 +52,11 @@ candidateVersion :: Version candidateVersion = [1, 9, 2] -build :: IORef [Maybe Version] -> BuildMutation -> M (Maybe (MutationState, Set PackageId))+build :: IORef [Maybe Version] -> BuildMutation -> M (Maybe MutationState) build buildRef BuildMutation {solverState = SolverState {constraints = [("dep", MutationConstraints {mutation})]}} = do liftIO (modifyIORef' buildRef (mutation.lower :)) pure do- s <- result =<< mutation.lower- pure (s, [])+ result =<< mutation.lower where result version | candidateVersion == version@@ -69,12 +74,12 @@ test_candidatesOptimize = do buildRef <- liftIO (newIORef []) let- result <- liftIO $ runMTest False do+ result <- liftIO $ runMTestDir def do majors <- candidatesOptimize availableVersions mempty dep for majors \ mut -> processMutationLower def lowerOptimizeMode lowerOptimizeUpdate initialState mut (build buildRef) mutationResults <- evalEither result- Just (MutationSuccess candidate True mstate [] (updateSolverState (const newConstraints) initialState)) === mutationResults+ Just (MutationSuccess candidate True mstate (updateSolverState (const newConstraints) initialState)) === mutationResults triedVersions <- liftIO (readIORef buildRef) (Just <$> targets) === triedVersions where
test/Hix/Test/Managed/LowerOptimize/MutationTest.hs view
@@ -2,14 +2,13 @@ import Exon (exon) -import Hix.Data.Error (Error (Fatal))+import Hix.Data.Error (ErrorMessage (Fatal)) import Hix.Data.Version (Versions) import qualified Hix.Managed.Cabal.Data.Packages import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages)) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages) import Hix.Managed.Cabal.Mock.SourcePackage (allDep)-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectStateProto import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import Hix.Managed.Data.StageState (BuildStatus (Failure, Success))@@ -18,10 +17,10 @@ import Hix.NixExpr (renderRootExpr) import Hix.Pretty (showP) import Hix.Test.Hedgehog (eqLines)-import Hix.Test.Managed.Run (TestParams (..), Result (..), testParams, lowerTest)+import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) import Hix.Test.Utils (UnitTest) -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = managedPackages [(("local1", "1.0"), ["direct1", "direct2"])] @@ -63,18 +62,19 @@ ("direct2", [2, 0, 1]) ]) ],- overrides = [- ("lower", [- ("direct1", "direct1-2.0.1"),- ("direct2", "direct2-2.0.1")- ])- ], initial = [ ("lower", [ ("direct1", [2, 0, 1]), ("direct2", [2, 0, 1]) ]) ],+ overrides = [+ ("lower", [+ ("direct1", "direct1-2.0.1"),+ ("direct2", "direct2-2.0.1")+ ])+ ],+ solver = [], resolving = False } @@ -129,6 +129,9 @@ hash = "transitive1-1.0.1"; }; };+ };+ solver = {+ lower = {}; }; resolving = false; }
test/Hix/Test/Managed/LowerOptimize/OrderTest.hs view
@@ -7,8 +7,7 @@ import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages)) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages) import Hix.Managed.Data.Constraints (EnvConstraints)-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectStateProto import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import Hix.Managed.Data.StageState (BuildStatus (Success))@@ -17,7 +16,7 @@ import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) import Hix.Test.Utils (UnitTest) -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = managedPackages [(("local1", "1.0"), ["dep1", "dep2", "dep3"])] @@ -62,7 +61,6 @@ ("dep3", [2, 1]) ]) ],- overrides = [("lower", [])], initial = [ ("lower", [ ("dep1", [2, 1]),@@ -70,6 +68,8 @@ ("dep3", [2, 1]) ]) ],+ overrides = [("lower", [])],+ solver = [], resolving = False }
test/Hix/Test/Managed/LowerStabilize/MutationTest.hs view
@@ -2,15 +2,12 @@ import Exon (exon) -import Hix.Data.Error (Error (Fatal))-import qualified Hix.Data.Overrides-import Hix.Data.Overrides (Override (Override))-import Hix.Data.Version (SourceHash (SourceHash), Versions)+import Hix.Data.Error (ErrorMessage (Fatal))+import Hix.Data.Version (Versions) import qualified Hix.Managed.Cabal.Data.Packages import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages)) import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages)-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages)-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ProjectPackages, managedPackages) import qualified Hix.Managed.Data.ProjectStateProto import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) import Hix.Managed.Data.StageState (BuildStatus (Failure, Success))@@ -19,7 +16,7 @@ import Hix.NixExpr (renderRootExpr) import Hix.Pretty (showP) import Hix.Test.Hedgehog (eqLines)-import Hix.Test.Managed.Run (TestParams (..), Result (..), testParams, lowerTest)+import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) import Hix.Test.Utils (UnitTest) available :: SourcePackages@@ -40,7 +37,7 @@ ghcPackages :: GhcPackages ghcPackages = GhcPackages {installed = [], available} -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = managedPackages [(("local1", "1.0"), ["direct1", "direct2"])] @@ -59,18 +56,19 @@ ("direct2", [1, 8, 1]) ]) ],- overrides = [- ("lower", [- ("direct1", Override {version = [1, 8, 1], hash = SourceHash "direct1-1.8.1"}),- ("direct2", Override {version = [1, 8, 1], hash = SourceHash "direct2-1.8.1"})- ])- ], initial = [ ("lower", [ ("direct1", [2, 0, 1]), ("direct2", [2, 0, 1]) ]) ],+ overrides = [+ ("lower", [+ ("direct1", "direct1-1.8.1"),+ ("direct2", "direct2-1.8.1")+ ])+ ],+ solver = [], resolving = False } @@ -123,6 +121,9 @@ hash = "direct2-1.9.1"; }; };+ };+ solver = {+ lower = {}; }; resolving = false; }
+ test/Hix/Test/Managed/Maint/Handlers.hs view
@@ -0,0 +1,377 @@+module Hix.Test.Managed.Maint.Handlers where++import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import Data.Time (TimeOfDay (TimeOfDay), UTCTime (UTCTime), fromGregorian, timeOfDayToTime)+import Data.Tuple.Extra (fst3)+import Data.Typeable (cast)+import Distribution.Compat.CharParsing (string)+import Distribution.Parsec (CabalParsing, Parsec (parsec), explicitEitherParsec)+import Distribution.Version (version0)+import Exon (exon)+import Path (parseRelDir, parseRelFile)+import Type.Reflection (typeRep)++import Hix.Class.Map (nAdjust, nElems, nKeys, nKeysSet, nMap, nMapWithKey, nOver, nTransform, nViaA, (!?))+import Hix.Data.Dep (Dep (..))+import Hix.Data.EnvName (EnvName)+import Hix.Data.MDep (MDep (..))+import qualified Hix.Data.Monad+import Hix.Data.Monad (M, appRes)+import Hix.Data.PackageId (PackageId (..))+import Hix.Data.PackageName (LocalPackage (..), PackageName)+import Hix.Managed.Cabal.Data.Revision (Revision (..))+import Hix.Managed.Data.BuildOutput (DepChanges (..), ModifiedId (..))+import Hix.Managed.Data.Envs (Envs)+import Hix.Managed.Data.MaintContext (MaintContext (..), MaintPackage (..))+import Hix.Managed.Data.ManagedPackage (ManagedPackage (..))+import Hix.Managed.Data.Mutable (depName)+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Git (BranchName (..), GitApi (..), MaintBranch (..), Tag (..))+import qualified Hix.Managed.Handlers.Context as ContextHandlers+import Hix.Managed.Handlers.Context (ContextKey (ContextMaint), ContextQuery (ContextQuery))+import Hix.Managed.Handlers.HackageClient (+ HackageClient (..),+ HackageError (..),+ HackageRequest (..),+ HackageResponse (..),+ )+import Hix.Managed.Handlers.Maint (MaintHandlers (..))+import Hix.Managed.Maint.Git (GitMaint (..), formatReleaseBranch, releaseBranchName)+import Hix.Monad (noteFatal)+import Hix.Pretty (HPretty (..), field, prettyMap, showP, showPL)+import Hix.Test.Managed.ReleaseMaintenance.Case (+ EnvStyle (..),+ MaintTestCase (..),+ PackageConf (..),+ PackageMeta (..),+ ProjectHistoryEvent (..),+ TestDep (ModifiedDep),+ partitionTestDeps,+ testDepName,+ )+import Hix.Test.Managed.ReleaseMaintenance.Gen (oldDepBounds, oldDepRange)+import Hix.Test.Utils (addFile)++dummyTime :: UTCTime+dummyTime = UTCTime (fromGregorian 2024 1 16) (timeOfDayToTime (TimeOfDay 0 0 0))++dummyRevision :: Word -> Revision+dummyRevision number = Revision {user = "user-rev", time = dummyTime, sha256 = "deadbeef", number}++data MaintEvent =+ EventFetchRevisions+ |+ EventPublishRevision { packageId :: PackageId, form :: (Text, Text) }+ |+ GitCommitted {+ package :: LocalPackage,+ branch :: MaintBranch,+ modified :: NonEmpty ModifiedId+ }+ deriving stock (Eq, Show)++data GitState =+ GitState {+ branches :: [(MaintBranch, BranchName, Tag)],+ current :: Maybe MaintBranch+ }+ deriving stock (Eq, Show)++data MaintState =+ MaintState {+ events :: [MaintEvent],+ published :: Set PackageName,+ git :: GitState+ }+ deriving stock (Eq, Show, Generic)++pathParserRevisions :: CabalParsing m => m PackageId+pathParserRevisions = do+ string "package/"+ pid <- parsec+ string "/revisions/"+ pure pid++pathParserPublishRevision :: CabalParsing m => m PackageId+pathParserPublishRevision = do+ string "package/"+ pid <- parsec+ string [exon|/#{toString pid.name}.cabal/edit|]+ pure pid++hackage :: ∀ a . Packages PackageMeta -> MVar MaintState -> HackageRequest a -> M (Either HackageError a)+hackage packages state = \case+ HackageRequest {path, accept = HackageResponseJson}+ | Right pid <- explicitEitherParsec pathParserRevisions (toString path)+ , Just package <- packages !? LocalPackage pid.name+ ->+ liftIO $ modifyMVar state \case+ MaintState {events, published, ..} -> do+ let inc = if Set.member pid.name published then 1 else 0+ res <- respond @[_] (dummyRevision <$> [0..package.revision + inc])+ pure (MaintState {events = EventFetchRevisions : events, published, ..}, res)+ where+ respond :: ∀ r . Typeable r => r -> IO (Either HackageError a)+ respond r | Just a <- cast r = pure (Right a)+ | otherwise = pure (Left (HackageFatal [exon|Unexpected json type: #{show (typeRep @a)}|]))++ HackageRequest {path, accept = HackageResponseHtml, body = Just (Left formData)}+ | Right pid <- explicitEitherParsec pathParserPublishRevision (toString path)+ ->+ withState \ MaintState {..} -> do+ let new = MaintState {published = Set.insert pid.name published, ..}+ pure (EventPublishRevision pid (NonEmpty.head formData), new, Right "all good")++ HackageRequest {path, accept} ->+ pure (Left (HackageFatal [exon|Unexpected Hackage request for path '#{path}' with type '#{show accept}'|]))+ where+ withState :: ∀ x . (MaintState -> IO (MaintEvent, MaintState, x)) -> M x+ withState f =+ liftIO $ modifyMVar state \ oldState -> do+ (newEvent, MaintState {..}, a) <- f oldState+ pure (MaintState {events = newEvent : events, ..}, a)++data MaintPremise =+ MaintPremise {+ packages :: Packages PackageMeta,+ tags :: [Tag],+ branches :: [(MaintBranch, BranchName, Tag)]+ }+ deriving stock (Eq, Show)++package0 ::+ EnvStyle ->+ Bool ->+ LocalPackage ->+ PackageConf ->+ PackageMeta+package0 envStyle anyDepModified package PackageConf {..} =+ PackageMeta {+ package,+ deps,+ version = version0,+ modified,+ bumped = any isRangeBump (nElems deps),+ envModified,+ released = False,+ revision = 0,+ shared = False+ }+ where+ envModified = case envStyle of+ EnvAll -> anyDepModified+ EnvEach -> modified++ modified = any isBump (nElems deps)++ isBump = \case+ ModifiedDep _ -> True+ _ -> False++ isRangeBump = \case+ ModifiedDep ModifiedId {range = Just _} -> True+ _ -> False++evolveHistory :: MaintTestCase -> MaintPremise+evolveHistory testCase =+ foldl' step MaintPremise {+ packages = nMapWithKey (package0 testCase.envStyle testCase.anyDepModified) testCase.packages,+ tags = [],+ branches = []+ } testCase.history+ where++ step MaintPremise {..} = \case+ Release {..} ->+ let+ version = bump major ((.version) <$> packages !? package)+ newPackages = nAdjust package packages (release version revision False)+ in withBranches newPackages (Just package) [package] version revision+ ReleaseShared {..} ->+ let+ version = bump major (maximum ((.version) <$> nElems packages))+ newPackages = nMap (release version revision True) packages+ in withBranches newPackages Nothing (nKeys packages) version revision+ where+ withBranches newPackages tagPackage names version revision =+ let+ tag = Tag {package = tagPackage, version}+ newBranch | 0 <- revision = []+ | otherwise = [(branch tag name version) | name <- names]+ in MaintPremise {packages = newPackages, tags = tag : tags, branches = newBranch ++ branches}++ branch tag name version =+ let mb = MaintBranch {package = name, version}+ in (mb, releaseBranchName mb, tag)++ release version revision shared PackageMeta {package, deps, modified, bumped, envModified} = do+ PackageMeta {version, released = True, ..}++ bump major = \case+ Just [s, ma, mi] -> if major then [s, ma + 1, 0] else [s, ma, mi + 1]+ _ -> if major then [0, 1, 0] else [0, 0, 1]++depChanges :: [PackageMeta] -> DepChanges+depChanges packages =+ DepChanges {+ modified,+ unmodified,+ failed+ }+ where+ (unmodified, modified, failed) = partitionTestDeps allDeps++ allDeps = nElems (mconcat ((.deps) <$> packages))++data EnvOutput =+ EnvOutput {+ targets :: [PackageMeta],+ changes :: DepChanges+ }+ deriving stock (Eq, Show)++instance HPretty EnvOutput where+ hpretty EnvOutput {..} =+ prettyMap "env" [+ field "targets" targets+ ]++buildOutputs :: Packages PackageMeta -> EnvStyle -> Envs EnvOutput+buildOutputs packages = \case+ EnvAll ->+ [("latest", output (nElems packages))]+ EnvEach ->+ flip nTransform packages \ name pkg ->+ ([exon|latest-##{name}|], output [pkg])+ where+ output targets =+ EnvOutput {+ targets,+ changes = depChanges targets+ }++gitMaint ::+ MVar MaintState ->+ MaintPremise ->+ GitMaint+gitMaint state premise =+ GitMaint {..}+ where+ bracket ma = ma++ readTags = pure premise.tags++ listTargetBranches target = do+ branches <- allBranches+ pure (filter ((target ==) . (.package)) branches)++ branchOffTag branch tag =+ update \ GitState {..} ->+ GitState {+ current = Just branch,+ branches = (branch, BranchName (formatReleaseBranch branch), tag) : branches,+ ..+ }++ switchBranch branch = do+ update \ GitState {..} -> GitState {current = Just branch, ..}+ pure (releaseBranchName branch)++ commitBump branch package modified = do+ updateState \ MaintState {..} -> MaintState {events = GitCommitted {package, branch, modified} : events, ..}+ pure (releaseBranchName branch)++ allBranches = liftIO $ readMVar state <&> \ MaintState {git = GitState {branches}} ->+ fst3 <$> branches ++ premise.branches++ update f = updateState \ MaintState {git, ..} -> MaintState {git = f git, ..}++ updateState f = liftIO $ modifyMVar_ state (pure . f)++buildCabalConfig :: PackageMeta -> DepChanges -> M Text+buildCabalConfig PackageMeta {package, deps} DepChanges {..} = do+ pure [exon|cabal-version: 2.2+name: ##{package}+version: 0.2.0+library ##{package}+ build-depends:+ #{showPL bdeps}+|]+ where+ bdeps = sortOn (.package) (mapMaybe mdep modified ++ mapMaybe udep unmodified)++ mdep ModifiedId {package = dpackage, range} =+ let name = depName dpackage+ in if isDep name+ then Just MDep {package = name, bounds = fromMaybe oldDepBounds range}+ else Nothing++ udep d =+ let name = depName d+ in if isDep name+ then Just MDep {package = name, bounds = oldDepBounds}+ else Nothing++ isDep = flip Set.member depNames++ depNames = nKeysSet deps++-- TODO we still need to keep adding the cabal file since publishRevision reads it.+-- It should probably generate it using the flake, on the fly (and this could then be mocked here).+runBump ::+ Envs EnvOutput ->+ EnvName ->+ M DepChanges+runBump outputs env = do+ root <- appRes.root+ EnvOutput {targets, changes} <- noteFatal [exon|No build output in test data for '#{showP env}'|] (outputs !? env)+ for_ targets \ meta@PackageMeta {package} -> do+ cabalPath <- parseRelFile [exon|packages/##{package}/##{package}.cabal|]+ cabalConfig <- buildCabalConfig meta changes+ addFile root cabalPath cabalConfig+ pure changes++testContext :: Envs EnvOutput -> Packages PackageMeta -> M MaintContext+testContext outputs packages = do+ maintPackages <- nViaA (Map.traverseWithKey maintPackage) packages+ pure MaintContext {packages = maintPackages, hackage = [], envs}+ where+ maintPackage package PackageMeta {version, deps} = do+ path <- pathError package $ parseRelDir [exon|packages/##{package}|]+ pure MaintPackage {+ package = ManagedPackage {+ name = package,+ version,+ deps = [Dep {package = testDepName dep, version = oldDepRange} | dep <- nElems deps]+ },+ path+ }++ envs = nOver outputs \ env -> [package | PackageMeta {package} <- env.targets]++ pathError package = noteFatal [exon|testContext: Invalid package name for path: #{showP package}|]++configQuery :: MaintContext -> ContextQuery a -> Maybe a+configQuery conf = \case+ ContextQuery ContextMaint -> Just conf+ _ -> Nothing++maintTestHandlers ::+ Envs EnvOutput ->+ MaintPremise ->+ M (MaintHandlers, MaintContext, MVar MaintState)+maintTestHandlers outputs premise = do+ state <- liftIO $ newMVar initialState+ context <- testContext outputs premise.packages+ let handlers = MaintHandlers {+ runBump = runBump outputs,+ git = GitApi \ _ f -> f (gitMaint state premise),+ context = ContextHandlers.handlersTest (const (pure Nothing)),+ publishHackages = [HackageClient "mock hackage" (hackage premise.packages state)]+ }+ pure (handlers, context, state)+ where+ initialState =+ MaintState {events = [], published = [], git = GitState {branches = [], current = Nothing}}
test/Hix/Test/Managed/ProjectContextProtoTest.hs view
@@ -3,23 +3,26 @@ import Data.Aeson (eitherDecodeStrict') import Distribution.Version (earlierVersion, intersectVersionRanges, majorBoundVersion, orLaterVersion, thisVersion) import Exon (exon)-import Hedgehog (evalEither, (===))+import Hedgehog ((===)) import Path (absdir) import qualified Hix.Data.Dep import Hix.Data.Dep (Dep (Dep), mkDep) import Hix.Data.EnvName (EnvName) import Hix.Data.Version (range0)-import Hix.Managed.Cabal.Data.Config (GhcDb (GhcDbSystem), GhcPath (GhcPath))+import Hix.Managed.Cabal.Data.Config (CabalConfig (..), GhcDb (GhcDbSystem), GhcPath (GhcPath))+import qualified Hix.Managed.Cabal.Data.ContextHackageRepo as ContextHackageRepo+import Hix.Managed.Cabal.Data.ContextHackageRepo (ContextHackageRepo, contextHackageRepo)+import qualified Hix.Managed.Cabal.Data.HackageLocation as HackageLocation+import qualified Hix.Managed.Cabal.Data.HackageRepo as HackageRepo+import Hix.Managed.Cabal.Data.HackageRepo (HackageRepo)+import Hix.Managed.Cabal.HackageRepo (hackageRepo) import qualified Hix.Managed.Data.EnvConfig import Hix.Managed.Data.EnvConfig (EnvConfig (EnvConfig)) import qualified Hix.Managed.Data.EnvContext import Hix.Managed.Data.EnvContext (EnvContext (EnvContext), EnvDeps (EnvDeps)) import qualified Hix.Managed.Data.ManagedPackage-import Hix.Managed.Data.ManagedPackage (ManagedPackage (ManagedPackage))-import qualified Hix.Managed.Data.ManagedPackageProto-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto (ManagedPackageProto))-import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Data.ManagedPackage (ManagedPackage (ManagedPackage), ProjectPackages) import qualified Hix.Managed.Data.ProjectContext import Hix.Managed.Data.ProjectContext (ProjectContext (ProjectContext)) import qualified Hix.Managed.Data.ProjectContextProto@@ -31,7 +34,8 @@ import Hix.Managed.Data.Targets (unsafeTargets) import qualified Hix.Managed.ProjectContextProto as ProjectContextProto import Hix.Test.Hedgehog (assertRight)-import Hix.Test.Utils (UnitTest, runMTest)+import Hix.Test.Run (runMTestDir)+import Hix.Test.Utils (UnitTest, toTestT) json :: ByteString json =@@ -106,13 +110,19 @@ "targets": ["local3", "local4"], "ghc": "/ghc" }+ },+ "hackage": {+ "local": {+ "name": "local",+ "publish": false+ } } }|] -packages :: Packages ManagedPackageProto+packages :: ProjectPackages packages = [- ("local1", ManagedPackageProto {+ ("local1", ManagedPackage { name = "local1", version = "1.2.1", deps = [@@ -126,32 +136,40 @@ mkDep "direct5" (intersectVersionRanges (orLaterVersion [5, 0]) (earlierVersion [5, 1])) ] }),- ("local2", ManagedPackageProto {+ ("local2", ManagedPackage { name = "local2", version = "1.1.1", deps = ["local1"] }),- ("local3", ManagedPackageProto {+ ("local3", ManagedPackage { name = "local3", version = "1.1.1", deps = [] }),- ("local4", ManagedPackageProto {+ ("local4", ManagedPackage { name = "local4", version = "1.1.1", deps = ["local2", "direct1", "direct2"] }),- ("local5", ManagedPackageProto {+ ("local5", ManagedPackage { name = "local5", version = "1.1.1", deps = ["local4", "local3"] }) ] -ghc :: GhcDb+ghc :: Maybe GhcDb ghc =- GhcDbSystem (Just (GhcPath [absdir|/ghc|]))+ Just (GhcDbSystem (Just (GhcPath [absdir|/ghc|]))) +targetContextRepo :: ContextHackageRepo+targetContextRepo =+ (contextHackageRepo "local") {ContextHackageRepo.publish = Just False}++targetRepo :: HackageRepo+targetRepo =+ (hackageRepo "local" HackageLocation.central) {HackageRepo.secure = Nothing}+ targetProto :: ProjectContextProto targetProto = ProjectContextProto {@@ -159,15 +177,16 @@ state = ProjectStateProto { bounds = [("local1", [("direct1", "<2.3"), ("direct2", "<1.5")])], versions = [],- overrides = mempty, initial = mempty,+ overrides = mempty,+ solver = mempty, resolving = False }, envs = [ ("lower-main", EnvConfig {targets = ["local1", "local2"], ghc}), ("lower-special", EnvConfig {targets = ["local3", "local4"], ghc}) ],- buildOutputsPrefix = Nothing+ hackage = [("local", targetContextRepo)] } targetEnvs :: NonEmpty (Either EnvName EnvContext)@@ -177,7 +196,7 @@ env = "lower-main", ghc, targets = unsafeTargets ["local1", "local2"],- deps = EnvDeps {mutable = ["direct1", "direct2", "direct3", "direct4", "direct5"], local = []},+ deps = EnvDeps {mutable = ["direct1", "direct2", "direct3", "direct4", "direct5"]}, query = ["direct1", "direct2", "direct3", "direct4", "direct5"], solverBounds = mempty },@@ -185,8 +204,8 @@ env = "lower-special", ghc, targets = unsafeTargets ["local3", "local4"],- deps = EnvDeps {mutable = ["direct1", "direct2"], local = ["local2"]},- query = ["direct1", "direct2"],+ deps = EnvDeps {mutable = ["direct1", "direct2", "local2"]},+ query = ["direct1", "direct2", "local2"], solverBounds = mempty } ]@@ -197,40 +216,35 @@ build = def, packages = [ ("local1", ManagedPackage {- package = "local1",+ name = "local1", version = [1, 2, 1],- local = [],- mutable = [- ("direct1", "^>=2.0"),- ("direct2", "<1.5"),- ("direct3", ">=0"),- ("direct4", "==13.23"),- ("direct5", ">=5.0 && <5.1")+ deps = [+ "direct1 ^>=2.0",+ "direct2 <1.5",+ "direct3 >=0",+ "direct4 ==13.23",+ "direct5 >=5.0 && <5.1" ] }), ("local2", ManagedPackage {- package = "local2",+ name = "local2", version = [1, 1, 1],- local = [("local1", ">=0")],- mutable = []+ deps = ["local1 >=0"] }), ("local3", ManagedPackage {- package = "local3",+ name = "local3", version = [1, 1, 1],- local = [],- mutable = []+ deps = [] }), ("local4", ManagedPackage {- package = "local4",+ name = "local4", version = [1, 1, 1],- local = [("local2", ">=0")],- mutable = [("direct1", ">=0"), ("direct2", ">=0")]+ deps = ["local2 >=0", "direct1 >=0", "direct2 >=0"] }), ("local5", ManagedPackage {- package = "local5",+ name = "local5", version = [1, 1, 1],- local = [("local3", ">=0"), ("local4", ">=0")],- mutable = []+ deps = ["local4 >=0", "local3 >=0"] }) ], state = ProjectState {@@ -242,10 +256,10 @@ ("direct4", ">=0"), ("direct5", ">=0") ]),- ("local2", []),+ ("local2", [("local1", ">=0")]), ("local3", []),- ("local4", [("direct1", ">=0"), ("direct2", ">=0")]),- ("local5", [])+ ("local4", [("direct1", ">=0"), ("direct2", ">=0"), ("local2", ">=0")]),+ ("local5", [("local3", ">=0"), ("local4", ">=0")]) ], versions = [ ("lower-main", [@@ -257,10 +271,10 @@ ]), ("lower-special", [ ("direct1", Nothing),- ("direct2", Nothing)+ ("direct2", Nothing),+ ("local2", Nothing) ]) ],- overrides = [], initial = [ ("lower-main", [ ("direct1", Nothing),@@ -271,17 +285,21 @@ ]), ("lower-special", [ ("direct1", Nothing),- ("direct2", Nothing)+ ("direct2", Nothing),+ ("local2", Nothing) ]) ],+ overrides = [],+ solver = [], resolving = False },- envs = targetEnvs+ envs = targetEnvs,+ cabal = CabalConfig {hackageMain = Nothing, hackageExtra = [targetRepo]} } test_parseProjectContextProto :: UnitTest test_parseProjectContextProto = do assertRight targetProto (eitherDecodeStrict' json)- project <- evalEither =<< liftIO do- runMTest False (ProjectContextProto.validate def targetProto)+ project <- toTestT do+ runMTestDir def (ProjectContextProto.validate def targetProto) targetProject === project
+ test/Hix/Test/Managed/ReleaseMaintenance/Case.hs view
@@ -0,0 +1,138 @@+module Hix.Test.Managed.ReleaseMaintenance.Case where++import Distribution.Pretty (Pretty (..))+import Distribution.Version (Version)+import Text.PrettyPrint (text, ($$), (<+>))++import Hix.Data.PackageName (LocalPackage (..), PackageName)+import Hix.Managed.Data.BuildOutput (ModifiedId (..))+import Hix.Managed.Data.Mutable (MutableDep, depName)+import Hix.Managed.Data.Packages (Deps, Packages)+import Hix.Pretty (HPretty (..), field, prettyMap, showP)++data TestDep =+ UnmodifiedDep MutableDep+ |+ ModifiedDep ModifiedId+ |+ FailedDep MutableDep+ deriving stock (Eq, Show)++instance Pretty TestDep where+ pretty = \case+ UnmodifiedDep mid -> pretty mid+ ModifiedDep mid -> pretty mid+ FailedDep mid -> pretty mid++bumpedMutableDep :: TestDep -> MutableDep+bumpedMutableDep = \case+ UnmodifiedDep mid -> mid+ ModifiedDep ModifiedId {package} -> package+ FailedDep mid -> mid++testDepName :: TestDep -> PackageName+testDepName = depName . bumpedMutableDep++isModifiedDep :: TestDep -> Bool+isModifiedDep = \case+ ModifiedDep _ -> True+ UnmodifiedDep _ -> False+ FailedDep _ -> False++partitionTestDeps :: [TestDep] -> ([MutableDep], [ModifiedId], [MutableDep])+partitionTestDeps =+ foldr step mempty+ where+ step dep (u, m, f) = case dep of+ UnmodifiedDep mid -> (mid : u, m, f)+ ModifiedDep mid -> (u, mid : m, f)+ FailedDep mid -> (u, m, mid : f)++data PackageConf =+ PackageConf {+ revision :: Word,+ deps :: Deps TestDep+ }+ deriving stock (Eq, Show)++instance Pretty PackageConf where+ pretty PackageConf {..} =+ text (show revision) $$ pretty deps++data PackageMeta =+ PackageMeta {+ package :: LocalPackage,+ version :: Version,+ revision :: Word,+ deps :: Deps TestDep,+ modified :: Bool,+ bumped :: Bool,+ envModified :: Bool,+ released :: Bool,+ shared :: Bool+ }+ deriving stock (Eq, Show)++instance HPretty PackageMeta where+ hpretty PackageMeta {..} =+ prettyMap (showP package) [+ field "deps" deps,+ field "version" version,+ field "revision" (fromIntegral @_ @Int revision),+ field "modified" modified,+ field "bumped" bumped,+ field "envModified" envModified,+ field "released" released,+ field "shared" shared+ ]++data EnvStyle =+ EnvAll+ |+ EnvEach+ deriving stock (Eq, Show)++instance Pretty EnvStyle where+ pretty = \case+ EnvAll -> text "all"+ EnvEach -> text "each"++data ProjectHistoryEvent =+ Release { package :: LocalPackage, major :: Bool, revision :: Word }+ |+ ReleaseShared { major :: Bool, revision :: Word }+ deriving stock (Eq, Show)++instance Pretty ProjectHistoryEvent where+ pretty = \case+ Release {..} -> text "release" <+> pretty package <+> prettyMajor major <+> prettyRevision revision+ ReleaseShared {..} -> text "release" <+> prettyMajor major <+> prettyRevision revision+ where+ prettyMajor major = if major then "major" else "minor"+ prettyRevision revision = text (show revision)++data MaintTestCase =+ MaintTestCase {+ packages :: Packages PackageConf,+ history :: [ProjectHistoryEvent],+ envStyle :: EnvStyle,+ anyDepModified :: Bool+ }+ deriving stock (Eq, Show)++instance HPretty MaintTestCase where+ hpretty MaintTestCase {..} =+ prettyMap "maint test" [+ field "packages" packages,+ field "history" history,+ field "style" envStyle+ ]++instance Default MaintTestCase where+ def =+ MaintTestCase {+ packages = [],+ history = [],+ envStyle = EnvAll,+ anyDepModified = False+ }
+ test/Hix/Test/Managed/ReleaseMaintenance/Gen.hs view
@@ -0,0 +1,107 @@+module Hix.Test.Managed.ReleaseMaintenance.Gen where++import Data.List (cycle)+import Distribution.Version (Version)+import Exon (exon)+import Hedgehog (Gen, GenT)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Hix.Class.Map (nElems, nForKeys, nKeysSet, nRestrictKeys, nConcat)+import Hix.Data.PackageName (LocalPackage (..), PackageName (..))+import Hix.Data.Version (VersionRange)+import Hix.Data.VersionBounds (VersionBounds, majorRange)+import Hix.Managed.Data.BuildOutput (ModifiedId (..))+import Hix.Managed.Data.Mutable (unsafeMutableDep)+import Hix.Managed.Data.Packages (Deps)+import Hix.Test.Managed.ReleaseMaintenance.Case (+ EnvStyle (EnvAll, EnvEach),+ MaintTestCase (..),+ PackageConf (..),+ ProjectHistoryEvent (..),+ TestDep (..),+ isModifiedDep,+ )+import Hix.Test.Managed.UnsafeIsString ()++initialDepVersion :: Version+initialDepVersion = [1, 0]++oldDepBounds :: VersionBounds+oldDepBounds = [[1, 0], [1, 1]]++oldDepRange :: VersionRange+oldDepRange = majorRange oldDepBounds++bumpedDepBounds :: VersionBounds+bumpedDepBounds = [[1, 0], [1, 2]]++bumpedDepRange :: VersionRange+bumpedDepRange = majorRange bumpedDepBounds++bumpedMinorVersion :: Version+bumpedMinorVersion = [1, 0, 1]++bumpedMajorVersion :: Version+bumpedMajorVersion = [1, 1]++genBumpedDep ::+ Monad m =>+ PackageName ->+ GenT m TestDep+genBumpedDep name =+ Gen.element @[] [+ UnmodifiedDep package,+ ModifiedDep ModifiedId {package, version = bumpedMinorVersion, range = Nothing},+ ModifiedDep ModifiedId {package, version = bumpedMajorVersion, range = Just bumpedDepBounds},+ FailedDep package+ ]+ where+ package = unsafeMutableDep name++-- TODO Properties we want to test:+-- * If a package has changes:+-- * The revision number is one greater than when the run started+-- * The release branch exists, has the proper branch style, and corresponds to the latest version (name and base tag)+-- * If a package has no changes:+-- * The revision number is equal to when the run started+-- * If a release branch for the latest version exists, the revision number must be greater than 0+genEvents ::+ NonEmpty LocalPackage ->+ Bool ->+ Gen [ProjectHistoryEvent]+genEvents packages shared+ | shared+ = Gen.list (Range.constant 1 5) (ReleaseShared <$> Gen.bool <*> Gen.word (Range.constant 0 2))+ | otherwise+ = Gen.list (Range.constant 1 10) do+ package <- Gen.element packages+ major <- Gen.bool+ revision <- Gen.word (Range.constant 0 2)+ pure Release {..}++genPackage :: Deps TestDep -> Gen PackageConf+genPackage depsAvail = do+ revision <- Gen.word (Range.constant 0 2)+ depNames <- Gen.subset (nKeysSet depsAvail)+ pure PackageConf {deps = nRestrictKeys depNames depsAvail, ..}++numbered :: IsString a => String -> Int -> [a]+numbered prefix to =+ [fromString [exon|#{prefix}#{show i}|] | i <- [1 .. to]]++genMaintTestCase :: Gen MaintTestCase+genMaintTestCase = do+ depCount <- Gen.int (Range.constant 0 10)+ packageCount <- Gen.int (Range.constant 1 3)+ envStyle <- Gen.element @[] [EnvAll, EnvEach]+ startStyle <- Gen.int (Range.constant 0 1)+ alts <- Gen.int (Range.constant 1 4)+ let packageNames = [fromString [exon|local#{show i}|] | i <- [1 .. packageCount]]+ segments = (take alts (drop startStyle (cycle [True, False])))+ depsBumped <- nForKeys (numbered "dep" depCount) genBumpedDep+ packages <- nForKeys (toList packageNames) (const (genPackage depsBumped))+ history <- concat <$> traverse (genEvents packageNames) segments+ let usedDeps = nConcat packages (const (.deps))+ anyDepModified = any isModifiedDep (nElems usedDeps)+ pure MaintTestCase {..}
+ test/Hix/Test/Managed/ReleaseMaintenanceTest.hs view
@@ -0,0 +1,172 @@+module Hix.Test.Managed.ReleaseMaintenanceTest where++import Hedgehog (Property, TestT, forAllWith, property, test, (===))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)++import Hix.Class.Map (nElems, nMap, nTo)+import Hix.Data.PackageId (PackageId (..))+import Hix.Data.PackageName (localPackageName)+import Hix.Managed.Data.BuildOutput (DepChanges (..))+import Hix.Managed.Data.Envs (Envs)+import Hix.Managed.Data.MaintConfig (MaintConfig (..))+import Hix.Managed.Data.Packages (Packages)+import Hix.Managed.Git (MaintBranch (..), Tag (..))+import Hix.Managed.Maint.Data.MaintResult (+ MaintChanged (..),+ MaintResult (..),+ NoPublishReason (..),+ UnchangedReason (..),+ )+import Hix.Managed.Maint.Git (releaseBranchName)+import Hix.Managed.ReleaseMaintenance (releaseMaintenance)+import Hix.Maybe (justIf)+import Hix.Pretty (showHP, showP)+import Hix.Test.Managed.Maint.Handlers (+ EnvOutput (..),+ GitState (..),+ MaintEvent (..),+ MaintPremise (..),+ MaintState (..),+ buildOutputs,+ dummyRevision,+ evolveHistory,+ maintTestHandlers,+ )+import Hix.Test.Managed.ReleaseMaintenance.Case (MaintTestCase (..), PackageMeta (..))+import Hix.Test.Managed.ReleaseMaintenance.Gen (genMaintTestCase)+import Hix.Test.Utils (runMTest)++config :: MaintConfig+config =+ MaintConfig {+ noFailures = False,+ commit = True,+ push = False,+ revision = True,+ targets = Nothing,+ fetch = False,+ globalGit = False,+ pr = False+ }++data MaintTestOutput =+ MaintTestOutput {+ results :: Packages MaintResult,+ events :: [MaintEvent],+ git :: GitState,+ packages :: Packages PackageMeta,+ outputs :: Envs EnvOutput+ }+ deriving stock (Eq, Show)++runMaintTest ::+ MaintTestCase ->+ TestT IO MaintTestOutput+runMaintTest testCase = do+ runMTest False do+ (handlers, context, state) <- maintTestHandlers outputs premise+ results <- releaseMaintenance handlers config context+ MaintState {events, git} <- liftIO $ readMVar state+ pure MaintTestOutput {packages = premise.packages, ..}+ where+ outputs = buildOutputs premise.packages testCase.envStyle+ premise = evolveHistory testCase++resultProps ::+ Packages PackageMeta ->+ Packages MaintResult+resultProps =+ nMap \ meta -> result (mkChanged (mkBranch meta)) meta+ where+ result changed = \case+ PackageMeta {modified, bumped, released, revision, envModified}+ | bumped+ , released+ -> changed (Published (dummyRevision (revision + 1)))++ | modified+ , released+ -> changed (Modified NoRangeUpdates)++ | released+ , envModified+ -> changed (Modified NoDirectDepUpdates)++ | released+ -> Unchanged NoUpdates++ | otherwise+ -> Unchanged NoTags++ mkChanged branch resolution = Changed {baseBranch = branch, ..}++ mkBranch PackageMeta {package, version} =+ releaseBranchName MaintBranch {..}++eventProps ::+ MaintTestOutput ->+ [MaintEvent]+eventProps MaintTestOutput {packages, outputs} =+ mconcat $ reverse $ nTo packages $ const \case+ PackageMeta {package, version, released, bumped}+ | released ->+ fold (justIf bumped (publishEvents PackageId {name = localPackageName package, version})) +++ maybeToList (gitEvents package version)+ | otherwise ->+ []+ where+ publishEvents packageId =+ [+ EventFetchRevisions,+ EventPublishRevision {+ packageId,+ form = ("pkgid", showP packageId)+ },+ EventFetchRevisions+ ]++ gitEvents package version = do+ output <- find (isTarget package) (nElems outputs)+ modified <- nonEmpty output.changes.modified+ pure GitCommitted {package, branch = MaintBranch {package, version}, modified}++ isTarget target EnvOutput {targets} = flip any targets \ PackageMeta {package} -> package == target++gitProps :: Packages PackageMeta -> GitState+gitProps packages =+ GitState {branches, current}+ where+ branches =+ reverse $ catMaybes $ nTo packages $ const \case+ PackageMeta {package, version, revision, released, shared}+ | released+ , revision == 0+ , let maintBranch = MaintBranch {package, version}+ -> Just (maintBranch, releaseBranchName maintBranch, Tag {package = justIf (not shared) package, version})+ | otherwise+ -> Nothing++ current =+ last $ catMaybes $ nTo packages $ const \case+ PackageMeta {package, version, released}+ | released+ -> Just MaintBranch {package, version}+ | otherwise+ -> Nothing+++prop_maint :: Property+prop_maint =+ property do+ testCase <- forAllWith showHP genMaintTestCase+ output <- test $ runMaintTest testCase+ resultProps output.packages === output.results+ eventProps output === output.events+ gitProps output.packages === output.git++test_maint :: TestTree+test_maint =+ testGroup "managed bounds maintenance" [+ testProperty "maint logic" prop_maint+ ]
− test/Hix/Test/Managed/Run.hs
@@ -1,147 +0,0 @@-module Hix.Test.Managed.Run where--import Data.IORef (readIORef)-import Hedgehog (TestT, evalEither, evalMaybe)--import Hix.Class.Map (nFromList, nKeys)-import Hix.Data.EnvName (EnvName)-import Hix.Data.Monad (M)-import Hix.Data.NixExpr (Expr)-import qualified Hix.Data.Options as ProjectOptions-import Hix.Data.Options (ProjectOptions)-import Hix.Data.PackageName (LocalPackage)-import Hix.Data.Version (Versions)-import Hix.Managed.Cabal.Changes (SolverPlan)-import Hix.Managed.Cabal.Data.Config (GhcDb (GhcDbSynthetic))-import qualified Hix.Managed.Cabal.Data.Packages-import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages))-import Hix.Managed.Data.BuildConfig (BuildConfig (toposortMutations))-import Hix.Managed.Data.Constraints (EnvConstraints)-import qualified Hix.Managed.Data.EnvConfig-import Hix.Managed.Data.EnvConfig (EnvConfig (EnvConfig))-import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto)-import Hix.Managed.Data.Packages (Packages)-import Hix.Managed.Data.ProjectContext (ProjectContext)-import qualified Hix.Managed.Data.ProjectContextProto as ProjectContextProto-import Hix.Managed.Data.ProjectContextProto (ProjectContextProto (..))-import Hix.Managed.Data.ProjectResult (ProjectResult)-import Hix.Managed.Data.ProjectStateProto (ProjectStateProto)-import Hix.Managed.Data.StageState (BuildStatus (Failure), resultFromStatus)-import qualified Hix.Managed.Handlers.Build as BuildHandlers-import Hix.Managed.Handlers.Build (BuildHandlers (..))-import qualified Hix.Managed.Handlers.Build.Test as BuildHandlers-import qualified Hix.Managed.Handlers.Report.Prod as ReportHandlers-import Hix.Managed.ProjectContext (withProjectContext)-import Hix.Test.Utils (runMLogTest, runMTest)--data TestParams =- TestParams {- envs :: [(EnvName, [LocalPackage])],- cabalLog :: Bool,- log :: Bool,- debug :: Bool,- packages :: Packages ManagedPackageProto,- ghcPackages :: GhcPackages,- state :: ProjectStateProto,- projectOptions :: ProjectOptions,- build :: Versions -> M BuildStatus- }--nosortOptions :: ProjectOptions-nosortOptions = def {ProjectOptions.build = def {toposortMutations = False}}--testParams ::- Bool ->- Packages ManagedPackageProto ->- TestParams-testParams debug packages =- TestParams {- envs = [],- cabalLog = False,- log = False,- debug,- packages,- ghcPackages = GhcPackages {installed = [], available = []},- state = def,- projectOptions = nosortOptions,- build = const (pure Failure)- }--data Result a =- Result {- stateFile :: Expr,- cabalLog :: [(EnvConstraints, Maybe SolverPlan)],- log :: [Text],- result :: a- }--testProjectContext ::- EnvName ->- TestParams ->- ProjectContextProto-testProjectContext defaultEnvName params =- ProjectContextProto {- ProjectContextProto.packages = params.packages,- state = params.state,- envs = nFromList (second mkEnv <$> maybe defaultEnv toList (nonEmpty params.envs)),- buildOutputsPrefix = Nothing- }- where- mkEnv targets = EnvConfig {targets, ghc = GhcDbSynthetic params.ghcPackages}-- defaultEnv = [(defaultEnvName, nKeys params.packages)]--managedTest' ::- EnvName ->- TestParams ->- (BuildHandlers -> ProjectOptions -> ProjectContextProto -> M a) ->- TestT IO (Result a)-managedTest' defaultEnvName params main =- withFrozenCallStack do- (handlers0, stateFileRef, _) <-- BuildHandlers.handlersUnitTest params.ghcPackages (fmap resultFromStatus . params.build)- (cabalRef, handlers1) <-- if params.cabalLog- then first Just <$> BuildHandlers.logCabal handlers0- else pure (Nothing, handlers0)- let- handlers =- if params.log- then handlers1 {report = ReportHandlers.handlersProd}- else handlers1- (log, e_result) <- liftIO (runner (main handlers params.projectOptions context))- result <- evalEither e_result- stateFile <- evalMaybe . head =<< liftIO (readIORef stateFileRef)- cabalLog <- fold <$> for cabalRef \ ref -> reverse <$> liftIO (readIORef ref)- pure Result {..}- where- runner | params.log = runMLogTest params.debug (not params.debug)- | otherwise = fmap ([],) . runMTest params.debug-- context = testProjectContext defaultEnvName params--managedTest ::- EnvName ->- TestParams ->- (BuildHandlers -> ProjectContext -> M ProjectResult) ->- TestT IO (Result ())-managedTest defaultEnvName params main =- withFrozenCallStack do- managedTest' defaultEnvName params \ handlers options context ->- withProjectContext handlers options context (main handlers)--lowerTest ::- TestParams ->- (BuildHandlers -> ProjectContext -> M ProjectResult) ->- TestT IO (Result ())-lowerTest params main =- withFrozenCallStack do- managedTest "lower" params main--bumpTest ::- TestParams ->- (BuildHandlers -> ProjectContext -> M ProjectResult) ->- TestT IO (Result ())-bumpTest params main =- withFrozenCallStack do- managedTest "latest" params main
− test/Hix/Test/Managed/SolveTest.hs
@@ -1,52 +0,0 @@-module Hix.Test.Managed.SolveTest where--import qualified Data.Set as Set-import Hedgehog (evalEither)--import Hix.Class.Map (nKeys)-import qualified Hix.Managed.Cabal.Changes-import Hix.Managed.Cabal.Changes (solverPlan)-import Hix.Managed.Cabal.Data.Config (GhcDb (GhcDbSystem))-import Hix.Managed.Cabal.Data.SolverState (solverState)-import qualified Hix.Managed.Cabal.Resources as SolveResources-import Hix.Managed.Cabal.Solve (solveWithCabal')-import Hix.Managed.Cabal.Sort (sortDeps)-import Hix.Managed.Data.EnvContext (EnvDeps (EnvDeps))-import Hix.Managed.Data.Mutable (unsafeMutableDep)-import Hix.Pretty (prettyL, showP, showPL)-import Hix.Test.Managed.UnsafeIsString ()-import Hix.Test.Utils (UnitTest, runMTest)--test_solve :: UnitTest-test_solve =- evalEither =<< liftIO do- runMTest True do- res <- SolveResources.acquire mempty def (GhcDbSystem Nothing)- mb_sip <- solveWithCabal' res state- sorted <- sortDeps res id (nKeys constraints)- liftIO do- putStrLn ""- putStrLn "Constraints:"- putStrLn (showP constraints)- for_ mb_sip \ sip -> do- let plan = solverPlan sip- putStrLn ""- putStrLn "Changes:"- putStrLn (show (prettyL plan.changes))- putStrLn ""- putStrLn "Matching DB:"- putStrLn (show (prettyL plan.matching))- putStrLn ""- putStrLn "Sorted:"- putStrLn (showPL sorted)- where- state = solverState [] (EnvDeps (Set.fromList (unsafeMutableDep <$> nKeys constraints)) mempty) constraints def- constraints =- [- ("ansi-terminal", mempty),- ("async", mempty),- ("polysemy-conc", mempty),- ("polysemy-time", mempty),- ("stm", mempty),- ("time", mempty)- ]
+ test/Hix/Test/Managed/TagTest.hs view
@@ -0,0 +1,58 @@+module Hix.Test.Managed.TagTest where++import Distribution.Parsec (eitherParsec)+import Hedgehog ((===))+import Test.Tasty (TestTree, testGroup)++import Hix.Managed.Git (Tag (..))+import Hix.Managed.Maint.Prep (TagPrio (..))+import Hix.Test.Utils (UnitTest, unitTest)++test_parseTag :: UnitTest+test_parseTag = do+ Right (Tag (Just "pack") [1, 2, 3]) === eitherParsec "pack-1.2.3"+ Right (Tag Nothing [1, 2, 3]) === eitherParsec "1.2.3"++test_ordTag :: UnitTest+test_ordTag =+ target === sortOn TagPrio input+ where+ target =+ [+ t p0 v1,+ t p1 v1,+ t p2 v1,+ t p0 v2,+ t p1 v2,+ t p2 v2,+ t p0 v3,+ t p2 v3+ ]++ input =+ [+ t p2 v3,+ t p2 v1,+ t p0 v3,+ t p1 v2,+ t p0 v1,+ t p2 v2,+ t p0 v2,+ t p1 v1+ ]++ t package version = Tag {package, version}++ p0 = Nothing+ p1 = Just "p1"+ p2 = Just "p2"+ v1 = "1.0.0"+ v2 = "1.1.0"+ v3 = "2.0.0"++test_tag :: TestTree+test_tag =+ testGroup "git tags" [+ unitTest "parse" test_parseTag,+ unitTest "order" test_ordTag+ ]
− test/Hix/Test/Managed/UnsafeIsString.hs
@@ -1,81 +0,0 @@-{-# options_ghc -Wno-orphans #-}--module Hix.Test.Managed.UnsafeIsString where--import Distribution.Version (VersionRange)-import Exon (exon)-import GHC.Exts (IsList (Item, fromList, toList))--import Hix.CabalParsec (unsafeParsec)-import qualified Hix.Data.Dep-import qualified Hix.Data.Dep as Dep-import Hix.Data.Dep (Dep (Dep))-import qualified Hix.Data.Overrides-import Hix.Data.Overrides (Override (Override))-import qualified Hix.Data.PackageId as PackageId-import Hix.Data.PackageId (PackageId (PackageId))-import Hix.Data.PackageName (PackageName)-import Hix.Data.Version (SourceHash (SourceHash), Version)-import qualified Hix.Data.VersionBounds-import Hix.Data.VersionBounds (VersionBounds (VersionBounds), fromLower, unsafeVersionBoundsFromRange, versionBounds)-import Hix.Managed.Cabal.Data.SourcePackage (SourcePackageId (..))-import Hix.Managed.Data.Constraints (MutationConstraints (mutation))-import Hix.Managed.Data.Mutable (MutableDep, unsafeMutableDep)-import qualified Hix.Managed.Data.MutableId-import Hix.Managed.Data.MutableId (MutableId (MutableId))-import Hix.Pretty (showP)--instance IsString Version where- fromString = unsafeParsec--instance IsString VersionRange where- fromString = unsafeParsec--instance IsString VersionBounds where- fromString =- unsafeVersionBoundsFromRange . fromString--instance IsList VersionBounds where- type Item VersionBounds = Version-- fromList = \case- [] -> VersionBounds {lower = Nothing, upper = Nothing}- [lower] -> fromLower lower- [lower, upper] -> versionBounds lower upper- l -> error [exon|IsList VersionBounds: not two elements or fewer: #{show l}|]-- toList VersionBounds {lower, upper} = maybeToList lower ++ maybeToList upper--instance IsString MutableDep where- fromString = unsafeMutableDep . fromString--instance IsString PackageId where- fromString = PackageId.fromCabal . unsafeParsec--instance IsString MutableId where- fromString s =- MutableId {name = unsafeMutableDep name, version}- where- PackageId {name, version} = fromString s--instance IsString Dep where- fromString = Dep.fromCabal . unsafeParsec--instance IsString Override where- fromString s =- Override {hash = SourceHash (showP package), version = package.version}- where- package = fromString @PackageId s--instance IsString (PackageName, MutationConstraints) where- fromString s =- (package, mempty {mutation = unsafeVersionBoundsFromRange version})- where- Dep {package, version} = fromString s--instance IsList SourcePackageId where- type Item SourcePackageId = Dep-- fromList s = SourcePackageId {deps = fromList s, description = Nothing}-- toList = (.deps)
test/Hix/Test/ManagedTest.hs view
@@ -6,6 +6,7 @@ import Hix.Test.Managed.Bump.CandidatesTest (test_candidatesBump) import Hix.Test.Managed.Bump.MutationTest (test_bumpMutation) import Hix.Test.Managed.DiffTest (test_diff)+import Hix.Test.Managed.HackageTest (test_hackageData) import Hix.Test.Managed.LowerAuto.MutationOptimizeTest (test_lowerAutoMutationOptimize) import Hix.Test.Managed.LowerAuto.MutationStabilizeTest (test_lowerAutoMutationStabilize) import Hix.Test.Managed.LowerInit.MutationTest (test_lowerInitMutation)@@ -15,6 +16,8 @@ import Hix.Test.Managed.LowerOptimize.OrderTest (test_mutationOrder) import Hix.Test.Managed.LowerStabilize.MutationTest (test_lowerStabilizeMutation) import Hix.Test.Managed.ProjectContextProtoTest (test_parseProjectContextProto)+import Hix.Test.Managed.ReleaseMaintenanceTest (test_maint)+import Hix.Test.Managed.TagTest (test_tag) import Hix.Test.Utils (unitTest) test_managed :: TestTree@@ -35,5 +38,8 @@ ], unitTest "parse ProjectContext" test_parseProjectContextProto, test_buildOutput,- test_diff+ test_diff,+ test_maint,+ test_tag,+ test_hackageData ]
test/Hix/Test/NewTest.hs view
@@ -5,15 +5,28 @@ import Path (absdir, relfile) import qualified Hix.Data.NewProjectConfig-import Hix.Data.NewProjectConfig (HixUrl, NewProjectConfig (NewProjectConfig))+import Hix.Data.NewProjectConfig (+ CreateProjectConfig (CreateProjectConfig),+ HixUrl,+ InitProjectConfig (InitProjectConfig),+ ) import Hix.Data.ProjectFile (ProjectFile (ProjectFile)) import Hix.Monad (runM) import Hix.New (license, newProjectFiles) import Hix.Test.Utils (UnitTest) -conf :: NewProjectConfig+conf :: InitProjectConfig conf =- NewProjectConfig {name = "spider", packages = False, hixUrl = def, author = "Me"}+ InitProjectConfig {+ name = "spider",+ config = CreateProjectConfig {+ packages = False,+ hixUrl = def,+ author = "Me",+ noInitGitAndFlake = True,+ devCli = False+ }+ } flake :: Text flake =
− test/Hix/Test/Utils.hs
@@ -1,42 +0,0 @@-module Hix.Test.Utils where--import Hedgehog (TestT, property, test, withTests)-import Path (Abs, Dir, Path, absdir)-import Test.Tasty (TestName, TestTree)-import Test.Tasty.Hedgehog (testProperty)--import qualified Hix.Console as Console-import Hix.Data.Error (Error)-import Hix.Data.GlobalOptions (GlobalOptions (debug, quiet, verbose), defaultGlobalOptions)-import Hix.Monad (M, runMLoggerWith, runMWith, withLogIORef)-import Hix.Test.Managed.UnsafeIsString ()--type UnitTest = TestT IO ()--unitTest ::- HasCallStack =>- TestName ->- TestT IO () ->- TestTree-unitTest desc t =- withFrozenCallStack do- testProperty desc (withTests 1 (property (test t)))--testRoot :: Path Abs Dir-testRoot = [absdir|/project|]--runMTest :: Bool -> M a -> IO (Either Error a)-runMTest debug =- runMWith (defaultGlobalOptions testRoot) {verbose = debug, debug, quiet = not debug}--runMLogTest :: Bool -> Bool -> M a -> IO ([Text], Either Error a)-runMLogTest debug onlyRef ma =- withLogIORef \ logger -> do- let- fullLogger | onlyRef = logger- | otherwise = \ level msg -> do- logger level msg- Console.err msg- runMLoggerWith fullLogger opts ma- where- opts = (defaultGlobalOptions testRoot) {verbose = debug, debug}
test/Main.hs view
@@ -42,5 +42,4 @@ ] main :: IO ()-main =- defaultMain tests+main = defaultMain tests
+ testing/Hix/Test/Hedgehog.hs view
@@ -0,0 +1,71 @@+module Hix.Test.Hedgehog where++import Data.List.Extra (takeEnd, zipWithLongest)+import qualified Data.Text as Text+import Hedgehog (TestT, evalEither, (===))++eqLines ::+ ∀ m .+ Monad m =>+ HasCallStack =>+ Text ->+ Text ->+ TestT m ()+eqLines l r =+ withFrozenCallStack do+ take common linesL === take common linesR+ if ll > lr+ then trailing "missing lines: " linesL+ else if lr > ll+ then trailing "extra lines: " linesR+ else unit+ where+ trailing desc ls = fail (toString (desc <> Text.unlines (drop common ls)))+ common = min ll lr+ ll = length linesL+ lr = length linesR+ linesL = Text.lines l+ linesR = Text.lines r++assertRight ::+ ∀ a m e .+ Eq a =>+ Show e =>+ Show a =>+ Monad m =>+ HasCallStack =>+ a ->+ Either e a ->+ TestT m ()+assertRight a =+ withFrozenCallStack do+ (===) a <=< evalEither++listEqZip ::+ ∀ m a .+ Monad m =>+ HasCallStack =>+ Eq a =>+ Show a =>+ [a] ->+ [a] ->+ TestT m ()+listEqZip target actual =+ withFrozenCallStack do+ for_ (zip [0 :: Natural ..] (zipWithLongest (,) target actual)) \case+ (i, (Just t, Just l)) -> (i, t) === (i, l)+ _ | [] <- actual -> fail "Result list is empty."+ _ -> target === actual++listEqTail ::+ ∀ m a .+ Monad m =>+ HasCallStack =>+ Eq a =>+ Show a =>+ [a] ->+ [a] ->+ TestT m ()+listEqTail target actual =+ withFrozenCallStack do+ target === takeEnd (length target) actual
+ testing/Hix/Test/Managed/Run.hs view
@@ -0,0 +1,147 @@+module Hix.Test.Managed.Run where++import Data.IORef (readIORef)+import Hedgehog (TestT, evalMaybe)++import Hix.Class.Map (nFromList, nKeys)+import Hix.Data.EnvName (EnvName)+import Hix.Data.Monad (LogLevel (..), M)+import Hix.Data.NixExpr (Expr)+import qualified Hix.Data.Options as ProjectOptions+import Hix.Data.Options (ProjectOptions)+import Hix.Data.PackageName (LocalPackage)+import Hix.Data.Version (Versions)+import Hix.Managed.Cabal.Changes (SolverPlan)+import Hix.Managed.Cabal.Data.Config (GhcDb (GhcDbSynthetic))+import qualified Hix.Managed.Cabal.Data.Packages+import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages))+import Hix.Managed.Data.BuildConfig (BuildConfig (toposortMutations))+import Hix.Managed.Data.Constraints (EnvConstraints)+import qualified Hix.Managed.Data.EnvConfig+import Hix.Managed.Data.EnvConfig (EnvConfig (EnvConfig))+import Hix.Managed.Data.ManagedPackage (ProjectPackages)+import Hix.Managed.Data.ProjectContext (ProjectContext)+import qualified Hix.Managed.Data.ProjectContextProto as ProjectContextProto+import Hix.Managed.Data.ProjectContextProto (ProjectContextProto (..))+import Hix.Managed.Data.ProjectResult (ProjectResult)+import Hix.Managed.Data.ProjectStateProto (ProjectStateProto)+import Hix.Managed.Data.StageState (BuildStatus (Failure), resultFromStatus)+import qualified Hix.Managed.Handlers.Build as BuildHandlers+import Hix.Managed.Handlers.Build (BuildHandlers (..))+import qualified Hix.Managed.Handlers.Build.Test as BuildHandlers+import Hix.Managed.Handlers.Project (ProjectHandlers (..))+import qualified Hix.Managed.Handlers.Report.Prod as ReportHandlers+import Hix.Managed.ProjectContext (processProjectResult, withProjectContext)+import Hix.Test.Run (LogConfig (..))+import Hix.Test.Utils (runMLogTest, runMTestLog)++data TestParams =+ TestParams {+ envs :: [(EnvName, [LocalPackage])],+ cabalLog :: Bool,+ log :: Bool,+ logConfig :: LogConfig,+ packages :: ProjectPackages,+ ghcPackages :: GhcPackages,+ state :: ProjectStateProto,+ projectOptions :: ProjectOptions,+ build :: Versions -> M BuildStatus+ }++nosortOptions :: ProjectOptions+nosortOptions = def {ProjectOptions.build = def {toposortMutations = False}}++testParams ::+ Bool ->+ ProjectPackages ->+ TestParams+testParams debug packages =+ TestParams {+ envs = [],+ cabalLog = False,+ log = False,+ logConfig = def {logLevel = if debug then LogDebug else LogError, onlyRef = not debug},+ packages,+ ghcPackages = GhcPackages {installed = [], available = []},+ state = def,+ projectOptions = nosortOptions,+ build = const (pure Failure)+ }++data Result a =+ Result {+ stateFile :: Expr,+ cabalLog :: [(EnvConstraints, Maybe SolverPlan)],+ log :: [Text],+ result :: a+ }++testProjectContext ::+ EnvName ->+ TestParams ->+ ProjectContextProto+testProjectContext defaultEnvName params =+ ProjectContextProto {+ ProjectContextProto.packages = params.packages,+ state = params.state,+ envs = nFromList (second mkEnv <$> maybe defaultEnv toList (nonEmpty params.envs)),+ hackage = []+ }+ where+ mkEnv targets = EnvConfig {targets, ghc = Just (GhcDbSynthetic params.ghcPackages)}++ defaultEnv = [(defaultEnvName, nKeys params.packages)]++managedTest' ::+ EnvName ->+ TestParams ->+ (BuildHandlers -> ProjectOptions -> ProjectContextProto -> M a) ->+ TestT IO (Result a)+managedTest' defaultEnvName params main =+ withFrozenCallStack do+ (handlers0, stateFileRef, _) <-+ BuildHandlers.handlersUnitTest params.ghcPackages (fmap resultFromStatus . params.build)+ (cabalRef, handlers1) <-+ if params.cabalLog+ then first Just <$> BuildHandlers.logCabal handlers0+ else pure (Nothing, handlers0)+ let+ handlers =+ if params.log+ then handlers1 {project = handlers1.project {report = ReportHandlers.handlersProd}}+ else handlers1+ (log, result) <- runner (main handlers params.projectOptions context)+ stateFile <- evalMaybe . head =<< liftIO (readIORef stateFileRef)+ cabalLog <- fold <$> for cabalRef \ ref -> reverse <$> liftIO (readIORef ref)+ pure Result {..}+ where+ runner | params.log = runMLogTest params.logConfig+ | otherwise = fmap ([],) . runMTestLog params.logConfig++ context = testProjectContext defaultEnvName params++managedTest ::+ EnvName ->+ TestParams ->+ (BuildHandlers -> ProjectContext -> M ProjectResult) ->+ TestT IO (Result ())+managedTest defaultEnvName params main =+ withFrozenCallStack do+ managedTest' defaultEnvName params \ handlers options context ->+ processProjectResult =<< withProjectContext handlers.project options context (main handlers)++lowerTest ::+ TestParams ->+ (BuildHandlers -> ProjectContext -> M ProjectResult) ->+ TestT IO (Result ())+lowerTest params main =+ withFrozenCallStack do+ managedTest "lower" params main++bumpTest ::+ TestParams ->+ (BuildHandlers -> ProjectContext -> M ProjectResult) ->+ TestT IO (Result ())+bumpTest params main =+ withFrozenCallStack do+ managedTest "latest" params main
+ testing/Hix/Test/Managed/UnsafeIsString.hs view
@@ -0,0 +1,83 @@+{-# options_ghc -Wno-orphans #-}++module Hix.Test.Managed.UnsafeIsString where++import Distribution.Simple (Dependency)+import Distribution.Version (VersionRange)+import Exon (exon)+import GHC.Exts (IsList (Item, fromList, toList))++import Hix.CabalParsec (unsafeParsec)+import qualified Hix.Data.Dep+import Hix.Data.Dep (Dep (Dep), unsafeDep)+import Hix.Data.Overrides (Override, override)+import qualified Hix.Data.PackageId as PackageId+import Hix.Data.PackageId (PackageId (PackageId))+import Hix.Data.PackageName (PackageName)+import Hix.Data.Version (SourceHash (SourceHash), Version)+import qualified Hix.Data.VersionBounds+import Hix.Data.VersionBounds (VersionBounds (VersionBounds), fromLower, unsafeVersionBoundsFromRange, versionBounds)+import Hix.Managed.Cabal.Data.SourcePackage (SourcePackageId (..))+import Hix.Managed.Data.Constraints (MutationConstraints (mutation))+import Hix.Managed.Data.Mutable (MutableDep, unsafeMutableDep)+import qualified Hix.Managed.Data.MutableId+import Hix.Managed.Data.MutableId (MutableId (MutableId))+import Hix.Pretty (showP)++instance IsString Version where+ fromString = unsafeParsec++instance IsString VersionRange where+ fromString = unsafeParsec++instance IsString VersionBounds where+ fromString =+ unsafeVersionBoundsFromRange . fromString++instance IsList VersionBounds where+ type Item VersionBounds = Version++ fromList = \case+ [] -> VersionBounds {lower = Nothing, upper = Nothing}+ [lower] -> fromLower lower+ [lower, upper] -> versionBounds lower upper+ l -> error [exon|IsList VersionBounds: not two elements or fewer: #{show l}|]++ toList VersionBounds {lower, upper} = maybeToList lower ++ maybeToList upper++instance IsString MutableDep where+ fromString = unsafeMutableDep . fromString++instance IsString PackageId where+ fromString = PackageId.fromCabal . unsafeParsec++instance IsString MutableId where+ fromString s =+ MutableId {name = unsafeMutableDep name, version}+ where+ PackageId {name, version} = fromString s++instance IsString Dep where+ fromString = unsafeDep++instance IsString Dependency where+ fromString = unsafeParsec++instance IsString Override where+ fromString s =+ override package.version (SourceHash (showP package))+ where+ package = fromString @PackageId s++instance IsString (PackageName, MutationConstraints) where+ fromString s =+ (package, mempty {mutation = unsafeVersionBoundsFromRange version})+ where+ Dep {package, version} = fromString s++instance IsList SourcePackageId where+ type Item SourcePackageId = Dep++ fromList s = SourcePackageId {deps = fromList s, description = Nothing}++ toList = (.deps)
+ testing/Hix/Test/Run.hs view
@@ -0,0 +1,62 @@+module Hix.Test.Run where++import Path (Abs, Dir, Path, SomeBase (Abs), absdir, reldir, (</>))+import Path.IO (createDirIfMissing, withSystemTempDir)++import qualified Hix.Console as Console+import Hix.Data.Error (Error)+import qualified Hix.Data.GlobalOptions as GlobalOptions+import Hix.Data.GlobalOptions (GlobalOptions, defaultGlobalOptions)+import Hix.Data.LogLevel (LogLevel (..))+import Hix.Data.PathSpec (PathSpec (PathConcrete))+import Hix.Monad (M, runMLoggerWith, runMWith, withLogIORef)++data LogConfig =+ LogConfig {+ logLevel :: LogLevel,+ refLevel :: LogLevel,+ onlyRef :: Bool+ }+ deriving stock (Eq, Show)++instance Default LogConfig where+ def = LogConfig {logLevel = LogError, refLevel = LogInfo, onlyRef = True}++logConfigDebug :: LogConfig+logConfigDebug = def {logLevel = LogDebug}++logConfigTrace :: LogConfig+logConfigTrace = def {logLevel = LogTrace}++testRoot :: Path Abs Dir+testRoot = [absdir|/project|]++withTestDir :: (GlobalOptions -> IO a) -> IO a+withTestDir prog =+ withSystemTempDir "hix-test" \ cwd -> do+ let root = cwd </> [reldir|project|]+ createDirIfMissing False root+ prog (defaultGlobalOptions cwd) {GlobalOptions.root = PathConcrete $ Abs root}++runMTestDir :: LogConfig -> M a -> IO (Either Error a)+runMTestDir LogConfig {logLevel} prog =+ withTestDir \ options ->+ runMWith options {GlobalOptions.logLevel} prog++runMTestDirWith :: (GlobalOptions -> GlobalOptions) -> M a -> IO (Either Error a)+runMTestDirWith f prog =+ withTestDir \ options ->+ runMWith (f options) prog++runMLogTestDir :: LogConfig -> M a -> IO ([Text], Either Error a)+runMLogTestDir LogConfig {..} ma =+ withLogIORef \ logger ->+ withTestDir \ options ->+ runMLoggerWith (fullLogger logger) options {GlobalOptions.logLevel = max logLevel refLevel} ma+ where+ fullLogger logger | onlyRef = logger+ | otherwise = \ level msg -> do+ when (level <= refLevel) do+ logger level msg+ when (level <= logLevel) do+ Console.err msg
+ testing/Hix/Test/Utils.hs view
@@ -0,0 +1,56 @@+module Hix.Test.Utils where++import qualified Data.Text.IO as Text+import Hedgehog (TestT, evalEither, property, test, withTests)+import Path (Abs, Dir, File, Path, Rel, parent, toFilePath, (</>))+import Path.IO (createDirIfMissing)+import Test.Tasty (TestName, TestTree)+import Test.Tasty.Hedgehog (testProperty)++import qualified Hix.Data.GlobalOptions as GlobalOptions+import Hix.Data.GlobalOptions (GlobalOptions)+import Hix.Data.LogLevel (LogLevel (..))+import Hix.Data.Monad (M)+import Hix.Test.Managed.UnsafeIsString ()+import Hix.Test.Run (LogConfig (logLevel), runMLogTestDir, runMTestDir, runMTestDirWith)++type UnitTest = TestT IO ()++unitTest ::+ HasCallStack =>+ TestName ->+ TestT IO () ->+ TestTree+unitTest desc t =+ withFrozenCallStack do+ testProperty desc (withTests 1 (property (test t)))++toTestT :: Show e => IO (Either e a) -> TestT IO a+toTestT = evalEither <=< liftIO++runMTestLog :: LogConfig -> M a -> TestT IO a+runMTestLog logConfig ma =+ toTestT (runMTestDir logConfig ma)++runMTestWith :: (GlobalOptions -> GlobalOptions) -> M a -> TestT IO a+runMTestWith f ma =+ toTestT (runMTestDirWith f ma)++runMTest :: Bool -> M a -> TestT IO a+runMTest debug =+ runMTestLog if debug then def {logLevel = LogDebug} else def++runMLogTest :: LogConfig -> M a -> TestT IO ([Text], a)+runMLogTest logConf prog =+ toTestT (sequence <$> runMLogTestDir logConf prog)++runMTestVerboseCabal :: M a -> TestT IO a+runMTestVerboseCabal =+ runMTestWith \ o -> o {GlobalOptions.logLevel = LogDebug, GlobalOptions.cabalVerbose = True}++addFile :: Path Abs Dir -> Path Rel File -> Text -> M ()+addFile root path content = do+ createDirIfMissing True (parent file)+ liftIO (Text.writeFile (toFilePath file) content)+ where+ file = root </> path