diff --git a/hix.cabal b/hix.cabal --- a/hix.cabal +++ b/hix.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: hix -version: 0.6.9 +version: 0.7.0 synopsis: Haskell/Nix development build tools description: See https://hackage.haskell.org/package/hix/docs/Hix.html category: Build @@ -27,29 +27,171 @@ Hix Hix.Bootstrap Hix.Cabal + Hix.CabalParsec + Hix.Class.EncodeNix + Hix.Class.Map + Hix.Class.SOP Hix.Compat Hix.Component + Hix.Console Hix.Data.BootstrapProjectConfig + Hix.Data.Bounds Hix.Data.ComponentConfig + Hix.Data.Dep + Hix.Data.EnvName Hix.Data.Error Hix.Data.GhciConfig Hix.Data.GhciTest + Hix.Data.GlobalOptions + Hix.Data.Json + Hix.Data.Monad Hix.Data.NewProjectConfig + Hix.Data.NixExpr + Hix.Data.Options + Hix.Data.OutputFormat + Hix.Data.OutputTarget + Hix.Data.Overrides + Hix.Data.PackageId + Hix.Data.PackageName Hix.Data.PreprocConfig Hix.Data.ProjectFile + Hix.Data.Version + Hix.Data.VersionBounds Hix.Env + Hix.Error Hix.Ghci + Hix.Hackage Hix.Json + Hix.Log + Hix.Managed.Build + Hix.Managed.Build.Mutation + Hix.Managed.Build.Single + Hix.Managed.Build.Solve + Hix.Managed.BuildOutput + Hix.Managed.BuildOutput.CommitMsg + Hix.Managed.BuildOutput.GithubActionsPr + Hix.Managed.Bump.App + Hix.Managed.Bump.Candidates + Hix.Managed.Bump.Optimize + Hix.Managed.Cabal.Changes + Hix.Managed.Cabal.Config + Hix.Managed.Cabal.Data.Config + Hix.Managed.Cabal.Data.Packages + Hix.Managed.Cabal.Data.SolveResources + Hix.Managed.Cabal.Data.SolverState + Hix.Managed.Cabal.Data.SolveTarget + Hix.Managed.Cabal.Data.SourcePackage + 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.Print + Hix.Managed.Cabal.Repo + Hix.Managed.Cabal.Resources + Hix.Managed.Cabal.Solve + Hix.Managed.Cabal.Targets + Hix.Managed.Constraints + Hix.Managed.Data.BuildConfig + Hix.Managed.Data.BuildOutput + Hix.Managed.Data.Bump + Hix.Managed.Data.Constraints + Hix.Managed.Data.CurrentBuild + Hix.Managed.Data.Diff + Hix.Managed.Data.EnvConfig + Hix.Managed.Data.EnvContext + Hix.Managed.Data.EnvRequest + Hix.Managed.Data.EnvResult + Hix.Managed.Data.Envs + Hix.Managed.Data.EnvState + Hix.Managed.Data.Initial + Hix.Managed.Data.Lower + Hix.Managed.Data.LowerConfig + 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.Packages + Hix.Managed.Data.ProcessState + Hix.Managed.Data.ProjectContext + Hix.Managed.Data.ProjectContextProto + Hix.Managed.Data.ProjectResult + Hix.Managed.Data.ProjectState + Hix.Managed.Data.ProjectStateProto + Hix.Managed.Data.Query + Hix.Managed.Data.QueryDep + Hix.Managed.Data.StageContext + Hix.Managed.Data.StageResult + Hix.Managed.Data.StageState + Hix.Managed.Data.StateFileConfig + Hix.Managed.Data.Targets + Hix.Managed.Diff + Hix.Managed.EnvContext + Hix.Managed.EnvRequest + Hix.Managed.EnvResult + Hix.Managed.Flow + 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.Mutation + Hix.Managed.Handlers.Mutation.Bump + Hix.Managed.Handlers.Mutation.Lower + Hix.Managed.Handlers.Report + Hix.Managed.Handlers.Report.Prod + Hix.Managed.Handlers.Report.Test + Hix.Managed.Handlers.StateFile + Hix.Managed.Handlers.StateFile.Prod + Hix.Managed.Handlers.StateFile.Test + Hix.Managed.Lower.App + Hix.Managed.Lower.Auto + Hix.Managed.Lower.Candidates + Hix.Managed.Lower.Data.LowerMode + Hix.Managed.Lower.Init + Hix.Managed.Lower.Optimize + Hix.Managed.Lower.Stabilize + 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.Report + Hix.Managed.StageContext + Hix.Managed.StageResult + Hix.Managed.StageState + Hix.Managed.StateFile + Hix.Managed.UpdateState + Hix.Maybe Hix.Monad Hix.New + Hix.NixExpr Hix.Options Hix.Optparse + Hix.Orphans.Version + Hix.OutputWriter Hix.Path Hix.Prelude Hix.Preproc + Hix.Pretty + Hix.These + Hix.Trace + Hix.Version + Hix.Zip hs-source-dirs: lib default-extensions: + StrictData AllowAmbiguousTypes ApplicativeDo BlockArguments @@ -64,6 +206,7 @@ GADTs LambdaCase LiberalTypeSynonyms + MonadComprehensions MultiWayIf OverloadedLabels OverloadedLists @@ -89,19 +232,32 @@ Cabal , aeson >=2.0 && <2.2 , base ==4.* + , bytestring + , cabal-install + , cabal-install-solver , casing >=0.1.4 && <0.2 + , containers + , exceptions ==0.10.* , exon >=1.4 && <1.7 , extra ==1.7.* , filepattern ==0.1.* , generic-lens ==2.2.* + , generics-sop ==0.5.* + , http-client ==0.7.* + , http-client-tls ==0.3.* + , http-types ==0.12.* , incipit-base ==0.5.* , lens >=5.1 && <5.3 , lens-regex-pcre ==1.1.* - , optparse-applicative ==0.17.* + , optparse-applicative >=0.17 && <0.19 , path ==0.9.* , path-io >=1.7 && <1.9 + , pretty , random ==1.2.* + , these ==1.2.* + , time , transformers + , typed-process ==0.2.* , unix mixins: base hiding (Prelude) @@ -114,6 +270,7 @@ hs-source-dirs: app default-extensions: + StrictData AllowAmbiguousTypes ApplicativeDo BlockArguments @@ -128,6 +285,7 @@ GADTs LambdaCase LiberalTypeSynonyms + MonadComprehensions MultiWayIf OverloadedLabels OverloadedLists @@ -164,14 +322,34 @@ main-is: Main.hs other-modules: Hix.Test.BootstrapTest + Hix.Test.BoundsTest Hix.Test.CabalFile Hix.Test.CabalTest Hix.Test.GhciTest + Hix.Test.Hedgehog + Hix.Test.Managed.BuildOutputTest + Hix.Test.Managed.Bump.CandidatesTest + Hix.Test.Managed.Bump.MutationTest + Hix.Test.Managed.DiffTest + Hix.Test.Managed.LowerAuto.MutationOptimizeTest + Hix.Test.Managed.LowerAuto.MutationStabilizeTest + Hix.Test.Managed.LowerInit.MutationTest + Hix.Test.Managed.LowerNativeTest + Hix.Test.Managed.LowerOptimize.CandidatesTest + Hix.Test.Managed.LowerOptimize.MutationTest + Hix.Test.Managed.LowerStabilize.MutationTest + Hix.Test.Managed.ProjectContextProtoTest + Hix.Test.Managed.Run + Hix.Test.Managed.UnsafeIsString + Hix.Test.ManagedTest Hix.Test.NewTest Hix.Test.PreprocTest + Hix.Test.Utils + Hix.Test.VersionTest hs-source-dirs: test default-extensions: + StrictData AllowAmbiguousTypes ApplicativeDo BlockArguments @@ -186,6 +364,7 @@ GADTs LambdaCase LiberalTypeSynonyms + MonadComprehensions MultiWayIf OverloadedLabels OverloadedLists @@ -209,15 +388,18 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Widentities -Wincomplete-uni-patterns -Wmissing-deriving-strategies -Wredundant-constraints -Wunused-type-patterns -Wunused-packages build-depends: Cabal + , aeson >=2.0 && <2.2 , base ==4.* , exon >=1.4 && <1.7 - , hedgehog >=1.1 && <1.3 + , extra ==1.7.* + , hedgehog >=1.1 && <1.5 , hix , incipit-base ==0.5.* , path ==0.9.* , path-io >=1.7 && <1.9 , tasty ==1.4.* , tasty-hedgehog >=1.3 && <1.5 + , these ==1.2.* , transformers mixins: base hiding (Prelude) diff --git a/lib/Hix.hs b/lib/Hix.hs --- a/lib/Hix.hs +++ b/lib/Hix.hs @@ -1,26 +1,33 @@ module Hix where import Hix.Bootstrap (bootstrapProject) -import Hix.Data.Error ( +import qualified Hix.Console as Console +import Hix.Console (errorMessage) +import qualified Hix.Data.GlobalOptions +import Hix.Data.GlobalOptions (GlobalOptions (GlobalOptions)) +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.Env (printEnvRunner) import Hix.Ghci (printGhciCmdline, printGhcidCmdline) -import Hix.Monad (M, runM) +import Hix.Managed.Bump.App (bumpCli) +import Hix.Managed.Lower.App (lowerAutoCli, lowerInitCli, lowerOptimizeCli, lowerStabilizeCli) +import Hix.Monad (M, runMWith) import Hix.New (newProject) -import qualified Hix.Options as Options -import Hix.Options ( - Command (BootstrapCmd, EnvRunner, GhciCmd, GhcidCmd, NewCmd, Preproc), - GlobalOptions (GlobalOptions), - Options (Options), - parseCli, - ) +import Hix.Options (parseCli) import Hix.Preproc (preprocess) handleError :: @@ -34,9 +41,10 @@ GhciError err -> printGhciError err NewError err -> printNewError err BootstrapError err -> printBootstrapError err - NoMatch msg | fromMaybe False verbose -> printPreprocError msg + NoMatch msg | verbose -> printPreprocError msg NoMatch _ -> unit Fatal err -> printFatalError err + Client err -> Console.err (errorMessage err) runCommand :: Command -> M () runCommand = \case @@ -46,8 +54,14 @@ 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 main :: IO () main = do Options global cmd <- parseCli - leftA (handleError global) =<< runM global.cwd (runCommand cmd) + leftA (printError global.verbose) =<< runMWith global (runCommand cmd) diff --git a/lib/Hix/Bootstrap.hs b/lib/Hix/Bootstrap.hs --- a/lib/Hix/Bootstrap.hs +++ b/lib/Hix/Bootstrap.hs @@ -2,7 +2,6 @@ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ask) -import Data.List.NonEmpty ((<|)) import qualified Data.Text as Text import Distribution.Compiler (PerCompilerFlavor (PerCompilerFlavor)) import qualified Distribution.PackageDescription as Cabal @@ -16,10 +15,9 @@ unPackageName, unUnqualComponentName, ) -import Distribution.Pretty (Pretty, pretty) +import Distribution.Pretty (pretty) import Distribution.Simple (Dependency (Dependency), depVerRange) import Distribution.Types.PackageDescription (license) -import Distribution.Utils.ShortText (ShortText, fromShortText) import qualified Distribution.Verbosity as Cabal import Exon (exon) import Path (Abs, Dir, File, Path, Rel, parent, parseRelFile, relfile, toFilePath, ()) @@ -28,42 +26,19 @@ import Hix.Compat (readGenericPackageDescription) import qualified Hix.Data.BootstrapProjectConfig import Hix.Data.BootstrapProjectConfig (BootstrapProjectConfig) -import qualified Hix.Data.ComponentConfig -import Hix.Data.ComponentConfig (PackageName (PackageName)) -import Hix.Data.Error (pathText, tryIO) +import qualified Hix.Data.Monad (AppResources (cwd)) +import Hix.Data.Monad (M (M)) import qualified Hix.Data.NewProjectConfig +import Hix.Data.NixExpr (Expr (ExprAttrs, ExprLit, ExprPrefix, ExprString), ExprAttr (ExprAttr, ExprAttrNil)) +import Hix.Data.PackageName (PackageName (PackageName)) import qualified Hix.Data.ProjectFile import Hix.Data.ProjectFile (ProjectFile (ProjectFile), createFile) -import qualified Hix.Monad -import Hix.Monad (Env (Env), M, noteBootstrap) +import Hix.Error (pathText, tryIO) +import Hix.Monad (AppResources (AppResources), noteBootstrap) +import Hix.NixExpr (mkAttrs, multi, multiOrSingle, nonEmptyAttrs, renderRootExpr, single, singleOpt) import qualified Hix.Prelude import Hix.Prelude (Prelude, findPrelude) -data ExprAttr = - ExprAttr { - name :: Text, - value :: Expr - } - | - ExprAttrNil - deriving stock (Eq, Show, Generic) - -data Expr = - ExprString Text - | - ExprLit Text - | - ExprList [Expr] - | - ExprAttrs [ExprAttr] - | - ExprPrefix Text Expr - deriving stock (Eq, Show, Generic) - -exprStrings :: [Text] -> Expr -exprStrings = - ExprList . fmap ExprString - data CabalInfo = CabalInfo { path :: Path Rel Dir, @@ -107,45 +82,6 @@ } deriving stock (Eq, Show, Generic) -indent :: - Functor t => - Int -> - t Text -> - t Text -indent n = - fmap (Text.replicate n " " <>) - -withSemicolon :: NonEmpty Text -> NonEmpty Text -withSemicolon = \case - e :| [] -> - [e <> ";"] - h :| h1 : t -> h <| withSemicolon (h1 :| t) - -renderAttrs :: Int -> [ExprAttr] -> [Text] -renderAttrs ind attrs = - attrs >>= \case - ExprAttr k v -> - case renderExpr ind v of - e :| [] -> [[exon|#{k} = #{e};|]] - h :| (h1 : t) -> [exon|#{k} = #{h}|] : toList (withSemicolon (h1 :| t)) - ExprAttrNil -> - [] - -renderExpr :: Int -> Expr -> NonEmpty Text -renderExpr ind = \case - ExprString s -> indent ind [[exon|"#{Text.replace "\"" "\\\"" s}"|]] - ExprLit e -> [e] - ExprList l -> "[" :| (indent (ind + 2) (toList . renderExpr ind =<< l)) ++ ["]"] - ExprAttrs a -> case renderAttrs ind a of - [] -> ["{}"] - as -> "{" :| indent (ind + 2) as ++ ["}"] - ExprPrefix p (renderExpr ind -> h :| t) -> - [exon|#{p} #{h}|] :| t - -renderRootExpr :: Expr -> Text -renderRootExpr = - Text.unlines . toList . renderExpr 0 - readCabal :: Path Abs Dir -> Path Rel File -> @@ -156,105 +92,15 @@ where dir = parent path -class RenderCabalOption a where - renderCabalOption :: a -> Text - -instance {-# overlappable #-} Pretty a => RenderCabalOption a where - renderCabalOption = show . pretty - -instance RenderCabalOption ShortText where - renderCabalOption = toText . fromShortText - -instance RenderCabalOption String where - renderCabalOption = toText - -checkEmpty :: - Text -> - Expr -> - ExprAttr -checkEmpty key = \case - ExprString value | Text.null value -> - ExprAttrNil - ExprList value | null value -> - ExprAttrNil - value -> - ExprAttr key value - -singleOpt :: - RenderCabalOption a => - Text -> - (e -> Maybe a) -> - e -> - ExprAttr -singleOpt key get entity = - maybe ExprAttrNil (checkEmpty key . ExprString) (renderCabalOption <$> get entity) - -single :: - RenderCabalOption a => - Text -> - (e -> a) -> - e -> - ExprAttr -single key get = - singleOpt key (Just . get) - -multiOpt :: - RenderCabalOption a => - Text -> - (e -> Maybe [a]) -> - e -> - ExprAttr -multiOpt key get entity = - maybe ExprAttrNil (checkEmpty key . exprStrings) (fmap renderCabalOption <$> get entity) - -multi :: - RenderCabalOption a => - Text -> - (e -> [a]) -> - e -> - ExprAttr -multi key get = - multiOpt key (Just . get) - -multiOrSingle :: - ∀ a e . - RenderCabalOption a => - Text -> - (e -> [a]) -> - e -> - ExprAttr -multiOrSingle key get entity = - check (renderCabalOption <$> get entity) - where - check :: [Text] -> ExprAttr - check [] = ExprAttrNil - check [sing] = ExprAttr key (ExprString sing) - check values = ExprAttr key (exprStrings values) - -mkAttrs :: [e -> ExprAttr] -> e -> [ExprAttr] -mkAttrs a e = - (fmap ($ e) a) - -notNil :: ExprAttr -> Bool -notNil = \case - ExprAttrNil -> False - _ -> True - -nonEmptyAttrs :: Text -> [ExprAttr] -> ExprAttr -nonEmptyAttrs key = - filter notNil >>> \case - [] -> ExprAttrNil - as -> ExprAttr key (ExprAttrs as) - -- TODO extract version and put it in a file knownPackageKeys :: PackageDescription -> [ExprAttr] knownPackageKeys = mkAttrs [ single "author" (.author), - single "build-type" buildType, + single "build-type" (pretty . buildType), single "copyright" (.copyright), - single "license" license, - singleOpt "license-file" (head . licenseFiles), + single "license" (pretty . license), + singleOpt "license-file" (fmap pretty . head . licenseFiles), single "version" (.package.pkgVersion) ] @@ -282,17 +128,17 @@ where vals = mkAttrs [ - multi "dependencies" (const deps), - multi "default-extensions" (.defaultExtensions), - multiOrSingle "source-dirs" (.hsSourceDirs), - singleOpt "language" (.defaultLanguage), - multi "ghc-options" (filter notDefaultGhcOption . ghcFlavour . (.options)), + multi "dependencies" (fmap pretty . const deps), + multi "default-extensions" (fmap pretty . (.defaultExtensions)), + multiOrSingle "source-dirs" (fmap pretty . (.hsSourceDirs)), + singleOpt "language" (fmap pretty . (.defaultLanguage)), + multi "ghc-options" (fmap (ExprString . toText) . filter notDefaultGhcOption . ghcFlavour . (.options)), misc ] info misc e = nonEmptyAttrs "component" (mkAttrs [ - multi "other-modules" (.otherModules) + multi "other-modules" (fmap pretty . (.otherModules)) ] e) (preludeWithVersion, deps) @@ -323,7 +169,7 @@ convertComponent Library lib.libBuildInfo extra where extra = mkAttrs [ - multi "reexported-modules" (.reexportedModules) + multi "reexported-modules" (fmap pretty . (.reexportedModules)) ] lib convertExecutable :: UnqualComponentName -> Cabal.Executable -> HixComponent @@ -373,8 +219,8 @@ preludePackageAttrs p | Just dep <- p.dep = ExprAttrs [ - (ExprAttr "name" (ExprString (toText p.prelude.preludePackage))), - (ExprAttr "version" (ExprString (show (pretty (depVerRange dep))))) + ExprAttr "name" (ExprString (toText p.prelude.preludePackage)), + ExprAttr "version" (ExprString (show (pretty (depVerRange dep)))) ] | otherwise = ExprString (toText p.prelude.preludePackage) key = case special of @@ -388,34 +234,33 @@ flakePackage :: HixPackage -> ExprAttr flakePackage pkg = - ExprAttr name attrs + ExprAttr (coerce pkg.name) attrs where - attrs = ExprAttrs (src : pkg.description : (ExprAttr "cabal" cabalConfig : comps)) - name = pkg.name.unPackageName + attrs = ExprAttrs (src : pkg.description : ExprAttr "cabal" cabalConfig : comps) src = ExprAttr "src" (ExprLit [exon|./#{Text.dropWhileEnd ('/' ==) (pathText pkg.src)}|]) - cabalConfig = ExprAttrs (pkg.known <> (if null pkg.meta then [] else [ExprAttr "meta" (ExprAttrs pkg.meta)])) + cabalConfig = ExprAttrs (pkg.known <> [ExprAttr "meta" (ExprAttrs pkg.meta) | not (null pkg.meta)]) comps = renderComponent <$> pkg.components mainPackage :: [HixPackage] -> ExprAttr mainPackage = \case - pkg : _ : _ -> ExprAttr "main" (ExprString pkg.name.unPackageName) + pkg : _ : _ -> ExprAttr "main" (ExprString (coerce pkg.name)) _ -> ExprAttrNil flake :: BootstrapProjectConfig -> [HixPackage] -> Expr flake conf pkgs = ExprAttrs [ - (ExprAttr "description" (ExprString "A Haskell project")), - (ExprAttr "inputs.hix.url" (ExprString conf.hixUrl.unHixUrl)), - (ExprAttr "outputs" (ExprPrefix "{hix, ...}: hix.lib.flake" (ExprAttrs [ - (ExprAttr "packages" (ExprAttrs (flakePackage <$> pkgs))), + ExprAttr "description" (ExprString "A Haskell project"), + ExprAttr "inputs.hix.url" (ExprString conf.hixUrl.unHixUrl), + ExprAttr "outputs" (ExprPrefix "{hix, ...}: hix.lib.flake" (ExprAttrs [ + ExprAttr "packages" (ExprAttrs (flakePackage <$> pkgs)), mainPackage pkgs - ]))) + ])) ] bootstrapFiles :: BootstrapProjectConfig -> M [ProjectFile] bootstrapFiles conf = do - Env {cwd} <- ask - cabals <- paths =<< lift (tryIO (getDirectoryFilesIgnore (toFilePath cwd) ["**/*.cabal"] ["dist-newstyle/**"])) + AppResources {cwd} <- M ask + cabals <- paths =<< M (lift (tryIO (getDirectoryFilesIgnore (toFilePath cwd) ["**/*.cabal"] ["dist-newstyle/**"]))) pkgs <- fmap convert <$> traverse (readCabal cwd) cabals pure [ ProjectFile {path = [relfile|flake.nix|], content = renderRootExpr (flake conf pkgs)} diff --git a/lib/Hix/Cabal.hs b/lib/Hix/Cabal.hs --- a/lib/Hix/Cabal.hs +++ b/lib/Hix/Cabal.hs @@ -29,7 +29,8 @@ import System.IO.Error (tryIOError) import Hix.Compat (readGenericPackageDescription) -import Hix.Data.Error (Error (..), pathText, sourceError) +import Hix.Data.Error (Error (..)) +import Hix.Error (pathText, sourceError) noMatch :: Text -> Path b File -> ExceptT Error IO a noMatch reason source = diff --git a/lib/Hix/CabalParsec.hs b/lib/Hix/CabalParsec.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/CabalParsec.hs @@ -0,0 +1,48 @@ +module Hix.CabalParsec where + +import Distribution.Parsec (Parsec, eitherParsec) +import Exon (exon) +import Type.Reflection (typeRep) + +import Hix.Data.Monad (M) +import Hix.Monad (eitherClient) + +eitherParsecFor :: + Parsec b => + ToString a => + String -> + a -> + Either String b +eitherParsecFor desc spec = + first errorMessage (eitherParsec s) + where + errorMessage err = error [exon|parsing #{desc} "#{s}": #{err}|] + s = toString spec + +unsafeParsecFor :: + Parsec b => + ToString a => + String -> + a -> + b +unsafeParsecFor desc spec = + either error id (eitherParsecFor desc spec) + +unsafeParsec :: + ∀ a b . + Parsec b => + Typeable b => + ToString a => + a -> + b +unsafeParsec = + unsafeParsecFor (show (typeRep @b)) + +parsecM :: + Parsec b => + ToString a => + String -> + a -> + M b +parsecM desc spec = + eitherClient (first toText (eitherParsecFor desc spec)) diff --git a/lib/Hix/Class/EncodeNix.hs b/lib/Hix/Class/EncodeNix.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Class/EncodeNix.hs @@ -0,0 +1,91 @@ +module Hix.Class.EncodeNix where + +import qualified Data.Map.Strict as Map +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Utils.ShortText (ShortText, fromShortText) +import Distribution.Version (Version, VersionRange, simplifyVersionRange) +import Generics.SOP (All2, K (K), SListI2, hcmap, hcollapse) +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) + +type EncodeField :: FieldK -> Constraint +class EncodeField field where + encodeField :: Field field -> ExprAttr + +instance ( + KnownSymbol name, + EncodeNix a + ) => EncodeField ('FieldK name a) where + encodeField (Field a) = + ExprAttr (toText (symbolVal (Proxy @name))) (encodeNix a) + +class EncodeProd a where + encodeProd :: a -> Expr + +instance ( + ToFields a fields, + All2 EncodeField fields, + SListI2 fields + ) => EncodeProd a where + encodeProd = + ExprAttrs . + hcollapse . + hcmap (Proxy @EncodeField) (K . encodeField) . + toFields + +class EncodeNixKey a where + encodeNixKey :: a -> Text + +instance EncodeNixKey Text where + encodeNixKey = id + +class EncodeNix a where + encodeNix :: a -> Expr + default encodeNix :: EncodeProd a => a -> Expr + encodeNix = encodeProd + +instance EncodeNix Expr where + encodeNix = id + +instance EncodeNix Bool where + encodeNix = exprBool + +instance EncodeNix Int where + encodeNix = exprShow + +instance EncodeNix Version where + encodeNix = encodeNix . pretty + +instance EncodeNix VersionRange where + encodeNix = encodeNix . pretty . simplifyVersionRange + +instance EncodeNix a => EncodeNix (Maybe a) where + encodeNix = \case + Just a -> encodeNix a + Nothing -> ExprNull + +instance EncodeNix a => EncodeNix [a] where + encodeNix = ExprList . fmap encodeNix + +instance EncodeNix a => EncodeNix (NonEmpty a) where + encodeNix = ExprList . toList . fmap encodeNix + +instance ( + EncodeNixKey k, + EncodeNix v + ) => EncodeNix (Map k v) where + encodeNix = ExprAttrs . fmap (uncurry ExprAttr . bimap encodeNixKey encodeNix) . Map.toList + +instance EncodeNix Doc where + encodeNix = ExprString . show + +instance EncodeNix Text where + encodeNix = ExprString + +instance EncodeNix ShortText where + encodeNix = encodeNix . toText . fromShortText + +instance Pretty a => EncodeNix (ViaPretty a) where + encodeNix (ViaPretty a) = encodeNix (pretty a) diff --git a/lib/Hix/Class/Map.hs b/lib/Hix/Class/Map.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Class/Map.hs @@ -0,0 +1,715 @@ +module Hix.Class.Map where + +import qualified Data.Map.Merge.Strict as Map +import Data.Map.Merge.Strict ( + SimpleWhenMatched, + SimpleWhenMissing, + WhenMatched, + WhenMissing, + dropMissing, + mapMissing, + preserveMissing, + zipWithMatched, + ) +import qualified Data.Map.Strict as Map +import Distribution.Pretty (Pretty (pretty)) +import Exon (exon) +import qualified Text.PrettyPrint as PrettyPrint +import Text.PrettyPrint (Doc, comma, hang, punctuate, sep, vcat, (<+>)) + +import Hix.Data.Monad (M) +import Hix.Monad (noteFatal) + +data LookupMonoid +data LookupMaybe +data LookupFatal + +type NMap :: Type -> Type -> Type -> Type -> Constraint +class (Ord k, Coercible map (Map k v)) => NMap map k v sort | map -> k v sort where + nGet :: map -> Map k v + nGet = coerce + +lookupError :: + ∀ k v . + Show k => + Text -> + k -> + Maybe v -> + M v +lookupError thing k = + noteFatal [exon|No such #{thing}: #{show k}|] + +nFatal :: + ∀ map k v sort . + Show k => + NMap map k v sort => + Text -> + k -> + map -> + M v +nFatal thing k m = + lookupError thing k (nGet m Map.!? k) + +type NLookup :: Type -> Type -> Type -> Type -> Constraint +class NLookup sort k v l | sort v -> l where + nLookup :: k -> Maybe v -> l + +instance Monoid v => NLookup LookupMonoid k v v where + nLookup _ = fold + +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 => + map -> + k -> + Maybe v +(!?) m k = nGet m Map.!? k + +infixl !? + +(!!) :: + ∀ map k v sort l . + NMap map k v sort => + NLookup sort k v l => + map -> + k -> + l +(!!) m k = nLookup @sort @k @v @l k (m !? k) + +infixl !! + +nInsert :: + ∀ map k v sort . + NMap map k v sort => + k -> + v -> + map -> + map +nInsert k v m = + coerce (Map.insert k v (nGet m)) + +nUpdate :: + ∀ map k v sort l . + NMap map k v sort => + NLookup sort k v l => + k -> + map -> + (l -> v) -> + map +nUpdate k m f = + nInsert k (f (m !! k)) m + +nUpdateWith :: + ∀ map k v sort l . + NMap map k v sort => + NLookup sort k v l => + k -> + (l -> v) -> + map -> + map +nUpdateWith k = + flip (nUpdate k) + +nAdjust :: + ∀ map k v sort . + NMap map k v sort => + k -> + map -> + (v -> v) -> + map +nAdjust k m f = + nVia (Map.adjust f k) m + +nVia :: + NMap map1 k1 v1 s1 => + NMap map2 k2 v2 s2 => + (Map k1 v1 -> Map k2 v2) -> + map1 -> + map2 +nVia = + coerce + +nViaA :: + Applicative m => + NMap map1 k1 v1 s1 => + NMap map2 k2 v2 s2 => + (Map k1 v1 -> m (Map k2 v2)) -> + map1 -> + m map2 +nViaA f m = + coerce <$> f (coerce m) + +nMapKeys :: + NMap map1 k1 v sort1 => + NMap map2 k2 v sort2 => + (k1 -> k2) -> + map1 -> + map2 +nMapKeys f = + nVia (Map.mapKeys f) + +nMap :: + NMap map1 k v1 sort1 => + NMap map2 k v2 sort2 => + (v1 -> v2) -> + map1 -> + map2 +nMap f = + coerce . fmap f . nGet + +nMap1 :: + ∀ map1 map2 map1' map2' k k' v1 v2 s1 s2 s1' s2' . + NMap map1 k map1' s1 => + NMap map2 k map2' s2 => + NMap map1' k' v1 s1' => + NMap map2' k' v2 s2' => + (v1 -> v2) -> + map1 -> + map2 +nMap1 = + nMap . nMap + +nMapWithKey :: + NMap map1 k v1 sort1 => + NMap map2 k v2 sort2 => + (k -> v1 -> v2) -> + map1 -> + map2 +nMapWithKey f = + coerce . Map.mapWithKey f . nGet + +nMapWithKey1 :: + ∀ map1 map2 map1' map2' k k' v1 v2 s1 s2 s1' s2' . + NMap map1 k map1' s1 => + NMap map2 k map2' s2 => + NMap map1' k' v1 s1' => + NMap map2' k' v2 s2' => + (k -> k' -> v1 -> v2) -> + map1 -> + map2 +nMapWithKey1 f = + nMapWithKey \ k -> nMapWithKey (f k) + +nTransform :: + NMap map1 k1 v1 sort1 => + NMap map2 k2 v2 sort2 => + (k1 -> v1 -> (k2, v2)) -> + map1 -> + map2 +nTransform f = + coerce . + Map.fromList . + fmap (uncurry f) . + Map.toList . + nGet + +nTransformMaybe :: + NMap map1 k1 v1 sort1 => + NMap map2 k2 v2 sort2 => + (k1 -> v1 -> Maybe (k2, v2)) -> + map1 -> + map2 +nTransformMaybe f = + coerce . + Map.fromList . + mapMaybe (uncurry f) . + Map.toList . + nGet + +nMapMaybe :: + NMap map1 k v1 sort1 => + NMap map2 k v2 sort2 => + (v1 -> Maybe v2) -> + map1 -> + map2 +nMapMaybe f = + coerce . Map.mapMaybeWithKey (const f) . nGet + +nMapMaybe1 :: + ∀ map1 map2 map1' map2' k k' v1 v2 s1 s2 s1' s2' . + NMap map1 k map1' s1 => + NMap map2 k map2' s2 => + NMap map1' k' v1 s1' => + NMap map2' k' v2 s2' => + (v1 -> Maybe v2) -> + map1 -> + map2 +nMapMaybe1 = + nMap . nMapMaybe + +nMapMaybeWithKey :: + NMap map1 k v1 sort1 => + NMap map2 k v2 sort2 => + (k -> v1 -> Maybe v2) -> + map1 -> + map2 +nMapMaybeWithKey f = + coerce . + Map.mapMaybeWithKey f . + nGet + +nMapMaybeWithKey1 :: + ∀ map1 map2 map1' map2' k k' v1 v2 s1 s2 s1' s2' . + NMap map1 k map1' s1 => + NMap map2 k map2' s2 => + NMap map1' k' v1 s1' => + NMap map2' k' v2 s2' => + (k' -> v1 -> Maybe v2) -> + map1 -> + map2 +nMapMaybeWithKey1 = + nMap . nMapMaybeWithKey + +nCatMaybes :: + NMap map1 k (Maybe v) sort1 => + NMap map2 k v sort2 => + map1 -> + map2 +nCatMaybes = + nMapMaybe id + +nFilter :: + ∀ map k v sort . + NMap map k v sort => + (v -> Bool) -> + map -> + map +nFilter = + nVia . Map.filter + +nFilter1 :: + ∀ map map' k k' v s s' . + NMap map k map' s => + NMap map' k' v s' => + (v -> Bool) -> + map -> + map +nFilter1 = + nMap . nFilter + +nPrettyWith :: + Pretty k => + NMap map k v sort => + (v -> Doc) -> + map -> + Doc +nPrettyWith prettyV (nGet -> m) = + sep (punctuate comma (assoc <$> Map.toList m)) + where + assoc (k, v) = pretty k <+> "->" <+> prettyV v + +nPretty :: + Pretty k => + Pretty v => + NMap map k v sort => + map -> + Doc +nPretty = + nPrettyWith pretty + +nPretty1 :: + Pretty k => + Pretty v => + NMap map k v sort => + map -> + Doc +nPretty1 (nGet -> m) = + vcat (assoc <$> Map.toList m) + where + assoc (k, v) = hang (pretty k PrettyPrint.<> ":") 2 (pretty v) + +nMergeA :: + ∀ map1 map2 map3 k v1 v2 v3 s1 s2 s3 m . + Applicative m => + NMap map1 k v1 s1 => + NMap map2 k v2 s2 => + NMap map3 k v3 s3 => + WhenMissing m k v1 v3 -> + WhenMissing m k v2 v3 -> + WhenMatched m k v1 v2 v3 -> + map1 -> + map2 -> + m map3 +nMergeA missing1 missing2 matched map1 map2 = + nViaA (Map.mergeA missing1 missing2 matched (nGet map1)) map2 + +nMerge :: + ∀ 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 => + SimpleWhenMissing k v1 v3 -> + SimpleWhenMissing k v2 v3 -> + SimpleWhenMatched k v1 v2 v3 -> + map1 -> + map2 -> + map3 +nMerge missing1 missing2 matched map1 map2 = + nVia (Map.merge missing1 missing2 matched (nGet map1)) map2 + +nAmendWithKey :: + ∀ map1 map2 k v1 v2 s1 s2 . + NMap map1 k v1 s1 => + NMap map2 k v2 s2 => + (k -> v1 -> v2 -> v2) -> + map1 -> + map2 -> + map2 +nAmendWithKey matched = + nMerge dropMissing preserveMissing (zipWithMatched matched) + +-- | For each key that is present in both maps, replace the value by the result of the combining function. +-- For everything else, leave @map2@ unchanged. +nAmend :: + ∀ map1 map2 k v1 v2 s1 s2 . + NMap map1 k v1 s1 => + NMap map2 k v2 s2 => + (v1 -> v2 -> v2) -> + map1 -> + map2 -> + map2 +nAmend matched = + nAmendWithKey (const matched) + +-- | For each key path that is present in both submaps, replace the value by the result of the combining function. +-- For everything else, leave @map2@ unchanged. +nAmend1 :: + ∀ map1 map2 map1' map2' k k' v1 v2 s1 s2 s1' s2' . + NMap map1 k map1' s1 => + NMap map2 k map2' s2 => + NMap map1' k' v1 s1' => + NMap map2' k' v2 s2' => + (v1 -> v2 -> v2) -> + map1 -> + map2 -> + map2 +nAmend1 matched = + nMerge dropMissing preserveMissing (zipWithMatched matched1) + where + matched1 _ map1' map2' = nAmend matched map1' map2' + +-- | For each key that is present in both maps, replace the value by the result of the combining function. +-- For each key that is present in @map1@, insert the result of the conversion function. +-- Keep keys only present in @map2@. +nPad :: + ∀ map1 map2 k v1 v2 s1 s2 . + NMap map1 k v1 s1 => + NMap map2 k v2 s2 => + (v1 -> v2 -> v2) -> + (v1 -> v2) -> + map1 -> + map2 -> + map2 +nPad matched conv = + nMerge (mapMissing (const conv)) preserveMissing (zipWithMatched (const matched)) + +-- | For each key path that is present in both submaps, replace the value by the result of the combining function. +-- For each key and key path that is present only in @map1@ and each submap, insert the result of the conversion +-- function. +-- Keep keys only present in @map2@ and each submap. +nPad1 :: + ∀ map1 map2 map1' map2' k k' v1 v2 s1 s2 s1' s2' . + NMap map1 k map1' s1 => + NMap map2 k map2' s2 => + NMap map1' k' v1 s1' => + NMap map2' k' v2 s2' => + (v1 -> v2 -> v2) -> + (v1 -> v2) -> + map1 -> + map2 -> + map2 +nPad1 matched conv = + nMerge (mapMissing missing) preserveMissing (zipWithMatched matched1) + where + missing _ = nMap conv + matched1 _ = nPad matched conv + +-- | For each key that is present only in @map1@, insert the result of the conversion function. +-- For everything else, leave @map2@ unchanged. +nPadKeep :: + ∀ map1 map2 k v1 v2 s1 s2 . + NMap map1 k v1 s1 => + NMap map2 k v2 s2 => + (v1 -> v2) -> + map1 -> + map2 -> + map2 +nPadKeep = + nPad \ _ v2 -> v2 + +-- | For each key and key path that is present only in @map1@ and each submap, insert the result of the conversion +-- function. +-- For everything else, leave @map2@ and its submaps unchanged. +nPadKeep1 :: + ∀ map1 map2 map1' map2' k k' v1 v2 s1 s2 s1' s2' . + NMap map1 k map1' s1 => + NMap map2 k map2' s2 => + NMap map1' k' v1 s1' => + NMap map2' k' v2 s2' => + (v1 -> v2) -> + map1 -> + map2 -> + map2 +nPadKeep1 = + nPad1 \ _ v2 -> v2 + +nZipWithKeyR :: + ∀ 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 => + (k -> Maybe v1 -> v2 -> v3) -> + map1 -> + map2 -> + map3 +nZipWithKeyR f = + nMerge dropMissing (mapMissing missing) (zipWithMatched matched) + where + missing k = f k Nothing + matched k v = f k (Just v) + +nZipR :: + ∀ 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 => + (Maybe v1 -> v2 -> v3) -> + map1 -> + map2 -> + map3 +nZipR f = nZipWithKeyR (const f) + +nZipWithKey :: + ∀ 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 => + (k -> v1 -> v2 -> v3) -> + map1 -> + map2 -> + map3 +nZipWithKey f = + nMerge dropMissing dropMissing (zipWithMatched f) + +nZip :: + ∀ 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 -> v2 -> v3) -> + map1 -> + map2 -> + map3 +nZip f = nZipWithKey (const f) + +nFromList :: + NMap map k v sort => + [(k, v)] -> + map +nFromList = + coerce . Map.fromList + +nList :: + NMap map k v sort => + map -> + [(k, v)] +nList = + Map.toList . coerce + +nTo :: + NMap map k v sort => + map -> + (k -> v -> a) -> + [a] +nTo m f = + fmap (uncurry f) (nList m) + +nToWith :: + NMap map k v sort => + (k -> v -> a) -> + map -> + [a] +nToWith = flip nTo + +nConcat :: + Monoid a => + NMap map k v sort => + map -> + (k -> v -> a) -> + a +nConcat m f = + mconcat (uncurry f <$> nList m) + +nConcatWith :: + Monoid a => + NMap map k v sort => + (k -> v -> a) -> + map -> + a +nConcatWith = + flip nConcat + +nToMaybe :: + NMap map k v sort => + map -> + (k -> v -> Maybe a) -> + [a] +nToMaybe m f = + mapMaybe (uncurry f) (nList m) + +nTo1 :: + ∀ map1 map2 k1 k2 v s1 s2 a . + NMap map1 k1 map2 s1 => + NMap map2 k2 v s2 => + map1 -> + (k1 -> k2 -> v -> a) -> + [a] +nTo1 m1 f = + nConcat m1 (nToWith . f) + +nToWith1 :: + ∀ map1 map2 k1 k2 v s1 s2 a . + NMap map1 k1 map2 s1 => + NMap map2 k2 v s2 => + (k1 -> k2 -> v -> a) -> + map1 -> + [a] +nToWith1 f = + nConcatWith (nToWith . f) + +nFromKeys :: + Foldable t => + NMap map k v sort => + t k -> + (k -> v) -> + map +nFromKeys keys f = + nFromList (toList keys <&> \ k -> (k, f k)) + +nFromKeysMaybe :: + Foldable t => + NMap map k v sort => + t k -> + (k -> Maybe v) -> + map +nFromKeysMaybe keys f = + nFromList (flip mapMaybe (toList keys) \ k -> (k,) <$> f k) + +nBy :: + Foldable t => + NMap map k v sort => + t v -> + (v -> k) -> + map +nBy values f = + nFromList (toList values <&> \ v -> (f v, v)) + +nGen :: + Foldable t => + NMap map k v sort => + t a -> + (a -> (k, v)) -> + map +nGen values f = + nFromList (f <$> toList values) + +nGenWith :: + Foldable t => + NMap map k v sort => + (a -> (k, v)) -> + t a -> + map +nGenWith = + flip nGen + +nGenMaybe :: + Foldable t => + NMap map k v sort => + t a -> + (a -> Maybe (k, v)) -> + map +nGenMaybe values f = + nFromList (mapMaybe f (toList values)) + +nForKeys :: + Applicative m => + NMap map k v sort => + [k] -> + (k -> m v) -> + m map +nForKeys keys f = + nFromList <$> for keys \ k -> (k,) <$> f k + +nFor :: + Applicative m => + NMap map k v sort => + [v] -> + (v -> m k) -> + m map +nFor values f = + nFromList <$> for values \ v -> (,v) <$> f v + +nElems :: + ∀ map k v s . + NMap map k v s => + map -> + [v] +nElems = + Map.elems . nGet + +nElems1 :: + ∀ map1 map2 k1 k2 v s1 s2 . + NMap map1 k1 map2 s1 => + NMap map2 k2 v s2 => + map1 -> + [v] +nElems1 = + nElems <=< nElems + +nFlatten :: + ∀ map1 map2 map3 k1 k2 v1 v2 s1 s2 . + Monoid map2 => + NMap map1 k1 map2 LookupMonoid => + NMap map2 k2 v1 s1 => + NMap map3 k2 v2 s2 => + (v1 -> v2) -> + map1 -> + map3 +nFlatten f = + nMap f . mconcat . nElems + +nKeys :: + NMap map k v sort => + map -> + [k] +nKeys = + Map.keys . nGet + +nKeysSet :: + NMap map k v sort => + map -> + Set k +nKeysSet = + Map.keysSet . nGet + +nRestrictKeys :: + NMap map k v sort => + Set k -> + map -> + map +nRestrictKeys keys = + nVia (`Map.restrictKeys` keys) + +nWithoutKeys :: + NMap map k v sort => + Set k -> + map -> + map +nWithoutKeys keys = + nVia (`Map.withoutKeys` keys) diff --git a/lib/Hix/Class/SOP.hs b/lib/Hix/Class/SOP.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Class/SOP.hs @@ -0,0 +1,54 @@ +module Hix.Class.SOP where + +import Generics.SOP (I (I), NP (Nil, (:*)), NS (S, Z), SOP (SOP)) +import Generics.SOP.GGP (GCode, GDatatypeInfoOf, GFrom, gfrom) +import Generics.SOP.Type.Metadata (ConstructorInfo (Record), DatatypeInfo (..), FieldInfo (FieldInfo)) + +data FieldK = + FieldK { + name :: Symbol, + tpe :: Type + } + +type Field :: FieldK -> Type +data Field k where + Field :: a -> Field ('FieldK name a) + +type ProdFields :: [FieldInfo] -> [Type] -> [FieldK] -> Constraint +class ProdFields info as fields | info as -> fields where + prodFields :: NP I as -> NP Field fields + +instance ProdFields '[] '[] '[] where + prodFields Nil = Nil + +instance ( + ProdFields info as fields + ) => ProdFields ('FieldInfo name : info) (a : as) ('FieldK name a : fields) where + prodFields (I a :* fields) = Field a :* prodFields @info fields + +type SumFields :: [ConstructorInfo] -> [[Type]] -> [[FieldK]] -> Constraint +class SumFields cons ass fields | cons ass -> fields where + sumFields :: NS (NP I) ass -> NS (NP Field) fields + +instance SumFields '[] '[] '[] where + sumFields = \case + +instance ( + ProdFields info as conFields, + SumFields cons ass fields + ) => SumFields ('Record con info : cons) (as : ass) (conFields : fields) where + sumFields = \case + Z con -> Z (prodFields @info con) + S cons -> S (sumFields @cons cons) + +class ToFields a fields | a -> fields where + toFields :: a -> SOP Field fields + +instance ( + Generic a, + GFrom a, + 'ADT mod name cons sni ~ GDatatypeInfoOf a, + ass ~ GCode a, + SumFields cons ass fields + ) => ToFields a fields where + toFields (gfrom -> SOP fields) = SOP (sumFields @cons fields) diff --git a/lib/Hix/Component.hs b/lib/Hix/Component.hs --- a/lib/Hix/Component.hs +++ b/lib/Hix/Component.hs @@ -11,21 +11,17 @@ import Hix.Data.ComponentConfig ( ComponentConfig, PackageConfig (PackageConfig), - PackageName (PackageName), PackagesConfig, SourceDir (SourceDir), Target (Target), TargetOrDefault (DefaultTarget, ExplicitTarget, NoDefaultTarget), ) -import Hix.Data.Error (Error (EnvError), pathText) +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 qualified Hix.Options as Options -import Hix.Options ( - ComponentCoords, - ComponentSpec (ComponentSpec), - PackageSpec (PackageSpec), - TargetSpec (TargetForComponent, TargetForFile), - ) import Hix.Path (rootDir) data ResolvedPackage = diff --git a/lib/Hix/Console.hs b/lib/Hix/Console.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Console.hs @@ -0,0 +1,84 @@ +module Hix.Console where + +import qualified Data.ByteString.Char8 as ByteString +import qualified Data.Text.IO as Text +import Exon (exon) +import System.IO (Handle, stderr, stdout) + +hPrint :: + MonadIO m => + Handle -> + Text -> + m () +hPrint h msg = + liftIO (Text.hPutStrLn h msg) + +hPrintBS :: + MonadIO m => + Handle -> + ByteString -> + m () +hPrintBS h msg = + liftIO (ByteString.hPutStrLn h msg) + +out :: MonadIO m => Text -> m () +out = hPrint stdout + +err :: MonadIO m => Text -> m () +err = hPrint stderr + +bytesOut :: MonadIO m => ByteString -> m () +bytesOut = hPrintBS stdout + +bytesErr :: MonadIO m => ByteString -> m () +bytesErr = hPrintBS stderr + +sgi :: Text -> Text +sgi param = + [exon|#{esc}[#{param}m|] + where + esc = "\ESC" + +sgis :: [Text] -> Text -> Text +sgis params chunk = + [exon|#{seqs}#{chunk}#{sgi "0"}|] + where + seqs = mconcat (sgi <$> params) + +color :: Int -> Text -> Text +color n = + sgis [show (30 + n)] + +data ColorOffsets = + ColorOffsets { + black :: Int, + red :: Int, + green :: Int, + yellow :: Int, + blue :: Int, + magenta :: Int, + cyan :: Int, + white :: Int + } + deriving stock (Eq, Show, Generic) + +colors :: ColorOffsets +colors = + ColorOffsets { + black = 0, + red = 1, + green = 2, + yellow = 3, + blue = 4, + magenta = 5, + cyan = 6, + white = 7 + } + +withChevrons :: Int -> Text -> Text +withChevrons col msg = + [exon|#{sgis [show (30 + col), "1"] ">>>"} #{msg}|] + +errorMessage :: Text -> Text +errorMessage msg = + withChevrons 1 [exon|Error: #{msg}|] diff --git a/lib/Hix/Data/Bounds.hs b/lib/Hix/Data/Bounds.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Bounds.hs @@ -0,0 +1,49 @@ +module Hix.Data.Bounds where + +import Data.Aeson (FromJSON (parseJSON), ToJSON) +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Version (Version, VersionRange) +import GHC.Exts (IsList) + +import Hix.Class.EncodeNix (EncodeNix) +import Hix.Class.Map (LookupMaybe, NMap, nPretty) +import Hix.Data.Json (jsonParsec) +import Hix.Data.PackageName (PackageName) +import Hix.Data.VersionBounds (VersionBounds) + +newtype Bounds = + Bounds (Map PackageName VersionBounds) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList, EncodeNix, FromJSON, ToJSON) + +instance NMap Bounds PackageName VersionBounds LookupMaybe where + +instance Pretty Bounds where + pretty = nPretty + +newtype Ranges = + Ranges (Map PackageName VersionRange) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap Ranges PackageName VersionRange LookupMaybe where + +instance Pretty Ranges where + pretty = nPretty + +instance FromJSON Ranges where + parseJSON v = + Ranges . fmap jsonParsec <$> parseJSON v + +data BoundExtension = + LowerBoundExtension Version + | + UpperBoundExtension Version + deriving stock (Eq, Show, Generic) + +newtype BoundExtensions = + BoundExtensions (Map PackageName BoundExtension) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap BoundExtensions PackageName BoundExtension LookupMaybe where diff --git a/lib/Hix/Data/ComponentConfig.hs b/lib/Hix/Data/ComponentConfig.hs --- a/lib/Hix/Data/ComponentConfig.hs +++ b/lib/Hix/Data/ComponentConfig.hs @@ -1,8 +1,11 @@ module Hix.Data.ComponentConfig where import Data.Aeson (FromJSON (parseJSON), FromJSONKey, withObject, (.:)) +import Distribution.Pretty (Pretty (pretty)) import Path (Abs, Dir, File, Path, Rel) +import Hix.Data.PackageName (PackageName) + newtype PackagePath = PackagePath { unPackagePath :: Path Rel Dir } deriving stock (Eq, Show, Ord, Generic) @@ -23,11 +26,6 @@ <|> (SourceDirs . pure <$> parseJSON v) -newtype PackageName = - PackageName { unPackageName :: Text } - deriving stock (Eq, Show, Generic) - deriving newtype (IsString, Ord, FromJSON, FromJSONKey) - newtype ModuleName = ModuleName { unModuleName :: Text } deriving stock (Eq, Show, Generic) @@ -38,10 +36,8 @@ deriving stock (Eq, Show, Generic) deriving newtype (IsString, Ord, FromJSON, FromJSONKey) -newtype EnvName = - EnvName { unEnvName :: 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) diff --git a/lib/Hix/Data/Dep.hs b/lib/Hix/Data/Dep.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Dep.hs @@ -0,0 +1,59 @@ +module Hix.Data.Dep where + +import Data.Aeson (FromJSON (parseJSON), Value (Object, String), (.:)) +import Data.Aeson.Types (Parser) +import Distribution.Package (mainLibSet) +import Distribution.Pretty (Pretty, pretty) +import Distribution.Types.Dependency (Dependency (Dependency)) +import Distribution.Version (VersionRange, thisVersion) +import Exon (exon) + +import Hix.Data.Json (aesonParsec, jsonParsec) +import qualified Hix.Data.PackageName as PackageName +import Hix.Data.PackageName (PackageName) +import Hix.Data.Version (Version) + +data Dep = + Dep { + package :: PackageName, + version :: VersionRange + } + deriving stock (Eq, Show, Generic) + +toCabal :: Dep -> Dependency +toCabal Dep {..} = + Dependency (PackageName.toCabal package) version mainLibSet + +fromCabal :: Dependency -> Dep +fromCabal (Dependency (PackageName.fromCabal -> package) version _) = + Dep {package, version} + +instance Pretty Dep where + pretty = pretty . toCabal + +mkDep :: PackageName -> VersionRange -> Dep +mkDep package version = Dep {..} + +jsonParseCabal :: String -> Parser Dep +jsonParseCabal v = fromCabal <$> aesonParsec v + +renderDep :: Dep -> Text +renderDep = show . pretty + +thisVersionDep :: PackageName -> Version -> Dep +thisVersionDep package version = + mkDep package (thisVersion version) + +instance FromJSON Dep where + parseJSON = \case + String s -> + jsonParseCabal (toString s) + Object o -> do + fromName <- jsonParseCabal =<< o .: "name" + version <- (jsonParsec <$> o .: "version") <|> pure fromName.version + pure fromName {version} + v -> + fail [exon|Invalid dependency format: #{show v}|] + +withVersion :: VersionRange -> Dep -> Dep +withVersion version dep = dep {version} diff --git a/lib/Hix/Data/EnvName.hs b/lib/Hix/Data/EnvName.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/EnvName.hs @@ -0,0 +1,15 @@ +module Hix.Data.EnvName where + +import Data.Aeson (FromJSON, FromJSONKey) +import Distribution.Pretty (Pretty (pretty)) + +import Hix.Class.EncodeNix (EncodeNixKey) +import Hix.Pretty (prettyText) + +newtype EnvName = + EnvName { unEnvName :: Text } + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey, EncodeNixKey) + +instance Pretty EnvName where + pretty (EnvName n) = prettyText n diff --git a/lib/Hix/Data/Error.hs b/lib/Hix/Data/Error.hs --- a/lib/Hix/Data/Error.hs +++ b/lib/Hix/Data/Error.hs @@ -1,12 +1,5 @@ module Hix.Data.Error where -import Control.Monad.Trans.Except (ExceptT, throwE) -import qualified Data.Text.IO as Text -import Exon (exon) -import Path (Path, toFilePath) -import System.IO (stderr) -import System.IO.Error (tryIOError) - data Error = PreprocError Text | @@ -21,66 +14,6 @@ NoMatch Text | Fatal Text + | + Client Text deriving stock (Eq, Show, Generic) - -pathText :: Path b t -> Text -pathText = - toText . toFilePath - -printPreprocError :: - MonadIO m => - Text -> - m () -printPreprocError msg = - liftIO (Text.hPutStrLn stderr [exon|>>> Preprocessor generator failed: #{msg}|]) - -printEnvError :: - MonadIO m => - Text -> - m () -printEnvError msg = - liftIO (Text.hPutStrLn stderr [exon|>>> Invalid env config: #{msg}|]) - -printGhciError :: - MonadIO m => - Text -> - m () -printGhciError msg = - liftIO (Text.hPutStrLn stderr [exon|>>> Invalid ghci config: #{msg}|]) - -printNewError :: - MonadIO m => - Text -> - m () -printNewError msg = - liftIO (Text.hPutStrLn stderr [exon|>>> Can't create new project: #{msg}|]) - -printBootstrapError :: - MonadIO m => - Text -> - m () -printBootstrapError msg = - liftIO (Text.hPutStrLn stderr [exon|>>> Can't bootstrap project: #{msg}|]) - -printFatalError :: - MonadIO m => - Text -> - m () -printFatalError msg = - liftIO (Text.hPutStrLn stderr [exon|>>> Fatal error: #{msg}|]) - -sourceError :: Text -> Path b t -> Text -sourceError reason source = - [exon|#{reason} the source file '#{pathText source}'|] - -tryIO :: - IO a -> - ExceptT Error IO a -tryIO ma = - liftIO (tryIOError ma) >>= \case - Right a -> pure a - Left err -> throwE (Fatal (show err)) - -note :: Text -> Maybe a -> ExceptT Error IO a -note err = - maybe (throwE (GhciError err)) pure diff --git a/lib/Hix/Data/GhciConfig.hs b/lib/Hix/Data/GhciConfig.hs --- a/lib/Hix/Data/GhciConfig.hs +++ b/lib/Hix/Data/GhciConfig.hs @@ -3,7 +3,8 @@ import Data.Aeson (FromJSON, FromJSONKey) import GHC.Exts (IsList) -import Hix.Data.ComponentConfig (EnvRunner, PackageName, PackagesConfig) +import Hix.Data.ComponentConfig (EnvRunner, PackagesConfig) +import Hix.Data.PackageName (PackageName) newtype RunnerName = RunnerName { unRunnerName :: Text } diff --git a/lib/Hix/Data/GlobalOptions.hs b/lib/Hix/Data/GlobalOptions.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/GlobalOptions.hs @@ -0,0 +1,28 @@ +module Hix.Data.GlobalOptions where + +import Path (Abs, Dir, Path) + +import Hix.Data.OutputFormat (OutputFormat (OutputNone)) +import Hix.Data.OutputTarget (OutputTarget (OutputDefault)) + +data GlobalOptions = + GlobalOptions { + verbose :: Bool, + debug :: Bool, + quiet :: Bool, + cwd :: Path Abs Dir, + output :: OutputFormat, + target :: OutputTarget + } + deriving stock (Eq, Show, Generic) + +defaultGlobalOptions :: Path Abs Dir -> GlobalOptions +defaultGlobalOptions cwd = + GlobalOptions { + verbose = False, + debug = False, + quiet = False, + cwd, + output = OutputNone, + target = OutputDefault + } diff --git a/lib/Hix/Data/Json.hs b/lib/Hix/Data/Json.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Json.hs @@ -0,0 +1,33 @@ +module Hix.Data.Json where + +import Data.Aeson (FromJSON (parseJSON), Key, Object, (.:?)) +import Data.Aeson.Types (Parser) +import Distribution.Parsec (Parsec, eitherParsec) + +aesonParsec :: + Parsec a => + String -> + Parser a +aesonParsec = + leftA fail . eitherParsec + +newtype JsonParsec a = + JsonParsec a + deriving stock (Eq, Show, Generic) + +instance Parsec a => FromJSON (JsonParsec a) where + parseJSON v = do + raw <- parseJSON v + JsonParsec <$> aesonParsec raw + +jsonParsec :: JsonParsec a -> a +jsonParsec = coerce + +foldMissing :: + Monoid a => + FromJSON a => + Object -> + Key -> + Parser a +foldMissing o k = + fold <$> o .:? k diff --git a/lib/Hix/Data/Monad.hs b/lib/Hix/Data/Monad.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Monad.hs @@ -0,0 +1,51 @@ +module Hix.Data.Monad 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 GHC.Records (HasField (getField)) +import Path (Abs, Dir, Path) + +import Hix.Data.Error (Error) +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, + output :: OutputFormat, + target :: OutputTarget, + logger :: LogLevel -> Text -> M () + } + +newtype M a = + M (ReaderT AppResources (ExceptT Error IO) a) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask) + +liftE :: ExceptT Error IO a -> M a +liftE = M . lift + +data AppResProxy = AppResProxy + +instance HasField name AppResources a => HasField name AppResProxy (M a) where + getField AppResProxy = M (asks (getField @name)) + +appRes :: AppResProxy +appRes = AppResProxy diff --git a/lib/Hix/Data/NixExpr.hs b/lib/Hix/Data/NixExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/NixExpr.hs @@ -0,0 +1,38 @@ +module Hix.Data.NixExpr where + +data ExprAttr = + ExprAttr { + name :: Text, + value :: Expr + } + | + ExprAttrNil + deriving stock (Eq, Show, Generic) + +data Expr = + ExprNull + | + ExprString Text + | + ExprLit Text + | + ExprList [Expr] + | + ExprAttrs [ExprAttr] + | + ExprPrefix Text Expr + deriving stock (Eq, Show, Generic) + +exprShow :: Show a => a -> Expr +exprShow = + ExprLit . show + +exprBool :: Bool -> Expr +exprBool = + ExprLit . \case + True -> "true" + False -> "false" + +newtype ViaPretty a = + ViaPretty a + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Data/Options.hs b/lib/Hix/Data/Options.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Options.hs @@ -0,0 +1,203 @@ +module Hix.Data.Options where + +import Path (Abs, Dir, File, Path, SomeBase) + +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.PackageName (PackageName) +import Hix.Data.PreprocConfig (PreprocConfig) +import Hix.Managed.Cabal.Data.Config (CabalConfig) +import Hix.Managed.Data.BuildConfig (BuildConfig) +import Hix.Managed.Data.ProjectContextProto (ProjectContextProto) +import Hix.Managed.Data.Query (RawQuery) +import Hix.Managed.Data.StateFileConfig (StateFileConfig) +import Hix.Managed.Handlers.Build (SpecialBuildHandlers) +import Hix.Optparse (JsonConfig) + +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 + } + deriving stock (Show, Generic) + +data PackageSpec = + PackageSpec { + name :: PackageName, + dir :: Maybe (SomeBase Dir) + } + deriving stock (Eq, Show, Generic) + +data ComponentSpec = + ComponentSpec { + name :: ComponentName, + dir :: Maybe SourceDir + } + deriving stock (Eq, Show, Generic) + +data ComponentCoords = + ComponentCoords { + package :: Maybe PackageSpec, + component :: Maybe ComponentSpec + } + deriving stock (Eq, Show, Generic) + +data TargetSpec = + TargetForFile (Path Abs File) + | + TargetForComponent ComponentCoords + deriving stock (Eq, Show, Generic) + +data TestOptions = + TestOptions { + mod :: ModuleName, + test :: Maybe Text, + runner :: Maybe RunnerName, + cd :: ChangeDir + } + deriving stock (Eq, Show, Generic) + +data EnvRunnerOptions = + EnvRunnerOptions { + config :: Either EnvConfig JsonConfig, + root :: Maybe (Path Abs Dir), + component :: Maybe TargetSpec + } + deriving stock (Show, Generic) + +newtype ExtraGhciOptions = + ExtraGhciOptions Text + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) + +newtype ExtraGhcidOptions = + ExtraGhcidOptions Text + deriving stock (Eq, Show, Generic) + deriving newtype (IsString) + +data GhciOptions = + GhciOptions { + config :: Either GhciConfig JsonConfig, + root :: Maybe (Path Abs Dir), + component :: TargetSpec, + test :: TestOptions, + extra :: Maybe ExtraGhciOptions + } + deriving stock (Show, Generic) + +data GhcidOptions = + GhcidOptions { + ghci :: GhciOptions, + extra :: Maybe ExtraGhcidOptions + } + deriving stock (Show, Generic) + +data NewOptions = + NewOptions { + config :: NewProjectConfig + } + deriving stock (Eq, Show, Generic) + +data BootstrapOptions = + BootstrapOptions { + config :: BootstrapProjectConfig + } + deriving stock (Eq, Show, Generic) + +data EnvRunnerCommandOptions = + EnvRunnerCommandOptions { + options :: EnvRunnerOptions, + test :: TestOptions, + extraGhci :: Maybe ExtraGhciOptions, + extraGhcid :: Maybe ExtraGhcidOptions + } + deriving stock (Show, Generic) + +data ProjectOptions = + ProjectOptions { + build :: BuildConfig, + envs :: [EnvName], + query :: RawQuery, + readUpperBounds :: Bool, + mergeBounds :: Bool + } + deriving stock (Eq, Show, Generic) + +instance Default ProjectOptions where + def = ProjectOptions { + build = def, + envs = [], + query = [], + readUpperBounds = False, + mergeBounds = False + } + +projectOptions :: [EnvName] -> ProjectOptions +projectOptions envs = def {envs} + +data ManagedOptions = + ManagedOptions { + context :: Either ProjectContextProto JsonConfig, + project :: ProjectOptions, + stateFile :: StateFileConfig, + cabal :: CabalConfig, + handlers :: Maybe SpecialBuildHandlers + } + deriving stock (Show, Generic) + +data BumpOptions = + BumpOptions { + common :: ManagedOptions + } + deriving stock (Show, Generic) + +data LowerOptions = + LowerOptions { + common :: ManagedOptions, + initOnly :: Bool, + reset :: Bool, + stabilize :: Bool + } + deriving stock (Show) + +data LowerCommand = + LowerInitCmd LowerOptions + | + LowerOptimizeCmd LowerOptions + | + LowerStabilizeCmd LowerOptions + | + LowerAutoCmd LowerOptions + deriving stock (Show) + +data Command = + Preproc PreprocOptions + | + EnvRunner EnvRunnerCommandOptions + | + GhcidCmd GhcidOptions + | + GhciCmd GhciOptions + | + NewCmd NewOptions + | + BootstrapCmd BootstrapOptions + | + BumpCmd BumpOptions + | + LowerCmd LowerCommand + deriving stock (Show) + +data Options = + Options { + global :: GlobalOptions, + cmd :: Command + } + deriving stock (Show) diff --git a/lib/Hix/Data/OutputFormat.hs b/lib/Hix/Data/OutputFormat.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/OutputFormat.hs @@ -0,0 +1,11 @@ +module Hix.Data.OutputFormat where + +data OutputFormat = + OutputNone + | + OutputJson + | + OutputCommitMsg + | + OutputGaPr + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Data/OutputTarget.hs b/lib/Hix/Data/OutputTarget.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/OutputTarget.hs @@ -0,0 +1,11 @@ +module Hix.Data.OutputTarget where + +import Path (Abs, File, Path) + +data OutputTarget = + OutputDefault + | + OutputStdout + | + OutputFile (Path Abs File) + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Data/Overrides.hs b/lib/Hix/Data/Overrides.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Overrides.hs @@ -0,0 +1,43 @@ +module Hix.Data.Overrides where + +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 Hix.Class.EncodeNix (EncodeNix) +import Hix.Class.Map (LookupMaybe, NMap, nPretty) +import Hix.Data.Json (JsonParsec (JsonParsec)) +import Hix.Data.PackageName (PackageName) +import Hix.Data.Version (SourceHash) + +data Override = + Override { + version :: Version, + hash :: SourceHash + } + deriving stock (Eq, Show, Generic) + deriving anyclass (EncodeNix) + +instance FromJSON Override where + parseJSON = + withObject "Override" \ o -> do + JsonParsec version <- o .: "version" + hash <- o .: "hash" + pure Override {..} + +instance Pretty Override where + pretty Override {..} = pretty version <+> brackets (pretty hash) + +-- | Overrides can be either for mutable (direct, nonlocal) deps, or for transitive deps, so they must use +-- 'PackageName'. +newtype Overrides = + Overrides (Map PackageName Override) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON, Semigroup, Monoid, IsList, EncodeNix) + +instance NMap Overrides PackageName Override LookupMaybe where + +instance Pretty Overrides where + pretty = nPretty diff --git a/lib/Hix/Data/PackageId.hs b/lib/Hix/Data/PackageId.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/PackageId.hs @@ -0,0 +1,32 @@ +module Hix.Data.PackageId where + +import Distribution.Package (PackageIdentifier (PackageIdentifier)) +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Version (Version) +import Exon (exon) + +import qualified Hix.Data.PackageName as PackageName +import Hix.Data.PackageName (PackageName (..)) +import Hix.Pretty (prettyText, showP) + +data PackageId = + PackageId { + name :: PackageName, + version :: Version + } + deriving stock (Eq, Show, Generic) + +renderPackage :: PackageId -> Text +renderPackage PackageId {..} = + [exon|##{name}-#{showP version}|] + +instance Pretty PackageId where + pretty = prettyText . renderPackage + +toCabal :: PackageId -> PackageIdentifier +toCabal PackageId {..} = + PackageIdentifier (PackageName.toCabal name) version + +fromCabal :: PackageIdentifier -> PackageId +fromCabal (PackageIdentifier (PackageName.fromCabal -> name) version) = + PackageId {..} diff --git a/lib/Hix/Data/PackageName.hs b/lib/Hix/Data/PackageName.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/PackageName.hs @@ -0,0 +1,55 @@ +module Hix.Data.PackageName where + +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import qualified Data.Set as Set +import qualified Distribution.Package as Cabal +import Distribution.Package (depPkgName, mkPackageName) +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Types.Dependency (Dependency) + +import Hix.Class.EncodeNix (EncodeNixKey) +import Hix.Pretty (prettyText) + +newtype PackageName = + PackageName Text + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey, ToJSON, ToJSONKey, EncodeNixKey) + +instance Pretty PackageName where + pretty (PackageName n) = prettyText n + +fromCabal :: Cabal.PackageName -> PackageName +fromCabal = + fromString . Cabal.unPackageName + +toCabal :: PackageName -> Cabal.PackageName +toCabal (PackageName name) = + mkPackageName (toString name) + +depPackageName :: Dependency -> PackageName +depPackageName = + fromCabal . depPkgName + +newtype LocalPackage = + LocalPackage PackageName + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey, Pretty, EncodeNixKey) + +localPackageName :: LocalPackage -> PackageName +localPackageName = coerce + +localPackageNames :: [LocalPackage] -> [PackageName] +localPackageNames = coerce + +sameLocalPackage :: LocalPackage -> PackageName -> Bool +sameLocalPackage (LocalPackage lp) p = lp == p + +isLocalPackage :: Set LocalPackage -> PackageName -> Bool +isLocalPackage lps p = Set.member (LocalPackage p) lps + +toLocalPackage :: Set LocalPackage -> PackageName -> Maybe LocalPackage +toLocalPackage lps p + | isLocalPackage lps p + = Just (LocalPackage p) + | otherwise + = Nothing diff --git a/lib/Hix/Data/ProjectFile.hs b/lib/Hix/Data/ProjectFile.hs --- a/lib/Hix/Data/ProjectFile.hs +++ b/lib/Hix/Data/ProjectFile.hs @@ -6,9 +6,9 @@ import Path (File, Path, Rel, parent, toFilePath, ()) import Path.IO (createDirIfMissing) -import Hix.Data.Error (tryIO) -import qualified Hix.Monad -import Hix.Monad (Env (Env), M) +import qualified Hix.Data.Monad (AppResources (cwd)) +import Hix.Data.Monad (AppResources (AppResources), M (M)) +import Hix.Error (tryIO) data ProjectFile = ProjectFile { @@ -19,9 +19,9 @@ createFile :: ProjectFile -> M () createFile f = do - Env {cwd} <- ask + AppResources {cwd} <- M ask let file = cwd f.path - lift $ tryIO do + M $ lift $ tryIO do createDirIfMissing True (parent file) Text.writeFile (toFilePath file) f.content diff --git a/lib/Hix/Data/Version.hs b/lib/Hix/Data/Version.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/Version.hs @@ -0,0 +1,64 @@ +module Hix.Data.Version ( + module Hix.Data.Version, + Version, + VersionRange, +) where + +import Data.Aeson (FromJSON (parseJSON)) +import Data.Generics.Labels () +import qualified Data.List.NonEmpty as NonEmpty +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Version (Version, VersionRange, anyVersion) +import Exon (exon) +import GHC.Exts (IsList) +import Text.PrettyPrint (Doc) + +import Hix.Class.EncodeNix (EncodeNix) +import Hix.Class.Map (LookupMaybe, NMap, nGenWith, nPretty) +import Hix.Data.Json (jsonParsec) +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import Hix.Data.PackageName (PackageName) +import Hix.Orphans.Version () +import Hix.Pretty (prettyText) + +range0 :: VersionRange +range0 = anyVersion + +newtype SourceHash = + SourceHash Text + deriving stock (Eq, Show, Generic) + deriving newtype (Ord, FromJSON, EncodeNix) + +instance Pretty SourceHash where + pretty (SourceHash h) = prettyText h + +data Major = + Major { + prefix :: Version, + versions :: NonEmpty Version + } + deriving stock (Eq, Show, Generic) + +prettyMajors :: NonEmpty Major -> Doc +prettyMajors = \case + [Major {prefix}] -> pretty prefix <> ".*" + majors -> [exon|#{pretty (NonEmpty.head majors).prefix}–#{pretty (NonEmpty.last majors).prefix}|] + +newtype Versions = + Versions (Map PackageName Version) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList, EncodeNix) + +instance NMap Versions PackageName Version LookupMaybe where + +instance Pretty Versions where + pretty = nPretty + +instance FromJSON Versions where + parseJSON v = + Versions . fmap jsonParsec <$> parseJSON v + +packageIdVersions :: [PackageId] -> Versions +packageIdVersions = + nGenWith \ PackageId {name, version} -> (name, version) diff --git a/lib/Hix/Data/VersionBounds.hs b/lib/Hix/Data/VersionBounds.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Data/VersionBounds.hs @@ -0,0 +1,152 @@ +module Hix.Data.VersionBounds where + +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (Object, String), object, (.:?), (.=)) +import Data.Aeson.Types (typeMismatch) +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Version ( + Version, + VersionRange, + earlierVersion, + intersectVersionRanges, + orLaterVersion, + simplifyVersionRange, + thisVersion, + ) + +import Hix.Class.EncodeNix (EncodeNix) +import Hix.Data.Json (aesonParsec, jsonParsec) +import Hix.Data.Version (range0) +import Hix.Pretty (showP) +import Hix.Version (lowerVersion, upperVersion) + +data Bound = + BoundLower + | + BoundUpper + deriving stock (Eq, Show, Generic) + +instance Pretty Bound where + pretty = \case + BoundLower -> "lower" + BoundUpper -> "upper" + +data VersionBounds = + VersionBounds { + lower :: Maybe Version, + upper :: Maybe Version + } + deriving stock (Eq, Show, Generic) + deriving anyclass (EncodeNix) + +instance Semigroup VersionBounds where + left <> right = VersionBounds {lower = left.lower <|> right.lower, upper = left.upper <|> right.upper} + +instance Monoid VersionBounds where + mempty = VersionBounds {lower = Nothing, upper = Nothing} + +unsafeVersionBoundsFromRange :: VersionRange -> VersionBounds +unsafeVersionBoundsFromRange range = + VersionBounds {lower = lowerVersion range, upper = upperVersion range} + +instance FromJSON VersionBounds where + parseJSON = \case + String s -> do + range <- aesonParsec (toString s) + pure (unsafeVersionBoundsFromRange range) + Object o -> do + lower <- fmap jsonParsec <$> o .:? "lower" + upper <- fmap jsonParsec <$> o .:? "upper" + pure VersionBounds {..} + v -> do + let + expected = + "a managed bound as either a string containing a Cabal-style range or an object with 'lower' and/or 'upper'" + <> + " as keys and simple versions as values" + typeMismatch expected v + +instance ToJSON VersionBounds where + toJSON VersionBounds {..} = + object [ + "lower" .= toJSON (showP @Text <$> lower), + "upper" .= toJSON (showP @Text <$> upper) + ] + +maybeRange :: + (Bound -> Version -> VersionRange) -> + VersionBounds -> + Maybe VersionRange +maybeRange mkRange bounds + | Just l <- bounds.lower + , Just u <- bounds.upper + , u <= l + = Just (thisVersion l) + + | Just l <- lower + , Just u <- upper + = Just (simplifyVersionRange (intersectVersionRanges l u)) + + | Just l <- lower + , Nothing <- upper + = Just l + + | Nothing <- lower + , Just u <- upper + = Just u + + | Nothing <- lower + , Nothing <- upper + = Nothing + where + lower = mkRange BoundLower <$> bounds.lower + upper = mkRange BoundUpper <$> bounds.upper + +-- | Return a @==lower@ range for invalid bounds. +-- The constructors prevent this from happening, so it's maybe for tests? +-- Probably better to make the type abstract and crash. +maybeMajorRange :: + VersionBounds -> + Maybe VersionRange +maybeMajorRange = + maybeRange \case + BoundLower -> orLaterVersion + BoundUpper -> earlierVersion + +majorRange :: VersionBounds -> VersionRange +majorRange = fromMaybe range0 . maybeMajorRange + +instance Pretty VersionBounds where + pretty = pretty . majorRange + +anyBounds :: VersionBounds +anyBounds = + VersionBounds {lower = Nothing, upper = Nothing} + +versionBounds :: Version -> Version -> VersionBounds +versionBounds lower upper = + VersionBounds {lower = Just lower, upper = Just upper} + +fromLower :: Version -> VersionBounds +fromLower lower = + VersionBounds {lower = Just lower, upper = Nothing} + +fromUpper :: Version -> VersionBounds +fromUpper upper = + VersionBounds {lower = Nothing, upper = Just upper} + +exactVersion :: Version -> VersionBounds +exactVersion version = versionBounds version version + +withLower :: Version -> VersionBounds -> VersionBounds +withLower lower VersionBounds {upper} = + VersionBounds {lower = Just lower, upper = clamp =<< upper} + where + clamp old | old < lower = Nothing + | otherwise = Just old + +withUpper :: Version -> VersionBounds -> VersionBounds +withUpper upper VersionBounds {lower} = + VersionBounds {lower = clamp =<< lower, upper = Just upper} + where + clamp old | old > upper = Nothing + | otherwise = Just old diff --git a/lib/Hix/Env.hs b/lib/Hix/Env.hs --- a/lib/Hix/Env.hs +++ b/lib/Hix/Env.hs @@ -5,18 +5,14 @@ import Hix.Component (targetComponent) import qualified Hix.Data.ComponentConfig -import Hix.Data.ComponentConfig ( - EnvRunner (EnvRunner), - PackageName, - PackagesConfig, - TargetOrDefault (DefaultTarget, ExplicitTarget), - ) -import Hix.Data.Error (pathText) +import Hix.Data.ComponentConfig (EnvRunner (EnvRunner), PackagesConfig, TargetOrDefault (DefaultTarget, ExplicitTarget)) +import Hix.Error (Error (EnvError), pathText) import qualified Hix.Data.GhciConfig -import Hix.Json (jsonConfig) -import Hix.Monad (M) -import qualified Hix.Options as Options -import Hix.Options (EnvRunnerOptions, TargetSpec) +import qualified Hix.Data.Options as Options +import Hix.Data.Options (EnvRunnerOptions, TargetSpec) +import Hix.Data.PackageName (PackageName) +import Hix.Json (jsonConfigE) +import Hix.Data.Monad (M) -- TODO when there is a solution for default command env fallback configuration, the DefaultTarget case must return -- Nothing when the config requests it @@ -34,7 +30,7 @@ envRunner :: EnvRunnerOptions -> M EnvRunner envRunner opts = do - config <- either pure jsonConfig opts.config + config <- jsonConfigE EnvError opts.config let runner = componentRunner opts.root config.mainPackage config.packages fromMaybe config.defaultEnv . join <$> traverse runner opts.component diff --git a/lib/Hix/Error.hs b/lib/Hix/Error.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Error.hs @@ -0,0 +1,115 @@ +module Hix.Error ( + module Hix.Data.Error, + module Hix.Error, +) where + +import Control.Monad.Trans.Except (ExceptT, throwE) +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 (..)) + +pathText :: Path b t -> Text +pathText = + toText . toFilePath + +prefixedError :: + MonadIO m => + Text -> + Text -> + m () +prefixedError desc msg = + Console.err (errorMessage [exon|#{desc}: #{msg}|]) + +printPreprocError :: + MonadIO m => + Text -> + m () +printPreprocError = + prefixedError "Preprocessor generator failed" + +printEnvError :: + MonadIO m => + Text -> + m () +printEnvError = + prefixedError "Invalid env config" + +printGhciError :: + MonadIO m => + Text -> + m () +printGhciError = + prefixedError "Invalid ghci config" + +printNewError :: + MonadIO m => + Text -> + m () +printNewError = + prefixedError "Can't create new project" + +printBootstrapError :: + MonadIO m => + Text -> + m () +printBootstrapError = + prefixedError "Can't bootstrap project" + +printFatalError :: + MonadIO m => + Text -> + m () +printFatalError = + prefixedError "Fatal error" + +sourceError :: Text -> Path b t -> Text +sourceError reason source = + [exon|#{reason} the source file '#{pathText source}'|] + +catchIO :: + (Text -> ExceptT Error IO a) -> + IO a -> + ExceptT Error IO a +catchIO handleError ma = + liftIO (tryIOError ma) >>= \case + Right a -> pure a + Left err -> handleError (show err) + +tryIOWith :: + (Text -> Error) -> + IO a -> + ExceptT Error IO a +tryIOWith mkErr ma = + liftIO (tryIOError ma) >>= \case + Right a -> pure a + Left err -> throwE (mkErr (show err)) + +tryIO :: + IO a -> + ExceptT Error IO a +tryIO = + tryIOWith Fatal + +note :: Text -> Maybe a -> ExceptT Error IO a +note err = + maybe (throwE (GhciError err)) pure + +printError :: + MonadIO m => + Bool -> + 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) diff --git a/lib/Hix/Ghci.hs b/lib/Hix/Ghci.hs --- a/lib/Hix/Ghci.hs +++ b/lib/Hix/Ghci.hs @@ -1,6 +1,5 @@ module Hix.Ghci where -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, catchE) import Data.List.Extra (nubOrd) import qualified Data.Map.Strict as Map @@ -19,19 +18,16 @@ ComponentConfig, ModuleName (ModuleName), PackageConfig, - PackageName, SourceDir (SourceDir), Target (Target), ) -import Hix.Data.Error (Error, note, pathText, tryIO) import qualified Hix.Data.GhciConfig import Hix.Data.GhciConfig (GhciConfig, GhciRunExpr (GhciRunExpr), GhciSetupCode (GhciSetupCode)) import qualified Hix.Data.GhciTest as GhciTest import Hix.Data.GhciTest (GhciRun (GhciRun), GhciTest (GhciTest), GhcidRun (GhcidRun)) -import Hix.Json (jsonConfig) -import Hix.Monad (M, noteGhci) -import qualified Hix.Options as Options -import Hix.Options ( +import Hix.Data.Monad (liftE) +import qualified Hix.Data.Options as Options +import Hix.Data.Options ( ExtraGhciOptions (ExtraGhciOptions), ExtraGhcidOptions (ExtraGhcidOptions), GhciOptions (GhciOptions), @@ -39,6 +35,10 @@ TargetSpec (TargetForFile), TestOptions (TestOptions), ) +import Hix.Data.PackageName (PackageName) +import Hix.Error (Error (GhciError), note, pathText, tryIO) +import Hix.Json (jsonConfigE) +import Hix.Monad (M, noteGhci) import Hix.Path (rootDir) relativeToComponent :: @@ -108,7 +108,7 @@ assemble :: GhciOptions -> M GhciTest assemble opt = do - config <- either pure jsonConfig opt.config + 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 @@ -175,8 +175,8 @@ M GhciRun ghciCmdlineFromOptions tmp opt = do conf <- assemble opt - shellScriptFile <- lift (ghciScriptFile tmp conf.script) - runScriptFile <- lift (traverse (ghciScriptFile tmp) conf.test) + shellScriptFile <- liftE (ghciScriptFile tmp conf.script) + runScriptFile <- liftE (traverse (ghciScriptFile tmp) conf.test) pure (ghciCmdline conf opt.extra shellScriptFile runScriptFile) ghcidCmdlineFromOptions :: @@ -195,7 +195,7 @@ GhciOptions -> M () printGhciCmdline opt = do - tmp <- lift hixTempDir + tmp <- liftE hixTempDir cmd <- ghciCmdlineFromOptions tmp opt liftIO (Text.putStrLn [exon|ghci #{cmd.shell} #{fold cmd.run}|]) @@ -203,6 +203,6 @@ GhcidOptions -> M () printGhcidCmdline opt = do - tmp <- lift hixTempDir + tmp <- liftE hixTempDir cmd <- ghcidCmdlineFromOptions tmp opt liftIO (Text.putStrLn cmd.cmdline) diff --git a/lib/Hix/Hackage.hs b/lib/Hix/Hackage.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Hackage.hs @@ -0,0 +1,120 @@ +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 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) + +data HackageVersions = + HackageVersions { + versions :: [String] + } + deriving stock (Eq, Show, Generic) + +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")] + } + + noVersion msg = + [] <$ Log.error [exon|Hackage request for '##{pkg}' failed: #{msg}|] + +latestVersionHackage :: Manager -> PackageName -> M (Maybe Version) +latestVersionHackage manager pkg = + head <$> versionsHackage manager pkg + +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 + +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 + + addToCache hash = liftIO (modifyIORef' cacheRef (Map.insert cacheKey hash)) + + cacheKey = renderPackage package diff --git a/lib/Hix/Json.hs b/lib/Hix/Json.hs --- a/lib/Hix/Json.hs +++ b/lib/Hix/Json.hs @@ -1,20 +1,20 @@ module Hix.Json where -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (throwE) import qualified Data.Aeson as Aeson import Data.Aeson (FromJSON, fromJSON) import Exon (exon) -import Hix.Data.Error (Error (GhciError)) -import Hix.Monad (M) +import Hix.Data.Error (Error) +import Hix.Data.Monad (M) +import Hix.Monad (throwM) import Hix.Optparse (JsonConfig (JsonConfig)) jsonConfig :: FromJSON a => + (Text -> Error) -> JsonConfig -> M a -jsonConfig (JsonConfig mv) = +jsonConfig consError (JsonConfig mv) = liftIO mv >>= \case Left msg -> failure [exon|Invalid JSON: #{toText msg}|] Right v -> case fromJSON v of @@ -22,4 +22,12 @@ Aeson.Error err -> failure [exon|Invalid JSON: #{toText err} #{show v}|] where - failure = lift . throwE . GhciError + failure = throwM . consError + +jsonConfigE :: + FromJSON a => + (Text -> Error) -> + Either a JsonConfig -> + M a +jsonConfigE consError = + either pure (jsonConfig consError) diff --git a/lib/Hix/Log.hs b/lib/Hix/Log.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Log.hs @@ -0,0 +1,61 @@ +module Hix.Log where + +import Control.Monad.Trans.Reader (ask) +import Exon (exon) +import Text.PrettyPrint (Doc) + +import Hix.Console (color, withChevrons) +import qualified Hix.Data.Monad +import Hix.Data.Monad (LogLevel (..), M (M)) + +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) + +debug :: Text -> M () +debug msg = + log LogDebug [exon|[#{color 6 "debug"}] #{msg}|] + +debugP :: Doc -> M () +debugP = debug . show + +info :: Text -> M () +info msg = + log LogInfo (withChevrons 5 msg) + +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}|] + +error :: Text -> M () +error msg = + log LogError (withChevrons 1 [exon|Error: #{msg}|]) + +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 + case level of + LogDebug | env.debug -> accept + LogVerbose | minVerbose -> accept + LogInfo | minInfo -> accept + LogWarn | minInfo -> accept + LogError -> accept + _ -> unit + where + accept = liftIO (handler level msg) diff --git a/lib/Hix/Managed/Build.hs b/lib/Hix/Managed/Build.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Build.hs @@ -0,0 +1,216 @@ +module Hix.Managed.Build where + +import Control.Monad (foldM) +import qualified Data.Map.Strict as Map +import Distribution.Pretty (Pretty) +import Exon (exon) +import Text.PrettyPrint (vcat) + +import Hix.Data.EnvName (EnvName) +import Hix.Data.Monad (M) +import Hix.Data.Overrides (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.Solve (solveMutation) +import qualified Hix.Managed.Cabal.Changes +import Hix.Managed.Cabal.Config (isNonReinstallableDep, isReinstallableId) +import Hix.Managed.Cabal.Data.SolverState (SolverState) +import qualified Hix.Managed.Data.BuildConfig +import Hix.Managed.Data.BuildConfig (BuildConfig) +import qualified Hix.Managed.Data.EnvContext +import Hix.Managed.Data.EnvContext (EnvContext) +import Hix.Managed.Data.Mutable (MutableDep, addBuildVersions) +import qualified Hix.Managed.Data.Mutation +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.Query (Query (Query)) +import qualified Hix.Managed.Data.QueryDep +import Hix.Managed.Data.QueryDep (QueryDep) +import qualified Hix.Managed.Data.StageContext +import Hix.Managed.Data.StageContext (StageContext (StageContext)) +import qualified Hix.Managed.Data.StageState +import Hix.Managed.Data.StageState ( + BuildStatus (Failure, Success), + StageState, + failed, + initStageState, + iterations, + justSuccess, + ) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.Handlers.Build (EnvBuilder) +import qualified Hix.Managed.Handlers.Mutation +import Hix.Managed.Handlers.Mutation (MutationHandlers) +import Hix.Managed.StageState (updateStageState) +import Hix.Pretty (prettyL, showP, showPL) + +logBuildInputs :: + EnvName -> + Text -> + [PackageId] -> + M () +logBuildInputs env description overrides = do + Log.info [exon|Building targets in '##{env}' with #{description}...|] + Log.debugP (vcat ["Overrides:", prettyL overrides]) + +logBuildResult :: Text -> BuildStatus -> M () +logBuildResult description status = + Log.info [exon|Build with ##{description} #{result status}|] + where + result = \case + Success -> "succeeded" + Failure -> "failed" + +updateMutationState :: + (Version -> VersionBounds -> VersionBounds) -> + Versions -> + Overrides -> + MutationState -> + MutationState +updateMutationState updateBound newVersions overrides MutationState {bounds, versions, initial} = + updateBoundsWith updateBound MutationState { + bounds, + versions = addBuildVersions newVersions versions, + overrides, + initial + } + +-- | /Note/: This quietly discards non-reinstallable packages. +-- +-- TODO Discard installed versions, for builds with initial versions. +buildVersions :: + EnvBuilder -> + EnvContext -> + Text -> + Versions -> + [PackageId] -> + M (Overrides, BuildStatus) +buildVersions builder context description versions overrideVersions = do + logBuildInputs context.env description reinstallable + (overrides, status) <- builder.buildWithState versions reinstallable + logBuildResult description status + pure (overrides, status) + where + reinstallable = filter isReinstallableId overrideVersions + +buildConstraints :: + EnvBuilder -> + EnvContext -> + Text -> + SolverState -> + M (Maybe (Versions, Overrides, BuildStatus)) +buildConstraints builder context description state = + solveMutation builder.cabal context.deps state >>= traverse \ changes -> do + (overrides, status) <- buildVersions builder context description changes.versions changes.overrides + pure (changes.versions, overrides, status) + +buildMutation :: + EnvBuilder -> + EnvContext -> + MutationState -> + BuildMutation -> + M (Maybe MutationState) +buildMutation builder context state BuildMutation {description, solverState, updateBound} = + result <$> buildConstraints builder context description solverState + where + result = \case + Just (versions, overrides, status) -> + justSuccess (updateMutationState updateBound versions overrides state) status + Nothing -> Nothing + +logMutationResult :: + MutableDep -> + MutationResult s -> + M () +logMutationResult package = \case + MutationSuccess candidate True _ _ -> + Log.verbose [exon|Build succeeded for #{showP candidate}|] + MutationSuccess _ False _ _ -> + Log.verbose [exon|Build is up to date for '##{package}'|] + MutationKeep -> + Log.verbose [exon|No better version found for '##{package}'|] + MutationFailed -> + Log.verbose [exon|Could not find a buildable version of '##{package}'|] + +validateMutation :: + EnvBuilder -> + EnvContext -> + MutationHandlers a s -> + StageState a s -> + DepMutation a -> + M (StageState a s) +validateMutation envBuilder context handlers stageState mutation = do + result <- processReinstallable + 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 + +convergeMutations :: + Pretty a => + MutationHandlers a s -> + BuildConfig -> + EnvBuilder -> + EnvContext -> + StageState a s -> + [DepMutation a] -> + M (StageState a s) +convergeMutations handlers conf builder context state0 = + spin state0 {iterations = 0} + where + spin state mutations + + | [] <- mutations + = pure state + + | state.iterations >= conf.maxIterations + = pure state + + | otherwise + = do + Log.debug [exon|Iteration #{show (state.iterations + 1)} for '##{context.env :: EnvName}'|] + newState <- build state 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} + Log.debug [exon|Building targets with mutations: #{showPL mutations}|] + foldM (validateMutation builder context handlers) state mutations + +reinstallableCandidates :: + (QueryDep -> M (Maybe (DepMutation a))) -> + Query -> + M [DepMutation a] +reinstallableCandidates candidates (Query query) = + catMaybes <$> traverse reinstallableOnly (toList query) + where + reinstallableOnly dep + | isNonReinstallableDep dep.package + = pure Nothing + | otherwise + = candidates dep + +processQuery :: + Pretty a => + (QueryDep -> M (Maybe (DepMutation a))) -> + MutationHandlers a s -> + BuildConfig -> + StageContext -> + s -> + M (StageState a s) +processQuery candidates handlers conf StageContext {env, builder, state, query = query} ext = do + mutations <- reinstallableCandidates candidates query + convergeMutations handlers conf builder env stageState mutations + where + stageState = initStageState state ext diff --git a/lib/Hix/Managed/Build/Mutation.hs b/lib/Hix/Managed/Build/Mutation.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Build/Mutation.hs @@ -0,0 +1,77 @@ +module Hix.Managed.Build.Mutation where + +import Control.Lens ((.~)) +import Exon (exon) + +import Hix.Class.Map (nAdjust, nAmendWithKey) +import Hix.Data.Monad (M) +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (VersionBounds, exactVersion) +import qualified Hix.Log as Log +import Hix.Managed.Cabal.Data.SolverState (SolverState, updateSolverState) +import Hix.Managed.Data.Constraints (EnvConstraints, MutationConstraints) +import Hix.Managed.Data.Mutable (MutableDep, depName, mutRelax) +import qualified Hix.Managed.Data.MutableId +import Hix.Managed.Data.MutableId (MutableId (MutableId)) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (BuildMutation (BuildMutation)) +import qualified Hix.Managed.Data.MutationState +import Hix.Managed.Data.MutationState (MutationState) +import Hix.Managed.Data.Packages (Deps) +import Hix.Pretty (showP) + +candidateMutation :: + SolverState -> + MutableId -> + (Version -> VersionBounds -> VersionBounds) -> + BuildMutation +candidateMutation solverState candidate updateBound = + BuildMutation { + description = showP candidate, + solverState, + updateBound + } + +candidateConstraints :: MutableId -> EnvConstraints -> EnvConstraints +candidateConstraints MutableId {..} constraints = + nAdjust (depName name) constraints (#mutation .~ exactVersion version) + +updateConstraints :: + (MutableId -> PackageId -> MutationConstraints -> MutationConstraints) -> + MutableId -> + MutationState -> + EnvConstraints -> + EnvConstraints +updateConstraints impl candidate state = + nAmendWithKey update (mutRelax state.versions :: Deps (Maybe Version)) + where + update name = \case + Just version -> impl candidate PackageId {..} + Nothing -> id + +-- | Boilerplate for mutation handlers, could be better. +-- +-- 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)) -> + (Version -> VersionBounds -> VersionBounds) -> + (MutableId -> PackageId -> MutationConstraints -> MutationConstraints) -> + SolverState -> + MutableDep -> + Version -> + 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 = (candidate, newSolverState newState, newState) + + candidate = MutableId {name = package, version} + + mutationSolverState = updateSolverState (candidateConstraints candidate) solverState + + newSolverState newState = + updateSolverState (updateConstraints updateConstraintBound candidate newState) solverState diff --git a/lib/Hix/Managed/Build/Single.hs b/lib/Hix/Managed/Build/Single.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Build/Single.hs @@ -0,0 +1,25 @@ +module Hix.Managed.Build.Single where + +import Hix.Data.Monad (M) +import Hix.Data.VersionBounds (exactVersion) +import Hix.Managed.Build (buildConstraints) +import Hix.Managed.Cabal.Data.SolverState (solverState) +import Hix.Managed.Constraints (fromVersions) +import qualified Hix.Managed.Data.EnvContext +import Hix.Managed.Data.EnvContext (EnvContext) +import Hix.Managed.Data.Mutable (MutableVersions) +import Hix.Managed.Data.StageState (BuildStatus (Failure)) +import Hix.Managed.Handlers.Build (EnvBuilder) + +buildVersions :: + EnvBuilder -> + EnvContext -> + Text -> + MutableVersions -> + M BuildStatus +buildVersions builder context description versions = + buildConstraints builder context description solver <&> \case + Just (_, _, status) -> status + Nothing -> Failure + where + solver = solverState context.solverBounds context.deps (fromVersions exactVersion versions) def diff --git a/lib/Hix/Managed/Build/Solve.hs b/lib/Hix/Managed/Build/Solve.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Build/Solve.hs @@ -0,0 +1,51 @@ +module Hix.Managed.Build.Solve where + +import qualified Data.Set as Set +import Distribution.Pretty (pretty) +import Exon (exon) +import Text.PrettyPrint (hang) + +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.Version (packageIdVersions) +import qualified Hix.Log as Log +import qualified Hix.Managed.Cabal.Changes +import Hix.Managed.Cabal.Changes (SolverChanges (SolverChanges), SolverPlan (SolverPlan)) +import Hix.Managed.Cabal.Data.SolverState (SolverState) +import qualified Hix.Managed.Data.EnvContext +import Hix.Managed.Data.EnvContext (EnvDeps) +import Hix.Managed.Data.Mutable (depName) +import qualified Hix.Managed.Handlers.Cabal +import Hix.Managed.Handlers.Cabal (CabalHandlers) +import Hix.Pretty (showPL) + +logNonReinstallable :: NonEmpty PackageId -> M () +logNonReinstallable ids = + Log.verbose [exon|NOTE: Cabal solver suggested new versions for non-reinstallable packages: #{showPL ids}|] + +-- TODO Do we need to filter locals out of @matching@ or can those not be in there? +processSolverPlan :: + EnvDeps -> + SolverPlan -> + M SolverChanges +processSolverPlan deps SolverPlan {..} = do + Log.debugP (hang "New project deps from solver:" 2 (pretty projectDeps)) + traverse_ logNonReinstallable nonReinstallable + pure SolverChanges {versions, overrides, projectDeps} + where + projectDeps = nRestrictKeys mutablePIds versions + versions = packageIdVersions (overrides ++ matching) + overrides = filter notLocal changes + notLocal PackageId {name} = not (isLocalPackage deps.local name) + mutablePIds = Set.fromList (depName <$> Set.toList deps.mutable) + +solveMutation :: + CabalHandlers -> + EnvDeps -> + SolverState -> + M (Maybe SolverChanges) +solveMutation cabal deps state = + traverse (processSolverPlan deps) =<< cabal.solveForVersion state diff --git a/lib/Hix/Managed/BuildOutput.hs b/lib/Hix/Managed/BuildOutput.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/BuildOutput.hs @@ -0,0 +1,67 @@ +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.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 qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.ProjectResult (ProjectResult) +import qualified Hix.Managed.EnvResult +import Hix.Managed.EnvResult ( + DepModification (DepAdded, DepUpdated), + DepResult, + DepResultDetail (DepModified), + DepResults (DepResults), + ) +import qualified Hix.Managed.ProjectResult as ProjectResult +import qualified Hix.OutputWriter +import Hix.OutputWriter (outputWriterGlobal) + +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 + +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 + +modifiedId :: DepResult -> ModifiedId +modifiedId result = + ModifiedId {package = result.package, version = result.version, range} + where + range = case result.detail of + DepModified (DepUpdated (justThere -> Just _)) -> Just result.bounds + DepModified (DepAdded _) -> Just result.bounds + _ -> Nothing + +buildOutput :: ProjectResult -> BuildOutput +buildOutput result = + buildOutputFromLists modified ((.package) <$> unmodified) failed + where + modified = modifiedId <$> nubSortOn (.package) (added ++ updated) + failed = (.package) <$> ProjectResult.failures result + DepResults {..} = ProjectResult.grouped result diff --git a/lib/Hix/Managed/BuildOutput/CommitMsg.hs b/lib/Hix/Managed/BuildOutput/CommitMsg.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/BuildOutput/CommitMsg.hs @@ -0,0 +1,32 @@ +module Hix.Managed.BuildOutput.CommitMsg where + +import qualified Data.Text as Text +import Exon (exon) + +import qualified Hix.Managed.Data.BuildOutput +import Hix.Managed.Data.BuildOutput (BuildOutput, ModifiedId) +import Hix.Pretty (showP) + +commitMessage :: Int -> Text -> Text +commitMessage num names + | num <= 3 + = [exon|Bump #{names}|] + | otherwise + = [exon|Bump #{show num} dependencies|] + +candidateList :: [ModifiedId] -> [Text] +candidateList = fmap \ c -> [exon|* #{showP c}|] + +commitBody :: [ModifiedId] -> [Text] +commitBody candidates = + ["New versions:", ""] ++ candidateList candidates + +commit :: BuildOutput -> Maybe (Text, [Text]) +commit output = + output.modifiedNames <&> \ names -> + (commitMessage (length output.modified) names, commitBody output.modified) + +formatCommit :: BuildOutput -> Maybe Text +formatCommit output = + commit output <&> \ (msg, body) -> + Text.intercalate "\n" ([msg, ""] ++ body) diff --git a/lib/Hix/Managed/BuildOutput/GithubActionsPr.hs b/lib/Hix/Managed/BuildOutput/GithubActionsPr.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/BuildOutput/GithubActionsPr.hs @@ -0,0 +1,58 @@ +module Hix.Managed.BuildOutput.GithubActionsPr where + +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 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}|]) + +formatOutput :: Text -> [Text] -> [Text] +formatOutput key = \case + [value] -> [[exon|#{key}=#{value}|]] + value -> [exon|#{key}< [Text] +formatOutputs = + concatMap (uncurry formatOutput) . Map.toList + +writeOutputs :: OutputWriter -> Map Text [Text] -> M () +writeOutputs writer values = + writer.textAppend (Text.unlines (formatOutputs values)) + +modifiedOutputs :: Text -> Text -> [Text] -> Map Text [Text] +modifiedOutputs date msg body = + [ + ("branch", [[exon|hix-managed/bump-#{date}|]]), + ("commit-message", [msg, ""] ++ body), + ("title", [msg]), + ("body", body), + ("committer", ["hix "]), + ("signoff", ["false"]), + ("delete-branch", ["true"]) + ] + +githubActionsPr :: BuildOutput -> OutputTarget -> M () +githubActionsPr output target = + for_ (commit output) \ (msg, body) -> do + date <- liftIO epochTime + writer <- outputWriterM envVarWriter target + writeOutputs writer (modifiedOutputs (show date) msg body) diff --git a/lib/Hix/Managed/Bump/App.hs b/lib/Hix/Managed/Bump/App.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Bump/App.hs @@ -0,0 +1,17 @@ +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.Managed.Bump.Optimize (bumpOptimizeMain) +import qualified Hix.Managed.Data.ProjectContextProto +import Hix.Managed.Handlers.Build.Test (chooseHandlers) +import Hix.Managed.ProjectContext (withProjectContext) + +bumpCli :: BumpOptions -> M () +bumpCli BumpOptions {common = opts} = do + context <- jsonConfigE Client opts.context + handlers <- liftIO (chooseHandlers opts.stateFile context.envs context.buildOutputsPrefix opts.cabal opts.handlers) + withProjectContext handlers opts.project context (bumpOptimizeMain handlers) diff --git a/lib/Hix/Managed/Bump/Candidates.hs b/lib/Hix/Managed/Bump/Candidates.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Bump/Candidates.hs @@ -0,0 +1,47 @@ +module Hix.Managed.Bump.Candidates where + +import Distribution.Version (Version) + +import Hix.Data.Monad (M) +import qualified Hix.Managed.Data.Bump +import Hix.Managed.Data.Bump (Bump (Bump)) +import Hix.Managed.Data.Mutable (depName) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (DepMutation (DepMutation)) +import qualified Hix.Managed.Data.QueryDep +import Hix.Managed.Data.QueryDep (QueryDep (QueryDep)) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.Handlers.Build (BuildHandlers) +import Hix.Version (nextMajor) + +-- | We only want to report a bump if the new version actually changes the build. +isBump :: Version -> Maybe Version -> Bool +isBump version = \case + Just current -> version > current + Nothing -> True + +-- | Decide whether the latest version of a dependency requires changes to the currently specified bound. +-- +-- If no latest version can be found, we return 'Nothing' to indicate that the dep should be skipped. +-- +-- Otherwise, the range field of the 'DepMutation' is determined: +-- +-- If the specified dependency has no upper bound (e.g. because the user has only entered the package name and ran the +-- app to resolve the bounds), or if the latest version is outside of the existing bounds, then we add a new bound to +-- the managed state, so we extend the version range by setting the upper bound to the major prefix of the next-highest +-- major of the latest version and return 'NewBounds'. +-- +-- Otherwise, we return 'OldBounds'. +candidatesBump :: + BuildHandlers -> + QueryDep -> + M (Maybe (DepMutation Bump)) +candidatesBump handlers QueryDep {package, current} = do + fmap mutation <$> handlers.latestVersion (depName package) + where + mutation version = + DepMutation { + package, + retract = False, + mutation = Bump {version, bound = nextMajor version, changed = isBump version current} + } diff --git a/lib/Hix/Managed/Bump/Optimize.hs b/lib/Hix/Managed/Bump/Optimize.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Bump/Optimize.hs @@ -0,0 +1,126 @@ +module Hix.Managed.Bump.Optimize where + +import Exon (exon) + +import Hix.Class.Map (nMap) +import Hix.Data.Monad (M) +import qualified Hix.Data.Overrides +import Hix.Data.VersionBounds (fromLower) +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 qualified Hix.Managed.Data.BuildConfig +import Hix.Managed.Data.BuildConfig (BuildConfig) +import Hix.Managed.Data.Bump (Bump (..)) +import Hix.Managed.Data.Constraints (EnvConstraints) +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 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)) +import qualified Hix.Managed.Data.StageContext +import Hix.Managed.Data.StageContext (StageContext (StageContext)) +import Hix.Managed.Data.StageResult (StageResult, StageSummary (StageNoAction, StageReport)) +import Hix.Managed.Data.StageState (BuildStatus, BuildSuccess) +import Hix.Managed.Flow (Flow, execStage, execStatelessStage) +import qualified Hix.Managed.Handlers.Build +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.Report (describeIterations) +import Hix.Managed.StageResult (stageResult) + +-- | Solver params for Bump consist of, in decreasing order of precedence: +-- +-- - User-specified bounds (added by the constructor 'solverState'). +-- +-- - The existing overrides from previous runs, used as preferred versions. +-- This ensures that the solver selects the same versions as in the last run while still allowing newer versions for +-- transitive dependencies that are later in the candidate list. +-- +-- - Installed versions from the package db, used as lower bounds. +-- +-- - 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 -> + EnvConstraints +bumpSolverParams deps cabal (Initial state) = + preferVersions (nMap (.version) state.overrides) <> + fromVersions fromLower (installedVersions cabal deps.mutable) <> + preferInstalled deps.mutable + +success :: Map MutableDep BuildSuccess -> Natural -> Text +success _ iterations = + [exon|Found working latest versions for all deps after #{iter}.|] + where + iter = describeIterations iterations + +failure :: Natural -> Text +failure iterations = + [exon|Couldn't find working latest versions for some deps after #{describeIterations iterations}.|] + +bumpBuild :: + BuildHandlers -> + BuildConfig -> + StageContext -> + M StageResult +bumpBuild handlers conf stage@StageContext {env, builder, state} = 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 + flags = SolverFlags {allowNewer = True} + +bumpBuildStage :: + BuildHandlers -> + BuildConfig -> + Flow BuildStatus +bumpBuildStage handlers conf = + execStage "bump" (bumpBuild handlers conf) + +bumpReportStage :: + BuildHandlers -> + Flow BuildStatus +bumpReportStage handlers = + execStatelessStage "bump-report" \ StageContext {query = Query query} -> + toSummary . toCandidates <$> traverse (candidatesBump handlers) (toList query) + where + toSummary = \case + Just cs -> StageReport "Found new versions:" cs + Nothing -> StageNoAction (Just "All dependencies are up to date.") + + toCandidates = nonEmpty . fmap toCandidate . catMaybes + + toCandidate DepMutation {package = name, mutation = Bump {version}} = + MutableId {..} + +bumpStages :: + BuildHandlers -> + BuildConfig -> + Flow BuildStatus +bumpStages handlers conf + | conf.lookup + = bumpReportStage handlers + | otherwise + = bumpBuildStage handlers conf + +bumpOptimizeMain :: + BuildHandlers -> + ProjectContext -> + M ProjectResult +bumpOptimizeMain handlers project = + processProject handlers project (void (bumpStages handlers project.build)) diff --git a/lib/Hix/Managed/Cabal/Changes.hs b/lib/Hix/Managed/Cabal/Changes.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Changes.hs @@ -0,0 +1,67 @@ +module Hix.Managed.Cabal.Changes where + +import Data.List (partition) +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.SolverInstallPlan (ResolverPackage (Configured, PreExisting), SolverInstallPlan) +import Distribution.InstalledPackageInfo (InstalledPackageInfo (..)) +import Distribution.Pretty (Pretty, pretty) +import Distribution.Solver.Types.InstSolverPackage (InstSolverPackage (..)) +import Distribution.Solver.Types.SolverPackage (SolverPackage (..)) +import Distribution.Solver.Types.SourcePackage (SourcePackage (..)) +import Text.PrettyPrint (hang, ($+$)) + +import qualified Hix.Data.PackageId as PackageId +import Hix.Data.PackageId (PackageId) +import Hix.Data.Version (Versions) +import Hix.Managed.Cabal.Config (isNonReinstallableId) +import Hix.Pretty (prettyL) + +-- | Raw results from Cabal, which include local packages in the overrides. +data SolverPlan = + SolverPlan { + -- | Deps whose versions differ from those in the package db, i.e. where the GHC set from nixpkgs has a different + -- version. + -- We need to add Nix overrides for these. + changes :: [PackageId], + + -- | Versions that match those in the package db. + -- We don't need to add Nix overrides for these. + matching :: [PackageId], + + -- | GHC boot packages that were selected for reinstallation, which is an error with the default settings. + nonReinstallable :: Maybe (NonEmpty PackageId) + } + deriving stock (Eq, Show, Generic) + +instance Pretty SolverPlan where + pretty SolverPlan {changes, matching} = + hang "changes:" 2 (prettyL changes) $+$ hang "matching:" 2 (prettyL matching) + +solverPlan :: + SolverInstallPlan -> + SolverPlan +solverPlan plan = + SolverPlan {..} + where + (nonEmpty -> nonReinstallable, changes) = partition isNonReinstallableId configured + + (configured, matching) = partitionEithers (mkVersion <$> SolverInstallPlan.toList plan) + + mkVersion = \case + Configured SolverPackage {solverPkgSource = SourcePackage {srcpkgPackageId}} -> + Left (PackageId.fromCabal srcpkgPackageId) + PreExisting InstSolverPackage {instSolverPkgIPI = InstalledPackageInfo {sourcePackageId}} -> + Right (PackageId.fromCabal sourcePackageId) + +data SolverChanges = + SolverChanges { + versions :: 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) diff --git a/lib/Hix/Managed/Cabal/Config.hs b/lib/Hix/Managed/Cabal/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Config.hs @@ -0,0 +1,35 @@ +module Hix.Managed.Cabal.Config where + +import qualified Data.Set as Set + +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId) +import Hix.Data.PackageName (PackageName) +import Hix.Managed.Data.Mutable (MutableDep, depName) + +nonReinstallableNames :: Set PackageName +nonReinstallableNames = + [ + "base", + "ghc-bignum", + "ghc-prim", + "ghc", + "integer-gmp", + "integer-simple", + "template-haskell" + ] + +isNonReinstallable :: PackageName -> Bool +isNonReinstallable = flip Set.member nonReinstallableNames + +isReinstallable :: PackageName -> Bool +isReinstallable = not . isNonReinstallable + +isNonReinstallableId :: PackageId -> Bool +isNonReinstallableId package = isNonReinstallable package.name + +isReinstallableId :: PackageId -> Bool +isReinstallableId package = isReinstallable package.name + +isNonReinstallableDep :: MutableDep -> Bool +isNonReinstallableDep = isNonReinstallable . depName diff --git a/lib/Hix/Managed/Cabal/Data/Config.hs b/lib/Hix/Managed/Cabal/Data/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Data/Config.hs @@ -0,0 +1,64 @@ +module Hix.Managed.Cabal.Data.Config where + +import Data.Aeson (FromJSON (parseJSON)) +import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Verbosity (Verbosity, verbose) +import Path (Abs, Dir, Path) + +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" + +newtype GhcPath = + GhcPath (Path Abs Dir) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON) + +data GhcDb = + GhcDbSystem (Maybe GhcPath) + | + GhcDbSynthetic GhcPackages + deriving stock (Eq, Show, Generic) + +instance FromJSON GhcDb where + parseJSON = fmap GhcDbSystem . parseJSON + +newtype HackageIndexState = + HackageIndexState Timestamp + deriving stock (Eq, Show, Generic) + +data CabalConfig = + CabalConfig { + indexState :: Maybe HackageIndexState + } + deriving stock (Eq, Show, Generic) + +instance Default CabalConfig where + def = + CabalConfig {indexState = Nothing} + +data SolveConfig = + SolveConfig { + hackageRepoName :: HackageRepoName, + verbosity :: Verbosity, + ghc :: Maybe GhcPath, + allowBoot :: Bool, + cabal :: CabalConfig + } + deriving stock (Eq, Show, Generic) + +instance Default SolveConfig where + def = + SolveConfig { + hackageRepoName = def, + verbosity = verbose, + ghc = Nothing, + allowBoot = False, + cabal = def + } diff --git a/lib/Hix/Managed/Cabal/Data/Packages.hs b/lib/Hix/Managed/Cabal/Data/Packages.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Data/Packages.hs @@ -0,0 +1,23 @@ +module Hix.Managed.Cabal.Data.Packages where + +import GHC.Exts (IsList) + +import Hix.Data.PackageId (PackageId) +import Hix.Managed.Cabal.Data.SourcePackage (SourcePackages) + +newtype InstalledPackages = + InstalledPackages [(PackageId, [PackageId])] + deriving stock (Eq, Show, Generic) + deriving newtype (IsList, Semigroup, Monoid) + +-- | Mock data for package indexes for the solver. +-- +-- Installed packages should not contain local packages, since they have fixed dependency versions. +-- Instead, they should be included in the available packages, but this is done automatically by the @SolveResources@ +-- initializer, so these here correspond only to Hackage packages. +data GhcPackages = + GhcPackages { + installed :: InstalledPackages, + available :: SourcePackages + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Cabal/Data/SolveResources.hs b/lib/Hix/Managed/Cabal/Data/SolveResources.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Data/SolveResources.hs @@ -0,0 +1,23 @@ +module Hix.Managed.Cabal.Data.SolveResources where + +import Distribution.Client.Dependency (DepResolverParams) +import Distribution.Client.Types (SourcePackageDb) +import Distribution.Simple (CompilerInfo) +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb) +import Distribution.System (Platform) + +import Hix.Managed.Cabal.Data.Config (SolveConfig (..)) +import Hix.Managed.Cabal.Init (SolveFlags) + +data SolveResources = + SolveResources { + conf :: SolveConfig, + flags :: SolveFlags, + platform :: Platform, + compiler :: CompilerInfo, + pkgConfigDb :: PkgConfigDb, + installedPkgIndex :: InstalledPackageIndex, + sourcePkgDb :: SourcePackageDb, + solverParams :: DepResolverParams -> DepResolverParams + } diff --git a/lib/Hix/Managed/Cabal/Data/SolveTarget.hs b/lib/Hix/Managed/Cabal/Data/SolveTarget.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Data/SolveTarget.hs @@ -0,0 +1,36 @@ +module Hix.Managed.Cabal.Data.SolveTarget where + +import Distribution.Client.Dependency (PackagePreference (..), PackageSpecifier (NamedPackage, SpecificSourcePackage)) +import Distribution.Client.Types (UnresolvedSourcePackage) +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Solver.Types.PackageConstraint (dispPackageProperty) +import Distribution.Version (simplifyVersionRange) +import Text.PrettyPrint (Doc, (<+>)) + +import Hix.Pretty (prettyL) + +data SolveTarget = + SolveTarget { + dep :: PackageSpecifier UnresolvedSourcePackage, + prefs :: [PackagePreference] + } + +prettySpec :: PackageSpecifier UnresolvedSourcePackage -> Doc +prettySpec = \case + NamedPackage name prop -> + "Named:" <+> pretty name <+> prettyL (dispPackageProperty <$> prop) + SpecificSourcePackage pkg -> + "Source:" <+> show pkg + +prettyPref :: PackagePreference -> Doc +prettyPref = \case + PackageVersionPreference pn vr -> + pretty pn <+> pretty (simplifyVersionRange vr) + PackageInstalledPreference pn ip -> + pretty pn <+> show ip + PackageStanzasPreference pn st -> + pretty pn <+> show st + +instance Pretty SolveTarget where + pretty SolveTarget {..} = + prettySpec dep <+> prettyL (prettyPref <$> prefs) diff --git a/lib/Hix/Managed/Cabal/Data/SolverState.hs b/lib/Hix/Managed/Cabal/Data/SolverState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Data/SolverState.hs @@ -0,0 +1,83 @@ +module Hix.Managed.Cabal.Data.SolverState ( + SolverState (SolverState, constraints, flags), + solverState, + updateSolverState, + SolverFlags (..), + compileSolverFlags, +) where + +import Distribution.Client.Dependency (DepResolverParams, removeUpperBounds) +import Distribution.Client.Types (RelaxDeps (RelaxDepsAll)) +import Distribution.Client.Types.AllowNewer (AllowNewer (AllowNewer)) +import GHC.Records (HasField (getField)) + +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 +import Hix.Managed.Data.EnvContext (EnvDeps) +import Hix.Managed.Data.Mutable (MutableDep, depName) + +data SolverFlags = + SolverFlags { + allowNewer :: Bool + } + deriving stock (Eq, Show, Generic) + +instance Default SolverFlags where + def = SolverFlags {allowNewer = False} + +flagAllowNewer :: DepResolverParams -> DepResolverParams +flagAllowNewer = + removeUpperBounds (AllowNewer RelaxDepsAll) + +compileSolverFlags :: SolverFlags -> DepResolverParams -> DepResolverParams +compileSolverFlags SolverFlags {..} = + flag flagAllowNewer allowNewer + where + flag f v | v = f + | otherwise = id + +data SolverState = + UnsafeSolverState EnvConstraints SolverFlags + deriving stock (Eq, Show) + +pattern SolverState :: EnvConstraints -> SolverFlags -> SolverState +pattern SolverState {constraints, flags} <- UnsafeSolverState constraints flags + +{-# complete SolverState #-} + +instance HasField "constraints" SolverState EnvConstraints where + getField (UnsafeSolverState c _) = c + +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) + +solverState :: + Ranges -> + EnvDeps -> + EnvConstraints -> + SolverFlags -> + SolverState +solverState user deps modeConstraints flags = + UnsafeSolverState constraints flags + where + constraints = + modeConstraints <> + explicitBounds user <> + localDepConstraints deps.local <> + mutableDepConstraints deps.mutable + +updateSolverState :: (EnvConstraints -> EnvConstraints) -> SolverState -> SolverState +updateSolverState f (UnsafeSolverState c p) = UnsafeSolverState (f c) p diff --git a/lib/Hix/Managed/Cabal/Data/SourcePackage.hs b/lib/Hix/Managed/Cabal/Data/SourcePackage.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Data/SourcePackage.hs @@ -0,0 +1,40 @@ +module Hix.Managed.Cabal.Data.SourcePackage where + +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Simple (Version) +import GHC.Exts (IsList) + +import Hix.Class.Map (LookupMaybe, LookupMonoid, NMap, nPretty1, nPrettyWith) +import Hix.Data.Dep (Dep) +import Hix.Data.PackageName (PackageName) +import Hix.Pretty (prettyL) + +newtype SourcePackageDeps = + SourcePackageDeps (Map Version [Dep]) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap SourcePackageDeps Version [Dep] LookupMonoid where + +instance Pretty SourcePackageDeps where + pretty = nPrettyWith prettyL + +newtype SourcePackages = + SourcePackages (Map PackageName SourcePackageDeps) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap SourcePackages PackageName SourcePackageDeps LookupMaybe where + +instance Pretty SourcePackages where + pretty = nPretty1 + +newtype SourcePackageVersions = + SourcePackageVersions (Map PackageName [Version]) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap SourcePackageVersions PackageName [Version] LookupMaybe where + +instance Pretty SourcePackageVersions where + pretty = nPrettyWith prettyL diff --git a/lib/Hix/Managed/Cabal/Init.hs b/lib/Hix/Managed/Cabal/Init.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Init.hs @@ -0,0 +1,85 @@ +module Hix.Managed.Cabal.Init where + +import Distribution.Client.Config (defaultCacheDir) +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.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 qualified Hix.Managed.Cabal.Data.Config +import Hix.Managed.Cabal.Data.Config (GhcPath (GhcPath), HackageRepoName, SolveConfig) +import Hix.Managed.Cabal.Repo (ensureHackageIndex) +import Hix.Monad (M, throwM, tryIOMWith) + +data SolveFlags = + SolveFlags { + global :: GlobalFlags, + main :: NixStyleFlags () + } + +emptySolveFlags :: SolveFlags +emptySolveFlags = + SolveFlags { + global = defaultGlobalFlags {globalConfigFile = toFlag "/dev/null"}, + 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}|]) + +globalFlags :: RemoteRepo -> FilePath -> GlobalFlags +globalFlags hackage 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] + } + +badCacheDir :: Text -> Error +badCacheDir err = Fatal [exon|Cannot access Cabal cache dir: #{err}|] + +mainFlags :: + SolveConfig -> + NixStyleFlags () +mainFlags conf = + basic { + configFlags, + projectFlags = basic.projectFlags {flagIgnoreProject = toFlag True} + } + where + basic = defaultNixStyleFlags () + + configFlags = + (defaultConfigFlags defaultProgramDb) { + configHcPath = pathFlag [relfile|ghc|], + configHcPkg = pathFlag [relfile|ghc-pkg|], + configVerbosity = toFlag conf.verbosity + } + + pathFlag exe = maybeToFlag (ghcPath exe <$> conf.ghc) + + ghcPath exe (GhcPath dir) = toFilePath (dir [reldir|bin|] exe) + +initialize :: + SolveConfig -> + M SolveFlags +initialize conf = do + hackage <- hackageRepo conf.hackageRepoName + cacheDir <- tryIOMWith badCacheDir defaultCacheDir + let global = globalFlags hackage cacheDir + let main = mainFlags conf + ensureHackageIndex conf global main + pure SolveFlags {global, main} diff --git a/lib/Hix/Managed/Cabal/Installed.hs b/lib/Hix/Managed/Cabal/Installed.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Installed.hs @@ -0,0 +1,14 @@ +module Hix.Managed.Cabal.Installed where + +import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupPackageName) + +import qualified Hix.Data.PackageName as PackageName +import Hix.Data.PackageName (PackageName) +import Hix.Data.Version (Version) + +installedVersion :: + InstalledPackageIndex -> + PackageName -> + Maybe Version +installedVersion index name = + fst <$> head (lookupPackageName index (PackageName.toCabal name)) diff --git a/lib/Hix/Managed/Cabal/Mock.hs b/lib/Hix/Managed/Cabal/Mock.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Mock.hs @@ -0,0 +1,33 @@ +module Hix.Managed.Cabal.Mock where + +import Distribution.Simple (buildCompilerId, unknownCompilerInfo) +import Distribution.Simple.Compiler (AbiTag (NoAbiTag)) +import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (NoPkgConfigDb)) +import Distribution.System (Arch (X86_64), OS (Linux), Platform (Platform)) + +import Hix.Managed.Data.ManagedPackage (ManagedPackage) +import Hix.Managed.Data.Packages (Packages) +import qualified Hix.Managed.Cabal.Data.Packages +import Hix.Managed.Cabal.Data.Packages (GhcPackages (GhcPackages)) +import qualified Hix.Managed.Cabal.Data.SolveResources +import Hix.Managed.Cabal.Data.SolveResources (SolveResources (SolveResources)) +import Hix.Managed.Cabal.Init (emptySolveFlags) +import Hix.Managed.Cabal.Mock.InstalledPackage (mockInstalledPackageIndex) +import qualified Hix.Managed.Cabal.Mock.SourcePackage as SourcePackage +import Hix.Managed.Cabal.Mock.SourcePackage (mockSourcePackageDb) + +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, + pkgConfigDb = NoPkgConfigDb, + installedPkgIndex = mockInstalledPackageIndex installed, + sourcePkgDb = SourcePackage.dbWithManaged packages (mockSourcePackageDb available), + solverParams = id + } diff --git a/lib/Hix/Managed/Cabal/Mock/InstalledPackage.hs b/lib/Hix/Managed/Cabal/Mock/InstalledPackage.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Mock/InstalledPackage.hs @@ -0,0 +1,28 @@ +module Hix.Managed.Cabal.Mock.InstalledPackage where + +import Distribution.InstalledPackageInfo (InstalledPackageInfo (..), emptyInstalledPackageInfo) +import Distribution.Package (UnitId, mkUnitId) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (InstalledPackageIndex) + +import qualified Hix.Data.PackageId as PackageId +import Hix.Data.PackageId (PackageId) +import Hix.Managed.Cabal.Data.Packages (InstalledPackages (InstalledPackages)) +import Hix.Pretty (showP) + +mockUnitId :: PackageId -> UnitId +mockUnitId = mkUnitId . showP + +installedPackageInfo :: PackageId -> [UnitId] -> InstalledPackageInfo +installedPackageInfo package depends = + emptyInstalledPackageInfo { + sourcePackageId = PackageId.toCabal package, + installedUnitId = mockUnitId package, + depends + } + +mockInstalledPackageIndex :: InstalledPackages -> InstalledPackageIndex +mockInstalledPackageIndex = + PackageIndex.fromList . + fmap (uncurry installedPackageInfo . second (fmap mockUnitId)) . + coerce diff --git a/lib/Hix/Managed/Cabal/Mock/SourcePackage.hs b/lib/Hix/Managed/Cabal/Mock/SourcePackage.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Mock/SourcePackage.hs @@ -0,0 +1,111 @@ +module Hix.Managed.Cabal.Mock.SourcePackage where + +import qualified Data.Map.Strict as Map +import Distribution.Client.Types (PackageLocation (LocalTarballPackage), SourcePackageDb (..), UnresolvedSourcePackage) +import Distribution.PackageDescription ( + CondTree (..), + Library (libBuildInfo), + LibraryVisibility (LibraryVisibilityPublic), + PackageDescription (..), + emptyLibrary, + emptyPackageDescription, BuildInfo (targetBuildDepends), + ) +import Distribution.Simple (Version) +import qualified Distribution.Solver.Types.PackageIndex as PackageIndex +import Distribution.Solver.Types.PackageIndex (PackageIndex) +import Distribution.Solver.Types.SourcePackage (SourcePackage (..)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription (..), emptyGenericPackageDescription) +import Distribution.Types.Library (libVisibility) +import Exon (exon) + +import Hix.Class.Map (nGet, nKeys, nMap, nTo1, nTransform, nVia, (!!)) +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 Hix.Data.PackageName (LocalPackage (LocalPackage), PackageName, localPackageName) +import Hix.Managed.Cabal.Data.SourcePackage (SourcePackageDeps, SourcePackageVersions, SourcePackages) +import qualified Hix.Managed.Data.ManagedPackage as ManagedPackage +import Hix.Managed.Data.ManagedPackage (ManagedPackage) +import Hix.Managed.Data.Packages (Packages) +import Hix.Monad (noteClient) + +allDeps :: [Dep] -> SourcePackageDeps -> SourcePackageDeps +allDeps deps = nVia (fmap (deps ++)) + +allDep :: Dep -> SourcePackageDeps -> SourcePackageDeps +allDep dep = nVia (fmap (dep :)) + +sourcePackageVersions :: SourcePackages -> SourcePackageVersions +sourcePackageVersions = nMap (sort . nKeys) + +queryVersions :: SourcePackageVersions -> PackageName -> M [Version] +queryVersions packages query = noteClient [exon|No such package in the source db: ##{query}|] (packages !! query) + +queryPackages :: SourcePackages -> PackageName -> M [Version] +queryPackages packages = + queryVersions (sourcePackageVersions packages) + +queryVersionsLatest :: SourcePackageVersions -> PackageName -> M (Maybe Version) +queryVersionsLatest packages query = last <$> queryVersions packages query + +queryPackagesLatest :: SourcePackages -> PackageName -> M (Maybe Version) +queryPackagesLatest packages = + queryVersionsLatest versions + where + versions = sourcePackageVersions packages + +-- | This _must_ have the dependencies in both 'targetBuildDepends' and 'condTreeConstraints', otherwise they will be +-- ignored or deleted depending on what resolver params are used. +-- This is also evidenced by looking at a parsed Cabal file, see @CabalTest@. +mockSourcePackage :: PackageName -> Version -> [Dep] -> UnresolvedSourcePackage +mockSourcePackage name version deps = + SourcePackage { + srcpkgPackageId = cabalId, + srcpkgDescription = emptyGenericPackageDescription { + packageDescription = emptyPackageDescription { + package = cabalId + }, + condLibrary = Just library + }, + srcpkgSource = LocalTarballPackage "/invalid", + srcpkgDescrOverride = Nothing + } + where + library = + mempty { + condTreeData = emptyLibrary { + libVisibility = LibraryVisibilityPublic, + libBuildInfo = mempty {targetBuildDepends = cabalDeps} + }, + condTreeConstraints = cabalDeps + } + cabalId = PackageId.toCabal PackageId {..} + cabalDeps = Dep.toCabal <$> deps + +mockSourcePackageDb :: SourcePackages -> SourcePackageDb +mockSourcePackageDb packages = + SourcePackageDb { + packageIndex = PackageIndex.fromList (nTo1 packages mockSourcePackage), + packagePreferences = [] + } + +managedSourcePackageVersions :: Packages ManagedPackage -> SourcePackageVersions +managedSourcePackageVersions = + nTransform \ (LocalPackage name) package -> (name, [package.version]) + +managedSourcePackage :: ManagedPackage -> UnresolvedSourcePackage +managedSourcePackage package = + mockSourcePackage (localPackageName package.package) package.version (ManagedPackage.deps package) + +managedPackageIndex :: Packages ManagedPackage -> PackageIndex UnresolvedSourcePackage +managedPackageIndex packages = + PackageIndex.fromList (managedSourcePackage <$> Map.elems (nGet packages)) + +dbWithManaged :: Packages ManagedPackage -> SourcePackageDb -> SourcePackageDb +dbWithManaged packages SourcePackageDb {packageIndex, packagePreferences} = + SourcePackageDb { + packageIndex = PackageIndex.merge packageIndex (managedPackageIndex packages), + packagePreferences + } diff --git a/lib/Hix/Managed/Cabal/Print.hs b/lib/Hix/Managed/Cabal/Print.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Print.hs @@ -0,0 +1,26 @@ +module Hix.Managed.Cabal.Print where + +import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan +import Distribution.Client.SolverInstallPlan (ResolverPackage (..), SolverInstallPlan, SolverPlanPackage) +import Distribution.InstalledPackageInfo (InstalledPackageInfo (InstalledPackageInfo, sourcePackageId)) +import Distribution.Pretty (pretty) +import Distribution.Solver.Types.InstSolverPackage (InstSolverPackage (InstSolverPackage, instSolverPkgIPI)) +import Distribution.Solver.Types.SolverPackage (SolverPackage (..)) +import Distribution.Solver.Types.SourcePackage (SourcePackage (..)) +import Exon (exon) + +import Hix.Data.Monad (M) +import qualified Hix.Log as Log + +showPackage :: SolverPlanPackage -> String +showPackage = \case + PreExisting InstSolverPackage {instSolverPkgIPI = InstalledPackageInfo {sourcePackageId}} -> + "existing: " <> show (pretty sourcePackageId) + Configured SolverPackage {solverPkgSource = SourcePackage {srcpkgPackageId}} -> + "configured: " <> show (pretty srcpkgPackageId) + +printPlan :: SolverInstallPlan -> M () +printPlan plan = do + Log.info "Plan:" + for_ (SolverInstallPlan.toList plan) \ pkg -> + Log.infoCont [exon|📦 #{toText (showPackage pkg)}|] diff --git a/lib/Hix/Managed/Cabal/Repo.hs b/lib/Hix/Managed/Cabal/Repo.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Repo.hs @@ -0,0 +1,137 @@ +module Hix.Managed.Cabal.Repo where + +import Data.Time (UTCTime (..), showGregorian, timeToTimeOfDay) +import Distribution.Client.CmdUpdate (updateAction) +import qualified Distribution.Client.GlobalFlags +import Distribution.Client.GlobalFlags (GlobalFlags (..)) +import Distribution.Client.IndexUtils (currentIndexTimestamp, indexBaseName) +import Distribution.Client.IndexUtils.Timestamp (timestampToUTCTime) +import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) +import Distribution.Client.Setup (RepoContext, withRepoContext) +import Distribution.Client.Types (RemoteRepo (..), Repo (RepoSecure), RepoName (RepoName)) +import qualified Distribution.Client.Types.Repo +import Distribution.Compat.Time (getFileAge) +import Distribution.Verbosity (Verbosity) +import Exon (exon) +import Path (Abs, File, Path, addExtension, parseAbsFile, toFilePath) +import Path.IO (doesFileExist) + +import Hix.Data.Error (Error (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.Maybe (justIf) +import Hix.Monad (M, catchIOM, eitherFatalShow, noteFatal, tryIOM, tryIOMWith, withLower) + +withRepoContextM :: + SolveConfig -> + GlobalFlags -> + (RepoContext -> M a) -> + M a +withRepoContextM conf flags f = + withLower \ lower -> withRepoContext conf.verbosity flags \ ctx -> lower (f ctx) + +fullHackageRepo :: + 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 + where + err = "Bad Hackage repo config" + +data IndexProblem = + IndexMissing + | + IndexOutdated + | + IndexMismatch + deriving stock (Eq, Show, Generic) + +indexOutdated :: Path Abs File -> IO Bool +indexOutdated (toFilePath -> index) = + (> 7) <$> getFileAge index + +updateRequest :: + SolveConfig -> + String +updateRequest SolveConfig {hackageRepoName, cabal = CabalConfig {indexState}} = + [exon|#{hackage}#{extra}|] + where + extra = foldMap stateField (timestampToUTCTime . coerce =<< indexState) + + stateField UTCTime {..} = [exon|,#{showGregorian utctDay}T#{show (timeToTimeOfDay utctDayTime)}Z|] + + HackageRepoName (toString -> hackage) = hackageRepoName + +updateIndex :: + SolveConfig -> + GlobalFlags -> + NixStyleFlags () -> + IndexProblem -> + M () +updateIndex conf global main problem = do + Log.verbose [exon|Hackage snapshot #{message}, fetching...|] + tryIOMWith (\ err -> Fatal [exon|Fetching hackage snapshot failed: #{err}|]) do + updateAction main [updateRequest conf] global + where + message = case problem of + IndexMissing -> "doesn't exist" + IndexOutdated -> "is older than 7 days" + IndexMismatch -> "differs from requested index state" + +indexPath :: Repo -> M (Path Abs File) +indexPath repo = + eitherFatalShow err do + base <- parseAbsFile (indexBaseName repo) + addExtension ".tar" base + where + err = "Bad Hackage repo config" + +matchIndexState :: + Verbosity -> + RepoContext -> + Repo -> + HackageIndexState -> + M (Maybe IndexProblem) +matchIndexState verbosity ctx repo (HackageIndexState target) = + catchIOM (match <$> currentIndexTimestamp verbosity ctx repo) (\ _ -> pure (Just IndexMissing)) + where + match current | current == target = Nothing + | otherwise = Just IndexMismatch + +indexProblem :: + SolveConfig -> + RepoContext -> + Repo -> + Path Abs File -> + M (Maybe IndexProblem) +indexProblem SolveConfig {verbosity, cabal} ctx repo path = do + Log.debug [exon|Checking hackage snapshot at #{pathText path}|] + tryIOM (doesFileExist path) >>= \case + False -> pure (Just IndexMissing) + True + | Just target <- cabal.indexState + -> matchIndexState verbosity ctx repo target + | otherwise + -> flip justIf IndexOutdated <$> tryIOM (indexOutdated path) + +-- TODO currentIndexTimestamp has a different signature in later versions +ensureHackageIndex :: + SolveConfig -> + GlobalFlags -> + NixStyleFlags () -> + M () +ensureHackageIndex conf global main = + withRepoContextM conf global \ ctx -> do + repo <- fullHackageRepo conf ctx + path <- indexPath repo + traverse_ (updateIndex conf global main) =<< indexProblem conf ctx repo path diff --git a/lib/Hix/Managed/Cabal/Resources.hs b/lib/Hix/Managed/Cabal/Resources.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Resources.hs @@ -0,0 +1,76 @@ +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 (PackageDB (GlobalPackageDB), PackageDBStack, compilerInfo) +import Distribution.Solver.Types.PkgConfigDb (readPkgConfigDb) +import Distribution.Verbosity (lessVerbose, silent, verbose) + +import qualified Hix.Data.Monad +import Hix.Data.Monad (M (M)) +import qualified Hix.Log as Log +import Hix.Managed.Cabal.Data.Config (CabalConfig, GhcDb (GhcDbSynthetic, GhcDbSystem), SolveConfig (..)) +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.Monad (tryIOM) + +packageDbs :: PackageDBStack +packageDbs = [GlobalPackageDB] + +-- | This adds the 'ManagedPackage's to the source package DB, which is the set of available package IDs. +-- 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. +-- +-- 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 -> + SolveConfig -> + M SolveResources +resources 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, + .. + } + +-- 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 -> + CabalConfig -> + GhcDb -> + M SolveResources +acquire packages cabal = \case + GhcDbSystem ghc -> do + verbosity <- M (asks (.debug)) <&> \case + True -> verbose + False -> lessVerbose silent + resources packages def {verbosity, ghc, cabal} + GhcDbSynthetic db -> + pure (mockSolveResources packages db) diff --git a/lib/Hix/Managed/Cabal/Solve.hs b/lib/Hix/Managed/Cabal/Solve.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Solve.hs @@ -0,0 +1,83 @@ +module Hix.Managed.Cabal.Solve where + +import Distribution.Client.Dependency ( + DepResolverParams, + PackagePreference, + PackageSpecifier, + addPreferences, + foldProgress, + resolveDependencies, + setAllowBootLibInstalls, + standardInstallPolicy, + ) +import Distribution.Client.Dependency.Types (Solver (Modular)) +import Distribution.Client.SolverInstallPlan (SolverInstallPlan) +import Distribution.Client.Types (UnresolvedSourcePackage) +import Distribution.Simple.Utils (debugNoWrap) +import Distribution.Solver.Types.Settings (AllowBootLibInstalls (AllowBootLibInstalls)) +import Distribution.Verbosity (Verbosity) +import Exon (exon) + +import Hix.Data.Error (Error (Fatal)) +import qualified Hix.Log as Log +import Hix.Managed.Cabal.Changes (SolverPlan, solverPlan) +import qualified Hix.Managed.Cabal.Data.Config +import qualified Hix.Managed.Cabal.Data.SolveResources +import Hix.Managed.Cabal.Data.SolveResources (SolveResources) +import qualified Hix.Managed.Cabal.Data.SolveTarget +import Hix.Managed.Cabal.Data.SolveTarget (SolveTarget) +import qualified Hix.Managed.Cabal.Data.SolverState +import Hix.Managed.Cabal.Data.SolverState (SolverState (SolverState), compileSolverFlags) +import Hix.Managed.Cabal.Targets (solveTargets) +import Hix.Monad (M, tryIOMAs) + +newtype Unresolvable = + Unresolvable Text + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord) + +logMsg :: Verbosity -> String -> IO a -> IO a +logMsg verbosity message rest = + debugNoWrap verbosity message *> rest + +solveSpecifiers :: + SolveResources -> + (DepResolverParams -> DepResolverParams) -> + [PackageSpecifier UnresolvedSourcePackage] -> + [PackagePreference] -> + IO (Either String SolverInstallPlan) +solveSpecifiers res mapParams pkgSpecifiers prefs = + foldProgress (logMsg res.conf.verbosity) (pure . Left) (pure . Right) $ + resolveDependencies res.platform res.compiler res.pkgConfigDb Modular params + where + params = + mapParams $ + res.solverParams $ + setAllowBootLibInstalls (AllowBootLibInstalls res.conf.allowBoot) $ + addPreferences prefs $ + standardInstallPolicy res.installedPkgIndex res.sourcePkgDb pkgSpecifiers + +solveForTargets :: + SolveResources -> + (DepResolverParams -> DepResolverParams) -> + [SolveTarget] -> + M (Either Unresolvable SolverInstallPlan) +solveForTargets res mapParams targets = + first fromString <$> tryIOMAs (Fatal "Cabal solver crashed.") (solveSpecifiers res mapParams pkgSpecifiers prefs) + where + pkgSpecifiers = (.dep) <$> targets + prefs = (.prefs) =<< targets + +solveWithCabal :: + SolveResources -> + SolverState -> + M (Maybe SolverPlan) +solveWithCabal solveResources SolverState {constraints, flags} = do + solveForTargets solveResources (compileSolverFlags flags) targets >>= \case + Right plan -> + pure (Just (solverPlan plan)) + Left err -> do + Log.debug [exon|Solver found no plan: ##{err}|] + pure Nothing + where + targets = solveTargets constraints diff --git a/lib/Hix/Managed/Cabal/Targets.hs b/lib/Hix/Managed/Cabal/Targets.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Cabal/Targets.hs @@ -0,0 +1,50 @@ +module Hix.Managed.Cabal.Targets where + +import Distribution.Client.Dependency ( + PackagePreference (PackageInstalledPreference, PackageVersionPreference), + PackageProperty (PackagePropertyVersion), + PackageSpecifier (NamedPackage), + ) +import Distribution.Solver.Types.InstalledPreference (InstalledPreference (PreferInstalled, PreferOldest)) +import Distribution.Version (orEarlierVersion, orLaterVersion) + +import Hix.Class.Map (nToWith) +import qualified Hix.Data.PackageName as PackageName +import Hix.Data.PackageName (PackageName) +import Hix.Data.Version (VersionRange) +import Hix.Data.VersionBounds (Bound (BoundLower, BoundUpper), VersionBounds, maybeRange) +import Hix.Managed.Cabal.Data.SolveTarget (SolveTarget (..)) +import qualified Hix.Managed.Data.Constraints +import Hix.Managed.Data.Constraints (EnvConstraints, MutationConstraints (MutationConstraints)) + +reifyBounds :: VersionBounds -> Maybe VersionRange +reifyBounds = + maybeRange \case + BoundLower -> orLaterVersion + BoundUpper -> orEarlierVersion + +solveTarget :: + PackageName -> + MutationConstraints -> + SolveTarget +solveTarget package MutationConstraints {mutation, oldest, installed, prefer, force} = + SolveTarget {dep, prefs} + where + dep = NamedPackage cabalName (PackagePropertyVersion <$> ranges) + + ranges = catMaybes [reifyBounds mutation, force] + + prefs = catMaybes [prefVersion <$> prefer, flag prefOldest oldest, flag prefInstalled installed] + + flag v = \case + Just True -> Just v + _ -> Nothing + + prefVersion = PackageVersionPreference cabalName + prefOldest = PackageInstalledPreference cabalName PreferOldest + prefInstalled = PackageInstalledPreference cabalName PreferInstalled + + cabalName = PackageName.toCabal package + +solveTargets :: EnvConstraints -> [SolveTarget] +solveTargets = nToWith solveTarget diff --git a/lib/Hix/Managed/Constraints.hs b/lib/Hix/Managed/Constraints.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Constraints.hs @@ -0,0 +1,37 @@ +module Hix.Managed.Constraints where + +import Distribution.Version (thisVersion) + +import Hix.Class.Map (nGenWith, nMap, nTransform) +import Hix.Data.Bounds (Ranges) +import Hix.Data.PackageName (PackageName) +import Hix.Data.Version (Version, Versions) +import Hix.Data.VersionBounds (VersionBounds, anyBounds) +import Hix.Managed.Data.Constraints (EnvConstraints, MutationConstraints (..)) +import Hix.Managed.Data.Mutable (MutableDep (MutableDep), MutableVersions) + +noBounds :: MutationConstraints +noBounds = mempty {mutation = anyBounds} + +forDeps :: (PackageName -> MutationConstraints) -> Set MutableDep -> EnvConstraints +forDeps f = + nGenWith \ (MutableDep package) -> (package, f package) + +fromVersions :: (Version -> VersionBounds) -> MutableVersions -> EnvConstraints +fromVersions bound = + nTransform \ (MutableDep package) v -> (package, mempty {mutation = foldMap bound v}) + +preferRanges :: Ranges -> EnvConstraints +preferRanges = + nMap \ range -> mempty {mutation = mempty, prefer = Just range} + +preferVersions :: Versions -> EnvConstraints +preferVersions = preferRanges . nMap thisVersion + +preferInstalled :: Set MutableDep -> EnvConstraints +preferInstalled = + forDeps \ _ -> mempty {mutation = mempty, installed = Just True} + +explicitBounds :: Ranges -> EnvConstraints +explicitBounds = + nMap \ range -> mempty {mutation = mempty, force = Just range} diff --git a/lib/Hix/Managed/Data/BuildConfig.hs b/lib/Hix/Managed/Data/BuildConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/BuildConfig.hs @@ -0,0 +1,22 @@ +module Hix.Managed.Data.BuildConfig where + +data BuildConfig = + BuildConfig { + maxIterations :: Natural, + maxFailedPre :: Natural, + maxFailedPost :: Natural, + lookup :: Bool, + validate :: Bool, + buildOutput :: Bool + } + deriving stock (Eq, Show, Generic) + +instance Default BuildConfig where + def = BuildConfig { + maxIterations = 3, + maxFailedPre = 99, + maxFailedPost = 0, + lookup = False, + validate = False, + buildOutput = False + } diff --git a/lib/Hix/Managed/Data/BuildOutput.hs b/lib/Hix/Managed/Data/BuildOutput.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/BuildOutput.hs @@ -0,0 +1,44 @@ +module Hix.Managed.Data.BuildOutput where + +import Data.Aeson (ToJSON (toJSON), object, (.=)) +import Distribution.Pretty (Pretty (pretty)) +import Text.PrettyPrint (brackets, (<+>)) + +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Managed.Data.Mutable (MutableDep) +import qualified Hix.Managed.Data.MutableId +import Hix.Managed.Data.MutableId (MutableId (MutableId)) +import Hix.Pretty (showP) + +data ModifiedId = + ModifiedId { + package :: MutableDep, + version :: Version, + range :: Maybe VersionBounds + } + deriving stock (Eq, Show, Generic) + +instance Pretty ModifiedId where + pretty ModifiedId {..} = + pretty MutableId {name = package, version} <+> brackets (maybe "old range matches" pretty range) + +instance ToJSON ModifiedId where + toJSON ModifiedId {..} = + object [ + "package" .= toJSON package, + "version" .= toJSON (showP version :: Text), + "range" .= toJSON (showP <$> range :: Maybe Text) + ] + +data BuildOutput = + BuildOutput { + modified :: [ModifiedId], + unmodified :: [MutableDep], + failed :: [MutableDep], + modifiedNames :: Maybe Text, + unmodifiedNames :: Maybe Text, + failedNames :: Maybe Text + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) diff --git a/lib/Hix/Managed/Data/Bump.hs b/lib/Hix/Managed/Data/Bump.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Bump.hs @@ -0,0 +1,18 @@ +module Hix.Managed.Data.Bump where + +import Distribution.Pretty (Pretty (pretty)) +import Text.PrettyPrint (brackets, parens, (<+>)) + +import Hix.Data.Version (Version) + +data Bump = + Bump { + version :: Version, + bound :: Version, + changed :: Bool + } + deriving stock (Eq, Show, Generic) + +instance Pretty Bump where + pretty Bump {version, bound, changed} = + pretty version <+> parens ("<" <> pretty bound) <+> brackets (if changed then "x" else " ") diff --git a/lib/Hix/Managed/Data/Constraints.hs b/lib/Hix/Managed/Data/Constraints.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Constraints.hs @@ -0,0 +1,89 @@ +module Hix.Managed.Data.Constraints where + +import qualified Data.Map.Strict as Map +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Version (VersionRange) +import GHC.Exts (IsList) +import Text.PrettyPrint (Doc, parens, (<+>)) + +import Hix.Class.Map (LookupMaybe, NMap, nPretty) +import Hix.Data.PackageName (PackageName) +import Hix.Data.VersionBounds (VersionBounds, anyBounds) +import Hix.Pretty (prettyL) + +-- | Left-biased semigroup op. +-- +-- TODO it might be sensible to split the non-mutation deps out of this type so it can be keyed by @MutableDep@. +data MutationConstraints = + MutationConstraints { + -- | This used to be an abstraction, but there was no use case for it. + -- Now it is hardcoded to use inclusive bounds for both, so a potential new mutation handler cannot customize that. + -- All handlers only evolve one of the bounds, while this now allows both to be changed. + mutation :: VersionBounds, + + -- | Prefer the oldest possible version. + oldest :: Maybe Bool, + + -- | Prefer the installed version. + installed :: Maybe Bool, + + -- | Concrete bounds overrides from user config. + force :: Maybe VersionRange, + + -- | Prefer a concrete version range. + prefer :: Maybe VersionRange + } + deriving stock (Eq, Show, Generic) + +instance Pretty MutationConstraints where + pretty MutationConstraints {mutation, oldest, installed, force, prefer} = + pretty mutation <+> + flags [("oldest", oldest), ("installed", installed)] <+> + foldMap pref prefer <+> + foldMap spec force + where + flags :: [(Doc, Maybe Bool)] -> Doc + flags = + mapMaybe flag >>> \case + [] -> mempty + fs -> parens (prettyL fs) + + flag = \case + (desc, Just True) -> Just desc + _ -> Nothing + + pref v = "~" <+> pretty v + spec v = "+" <+> pretty v + +instance Semigroup MutationConstraints where + l <> r = + MutationConstraints { + mutation = l.mutation <> l.mutation, + oldest = l.oldest <|> r.oldest, + installed = l.installed <|> r.installed, + force = l.force <|> r.force, + prefer = l.prefer <|> r.prefer + } + +instance Monoid MutationConstraints where + mempty = + MutationConstraints { + mutation = anyBounds, + oldest = Nothing, + installed = Nothing, + force = Nothing, + prefer = Nothing + } + +newtype EnvConstraints = + EnvConstraints (Map PackageName MutationConstraints) + deriving stock (Eq, Show, Generic) + deriving newtype (Monoid, IsList) + +instance Semigroup EnvConstraints where + EnvConstraints l <> EnvConstraints r = EnvConstraints (Map.unionWith (<>) l r) + +instance NMap EnvConstraints PackageName MutationConstraints LookupMaybe where + +instance Pretty EnvConstraints where + pretty = nPretty diff --git a/lib/Hix/Managed/Data/CurrentBuild.hs b/lib/Hix/Managed/Data/CurrentBuild.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/CurrentBuild.hs @@ -0,0 +1,9 @@ +module Hix.Managed.Data.CurrentBuild where + +import Hix.Data.PackageName (LocalPackage) + +data CurrentBuild = + CurrentBuild { + target :: LocalPackage + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Data/Diff.hs b/lib/Hix/Managed/Data/Diff.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Diff.hs @@ -0,0 +1,66 @@ +module Hix.Managed.Data.Diff where + +import Data.These (These, mergeTheseWith) +import Distribution.Pretty (Pretty (pretty)) +import Text.PrettyPrint (Doc, brackets, (<+>)) + +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Pretty (prettyL) + +class PrettyDiffDetail a where + prettyDiffDetail :: a -> Maybe Doc + +instance PrettyDiffDetail () where + prettyDiffDetail () = Nothing + +data Diff d a = + DiffAdded a + | + DiffChanged { + original :: a, + new :: a, + detail :: d + } + deriving stock (Eq, Show, Generic, Functor) + +instance ( + Pretty a, + PrettyDiffDetail d + ) => Pretty (Diff d a) where + pretty = \case + DiffAdded a -> "[+]" <+> pretty a + DiffChanged {original, new, detail} -> pretty original <+> "->" <+> pretty new <+> fold (prettyDiffDetail detail) + +type VersionDiff = Diff () Version + +newtype BoundsDiffDetail = + BoundsDiffDetail (These VersionDiff VersionDiff) + deriving stock (Eq, Show, Generic) + +type BoundsDiff = Diff BoundsDiffDetail VersionBounds + +instance PrettyDiffDetail BoundsDiffDetail where + prettyDiffDetail (BoundsDiffDetail detail) = + Just (brackets (mergeTheseWith pretty pretty cat detail)) + where + cat l u = prettyL @[] [l, u] + +data Change d a = + Changed (Diff d a) + | + Unchanged (Maybe a) + deriving stock (Eq, Show, Generic, Functor) + +instance ( + Pretty a, + PrettyDiffDetail d + ) => Pretty (Change d a) where + pretty = \case + Unchanged Nothing -> "[0]" + Unchanged (Just a) -> "[=]" <+> pretty a + Changed diff -> pretty diff + +type VersionChange = Change () Version + +type BoundsChange = Change BoundsDiffDetail VersionBounds diff --git a/lib/Hix/Managed/Data/EnvConfig.hs b/lib/Hix/Managed/Data/EnvConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/EnvConfig.hs @@ -0,0 +1,14 @@ +module Hix.Managed.Data.EnvConfig where + +import Data.Aeson (FromJSON) + +import Hix.Data.PackageName (LocalPackage) +import Hix.Managed.Cabal.Data.Config (GhcDb) + +data EnvConfig = + EnvConfig { + targets :: [LocalPackage], + ghc :: GhcDb + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) diff --git a/lib/Hix/Managed/Data/EnvContext.hs b/lib/Hix/Managed/Data/EnvContext.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/EnvContext.hs @@ -0,0 +1,45 @@ +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 + } + deriving stock (Eq, Show, Generic) + deriving (Semigroup, Monoid) via (Generically EnvDeps) + +-- | Static data defining a managed bounds job for an environment. +data EnvContext = + EnvContext { + -- | 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, + + -- | The set of local packages associated with this environment. + -- Sorted topologically by smart constructor. + targets :: Targets, + + -- | The names of dependencies associated with this environment. + deps :: EnvDeps, + + -- | The subset of this environment's remote dependencies whose bounds should be updated. + query :: NonEmpty MutableDep, + + solverBounds :: Ranges + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Data/EnvRequest.hs b/lib/Hix/Managed/Data/EnvRequest.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/EnvRequest.hs @@ -0,0 +1,18 @@ +module Hix.Managed.Data.EnvRequest where + +import Hix.Managed.Data.EnvContext (EnvContext) +import Hix.Managed.Data.EnvState (EnvState) +import Hix.Managed.Data.Initial (Initial) +import Hix.Managed.Handlers.Build (EnvBuilder) + +-- | Resources for an env job. +data EnvRequest = + EnvRequest { + -- | For convenience. + context :: EnvContext, + + builder :: EnvBuilder, + + -- | The state at the beginning of the processing step for this env. + state :: Initial EnvState + } diff --git a/lib/Hix/Managed/Data/EnvResult.hs b/lib/Hix/Managed/Data/EnvResult.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/EnvResult.hs @@ -0,0 +1,14 @@ +module Hix.Managed.Data.EnvResult where + +import Hix.Data.EnvName (EnvName) +import Hix.Managed.Data.EnvState (EnvState) +import Hix.Managed.Data.StageResult (StageSummary) + +data EnvResult = + EnvResult { + env :: EnvName, + -- | The final state, which is 'Nothing' for stages that don't interact with it. + state :: Maybe EnvState, + summaries :: NonEmpty StageSummary + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Data/EnvState.hs b/lib/Hix/Managed/Data/EnvState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/EnvState.hs @@ -0,0 +1,36 @@ +module Hix.Managed.Data.EnvState where + +import Distribution.Pretty (Pretty (pretty)) +import GHC.Generics (Generically (Generically)) +import Text.PrettyPrint (hang, ($+$)) + +import Hix.Data.Overrides (Overrides) +import Hix.Managed.Data.Diff (BoundsChange, VersionChange) +import Hix.Managed.Data.Mutable (MutableDeps) + +-- | All the @*Diff@ fields are initialized as @DiffAbsent@ if there is no entry in the managed state, using the flake +-- config's packages to determine the set of dependencies. +data EnvState = + EnvState { + -- | Bounds can differ from the lowest or highest version that was tested. + -- As of now, this only matters for Bump, which uses the next-greater major version as upper bound. + bounds :: MutableDeps BoundsChange, + + -- | The precise version determined to be working for the env's target bound. + versions :: 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 + } + deriving stock (Eq, Show, Generic) + deriving (Semigroup, Monoid) via (Generically EnvState) + +instance Pretty EnvState where + pretty EnvState {..} = + hang "bounds:" 2 (pretty bounds) $+$ + hang "versions:" 2 (pretty versions) $+$ + hang "overrides:" 2 (pretty overrides) $+$ + hang "initial:" 2 (pretty initial) diff --git a/lib/Hix/Managed/Data/Envs.hs b/lib/Hix/Managed/Data/Envs.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Envs.hs @@ -0,0 +1,19 @@ +module Hix.Managed.Data.Envs where + +import Data.Aeson (FromJSON) +import Distribution.Pretty (Pretty (pretty)) +import GHC.Exts (IsList) + +import Hix.Class.EncodeNix (EncodeNix) +import Hix.Class.Map (LookupMonoid, NMap, nPretty1) +import Hix.Data.EnvName (EnvName) + +newtype Envs a = + Envs (Map EnvName a) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON, Semigroup, Monoid, IsList, EncodeNix) + +instance NMap (Envs a) EnvName a LookupMonoid where + +instance Pretty a => Pretty (Envs a) where + pretty = nPretty1 diff --git a/lib/Hix/Managed/Data/Initial.hs b/lib/Hix/Managed/Data/Initial.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Initial.hs @@ -0,0 +1,14 @@ +module Hix.Managed.Data.Initial where + +import Data.Aeson (FromJSON, ToJSON) +import Distribution.Pretty (Pretty (pretty)) + +import Hix.Class.EncodeNix (EncodeNix) + +newtype Initial a = + Initial a + deriving stock (Eq, Show, Generic, Functor) + deriving newtype (Semigroup, Monoid, FromJSON, ToJSON, EncodeNix) + +instance Pretty a => Pretty (Initial a) where + pretty (Initial a) = pretty a diff --git a/lib/Hix/Managed/Data/Lower.hs b/lib/Hix/Managed/Data/Lower.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Lower.hs @@ -0,0 +1,14 @@ +module Hix.Managed.Data.Lower where + +import Distribution.Pretty (Pretty (pretty)) + +import Hix.Data.Version (Major, prettyMajors) + +data Lower = + Lower { + majors :: NonEmpty Major + } + deriving stock (Eq, Show, Generic) + +instance Pretty Lower where + pretty Lower {majors} = prettyMajors majors diff --git a/lib/Hix/Managed/Data/LowerConfig.hs b/lib/Hix/Managed/Data/LowerConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/LowerConfig.hs @@ -0,0 +1,24 @@ +module Hix.Managed.Data.LowerConfig where + +import qualified Hix.Data.Options +import Hix.Data.Options (LowerOptions (LowerOptions)) + +data LowerConfig = + LowerConfig { + initOnly :: Bool, + reset :: Bool, + stabilize :: Bool + } + deriving stock (Eq, Show, Generic) + +lowerConfig :: LowerOptions -> LowerConfig +lowerConfig LowerOptions {..} = + LowerConfig {..} + +instance Default LowerConfig where + def = + LowerConfig { + initOnly = False, + reset = False, + stabilize = False + } diff --git a/lib/Hix/Managed/Data/ManagedPackage.hs b/lib/Hix/Managed/Data/ManagedPackage.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ManagedPackage.hs @@ -0,0 +1,40 @@ +module Hix.Managed.Data.ManagedPackage where + +import Distribution.Pretty (Pretty (pretty)) +import Text.PrettyPrint (hang, ($+$)) + +import Hix.Class.Map (nTo, nTransform) +import Hix.Data.Bounds (Ranges) +import qualified Hix.Data.Dep +import Hix.Data.Dep (Dep (Dep)) +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import Hix.Data.PackageName (LocalPackage (LocalPackage), localPackageName) +import Hix.Data.Version (Version) +import Hix.Managed.Data.Mutable (LocalRanges, MutableRanges, depName) + +data ManagedPackage = + ManagedPackage { + package :: LocalPackage, + version :: Version, + local :: LocalRanges, + mutable :: MutableRanges + } + deriving stock (Eq, Show, Generic) + +instance Pretty ManagedPackage where + pretty ManagedPackage {..} = + hang (pretty package) 2 (pretty local $+$ pretty mutable) + +ranges :: ManagedPackage -> Ranges +ranges ManagedPackage {local, mutable} = + nTransform (\ k v -> (localPackageName k, v)) local <> + nTransform (\ k v -> (depName k, v)) mutable + +packageId :: ManagedPackage -> PackageId +packageId ManagedPackage {package = LocalPackage name, version} = + PackageId {..} + +deps :: ManagedPackage -> [Dep] +deps mp = + nTo (ranges mp) \ package version -> Dep {..} diff --git a/lib/Hix/Managed/Data/ManagedPackageProto.hs b/lib/Hix/Managed/Data/ManagedPackageProto.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ManagedPackageProto.hs @@ -0,0 +1,44 @@ +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}) diff --git a/lib/Hix/Managed/Data/Mutable.hs b/lib/Hix/Managed/Data/Mutable.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Mutable.hs @@ -0,0 +1,251 @@ +module Hix.Managed.Data.Mutable ( + MutableDep (MutableDep), + MutableDeps, + unsafeMutableDep, + depName, + isMutableDep, + MutableVersions, + MutableBounds, + MutableRanges, + LocalRanges, + mutRestrictKeys, + mutLookup, + mutReplace, + mutReplaceTargets, + mutUpdate, + mutUpdateTargets, + classifyPackageDep, + mutRelax, + mutUpdatePartial, + mutReplacePartial, + addBuildVersions, + mutFromSet, + mutRelaxVersions, +) where + +import Data.Aeson (ToJSON, ToJSONKey) +import qualified Data.Set as Set +import Distribution.Pretty (Pretty (pretty)) +import Exon (ToSegment (toSegment)) +import GHC.Exts (IsList) + +import Hix.Class.EncodeNix (EncodeNix (encodeNix), EncodeNixKey) +import Hix.Class.Map ( + LookupMaybe, + NLookup, + NMap, + nAmend, + nFromKeys, + nMap, + nMapKeys, + nPretty, + nPrettyWith, + nRestrictKeys, + nTransformMaybe, + (!!), + ) +import qualified Hix.Data.Dep +import Hix.Data.Dep (Dep (Dep)) +import Hix.Data.PackageName (LocalPackage (LocalPackage), PackageName) +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) + +newtype MutableDep = + UnsafeMutableDep PackageName + deriving stock (Eq, Show) + deriving newtype (Ord, ToJSON, ToJSONKey, Pretty, EncodeNixKey) + +pattern MutableDep :: PackageName -> MutableDep +pattern MutableDep name <- UnsafeMutableDep name + +{-# complete MutableDep #-} + +unsafeMutableDep :: PackageName -> MutableDep +unsafeMutableDep = UnsafeMutableDep + +depName :: MutableDep -> PackageName +depName (UnsafeMutableDep name) = name + +isMutableDep :: Set MutableDep -> PackageName -> Bool +isMutableDep mut p = Set.member (UnsafeMutableDep p) mut + +instance IsString a => ToSegment MutableDep a where + toSegment (UnsafeMutableDep name) = toSegment name + +newtype MutableDeps a = + MutableDeps (Map MutableDep a) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, EncodeNix) + +instance NMap (MutableDeps a) MutableDep a LookupMaybe where + +instance Pretty a => Pretty (MutableDeps a) where + pretty = nPretty + +newtype MutableVersions = + MutableVersions (Map MutableDep (Maybe Version)) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap MutableVersions MutableDep (Maybe Version) LookupMaybe where + +instance Pretty MutableVersions where + pretty = nPrettyWith (maybe "[missing]" pretty) + +instance EncodeNix MutableVersions where + encodeNix = encodeNix . mutRelaxVersions + +newtype MutableBounds = + MutableBounds (Map MutableDep VersionBounds) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList, EncodeNix, ToJSON) + +instance NMap MutableBounds MutableDep VersionBounds LookupMaybe where + +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) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap MutableRanges MutableDep VersionRange LookupMaybe where + +instance Pretty MutableRanges where + pretty = nPretty + +newtype LocalRanges = + LocalRanges (Map LocalPackage VersionRange) + deriving stock (Eq, Show, Generic) + deriving newtype (Semigroup, Monoid, IsList) + +instance NMap LocalRanges LocalPackage VersionRange LookupMaybe where + +instance Pretty LocalRanges where + pretty = nPretty + +mutLookup :: + NMap map MutableDep v sort => + NLookup sort MutableDep v l => + PackageName -> + map -> + l +mutLookup k m = + m !! (UnsafeMutableDep k) + +mutRestrictKeys :: + NMap map MutableDep v sort => + Set PackageName -> + map -> + map +mutRestrictKeys keys = + nRestrictKeys (Set.fromList (UnsafeMutableDep <$> Set.toList keys)) + +mutReplace :: + NMap map MutableDep v sort => + map -> + map -> + map +mutReplace = + nAmend \ new _ -> new + +mutReplaceTargets :: + NMap map MutableDep v sort => + Targets -> + map -> + Packages map -> + Packages map +mutReplaceTargets targets new = + overTargets targets (mutReplace new) + +mutUpdate :: + NMap map1 MutableDep v1 s1 => + NMap map2 MutableDep v2 s2 => + (v1 -> v2 -> v2) -> + map1 -> + map2 -> + map2 +mutUpdate = + nAmend + +mutUpdateTargets :: + NMap map1 MutableDep v1 s1 => + NMap map2 MutableDep v2 s2 => + Targets -> + (v1 -> v2 -> v2) -> + map1 -> + Packages map2 -> + Packages map2 +mutUpdateTargets targets f new = + overTargets targets (mutUpdate f new) + +mutRelax :: + NMap map1 MutableDep v s1 => + NMap map2 PackageName v s2 => + map1 -> + map2 +mutRelax = + nMapKeys depName + +mutRelaxVersions :: + MutableVersions -> + Versions +mutRelaxVersions = + nTransformMaybe \ dep -> fmap (depName dep,) + +-- | Update a MutableDep map with a PackageName map, only where the original is defined. +mutUpdatePartial :: + ∀ map1 map2 v1 v2 s1 s2 . + NMap map1 PackageName v1 s1 => + NMap map2 MutableDep v2 s2 => + (v1 -> v2 -> v2) -> + map1 -> + map2 -> + map2 +mutUpdatePartial f map1 map2 = + nAmend f (nMapKeys UnsafeMutableDep map1 :: MutableDeps v1) map2 + +-- | Replace entries in a MutableDep map with those from a PackageName map, only where the original is defined. +mutReplacePartial :: + ∀ map1 map2 v1 s1 s2 . + NMap map1 PackageName v1 s1 => + NMap map2 MutableDep v1 s2 => + map1 -> + map2 -> + map2 +mutReplacePartial = + mutUpdatePartial const + +addBuildVersions :: Versions -> MutableVersions -> MutableVersions +addBuildVersions versions = + mutReplacePartial (nMap Just versions :: Deps (Maybe Version)) + +classifyPackageDep :: Set LocalPackage -> Dep -> Either (LocalPackage, VersionRange) (MutableDep, VersionRange) +classifyPackageDep locals Dep {package, version} + | Set.member localName locals + = Left (localName, version) + | otherwise + = Right (UnsafeMutableDep package, version) + where + localName = LocalPackage package + +mutFromSet :: + NMap map MutableDep v sort => + Set MutableDep -> + (MutableDep -> v) -> + map +mutFromSet = + nFromKeys diff --git a/lib/Hix/Managed/Data/MutableId.hs b/lib/Hix/Managed/Data/MutableId.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/MutableId.hs @@ -0,0 +1,28 @@ +module Hix.Managed.Data.MutableId where + +import Data.Aeson (ToJSON (toJSON), object, (.=)) +import Distribution.Pretty (Pretty (pretty)) +import Distribution.Version (Version) + +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import Hix.Managed.Data.Mutable (MutableDep (MutableDep)) +import Hix.Pretty (showP) + +data MutableId = + MutableId { + name :: MutableDep, + version :: Version + } + deriving stock (Eq, Show, Generic) + +toPackageId :: MutableId -> PackageId +toPackageId MutableId {name = MutableDep name, version} = + PackageId {name, version} + +instance Pretty MutableId where + pretty = pretty . toPackageId + +instance ToJSON MutableId where + toJSON MutableId {..} = + object ["name" .= toJSON name, "version" .= toJSON (showP version :: Text)] diff --git a/lib/Hix/Managed/Data/Mutation.hs b/lib/Hix/Managed/Data/Mutation.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Mutation.hs @@ -0,0 +1,61 @@ +module Hix.Managed.Data.Mutation where + +import Distribution.Pretty (Pretty (pretty)) +import qualified Text.PrettyPrint as PrettyPrint +import Text.PrettyPrint (parens, (<+>)) + +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Managed.Cabal.Data.SolverState (SolverState) +import Hix.Managed.Data.Mutable (MutableDep) +import Hix.Managed.Data.MutableId (MutableId) +import Hix.Managed.Data.MutationState (MutationState) +import Hix.Pretty (prettyText, showP) + +data DepMutation a = + DepMutation { + package :: MutableDep, + retract :: Bool, + mutation :: a + } + deriving stock (Eq, Show, Generic) + +instance Pretty a => Pretty (DepMutation a) where + pretty DepMutation {package, mutation, retract} = + pretty package PrettyPrint.<> ":" <+> pretty mutation <+> parens retext + where + retext | retract = "retract" + | otherwise = "extend" + +data BuildMutation = + BuildMutation { + description :: Text, + solverState :: SolverState, + updateBound :: Version -> VersionBounds -> VersionBounds + } + deriving stock (Generic) + +data MutationResult s = + MutationSuccess { candidate :: MutableId, changed :: Bool, state :: MutationState, ext :: s } + | + MutationKeep + | + MutationFailed + deriving stock (Eq, Show, Generic) + +data FailedMutation = + FailedMutation { + package :: MutableDep, + mutation :: Text + } + deriving stock (Eq, Show, Generic) + +instance Pretty FailedMutation where + pretty FailedMutation {package, mutation} = pretty package <+> prettyText mutation + +failedMutation :: + Pretty a => + DepMutation a -> + FailedMutation +failedMutation DepMutation {package, mutation} = + FailedMutation {package, mutation = showP mutation} diff --git a/lib/Hix/Managed/Data/MutationMode.hs b/lib/Hix/Managed/Data/MutationMode.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/MutationMode.hs @@ -0,0 +1,7 @@ +module Hix.Managed.Data.MutationMode where + +data MutationMode = + MutationMode { + foo :: Int + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Data/MutationState.hs b/lib/Hix/Managed/Data/MutationState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/MutationState.hs @@ -0,0 +1,40 @@ +module Hix.Managed.Data.MutationState where + +import Data.Map.Merge.Strict (dropMissing, mapMaybeMissing, zipWithMatched) +import Distribution.Pretty (Pretty (pretty)) +import GHC.Generics (Generically (Generically)) +import Text.PrettyPrint (hang, ($+$)) + +import Hix.Class.Map (nMerge) +import Hix.Data.Overrides (Overrides) +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Managed.Data.Mutable (MutableBounds, MutableVersions) + +data MutationState = + MutationState { + bounds :: MutableBounds, + versions :: MutableVersions, + overrides :: Overrides, + initial :: MutableVersions + } + deriving stock (Eq, Show, Generic) + deriving (Semigroup, Monoid) via (Generically MutationState) + +instance Pretty MutationState where + pretty MutationState {..} = + hang "bounds:" 2 (pretty bounds) $+$ + hang "versions:" 2 (pretty versions) $+$ + hang "overrides:" 2 (pretty overrides) $+$ + hang "initial:" 2 (pretty initial) + +updateBoundsWith :: (Version -> VersionBounds -> VersionBounds) -> MutationState -> MutationState +updateBoundsWith update MutationState {bounds, versions, ..} = + MutationState { + bounds = nMerge addBound dropMissing updateBound versions bounds, + versions, + .. + } + where + addBound = mapMaybeMissing \ _ -> fmap (flip update mempty) + updateBound = zipWithMatched \ _ -> maybe id update diff --git a/lib/Hix/Managed/Data/Packages.hs b/lib/Hix/Managed/Data/Packages.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Packages.hs @@ -0,0 +1,29 @@ +module Hix.Managed.Data.Packages where + +import Data.Aeson (FromJSON) +import Distribution.Pretty (Pretty (pretty)) +import GHC.Exts (IsList) + +import Hix.Class.EncodeNix (EncodeNix) +import Hix.Class.Map (LookupMaybe, LookupMonoid, NMap, nPretty, nPretty1) +import Hix.Data.PackageName (LocalPackage, PackageName) + +newtype Packages a = + Packages (Map LocalPackage a) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON, Semigroup, Monoid, IsList, EncodeNix) + +instance NMap (Packages a) LocalPackage a LookupMonoid where + +instance Pretty a => Pretty (Packages a) where + pretty = nPretty1 + +newtype Deps a = + Deps (Map PackageName a) + deriving stock (Eq, Show, Generic) + deriving newtype (FromJSON, Semigroup, Monoid, IsList, EncodeNix) + +instance NMap (Deps a) PackageName a LookupMaybe where + +instance Pretty a => Pretty (Deps a) where + pretty = nPretty diff --git a/lib/Hix/Managed/Data/ProcessState.hs b/lib/Hix/Managed/Data/ProcessState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ProcessState.hs @@ -0,0 +1,52 @@ +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.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.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) + +data ProcessState = + ProcessState { + packages :: Packages ManagedPackage, + state :: ProjectState + } + deriving stock (Eq, Show, Generic) + +instance Pretty ProcessState where + pretty ProcessState {..} = + 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 = + nAmend \ bounds ManagedPackage {..} -> ManagedPackage {mutable = nMap majorRange bounds, ..} + +removeLowerBounds :: ManagedPackage -> ManagedPackage +removeLowerBounds = + #mutable %~ nMap removeLowerBound + +-- | We remove lower bounds because they are likely to interfere with LowerInit, but upper bounds are useful. +initProcessState :: ProjectContext -> ProcessState +initProcessState context = + ProcessState { + packages = updateManagedPackages context.state.bounds (nMap removeLowerBounds context.packages), + state = context.state + } diff --git a/lib/Hix/Managed/Data/ProjectContext.hs b/lib/Hix/Managed/Data/ProjectContext.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ProjectContext.hs @@ -0,0 +1,17 @@ +module Hix.Managed.Data.ProjectContext where + +import Hix.Data.EnvName (EnvName) +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.ProjectState (ProjectState) + +data ProjectContext = + ProjectContext { + build :: BuildConfig, + state :: ProjectState, + packages :: Packages ManagedPackage, + envs :: NonEmpty (Either EnvName EnvContext) + } + deriving stock (Eq, Show) diff --git a/lib/Hix/Managed/Data/ProjectContextProto.hs b/lib/Hix/Managed/Data/ProjectContextProto.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ProjectContextProto.hs @@ -0,0 +1,29 @@ +module Hix.Managed.Data.ProjectContextProto where + +import Data.Aeson (FromJSON) + +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.ProjectStateProto (ProjectStateProto) +import Hix.Managed.Handlers.Build (BuildOutputsPrefix) + +data ProjectContextProto = + ProjectContextProto { + packages :: Packages ManagedPackageProto, + state :: ProjectStateProto, + envs :: Envs EnvConfig, + buildOutputsPrefix :: Maybe BuildOutputsPrefix + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON) + +instance Default ProjectContextProto where + def = + ProjectContextProto { + packages = mempty, + state = def, + envs = mempty, + buildOutputsPrefix = Nothing + } diff --git a/lib/Hix/Managed/Data/ProjectResult.hs b/lib/Hix/Managed/Data/ProjectResult.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ProjectResult.hs @@ -0,0 +1,11 @@ +module Hix.Managed.Data.ProjectResult where + +import Hix.Managed.Data.EnvResult (EnvResult) +import Hix.Managed.Data.ProjectState (ProjectState) + +data ProjectResult = + ProjectResult { + envs :: NonEmpty EnvResult, + state :: ProjectState + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Data/ProjectState.hs b/lib/Hix/Managed/Data/ProjectState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ProjectState.hs @@ -0,0 +1,31 @@ +module Hix.Managed.Data.ProjectState where + +import Distribution.Pretty (Pretty (pretty)) +import Text.PrettyPrint (hang, ($+$)) + +import Hix.Class.EncodeNix (EncodeNix) +import Hix.Data.Overrides (Overrides) +import Hix.Managed.Data.Envs (Envs) +import Hix.Managed.Data.Mutable (MutableBounds, MutableVersions) +import Hix.Managed.Data.Packages (Packages) + +data ProjectState = + ProjectState { + bounds :: Packages MutableBounds, + versions :: Envs MutableVersions, + initial :: Envs MutableVersions, + overrides :: Envs Overrides, + resolving :: Bool + } + deriving stock (Eq, Show, Generic) + deriving anyclass (EncodeNix) + +instance Pretty ProjectState where + pretty ProjectState {..} = + hang "bounds:" 2 (pretty bounds) $+$ + hang "versions:" 2 (pretty versions) $+$ + hang "initial:" 2 (pretty initial) $+$ + hang "overrides:" 2 (pretty overrides) + +instance Default ProjectState where + def = ProjectState {bounds = mempty, versions = mempty, overrides = mempty, initial = mempty, resolving = False} diff --git a/lib/Hix/Managed/Data/ProjectStateProto.hs b/lib/Hix/Managed/Data/ProjectStateProto.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/ProjectStateProto.hs @@ -0,0 +1,50 @@ +module Hix.Managed.Data.ProjectStateProto where + +import Data.Aeson (FromJSON (parseJSON), withObject, (.:?)) +import Distribution.Pretty (Pretty (pretty)) +import Text.PrettyPrint (hang, ($+$)) + +import Hix.Class.EncodeNix (EncodeNix) +import Hix.Data.Bounds (Bounds) +import Hix.Data.Json (foldMissing) +import Hix.Data.Overrides (Overrides) +import Hix.Data.Version (Versions) +import Hix.Managed.Data.Envs (Envs) +import Hix.Managed.Data.Packages (Packages) + +data ProjectStateProto = + ProjectStateProto { + bounds :: Packages Bounds, + versions :: Envs Versions, + overrides :: Envs Overrides, + initial :: Envs Versions, + resolving :: Bool + } + deriving stock (Eq, Show, Generic) + deriving anyclass (EncodeNix) + +instance Pretty ProjectStateProto where + pretty ProjectStateProto {..} = + hang "bounds:" 2 (pretty bounds) $+$ + hang "versions:" 2 (pretty versions) $+$ + hang "overrides:" 2 (pretty overrides) $+$ + hang "initial:" 2 (pretty initial) + +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" + resolving <- fromMaybe False <$> o .:? "resolving" + pure ProjectStateProto {..} + +instance Default ProjectStateProto where + def = + ProjectStateProto { + bounds = mempty, + versions = mempty, + overrides = mempty, + initial = mempty, + resolving = False + } diff --git a/lib/Hix/Managed/Data/Query.hs b/lib/Hix/Managed/Data/Query.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Query.hs @@ -0,0 +1,15 @@ +module Hix.Managed.Data.Query where + +import GHC.Exts (IsList) + +import Hix.Data.PackageName (PackageName) +import Hix.Managed.Data.QueryDep (QueryDep) + +newtype RawQuery = + RawQuery [PackageName] + deriving stock (Eq, Show, Generic) + deriving newtype (IsList) + +newtype Query = + Query (NonEmpty QueryDep) + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Data/QueryDep.hs b/lib/Hix/Managed/Data/QueryDep.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/QueryDep.hs @@ -0,0 +1,18 @@ +module Hix.Managed.Data.QueryDep where + +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Managed.Data.Mutable (MutableDep) + +-- | A dep that is eligible for being processed, which requires that it is not referring to a project-local package, +-- that it wasn't excluded by CLI options and arbitrary other conditions specific to individual stages. +data QueryDep = + QueryDep { + package :: MutableDep, + -- | Used to constrain the spectrum of candidate versions in some modes. + bounds :: VersionBounds, + current :: Maybe Version, + installed :: Maybe Version, + override :: Maybe Version + } + deriving stock (Eq, Show, Generic) diff --git a/lib/Hix/Managed/Data/StageContext.hs b/lib/Hix/Managed/Data/StageContext.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/StageContext.hs @@ -0,0 +1,17 @@ +module Hix.Managed.Data.StageContext where + +import Hix.Managed.Data.EnvContext (EnvContext) +import Hix.Managed.Data.Initial (Initial) +import Hix.Managed.Data.Mutable (MutableVersions) +import Hix.Managed.Data.MutationState (MutationState) +import Hix.Managed.Data.Query (Query) +import Hix.Managed.Handlers.Build (EnvBuilder) + +data StageContext = + StageContext { + env :: EnvContext, + builder :: EnvBuilder, + state :: Initial MutationState, + query :: Query, + initial :: MutableVersions + } diff --git a/lib/Hix/Managed/Data/StageResult.hs b/lib/Hix/Managed/Data/StageResult.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/StageResult.hs @@ -0,0 +1,33 @@ +module Hix.Managed.Data.StageResult where + +import Hix.Managed.Data.MutableId (MutableId) +import Hix.Managed.Data.Mutation (FailedMutation) +import Hix.Managed.Data.MutationState (MutationState) + +data StageFailure = + FailedPrecondition (NonEmpty Text) + | + FailedMutations Text (NonEmpty FailedMutation) + deriving stock (Eq, Show, Generic) + +data StageSummary = + StageFailure StageFailure + | + StageSuccess Text + | + StageNoAction (Maybe Text) + | + StageReport Text (NonEmpty MutableId) + deriving stock (Eq, Show, Generic) + +data StageResult = + StageResult { + summary :: StageSummary, + state :: Maybe MutationState + } + deriving stock (Eq, Show, Generic) + +stageFailures :: StageSummary -> [FailedMutation] +stageFailures = \case + StageFailure (FailedMutations _ mutations) -> toList mutations + _ -> [] diff --git a/lib/Hix/Managed/Data/StageState.hs b/lib/Hix/Managed/Data/StageState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/StageState.hs @@ -0,0 +1,55 @@ +module Hix.Managed.Data.StageState where + +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) + +data BuildStatus = + Success + | + Failure + deriving stock (Eq, Show, Generic) + +justSuccess :: a -> BuildStatus -> Maybe a +justSuccess a = \case + Success -> Just a + Failure -> Nothing + +buildStatus :: Bool -> BuildStatus +buildStatus = \case + True -> Success + False -> Failure + +data BuildSuccess = + CandidateBuilt MutableId + | + Unmodified MutableDep + deriving stock (Eq, Show, Generic) + +buildSuccessPackage :: BuildSuccess -> MutableDep +buildSuccessPackage = \case + CandidateBuilt MutableId {name} -> name + Unmodified name -> name + +modifiedCandidates :: [BuildSuccess] -> [MutableId] +modifiedCandidates = + mapMaybe \case + CandidateBuilt candidate -> Just candidate + Unmodified _ -> Nothing + +data StageState a s = + StageState { + success :: Map MutableDep BuildSuccess, + failed :: [DepMutation a], + state :: MutationState, + iterations :: Natural, + ext :: s + } + deriving stock (Eq, Show) + +initStageState :: Initial MutationState -> s -> StageState a s +initStageState (Initial state) ext = + StageState {success = [], failed = [], iterations = 0, ..} diff --git a/lib/Hix/Managed/Data/StateFileConfig.hs b/lib/Hix/Managed/Data/StateFileConfig.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/StateFileConfig.hs @@ -0,0 +1,17 @@ +module Hix.Managed.Data.StateFileConfig where + +import Path (Abs, Dir, File, Path, Rel, relfile) + +data StateFileConfig = + StateFileConfig { + file :: Path Rel File, + projectRoot :: Maybe (Path Abs Dir) + } + deriving stock (Eq, Show, Generic) + +instance Default StateFileConfig where + def = + StateFileConfig { + file = [relfile|ops/managed.nix|], + projectRoot = Nothing + } diff --git a/lib/Hix/Managed/Data/Targets.hs b/lib/Hix/Managed/Data/Targets.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Data/Targets.hs @@ -0,0 +1,98 @@ +module Hix.Managed.Data.Targets ( + Targets (Targets), + unsafeTargets, + getTargets, + targetsSet, + singleTarget, + sortTargets, + allMTargets, + 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 Hix.Class.EncodeNix (EncodeNixKey) +import Hix.Class.Map (nGet, nMap, nMapWithKey, nRestrictKeys) +import Hix.Data.PackageName (LocalPackage (LocalPackage)) +import Hix.Managed.Data.Packages (Packages) + +newtype EnvMember = + EnvMember LocalPackage + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON, FromJSONKey, Pretty, EncodeNixKey) + +newtype Targets = + UnsafeTargets [LocalPackage] + deriving stock (Eq, Show) + +pattern Targets :: [LocalPackage] -> Targets +pattern Targets pkgs <- UnsafeTargets pkgs + +{-# complete Targets #-} + +unsafeTargets :: [LocalPackage] -> Targets +unsafeTargets = UnsafeTargets + +singleTarget :: LocalPackage -> Targets +singleTarget = UnsafeTargets . pure + +instance IsString Targets where + fromString = singleTarget . fromString + +getTargets :: Targets -> [LocalPackage] +getTargets (Targets pkgs) = pkgs + +targetsSet :: Targets -> Set LocalPackage +targetsSet (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) + +onlyFrom :: Set LocalPackage -> [LocalPackage] -> [LocalPackage] +onlyFrom targets deps = + mapMaybe isTarget deps + where + isTarget = \case + dep | Set.member dep targets -> Just dep + _ -> Nothing + +sortTargets :: + Packages [LocalPackage] -> + [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 + +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 diff --git a/lib/Hix/Managed/Diff.hs b/lib/Hix/Managed/Diff.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Diff.hs @@ -0,0 +1,143 @@ +module Hix.Managed.Diff where + +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.Managed.Data.Diff (BoundsChange, BoundsDiffDetail (..), Change (..), Diff (..), VersionChange) +import Hix.Managed.Data.Mutable (MutableBounds, MutableDep, MutableDeps, MutableVersions) +import Hix.These (maybeThese) + +diffOriginal :: Diff d a -> Maybe a +diffOriginal = \case + DiffChanged original _ _ -> Just original + _ -> Nothing + +changeOriginal :: Change d a -> Maybe a +changeOriginal = \case + Unchanged original -> original + Changed d -> diffOriginal d + +reifyChangeWith :: b -> (a -> b) -> Change d a -> b +reifyChangeWith absent f = \case + Unchanged Nothing -> absent + Unchanged (Just a) -> f a + Changed (DiffAdded a) -> f a + Changed (DiffChanged _ a _) -> f a + +reifyChange :: a -> Change d a -> a +reifyChange absent = reifyChangeWith absent id + +reifyChangeMaybe :: Change d a -> Maybe a +reifyChangeMaybe = reifyChangeWith Nothing Just + +reifyBoundsChangeMaybe :: BoundsChange -> Maybe VersionBounds +reifyBoundsChangeMaybe = reifyChangeMaybe + +reifyBoundsChange :: BoundsChange -> VersionBounds +reifyBoundsChange = reifyChange anyBounds + +reifyBoundsChanges :: MutableDeps BoundsChange -> MutableBounds +reifyBoundsChanges = nMap reifyBoundsChange + +reifyVersionChange :: VersionChange -> Maybe Version +reifyVersionChange = reifyChangeMaybe + +reifyVersionChanges :: MutableDeps VersionChange -> MutableVersions +reifyVersionChanges = nMap reifyVersionChange + +applyVersionChange :: VersionChange -> Maybe Version -> Maybe Version +applyVersionChange d _ = reifyVersionChange d + +applyBoundsChange :: BoundsChange -> VersionBounds -> VersionBounds +applyBoundsChange d old = + fromMaybe old (reifyBoundsChangeMaybe d) + +diff :: + (a -> a -> Maybe d) -> + a -> + a -> + Change d a +diff mkDetail original new = + case mkDetail original new of + Just detail -> Changed (DiffChanged original new detail) + Nothing -> Unchanged (Just original) + +diffMaybe :: + (a -> a -> Maybe d) -> + Maybe a -> + Maybe a -> + Change d a +diffMaybe mkDetail original new = + case (original, new) of + (Just o, Just n) -> diff mkDetail o n + (Just o, Nothing) -> Unchanged (Just o) + (Nothing, Just n) -> Changed (DiffAdded n) + (Nothing, Nothing) -> Unchanged Nothing + +versionDiffDetail :: Version -> Version -> Maybe () +versionDiffDetail original new + | original == new + = Nothing + | otherwise + = Just () + +versionChange :: Maybe Version -> Maybe Version -> VersionChange +versionChange = diffMaybe versionDiffDetail + +versionDiff :: Maybe Version -> Maybe Version -> Maybe (Diff () Version) +versionDiff original new = + case versionChange original new of + Changed d -> Just d + Unchanged _ -> Nothing + +boundsDiffDetail :: VersionBounds -> VersionBounds -> Maybe BoundsDiffDetail +boundsDiffDetail original new = + BoundsDiffDetail <$> maybeThese diffL diffU + where + diffL = versionDiff original.lower combined.lower + diffU = versionDiff original.upper combined.upper + combined = new <> original + +boundsChange :: VersionBounds -> VersionBounds -> BoundsChange +boundsChange = diff boundsDiffDetail + +updateVersionChange :: Version -> VersionChange -> VersionChange +updateVersionChange new d = + diffMaybe versionDiffDetail (changeOriginal d) (Just new) + +-- | We never want to remove any bounds, but mutations only return the bound they have targeted, so we need to fall back +-- to the original bounds when updating. +updateBoundsChange :: VersionBounds -> BoundsChange -> BoundsChange +updateBoundsChange new d = + diffMaybe boundsDiffDetail original (Just combined) + where + (original, combined) = case changeOriginal d of + Just o -> (Just o, new <> o) + Nothing -> (Nothing, new) + +updateVersionChanges :: + NMap vmap MutableDep (Maybe Version) s1 => + NMap map MutableDep VersionChange s2 => + vmap -> + map -> + map +updateVersionChanges = + nAmend (maybe id updateVersionChange) + +updateBoundsChanges :: + NMap vmap MutableDep VersionBounds s1 => + NMap map MutableDep BoundsChange s2 => + vmap -> + map -> + map +updateBoundsChanges = + nAmend updateBoundsChange + +initChanges :: + NMap map1 k (Maybe v1) s1 => + NMap map2 k (Change d v1) s2 => + map1 -> + map2 +initChanges = + nMap Unchanged diff --git a/lib/Hix/Managed/EnvContext.hs b/lib/Hix/Managed/EnvContext.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/EnvContext.hs @@ -0,0 +1,68 @@ +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) +import Hix.Data.EnvName (EnvName) +import Hix.Data.Monad (M) +import qualified Hix.Data.Options +import Hix.Data.Options (ProjectOptions) +import Hix.Data.PackageName (LocalPackage) +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 qualified Hix.Managed.ManagedPackage as ManagedPackage +import Hix.Monad (clientError) +import Hix.Pretty (showPL) + +unknownTargets :: EnvName -> NonEmpty LocalPackage -> M () +unknownTargets env missing = + clientError msg + where + msg = + [exon|The flake config for '##{env}' references #{number} in its targets that #{verb} present|] + <> + [exon| in the configuration: #{showPL (toList missing)}|] + (number, verb) | [_] <- missing = ("a package", "isn't") + | otherwise = ("several packages", "aren't") + +envContext :: + ProjectOptions -> + Packages ManagedPackage -> + Maybe (NonEmpty MutableDep) -> + EnvName -> + EnvConfig -> + Either EnvDeps EnvContext +envContext opts packages querySpec env envConfig = + maybeToRight deps (create <$> nonEmpty envQuery) + where + create query = EnvContext {ghc = envConfig.ghc, query, deps, ..} + + deps = EnvDeps {local, mutable} + + solverBounds | opts.mergeBounds = mutRelax mutableDeps + | otherwise = mempty + + envQuery = maybe (toList mutable) (NonEmpty.filter (flip Set.member mutable)) querySpec + + local = nKeysSet localDeps + + mutable = nKeysSet mutableDeps + + (targets, localDeps, mutableDeps) = ManagedPackage.forTargets packages envConfig.targets + +envContexts :: + ProjectOptions -> + Packages ManagedPackage -> + Envs EnvConfig -> + Maybe (NonEmpty MutableDep) -> + M (Envs (Either EnvDeps EnvContext)) +envContexts opts packages envConfigs query = do + pure (nMapWithKey (envContext opts packages query) envConfigs) diff --git a/lib/Hix/Managed/EnvRequest.hs b/lib/Hix/Managed/EnvRequest.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/EnvRequest.hs @@ -0,0 +1,77 @@ +module Hix.Managed.EnvRequest where + +import Control.Lens ((%~)) +import Distribution.Pretty (pretty) +import Exon (exon) + +import Hix.Class.Map (nFlatten, nMap, nRestrictKeys, (!!)) +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 qualified Hix.Managed.Data.EnvContext +import Hix.Managed.Data.EnvContext (EnvContext) +import qualified Hix.Managed.Data.EnvRequest +import Hix.Managed.Data.EnvRequest (EnvRequest (EnvRequest)) +import qualified Hix.Managed.Data.EnvResult +import Hix.Managed.Data.EnvResult (EnvResult) +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.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.UpdateState (projectStateWithEnv) + +initialEnvState :: + EnvContext -> + ProjectState -> + Initial EnvState +initialEnvState context projectState = + Initial EnvState {..} + where + bounds = nFlatten (Unchanged . Just) (nRestrictKeys (targetsSet context.targets) projectState.bounds) + versions = initChanges (projectState.versions !! context.env) + overrides = projectState.overrides !! context.env + initial = initChanges (projectState.initial !! context.env) + +updateProcessState :: + EnvContext -> + Initial EnvState -> + EnvResult -> + ProcessState -> + ProcessState +updateProcessState context (Initial initialState) envResult ProcessState {state = projectState, packages} = do + ProcessState { + packages = overTargets context.targets replaceBounds packages, + state = projectStateWithEnv context final projectState + } + where + replaceBounds = #mutable %~ mutReplace ranges + ranges = nMap (majorRange . reifyBoundsChange) final.bounds + final = fromMaybe initialState envResult.state + +withEnvRequest :: + BuildHandlers -> + ProcessState -> + EnvContext -> + 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 + Log.debug [exon|Finished '##{context.env :: EnvName}' with final state:|] + Log.debugP (pretty newState) + pure (newState, envResult) + where + initialState = initialEnvState context state.state diff --git a/lib/Hix/Managed/EnvResult.hs b/lib/Hix/Managed/EnvResult.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/EnvResult.hs @@ -0,0 +1,122 @@ +module Hix.Managed.EnvResult where + +import Data.List.Extra (nubSortOn) +import Data.These (These (That, These, This)) +import Data.These.Combinators (justHere, justThere) +import GHC.Generics (Generically (Generically)) + +import Hix.Class.Map (nElems, nZipWithKey) +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Managed.Data.Diff ( + BoundsChange, + BoundsDiffDetail (BoundsDiffDetail), + Change (Changed, Unchanged), + Diff (DiffAdded, DiffChanged), + VersionChange, + ) +import Hix.Managed.Data.EnvResult (EnvResult (..)) +import qualified Hix.Managed.Data.EnvState +import Hix.Managed.Data.Mutable (MutableDep, MutableDeps) +import qualified Hix.Managed.Data.MutableId +import Hix.Managed.Data.MutableId (MutableId (MutableId)) +import Hix.Managed.Data.Mutation (FailedMutation) +import Hix.Managed.Data.StageResult (stageFailures) +import Hix.Managed.Diff (diffOriginal, reifyBoundsChange, reifyVersionChange) +import Hix.These (maybeThese) + +newtype BoundsModification = + BoundsModification (These (Maybe Version) (Maybe Version)) + deriving stock (Eq, Show, Generic) + +data DepModification = + DepAdded (Maybe BoundsModification) + | + DepUpdated (These Version BoundsModification) + deriving stock (Eq, Show, Generic) + +data DepResultDetail = + DepModified DepModification + | + DepUnmodified + deriving stock (Eq, Show, Generic) + +data DepResult = + DepResult { + package :: MutableDep, + version :: Version, + bounds :: VersionBounds, + detail :: DepResultDetail + } + deriving stock (Eq, Show, Generic) + +depResultId :: DepResult -> MutableId +depResultId DepResult {package, version} = + MutableId {name = package, version} + +depResult :: MutableDep -> VersionChange -> BoundsChange -> Maybe DepResult +depResult package versionChange boundsChange = do + version <- reifyVersionChange versionChange + pure DepResult { + package, + version, + bounds = reifyBoundsChange boundsChange, + detail + } + where + detail = case versionChange of + Changed (DiffAdded _) -> DepModified (DepAdded boundsUpdate) + Changed (DiffChanged original _ _) -> + DepModified (DepUpdated (maybe This (flip These) boundsUpdate original)) + Unchanged _ + | Just b <- boundsUpdate + -> DepModified (DepUpdated (That b)) + _ -> DepUnmodified + + boundsUpdate = case boundsChange of + Changed (DiffChanged _ _ (BoundsDiffDetail det)) -> + BoundsModification <$> maybeThese (diffOriginal <$> justHere det) (diffOriginal <$> justThere det) + _ -> Nothing + +deps :: EnvResult -> [DepResult] +deps EnvResult {state = Nothing} = + [] +deps EnvResult {state = Just state} = + catMaybes (nElems dv) + where + dv :: MutableDeps (Maybe DepResult) + dv = nZipWithKey depResult state.versions state.bounds + +data DepResults = + DepResults { + added :: [DepResult], + updated :: [DepResult], + unmodified :: [DepResult] + } + deriving stock (Eq, Show, Generic) + deriving (Semigroup, Monoid) via (Generically DepResults) + +-- TODO When this is used after merging envs for a report, it should probably combine packages from different lists. +-- If one env updates a package, we don't want to report it as unmodified because there's another env with the same dep. +-- Most likely the output should be env-keyed though, but not sure this is always desirable. +normalizeDepResults :: DepResults -> DepResults +normalizeDepResults DepResults {..} = + DepResults {added = normalize added, updated = normalize updated, unmodified = normalize unmodified} + where + normalize = nubSortOn (.package) + +grouped :: EnvResult -> DepResults +grouped result = + normalizeDepResults DepResults {..} + where + (added, updated, unmodified) = foldr (flip step) mempty (deps result) + + step (a, up, un) dep = + case dep.detail of + DepModified DepAdded {} -> (dep : a, up, un) + DepModified DepUpdated {} -> (a, dep : up, un) + DepUnmodified -> (a, up, dep : un) + +failures :: EnvResult -> [FailedMutation] +failures EnvResult {summaries} = + stageFailures =<< toList summaries diff --git a/lib/Hix/Managed/Flow.hs b/lib/Hix/Managed/Flow.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Flow.hs @@ -0,0 +1,144 @@ +module Hix.Managed.Flow ( + Flow, + liftM, + runStage, + execStage, + evalStage, + runStage_, + execStatelessStage, + evalStageState, + runFlow, + execFlow, + evalFlow, + stageError, +) where + +import Control.Lens ((%=)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (StateT, get, gets, runStateT) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as Text +import Exon (exon) + +import Hix.Data.Error (Error (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 +import Hix.Managed.Data.EnvRequest (EnvRequest (EnvRequest)) +import qualified Hix.Managed.Data.EnvResult +import Hix.Managed.Data.EnvResult (EnvResult (EnvResult)) +import Hix.Managed.Data.EnvState (EnvState) +import Hix.Managed.Data.Initial (Initial (Initial)) +import Hix.Managed.Data.StageContext (StageContext) +import Hix.Managed.Data.StageResult (StageFailure (FailedPrecondition), StageResult (..), StageSummary (StageFailure)) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Managed.StageContext (stageContext) +import Hix.Managed.UpdateState (envStateWithMutations) +import Hix.Monad (throwM) + +data FlowState = + FlowState { + env :: EnvRequest, + current :: EnvState, + summaries :: [StageSummary] + } + deriving stock (Generic) + +type FlowM = StateT FlowState M + +newtype Flow x = + Flow (FlowM x) + deriving newtype (Functor, Applicative, Monad) + +liftM :: M a -> Flow a +liftM = Flow . lift + +addResult :: + StageResult -> + Flow BuildStatus +addResult StageResult {state, summary} = + Flow do + #summaries %= (summary :) + #current %= maybe id envStateWithMutations state + pure status + where + status = case summary of + StageFailure _ -> Failure + _ -> Success + +newContext :: Flow StageContext +newContext = do + FlowState {env, current} <- Flow get + pure (stageContext env current) + +runStage :: + ∀ o . + Text -> + (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}'|]) + context <- newContext + (result, o) <- liftM (stage context) + status <- addResult result + pure (status, o) + +execStage :: + Text -> + (StageContext -> M StageResult) -> + Flow BuildStatus +execStage description stage = + fst <$> runStage description (fmap (, ()) . stage) + +evalStage :: + Text -> + (StageContext -> M (StageResult, o)) -> + Flow o +evalStage description stage = + snd <$> runStage description stage + +runStage_ :: + Text -> + (StageContext -> M StageResult) -> + Flow () +runStage_ description stage = + void (execStage description stage) + +execStatelessStage :: + Text -> + (StageContext -> M StageSummary) -> + Flow BuildStatus +execStatelessStage description f = do + execStage description \ context -> do + summary <- f context + pure StageResult {state = Nothing, summary} + +stageError :: Text -> Flow () +stageError msg = + void (execStatelessStage "" (const (pure (StageFailure (FailedPrecondition [msg]))))) + +evalStageState :: (EnvState -> StageContext -> a) -> Flow a +evalStageState f = do + context <- newContext + state <- Flow (gets (.current)) + pure (f state context) + +runFlow :: EnvRequest -> Flow o -> M (o, EnvResult) +runFlow request@EnvRequest {context, state = (Initial initState)} (Flow m) = + runStateT m FlowState {env = request, current = initState, summaries = []} >>= traverse \case + FlowState {summaries = h : t, current = finalState} -> + pure EnvResult {env = context.env, state = Just finalState, summaries = NonEmpty.reverse (h :| t)} + FlowState {summaries = []} -> + throwM (Fatal "Executed flow with no stages") + +execFlow :: EnvRequest -> Flow () -> M EnvResult +execFlow env m = + snd <$> runFlow env m + +evalFlow :: EnvRequest -> Flow o -> M o +evalFlow env m = + fst <$> runFlow env m diff --git a/lib/Hix/Managed/Handlers/Build.hs b/lib/Hix/Managed/Handlers/Build.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Build.hs @@ -0,0 +1,95 @@ +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.Managed.Cabal.Changes (SolverPlan) +import Hix.Managed.Cabal.Data.Config (GhcDb) +import Hix.Managed.Data.Constraints (EnvConstraints) +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.StageState (BuildStatus (Failure)) +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 Hix.Managed.Overrides (packageOverrides) + +newtype BuildOutputsPrefix = + BuildOutputsPrefix Text + deriving stock (Eq, Show, Generic) + deriving newtype (IsString, Ord, FromJSON) + +data EnvBuilder = + EnvBuilder { + cabal :: CabalHandlers, + buildWithState :: Versions -> [PackageId] -> M (Overrides, BuildStatus) + } + +data Builder = + Builder { + withEnvBuilder :: ∀ a . CabalHandlers -> EnvContext -> Initial EnvState -> (EnvBuilder -> M a) -> M a + } + +runBuilder :: Builder -> CabalHandlers -> EnvContext -> Initial EnvState -> (EnvBuilder -> M a) -> M a +runBuilder Builder {withEnvBuilder} = withEnvBuilder + +data BuildHandlers = + BuildHandlers { + stateFile :: StateFileHandlers, + report :: ReportHandlers, + cabal :: Packages ManagedPackage -> GhcDb -> M CabalHandlers, + withBuilder :: ∀ a . (Builder -> M a) -> M a, + versions :: PackageName -> M [Version], + latestVersion :: PackageName -> M (Maybe Version) + } + +testBuilder :: (Versions -> [PackageId] -> M (Overrides, BuildStatus)) -> (Builder -> M a) -> M a +testBuilder buildWithState use = + use Builder {withEnvBuilder = \ cabal _ _ useE -> useE EnvBuilder {cabal, buildWithState}} + +versionsBuilder :: HackageHandlers -> (Versions -> M BuildStatus) -> (Builder -> M a) -> M a +versionsBuilder hackage build = + testBuilder \ versions overrideVersions -> do + overrides <- packageOverrides hackage overrideVersions + status <- build versions + pure (overrides, status) + +handlersNull :: BuildHandlers +handlersNull = + BuildHandlers { + stateFile = StateFileHandlers.handlersNull, + report = Report.handlersNull, + cabal = \ _ _ -> pure Solve.handlersNull, + withBuilder = testBuilder \ _ _ -> pure (mempty, Failure), + versions = \ _ -> pure [], + latestVersion = \ _ -> pure Nothing + } + +wrapCabal :: (CabalHandlers -> CabalHandlers) -> BuildHandlers -> BuildHandlers +wrapCabal f BuildHandlers {..} = + BuildHandlers {cabal = \ p d -> f <$> cabal p d, ..} + +logCabal :: + MonadIO m => + BuildHandlers -> + m (IORef [(EnvConstraints, Maybe SolverPlan)], BuildHandlers) +logCabal handlers = do + ref <- liftIO (newIORef []) + pure (ref, wrapCabal (Cabal.logCabal ref) handlers) + +data SpecialBuildHandlers = + TestBumpHandlers + deriving stock (Eq, Show) diff --git a/lib/Hix/Managed/Handlers/Build/Prod.hs b/lib/Hix/Managed/Handlers/Build/Prod.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Build/Prod.hs @@ -0,0 +1,188 @@ +module Hix.Managed.Handlers.Build.Prod where + +import Control.Monad.Catch (catch) +import Control.Monad.Trans.Reader (asks) +import Exon (exon) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Path (Abs, Dir, Path, toFilePath) +import Path.IO (copyDirRecur') +import System.IO.Error (IOError) +import System.Process.Typed ( + ExitCode (ExitFailure, ExitSuccess), + ProcessConfig, + inherit, + nullStream, + proc, + runProcess, + setStderr, + setStdout, + setWorkingDir, + ) + +import Hix.Data.EnvName (EnvName) +import Hix.Data.Error (Error (Fatal)) +import qualified Hix.Data.Monad +import Hix.Data.Monad (M (M)) +import Hix.Data.Overrides (Overrides) +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.Cabal.Data.Config (CabalConfig) +import Hix.Managed.Data.EnvConfig (EnvConfig) +import qualified Hix.Managed.Data.EnvContext +import Hix.Managed.Data.EnvContext (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 (BuildStatus, buildStatus) +import qualified Hix.Managed.Data.StateFileConfig +import Hix.Managed.Data.StateFileConfig (StateFileConfig) +import Hix.Managed.Data.Targets (allMTargets) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.Handlers.Build (BuildHandlers (..), BuildOutputsPrefix, Builder (Builder), EnvBuilder (EnvBuilder)) +import Hix.Managed.Handlers.Cabal (CabalHandlers) +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 Hix.Managed.Handlers.StateFile (StateFileHandlers) +import qualified Hix.Managed.Handlers.StateFile.Prod as StateFileHandlers +import Hix.Managed.Overrides (packageOverrides) +import Hix.Managed.Path (rootOrCwd) +import Hix.Managed.StateFile (writeBuildStateFor, writeInitialEnvState) +import Hix.Monad (throwM, tryIOM, withTempDir) + +data BuilderResources = + BuilderResources { + hackage :: HackageHandlers, + stateFileHandlers :: StateFileHandlers, + envsConf :: Envs EnvConfig, + buildOutputsPrefix :: Maybe BuildOutputsPrefix, + root :: Path Abs Dir + } + +data EnvBuilderResources = + EnvBuilderResources { + global :: BuilderResources, + context :: EnvContext + } + +withTempProject :: + Maybe (Path Abs Dir) -> + (Path Abs Dir -> M a) -> + M a +withTempProject rootOverride use = do + projectRoot <- rootOrCwd rootOverride + catch + do + withTempDir "managed-build" \ tmpRoot -> do + copyDirRecur' projectRoot tmpRoot + use tmpRoot + \ (err :: IOError) -> throwM (Fatal (show err)) + +nixProc :: + Path Abs Dir -> + [Text] -> + Text -> + [Text] -> + M (ProcessConfig () () ()) +nixProc root cmd installable extra = do + Log.debug [exon|Running nix at '#{pathText root}' with args #{show args}|] + conf <$> M (asks (.debug)) + where + conf debug = err debug (setWorkingDir (toFilePath root) (proc "nix" args)) + + err = \case + True -> setStderr inherit + False -> setStderr nullStream + + args = toString <$> cmd ++ [exon|path:#{".#"}#{installable}|] : extra + +buildPackage :: + Path Abs Dir -> + EnvName -> + LocalPackage -> + M Bool +buildPackage root env target = do + debug <- M (asks (.debug)) + conf <- nixProc root ["-L", "build"] [exon|env.##{env}.##{target}|] [] + tryIOM (runProcess (err debug conf)) <&> \case + ExitSuccess -> True + ExitFailure _ -> False + where + err = \case + True -> setStdout inherit + False -> id + +buildWithState :: + EnvBuilderResources -> + Versions -> + [PackageId] -> + M (Overrides, BuildStatus) +buildWithState EnvBuilderResources {global, context = context@EnvContext {env, targets}} _ overrideVersions = do + overrides <- packageOverrides global.hackage overrideVersions + writeBuildStateFor "current build" global.stateFileHandlers global.root context overrides + status <- buildStatus <$> allMTargets (buildPackage global.root env) targets + pure (overrides, status) + +-- | This used to have the purpose of reading an updated GHC package db using the current managed state, but this has +-- become obsolete. +-- +-- TODO Decide whether to keep this for abstraction purposes. +withEnvBuilder :: + ∀ a . + BuilderResources -> + CabalHandlers -> + EnvContext -> + Initial EnvState -> + (EnvBuilder -> 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 {..} + +withBuilder :: + HackageHandlers -> + StateFileHandlers -> + StateFileConfig -> + Envs EnvConfig -> + Maybe BuildOutputsPrefix -> + (Builder -> M a) -> + M a +withBuilder hackage stateFileHandlers stateFileConf envsConf buildOutputsPrefix use = + withTempProject stateFileConf.projectRoot \ root -> do + let resources = BuilderResources {..} + use Builder {withEnvBuilder = withEnvBuilder resources} + +handlersProd :: + MonadIO m => + StateFileConfig -> + Envs EnvConfig -> + Maybe BuildOutputsPrefix -> + CabalConfig -> + Bool -> + m BuildHandlers +handlersProd stateFileConf envsConf buildOutputsPrefix cabalConf oldest = do + manager <- liftIO (newManager tlsManagerSettings) + hackage <- HackageHandlers.handlersProd + let stateFile = StateFileHandlers.handlersProd stateFileConf + pure BuildHandlers { + stateFile, + report = ReportHandlers.handlersProd, + cabal = CabalHandlers.handlersProd cabalConf oldest, + withBuilder = withBuilder hackage stateFile stateFileConf envsConf buildOutputsPrefix, + versions = versionsHackage manager, + latestVersion = latestVersionHackage manager + } diff --git a/lib/Hix/Managed/Handlers/Build/Test.hs b/lib/Hix/Managed/Handlers/Build/Test.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Build/Test.hs @@ -0,0 +1,92 @@ +module Hix.Managed.Handlers.Build.Test where + +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.PackageName (PackageName) +import Hix.Data.Version (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.EnvConfig (EnvConfig) +import Hix.Managed.Data.Envs (Envs) +import Hix.Managed.Data.Mutation (FailedMutation) +import Hix.Managed.Data.StageState (BuildStatus) +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.Report.Test as ReportHandlers +import qualified Hix.Managed.Handlers.StateFile.Test as StateFile +import Hix.Monad (clientError) + +handlersUnitTest :: + MonadIO m => + GhcPackages -> + (Versions -> M BuildStatus) -> + m (BuildHandlers, IORef [Expr], IORef [FailedMutation]) +handlersUnitTest ghcPackages builder = do + (stateFile, stateFileRef) <- StateFile.handlersUnitTest + (report, mutationsRef) <- ReportHandlers.handlersUnitTest + let + handlers = + BuildHandlers { + stateFile, + report, + cabal, + withBuilder = versionsBuilder HackageHandlers.handlersNull builder, + versions = queryVersions versions, + latestVersion = queryVersionsLatest versions + } + 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 -> + CabalConfig -> + Bool -> + m BuildHandlers +handlersBumpTest stateFileConf envsConf buildOutputsPrefix cabalConf oldest = do + handlers <- handlersProd stateFileConf envsConf buildOutputsPrefix cabalConf oldest + pure handlers { + cabal = CabalHandlers.handlersTest cabalConf oldest, + latestVersion = latestVersionNixTestBump + } + +chooseHandlers :: + MonadIO m => + StateFileConfig -> + Envs EnvConfig -> + Maybe BuildOutputsPrefix -> + CabalConfig -> + Maybe SpecialBuildHandlers -> + m BuildHandlers +chooseHandlers stateFileConf envsConf buildOutputsPrefix cabalConf = \case + Just TestBumpHandlers -> handlersBumpTest stateFileConf envsConf buildOutputsPrefix cabalConf oldest + Nothing -> handlersProd stateFileConf envsConf buildOutputsPrefix cabalConf oldest + where + oldest = False diff --git a/lib/Hix/Managed/Handlers/Cabal.hs b/lib/Hix/Managed/Handlers/Cabal.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Cabal.hs @@ -0,0 +1,41 @@ +module Hix.Managed.Handlers.Cabal where + +import Data.IORef (IORef, modifyIORef') + +import Hix.Class.Map (nFromKeys) +import Hix.Data.Monad (M) +import Hix.Data.PackageName (PackageName) +import Hix.Data.Version (Version) +import Hix.Managed.Cabal.Changes (SolverPlan) +import Hix.Managed.Cabal.Data.SolverState (SolverState) +import Hix.Managed.Data.Constraints (EnvConstraints) +import Hix.Managed.Data.Mutable (MutableDep, MutableVersions, depName) + +data CabalHandlers = + CabalHandlers { + solveForVersion :: SolverState -> M (Maybe SolverPlan), + installedVersion :: PackageName -> Maybe Version + } + +handlersNull :: CabalHandlers +handlersNull = + CabalHandlers { + solveForVersion = \ _ -> pure Nothing, + installedVersion = const Nothing + } + +installedVersions :: + CabalHandlers -> + Set MutableDep -> + MutableVersions +installedVersions cabal names = + nFromKeys names (cabal.installedVersion . depName) + +logCabal :: IORef [(EnvConstraints, Maybe SolverPlan)] -> CabalHandlers -> CabalHandlers +logCabal ref CabalHandlers {..} = + CabalHandlers {solveForVersion = solve, ..} + where + solve state = do + plan <- solveForVersion state + liftIO (modifyIORef' ref ((state.constraints, plan) :)) + pure plan diff --git a/lib/Hix/Managed/Handlers/Cabal/Prod.hs b/lib/Hix/Managed/Handlers/Cabal/Prod.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Cabal/Prod.hs @@ -0,0 +1,87 @@ +module Hix.Managed.Handlers.Cabal.Prod where + +import qualified Data.Map.Strict as Map +import Distribution.Client.Dependency (PackagesPreferenceDefault (PreferAllOldest), setPreferenceDefault) +import qualified Distribution.Client.Types +import Distribution.Client.Types (SourcePackageDb (SourcePackageDb), UnresolvedSourcePackage) +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 Hix.Data.PackageId (PackageId (PackageId)) +import qualified Hix.Data.PackageName as PackageName +import Hix.Data.PackageName (PackageName) +import Hix.Managed.Cabal.Data.Config (GhcDb, CabalConfig) +import qualified Hix.Managed.Cabal.Data.SolveResources as SolveResources +import Hix.Managed.Cabal.Data.SolveResources (SolveResources (SolveResources), solverParams) +import Hix.Managed.Cabal.Installed (installedVersion) +import qualified Hix.Managed.Cabal.Resources as SolveResources +import Hix.Managed.Cabal.Solve (solveWithCabal) +import Hix.Managed.Data.ManagedPackage (ManagedPackage) +import Hix.Managed.Data.Packages (Packages) +import Hix.Managed.Handlers.Cabal (CabalHandlers (..)) +import Hix.Zip (zipApplyL) + +handlersWith :: + (SolveResources -> SolveResources) -> + CabalConfig -> + Bool -> + Packages ManagedPackage -> + GhcDb -> + M CabalHandlers +handlersWith trans cabalConf oldest packages ghc = do + solveResources <- trans <$> SolveResources.acquire packages cabalConf ghc + pure CabalHandlers { + solveForVersion = solveWithCabal solveResources {solverParams}, + installedVersion = installedVersion solveResources.installedPkgIndex + } + where + solverParams | oldest = setPreferenceDefault PreferAllOldest + | otherwise = id + +handlersProd :: + CabalConfig -> + Bool -> + Packages ManagedPackage -> + GhcDb -> + M CabalHandlers +handlersProd = + handlersWith id + +testPackagesBump :: Map PackageName PackageId +testPackagesBump = + Map.fromList $ zipApplyL (.name) [ + PackageId {name = "aeson", version = [2, 2, 0, 0]}, + PackageId {name = "base", version = [4, 17, 2, 0]}, + PackageId {name = "extra", version = [1, 7, 14]}, + PackageId {name = "th-abstraction", version = [0, 5, 0, 0]}, + PackageId {name = "path", version = [0, 9, 5]} + ] + +removeLaterVersions :: + PackageId -> + PackageIndex UnresolvedSourcePackage -> + PackageIndex UnresolvedSourcePackage +removeLaterVersions PackageId {..} = + PackageIndex.deleteDependency (PackageName.toCabal name) (laterVersion version) + +testResources :: SolveResources -> SolveResources +testResources SolveResources {..} = + SolveResources {sourcePkgDb = removeLaterTestPackageVersions sourcePkgDb, ..} + where + removeLaterTestPackageVersions SourcePackageDb {..} = + SourcePackageDb { + packageIndex = Map.foldr' removeLaterVersions packageIndex testPackagesBump, + .. + } + +handlersTest :: + CabalConfig -> + Bool -> + Packages ManagedPackage -> + GhcDb -> + M CabalHandlers +handlersTest = + handlersWith testResources diff --git a/lib/Hix/Managed/Handlers/Hackage.hs b/lib/Hix/Managed/Handlers/Hackage.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Hackage.hs @@ -0,0 +1,17 @@ +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)) + } diff --git a/lib/Hix/Managed/Handlers/Hackage/Prod.hs b/lib/Hix/Managed/Handlers/Hackage/Prod.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Hackage/Prod.hs @@ -0,0 +1,16 @@ +module Hix.Managed.Handlers.Hackage.Prod where + +import Data.IORef (newIORef) + +import Hix.Hackage (fetchHashHackageCached) +import qualified Hix.Managed.Handlers.Hackage +import Hix.Managed.Handlers.Hackage (HackageHandlers (HackageHandlers)) + +handlersProd :: + MonadIO m => + m HackageHandlers +handlersProd = do + hashCache <- liftIO (newIORef mempty) + pure HackageHandlers { + fetchHash = fetchHashHackageCached hashCache + } diff --git a/lib/Hix/Managed/Handlers/Mutation.hs b/lib/Hix/Managed/Handlers/Mutation.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Mutation.hs @@ -0,0 +1,14 @@ +module Hix.Managed.Handlers.Mutation where + +import Hix.Data.Monad (M) +import Hix.Managed.Data.Mutation (BuildMutation, DepMutation, MutationResult) +import Hix.Managed.Data.MutationState (MutationState) + +data MutationHandlers a s = + MutationHandlers { + process :: + s -> + DepMutation a -> + (BuildMutation -> M (Maybe MutationState)) -> + M (MutationResult s) + } diff --git a/lib/Hix/Managed/Handlers/Mutation/Bump.hs b/lib/Hix/Managed/Handlers/Mutation/Bump.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Mutation/Bump.hs @@ -0,0 +1,50 @@ +module Hix.Managed.Handlers.Mutation.Bump where + +import Hix.Data.Monad (M) +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import Hix.Data.Version (Version) +import qualified Hix.Data.VersionBounds as VersionBounds +import Hix.Data.VersionBounds (VersionBounds, fromLower) +import Hix.Managed.Build.Mutation (buildCandidate) +import Hix.Managed.Cabal.Data.SolverState (SolverState) +import qualified Hix.Managed.Data.Bump +import Hix.Managed.Data.Bump (Bump (Bump)) +import qualified Hix.Managed.Data.Constraints +import Hix.Managed.Data.Constraints (MutationConstraints (MutationConstraints)) +import Hix.Managed.Data.MutableId (MutableId) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation ( + BuildMutation, + DepMutation (DepMutation), + MutationResult (MutationFailed, MutationSuccess), + ) +import Hix.Managed.Data.MutationState (MutationState) +import qualified Hix.Managed.Handlers.Mutation +import Hix.Managed.Handlers.Mutation (MutationHandlers (MutationHandlers)) +import Hix.Version (nextMajor) + +updateConstraintsBump :: MutableId -> PackageId -> MutationConstraints -> MutationConstraints +updateConstraintsBump _ PackageId {version} MutationConstraints {..} = + MutationConstraints {mutation = fromLower version, ..} + +updateBound :: Version -> VersionBounds -> VersionBounds +updateBound = VersionBounds.withUpper . nextMajor + +-- TODO Avoid building unchanged candidates after the first build of the same set of deps. +processMutationBump :: + SolverState -> + DepMutation Bump -> + (BuildMutation -> M (Maybe MutationState)) -> + M (MutationResult SolverState) +processMutationBump solver DepMutation {package, mutation = Bump {version, changed}} build = + builder version <&> \case + Just (candidate, ext, state) -> + MutationSuccess {candidate, changed, state, ext} + Nothing -> + MutationFailed + where + builder = buildCandidate build updateBound updateConstraintsBump solver package + +handlersBump :: MutationHandlers Bump SolverState +handlersBump = MutationHandlers {process = processMutationBump} diff --git a/lib/Hix/Managed/Handlers/Mutation/Lower.hs b/lib/Hix/Managed/Handlers/Mutation/Lower.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Mutation/Lower.hs @@ -0,0 +1,83 @@ +module Hix.Managed.Handlers.Mutation.Lower where + +import Control.Monad (foldM) +import Data.Foldable.Extra (firstJustM) +import Data.Generics.Labels () +import Exon (exon) + +import Hix.Data.Monad (M) +import Hix.Data.PackageId (PackageId) +import qualified Hix.Data.Version +import Hix.Data.Version (Major (Major)) +import Hix.Data.VersionBounds (withLower) +import qualified Hix.Log as Log +import Hix.Managed.Build.Mutation (buildCandidate) +import Hix.Managed.Cabal.Data.SolverState (SolverState) +import qualified Hix.Managed.Data.BuildConfig +import Hix.Managed.Data.BuildConfig (BuildConfig) +import Hix.Managed.Data.Constraints (MutationConstraints) +import qualified Hix.Managed.Data.Lower +import Hix.Managed.Data.Lower (Lower (Lower)) +import Hix.Managed.Data.MutableId (MutableId) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (BuildMutation, DepMutation (DepMutation), MutationResult (MutationSuccess)) +import Hix.Managed.Data.MutationState (MutationState) +import qualified Hix.Managed.Handlers.Mutation +import Hix.Managed.Handlers.Mutation (MutationHandlers (MutationHandlers)) +import qualified Hix.Managed.Lower.Data.LowerMode +import Hix.Managed.Lower.Data.LowerMode (LowerMode) +import Hix.Pretty (showP) + +-- TODO would be nice if the deps that succeed as transitive deps would have their candidates trimmed so that it +-- immediately returns success when the version is encountered that succeeded most recently that way. +-- +-- TODO Can we get a sensible value for @changed@? +processMutationLower :: + BuildConfig -> + LowerMode -> + (Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints) -> + SolverState -> + DepMutation Lower -> + (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)) -> + MutationSuccess {candidate, changed = True, state, ext} + (_, Nothing) -> + mode.noSuccess + where + -- | We skip all remaining majors when the number of failed majors exceeds the configured limit. + -- There are different values for failures before the first and after the last success. + -- This avoid building the project tens of times for versions that cannot succeed. + -- + -- We also skip all remaining majors when @firstSuccess@ is set, after a major succeeded. + buildMajor (failed, prev) Major {prefix, versions} + | Right n <- failed + , n > conf.maxFailedPre + = pure (failed, prev) + + | Left n <- failed + , n > conf.maxFailedPost + = pure (failed, prev) + + | mode.firstSuccess + , Just _ <- prev + = pure (failed, prev) + + | otherwise + = do + Log.debug [exon|Building major #{showP prefix} for '##{package}'|] + firstJustM builder versions <&> \case + Just result -> (Left 0, Just result) + Nothing -> (bimap (+ 1) (+ 1) failed, prev) + + builder = buildCandidate build withLower (update retract) solver package + +handlersLower :: + BuildConfig -> + LowerMode -> + (Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints) -> + MutationHandlers Lower SolverState +handlersLower conf mode updatePackageParams = + MutationHandlers {process = processMutationLower conf mode updatePackageParams} diff --git a/lib/Hix/Managed/Handlers/Report.hs b/lib/Hix/Managed/Handlers/Report.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Report.hs @@ -0,0 +1,13 @@ +module Hix.Managed.Handlers.Report where + +import Hix.Data.Monad (M) +import Hix.Managed.Data.ProjectResult (ProjectResult) + +data ReportHandlers = + ReportHandlers { + mutations :: ProjectResult -> M () + } + +handlersNull :: ReportHandlers +handlersNull = + ReportHandlers {mutations = \ _ -> unit} diff --git a/lib/Hix/Managed/Handlers/Report/Prod.hs b/lib/Hix/Managed/Handlers/Report/Prod.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Report/Prod.hs @@ -0,0 +1,186 @@ +module Hix.Managed.Handlers.Report.Prod where + +import qualified Data.Text as Text +import Data.These (These (..)) +import Data.These.Combinators (justHere, justThere) +import Exon (exon) + +import qualified Hix.Console +import Hix.Console (color, colors) +import Hix.Data.Monad (M) +import Hix.Data.Version (Version) +import qualified Hix.Data.VersionBounds +import Hix.Data.VersionBounds (VersionBounds (VersionBounds)) +import qualified Hix.Log as Log +import qualified Hix.Managed.Data.EnvResult +import Hix.Managed.Data.EnvResult (EnvResult (EnvResult)) +import Hix.Managed.Data.Mutable (MutableDep) +import qualified Hix.Managed.Data.MutableId +import Hix.Managed.Data.MutableId (MutableId (MutableId)) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (FailedMutation) +import qualified Hix.Managed.Data.ProjectResult as ProjectResult +import Hix.Managed.Data.ProjectResult (ProjectResult) +import Hix.Managed.Data.StageResult (StageFailure (FailedMutations, FailedPrecondition), StageSummary (..)) +import qualified Hix.Managed.EnvResult +import qualified Hix.Managed.EnvResult as EnvResult +import Hix.Managed.EnvResult ( + BoundsModification (BoundsModification), + DepModification (DepAdded, DepUpdated), + DepResult (DepResult), + DepResultDetail (..), + DepResults (DepResults), + ) +import qualified Hix.Managed.Handlers.Report +import Hix.Managed.Handlers.Report (ReportHandlers (ReportHandlers)) +import Hix.Pretty (showP) + +blankLine :: M () +blankLine = Log.infoPlain "" + +listFailed :: + FailedMutation -> + Text +listFailed mutation = [exon|📦 #{showP mutation.package}|] + +reportFailed :: + NonEmpty FailedMutation -> + M () +reportFailed = + traverse_ \ mut -> Log.infoCont (listFailed mut) + +reportNewVersions :: + NonEmpty MutableId -> + M () +reportNewVersions = + traverse_ \ MutableId {name, version} -> + Log.infoCont [exon|📦 '##{name}': #{showP version}|] + +printSummary :: StageSummary -> M () +printSummary = \case + StageSuccess msg -> Log.info msg + StageFailure (FailedMutations msg failed) -> do + Log.info msg + reportFailed failed + StageFailure (FailedPrecondition msg) -> + traverse_ Log.info msg + StageNoAction msg -> traverse_ Log.info msg + StageReport msg versions -> do + Log.info msg + reportNewVersions versions + +printBounds :: + (Version -> Text) -> + (Version -> Text) -> + Maybe Version -> + Maybe Version -> + Text +printBounds printL printU lower upper = + case (lower, upper) of + (Just l, Just u) -> [exon|[#{printL l}, #{printU u}]|] + (Just l, Nothing) -> [exon|>=#{printL l}|] + (Nothing, Just u) -> [exon|<#{printU u}|] + (Nothing, Nothing) -> "[no bounds]" + +formatDepLine :: MutableDep -> Text -> Text -> (Text, Text, Text) +formatDepLine package version bounds = + ([exon|📦 #{color colors.blue (showP package)}|], version, [exon|↕ #{bounds}|]) + +formatBoundsModification :: VersionBounds -> BoundsModification -> Text +formatBoundsModification VersionBounds {lower = lowerNew, upper = upperNew} (BoundsModification bm) = + [exon|#{original} -> #{new}|] + where + + original = interval lowerOriginal upperOriginal colors.red lowerChanged upperChanged + new = interval lowerNew upperNew colors.green lowerChanged upperChanged + + lowerOriginal = fromMaybe lowerNew lowerDiff + upperOriginal = fromMaybe upperNew upperDiff + + lowerChanged = isJust lowerDiff + upperChanged = isJust upperDiff + + lowerDiff = justHere bm + upperDiff = justThere bm + + interval l u col colL colU = + printBounds (bound col colL) (bound col colU) l u + + bound col useCol v + | useCol + = color col (showP v) + | otherwise + = showP v + +formatDep :: MutableDep -> Version -> VersionBounds -> Maybe BoundsModification -> (Text, Text, Text) +formatDep package version bounds boundsMod = + formatDepLine package (showP version) (maybe unchangedBounds changedBounds boundsMod) + where + changedBounds = formatBoundsModification bounds + unchangedBounds = printBounds showP showP bounds.lower bounds.upper + +formatDepUpdate :: + MutableDep -> + Version -> + VersionBounds -> + These Version BoundsModification -> + (Text, Text, Text) +formatDepUpdate package version bounds update = + formatDepLine package versionDesc boundsDesc + where + versionDesc = case justHere update of + Just original -> versionUpdate original version + Nothing -> showP version + + versionUpdate original new = + [exon|#{color colors.red (showP original)} -> #{color colors.green (showP new)}|] + + boundsDesc = case justThere update of + Just boundsMod -> formatBoundsModification bounds boundsMod + Nothing -> showP bounds + +printAligned :: [(Text, Text, Text)] -> M () +printAligned deps = + traverse_ printLine deps + where + printLine (p, v, b) = Log.infoCont (padded p maxP <> padded v maxV <> b) + padded s maxlen = s <> Text.replicate (maxlen - Text.length s + 3) " " + maxP = maxi ps + maxV = maxi vs + maxi = fromMaybe 0 . maximum . fmap Text.length + (ps, vs, _) = unzip3 deps + +formatDepResult :: DepResult -> Maybe (Text, Text, Text) +formatDepResult DepResult {..} = + case detail of + DepModified (DepAdded boundsMod) -> Just (formatDep package version bounds boundsMod) + DepModified (DepUpdated update) -> Just (formatDepUpdate package version bounds update) + DepUnmodified -> Nothing + +-- TODO don't print the env name when using @sets = "all"@ (or even when only one env is processed?) +envResult :: + EnvResult -> + M () +envResult result@EnvResult {env, summaries} = do + Log.info envLabel + traverse_ printSummary summaries + for_ (nonEmpty added) \ deps -> do + Log.info "Added new versions:" + printAligned (mapMaybe formatDepResult (toList deps)) + for_ (nonEmpty updated) \ deps -> do + Log.info "Updated versions:" + printAligned (mapMaybe formatDepResult (toList deps)) + where + DepResults {..} = EnvResult.grouped result + envLabel = color colors.yellow (showP env) + +mutations :: + ProjectResult -> + M () +mutations results = do + blankLine + sequence_ (intersperse blankLine (envResult <$> toList results.envs)) + +handlersProd :: ReportHandlers +handlersProd = + ReportHandlers {mutations} diff --git a/lib/Hix/Managed/Handlers/Report/Test.hs b/lib/Hix/Managed/Handlers/Report/Test.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/Report/Test.hs @@ -0,0 +1,27 @@ +module Hix.Managed.Handlers.Report.Test where + +import Data.IORef (IORef, modifyIORef, newIORef) + +import Hix.Data.Monad (M) +import Hix.Managed.Data.Mutation (FailedMutation) +import qualified Hix.Managed.Data.ProjectResult +import Hix.Managed.Data.ProjectResult (ProjectResult) +import qualified Hix.Managed.EnvResult as EnvResult +import Hix.Managed.Handlers.Report (ReportHandlers (..), handlersNull) + +reportMutationsIORef :: + IORef [FailedMutation] -> + ProjectResult -> + M () +reportMutationsIORef out results = + liftIO $ modifyIORef out \ old -> + foldl' (flip (++)) old failed + where + failed = EnvResult.failures <$> toList results.envs + +handlersUnitTest :: + MonadIO m => + m (ReportHandlers, IORef [FailedMutation]) +handlersUnitTest = do + mutationsRef <- liftIO (newIORef []) + pure (handlersNull {mutations = reportMutationsIORef mutationsRef}, mutationsRef) diff --git a/lib/Hix/Managed/Handlers/StateFile.hs b/lib/Hix/Managed/Handlers/StateFile.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/StateFile.hs @@ -0,0 +1,15 @@ +module Hix.Managed.Handlers.StateFile where + +import Path (Abs, Dir, Path) + +import Hix.Data.Monad (M) +import Hix.Data.NixExpr (Expr) + +data StateFileHandlers = + StateFileHandlers { + writeFile :: Maybe (Path Abs Dir) -> Expr -> M () + } + +handlersNull :: StateFileHandlers +handlersNull = + StateFileHandlers {writeFile = \ _ _ -> unit} diff --git a/lib/Hix/Managed/Handlers/StateFile/Prod.hs b/lib/Hix/Managed/Handlers/StateFile/Prod.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/StateFile/Prod.hs @@ -0,0 +1,54 @@ +module Hix.Managed.Handlers.StateFile.Prod where + +import qualified Data.Text.IO as Text +import Path (Abs, File, Path, parent, toFilePath, (), Dir) +import Path.IO (createDirIfMissing, doesDirExist, doesFileExist) +import System.Posix (fileMode, getFileStatus, ownerWriteMode, setFileMode, unionFileModes) + +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.Monad (M, tryIOM) +import Hix.NixExpr (renderRootExpr) + +setDepsFileWritable :: + Path Abs File -> + M () +setDepsFileWritable file = + tryIOM do + whenM (doesDirExist dir) do + whenM (doesFileExist file) do + fileCur <- getFileStatus fileFp + setWrite fileFp (fileMode fileCur) + where + setWrite path cur = setFileMode path (unionFileModes cur ownerWriteMode) + fileFp = toFilePath file + dir = parent file + +initFile :: + StateFileConfig -> + Maybe (Path Abs Dir) -> + M (Path Abs File) +initFile conf tmpRoot = do + root <- maybe (rootOrCwd conf.projectRoot) pure tmpRoot + let depsFile = root conf.file + createDirIfMissing False (parent depsFile) + setDepsFileWritable depsFile + pure depsFile + +writeFile :: + StateFileConfig -> + Maybe (Path Abs Dir) -> + Expr -> + M () +writeFile conf tmpRoot nixExpr = do + path <- initFile conf tmpRoot + liftIO (Text.writeFile (toFilePath path) (renderRootExpr nixExpr)) + +handlersProd :: + StateFileConfig -> + StateFileHandlers +handlersProd conf = + StateFileHandlers {writeFile = writeFile conf} diff --git a/lib/Hix/Managed/Handlers/StateFile/Test.hs b/lib/Hix/Managed/Handlers/StateFile/Test.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Handlers/StateFile/Test.hs @@ -0,0 +1,23 @@ +module Hix.Managed.Handlers.StateFile.Test where + +import Data.IORef (IORef, modifyIORef, newIORef) + +import Hix.Data.Monad (M) +import Hix.Data.NixExpr (Expr) +import Hix.Managed.Handlers.StateFile (StateFileHandlers (StateFileHandlers), writeFile) + +writeFileIORef :: + IORef [Expr] -> + Maybe a -> + Expr -> + M () +writeFileIORef out _ expr = + liftIO $ modifyIORef out (expr :) + +handlersUnitTest :: + MonadIO m => + m (StateFileHandlers, IORef [Expr]) +handlersUnitTest = do + ref <- liftIO (newIORef []) + let handlers = StateFileHandlers {writeFile = writeFileIORef ref} + pure (handlers, ref) diff --git a/lib/Hix/Managed/Lower/App.hs b/lib/Hix/Managed/Lower/App.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Lower/App.hs @@ -0,0 +1,41 @@ +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.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.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) + +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.cabal common.handlers + withProjectContext handlers common.project context (main conf handlers) + where + conf = lowerConfig opts + +lowerInitCli :: LowerOptions -> M () +lowerInitCli = lowerCli lowerInitMain + +lowerOptimizeCli :: LowerOptions -> M () +lowerOptimizeCli = lowerCli (const lowerOptimizeMain) + +lowerStabilizeCli :: LowerOptions -> M () +lowerStabilizeCli = lowerCli (const lowerStabilizeMain) + +lowerAutoCli :: LowerOptions -> M () +lowerAutoCli = lowerCli lowerAutoMain diff --git a/lib/Hix/Managed/Lower/Auto.hs b/lib/Hix/Managed/Lower/Auto.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Lower/Auto.hs @@ -0,0 +1,110 @@ +module Hix.Managed.Lower.Auto where + +import qualified Data.Set as Set + +import Hix.Class.Map (nToMaybe, nZipR) +import Hix.Data.Monad (M) +import Hix.Managed.Data.BuildConfig (BuildConfig) +import qualified Hix.Managed.Data.EnvState +import Hix.Managed.Data.EnvState (EnvState (EnvState)) +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)) +import qualified Hix.Managed.Data.QueryDep +import Hix.Managed.Data.StageContext (StageContext (StageContext), query) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Managed.Diff (reifyVersionChanges) +import Hix.Managed.Flow (Flow, evalStageState, runStage_, stageError) +import Hix.Managed.Handlers.Build (BuildHandlers) +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) + +suggestStabilize :: Flow () +suggestStabilize = stageError "Re-run with --stabilize to attempt to fix the bounds." + +-- | This skips building with initial bounds because it only runs after LowerInit failed, which means that we have no +-- initial bounds. +stabilizeInitFailure :: + BuildHandlers -> + LowerConfig -> + BuildConfig -> + Flow () +stabilizeInitFailure handlers conf buildConf + | conf.stabilize + = stabilizeStage handlers buildConf + | otherwise + = suggestStabilize + +-- TODO needs some more work +pristineBounds :: EnvState -> Query -> Maybe Query +pristineBounds EnvState {versions, initial} (Query query) = + Query <$> nonEmpty (restrictQuery (nToMaybe pristine nameIfJust)) + where + nameIfJust name = \case + Just _ -> Just name + Nothing -> Nothing + + restrictQuery (Set.fromList -> names) = + filter (flip Set.member names . (.package)) (toList query) + + pristine :: MutableVersions + pristine = nZipR justEqual (reifyVersionChanges initial) (reifyVersionChanges versions) + + justEqual (Just (Just ini)) (Just current) | ini == current = Just current + justEqual _ _ = Nothing + +-- | Return the current 'Query' without those deps whose current versions differ from their initial ones, i.e. that have +-- been optimized before. +pristineBoundsQuery :: Flow (Maybe Query) +pristineBoundsQuery = + evalStageState \ env StageContext {query} -> pristineBounds env query + +-- | Run Optimize, but only consider the deps that have not been optimized before. +-- +-- TODO this could use a flag for forcing optimization of all (query) deps. +optimizePristineBounds :: + BuildHandlers -> + BuildConfig -> + Flow () +optimizePristineBounds handlers conf = do + pristineBoundsQuery >>= \case + Just newQuery -> + runStage_ "auto-optimize" \ context -> + lowerOptimize handlers conf context {query = newQuery} + Nothing -> unit + +postInit :: + BuildHandlers -> + LowerConfig -> + BuildConfig -> + Flow () +postInit handlers conf buildConf = + validateCurrent >>= \case + Success -> optimizePristineBounds handlers buildConf + Failure | conf.stabilize -> stabilizeIfPossible handlers buildConf + | otherwise -> suggestStabilize + +lowerAutoStages :: + BuildHandlers -> + LowerConfig -> + BuildConfig -> + Flow () +lowerAutoStages handlers conf buildConf = + lowerInitStage handlers conf buildConf >>= \case + Success | conf.initOnly -> unit + | otherwise -> postInit handlers conf buildConf + Failure -> stabilizeInitFailure handlers conf buildConf + +lowerAutoMain :: + LowerConfig -> + BuildHandlers -> + ProjectContext -> + M ProjectResult +lowerAutoMain conf handlers project = + processProject handlers project (lowerAutoStages handlers conf project.build) diff --git a/lib/Hix/Managed/Lower/Candidates.hs b/lib/Hix/Managed/Lower/Candidates.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Lower/Candidates.hs @@ -0,0 +1,196 @@ +module Hix.Managed.Lower.Candidates where + +import qualified Data.Set as Set +import qualified Data.Text as Text +import Distribution.Pretty (pretty) +import Distribution.Version (Version) +import Exon (exon) + +import Hix.Class.Map ((!!)) +import Hix.Data.Error (Error (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) +import qualified Hix.Log as Log +import qualified Hix.Managed.Data.Lower +import Hix.Managed.Data.Lower (Lower (Lower)) +import Hix.Managed.Data.Mutable (MutableDep, MutableVersions, depName) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (DepMutation (DepMutation)) +import qualified Hix.Managed.Data.QueryDep +import Hix.Managed.Data.QueryDep (QueryDep) +import Hix.Monad (throwM) +import Hix.Pretty (showP) +import Hix.Version (allMajors, majorParts, majorsBefore, versionsBetween, versionsFrom) + +logNoVersions :: + MutableDep -> + [Version] -> + Maybe a -> + M (Maybe a) +logNoVersions package allVersions mutation = do + when (isNothing mutation) do + Log.debug [exon|Available versions: #{Text.intercalate ", " (show . pretty <$> allVersions)}|] + Log.warn [exon|No suitable version found for '##{package}'.|] + pure mutation + +specifiedLower :: VersionBounds -> Maybe (Int, Int) +specifiedLower = majorParts <=< (.lower) + +specifiedUpper :: VersionBounds -> Maybe (Int, Int) +specifiedUpper = majorParts <=< (.upper) + +prefix :: Int -> Int -> Text +prefix s m = [exon|#{show s}.#{show m}|] + +candidates :: + (PackageName -> M [Version]) -> + QueryDep -> + Bool -> + ([Version] -> Maybe (NonEmpty Major)) -> + M (Maybe (DepMutation Lower)) +candidates fetchVersions dep retract selection = do + allVersions <- fetchVersions (depName package) + let + result = do + majors <- selection (sort allVersions) + pure DepMutation {package, retract, mutation = Lower {majors}} + logNoVersions package allVersions result + pure result + where + package = dep.package + +data InitConfig = + InitBeforeUpper Int Int + | + InitAll + deriving stock (Eq, Show, Generic) + +initConfig :: VersionBounds -> InitConfig +initConfig version = + case specifiedUpper version of + Just (s, m) -> InitBeforeUpper s m + _ -> InitAll + +logInitConfig :: MutableDep -> InitConfig -> M () +logInitConfig package conf = + Log.verbose [exon|Choosing versions for '##{package}' from #{msg conf}.|] + where + msg = \case + InitBeforeUpper s m -> + [exon|all majors before the specified upper bound #{prefix s m}|] + InitAll -> + "all majors" + +selectionInit :: InitConfig -> [Version] -> Maybe (NonEmpty Major) +selectionInit = \case + InitBeforeUpper s m -> + nonEmpty . reverse . majorsBefore s m + InitAll -> + nonEmpty . reverse . allMajors + +candidatesInit :: + (PackageName -> M [Version]) -> + Set MutableDep -> + QueryDep -> + M (Maybe (DepMutation Lower)) +candidatesInit fetchVersions pre dep + | Set.member dep.package pre + = pure Nothing + | otherwise + = do + logInitConfig dep.package conf + candidates fetchVersions dep False (selectionInit conf) + where + conf = initConfig dep.bounds + +data OptimizeConfig = + OptimizeMajorsBefore Int Int + | + OptimizeNoBound + deriving stock (Eq, Show, Generic) + +optimizeConfig :: + Maybe Version -> + VersionBounds -> + OptimizeConfig +optimizeConfig initial version = + case majorParts =<< (version.lower <|> initial) of + Just (s, m) -> OptimizeMajorsBefore s m + Nothing -> OptimizeNoBound + +logOptimizeConfig :: + MutableDep -> + OptimizeConfig -> + M () +logOptimizeConfig package = \case + OptimizeMajorsBefore s m -> + Log.verbose [exon|Choosing versions for '##{package}' from all majors before #{prefix s m}.|] + OptimizeNoBound -> + throwM (Client [exon|'##{package}' has no initial lower bound. Please run '.#lower.init' first.|]) + +selectionOptimize :: OptimizeConfig -> [Version] -> Maybe (NonEmpty Major) +selectionOptimize = \case + OptimizeMajorsBefore s m -> do + nonEmpty . reverse . majorsBefore s m + OptimizeNoBound -> + const Nothing + +candidatesOptimize :: + (PackageName -> M [Version]) -> + MutableVersions -> + QueryDep -> + M (Maybe (DepMutation Lower)) +candidatesOptimize fetchVersions initial dep = do + logOptimizeConfig dep.package conf + candidates fetchVersions dep False (selectionOptimize conf) + where + conf = optimizeConfig (join (initial !! dep.package)) dep.bounds + +data StabilizeConfig = + StabilizeFromVersion Version (Maybe Version) + | + StabilizeNoBound InitConfig + deriving stock (Eq, Show, Generic) + +stabilizeConfig :: VersionBounds -> Maybe Version -> StabilizeConfig +stabilizeConfig version initialBound = + case version.lower of + Just v -> StabilizeFromVersion v (initialBound <|> version.upper) + Nothing | Just v <- initialBound -> StabilizeFromVersion v (initialBound <|> version.upper) + Nothing -> StabilizeNoBound (initConfig version) + +logStabilizeConfig :: MutableDep -> StabilizeConfig -> M () +logStabilizeConfig package = \case + StabilizeFromVersion v Nothing -> + Log.verbose [exon|Choosing versions for '##{package}' after the current version #{showP v}.|] + StabilizeFromVersion l (Just u) -> + Log.verbose [exon|Choosing versions for '##{package}' between the current version #{showP l} and the initial version #{showP u}.|] + StabilizeNoBound conf -> + logInitConfig package conf + +selectionStabilize :: StabilizeConfig -> [Version] -> Maybe (NonEmpty Major) +selectionStabilize = \case + StabilizeFromVersion l Nothing -> + nonEmpty . versionsFrom l + StabilizeFromVersion l (Just u) -> + nonEmpty . versionsBetween l u + StabilizeNoBound conf -> + selectionInit conf + +candidatesStabilize :: + (PackageName -> M [Version]) -> + QueryDep -> + Maybe Version -> + M (Maybe (DepMutation Lower)) +candidatesStabilize fetchVersions dep initialBound = do + logStabilizeConfig dep.package conf + candidates fetchVersions dep (isRetract conf) (selectionStabilize conf) + where + conf = stabilizeConfig dep.bounds initialBound + + isRetract = \case + StabilizeFromVersion _ _ -> True + StabilizeNoBound _ -> False diff --git a/lib/Hix/Managed/Lower/Data/LowerMode.hs b/lib/Hix/Managed/Lower/Data/LowerMode.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Lower/Data/LowerMode.hs @@ -0,0 +1,32 @@ +module Hix.Managed.Lower.Data.LowerMode where + +import Hix.Managed.Cabal.Data.SolverState (SolverState) +import Hix.Managed.Data.Mutation (MutationResult (MutationFailed, MutationKeep)) + +data LowerMode = + LowerMode { + firstSuccess :: Bool, + noSuccess :: MutationResult SolverState + } + deriving stock (Eq, Show, Generic) + +lowerInitMode :: LowerMode +lowerInitMode = + LowerMode { + firstSuccess = True, + noSuccess = MutationFailed + } + +lowerOptimizeMode :: LowerMode +lowerOptimizeMode = + LowerMode { + firstSuccess = False, + noSuccess = MutationKeep + } + +lowerStabilizeMode :: LowerMode +lowerStabilizeMode = + LowerMode { + firstSuccess = True, + noSuccess = MutationFailed + } diff --git a/lib/Hix/Managed/Lower/Init.hs b/lib/Hix/Managed/Lower/Init.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Lower/Init.hs @@ -0,0 +1,94 @@ +module Hix.Managed.Lower.Init where + +import Exon (exon) + +import Hix.Class.Map (nCatMaybes, nKeysSet) +import Hix.Data.Monad (M) +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import Hix.Data.Version (Version) +import Hix.Data.VersionBounds (fromUpper) +import Hix.Managed.Build (processQuery) +import Hix.Managed.Cabal.Data.SolverState (solverState) +import Hix.Managed.Constraints (fromVersions) +import Hix.Managed.Data.BuildConfig (BuildConfig) +import qualified Hix.Managed.Data.Constraints +import Hix.Managed.Data.Constraints (MutationConstraints (MutationConstraints)) +import qualified Hix.Managed.Data.EnvContext +import qualified Hix.Managed.Data.LowerConfig +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 +import Hix.Managed.Data.StageContext (StageContext) +import Hix.Managed.Data.StageResult (StageResult) +import Hix.Managed.Data.StageState (BuildStatus, BuildSuccess) +import Hix.Managed.Flow (Flow, execStage) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.Handlers.Build (BuildHandlers) +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.Report (describeIterations) +import Hix.Managed.StageResult (stageResultInit) + +lowerInitUpdate :: Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints +lowerInitUpdate _ _ PackageId {version} MutationConstraints {..} = + MutationConstraints {mutation = fromUpper version, ..} + +success :: Map MutableDep BuildSuccess -> Natural -> Text +success _ iterations = + [exon|Found initial lower bounds for all deps after #{iter}.|] + where + iter = describeIterations iterations + +failure :: Natural -> Text +failure iterations = + [exon|Couldn't find working initial lower bounds for some deps after #{describeIterations iterations}.|] + +-- TODO This could instead only update the initial versions, so that a subsequent @lower.optimize@ can skip the versions +-- it elaborated before. +-- But it would require some nontrivial changes to the state update mechanisms. +-- +-- | Determine initial lower bounds for the selected dependencies if they have none or @--reset@ was specified. +-- If none of the selected deps need to be processed, the state is not updated. +-- Otherwise, the lower bounds of _all_ deps are reset to the initial ones, requiring the user to run @lower.optimize@ +-- again. +lowerInit :: + BuildHandlers -> + LowerConfig -> + BuildConfig -> + StageContext -> + M StageResult +lowerInit handlers conf buildConf context = do + result <- processQuery candidates mutationHandlers buildConf context ext + pure (stageResultInit success failure result) + where + candidates = candidatesInit handlers.versions (nKeysSet (nCatMaybes keep :: MutableDeps Version)) + + mutationHandlers = Mutation.handlersLower buildConf lowerInitMode lowerInitUpdate + + ext = solverState context.env.solverBounds context.env.deps (fromVersions fromUpper keep) def + + keep | conf.reset = mempty + | otherwise = context.initial + +lowerInitStage :: + BuildHandlers -> + LowerConfig -> + BuildConfig -> + Flow BuildStatus +lowerInitStage handlers conf buildConf = + execStage "lower-init" (lowerInit handlers conf buildConf) + +lowerInitMain :: + LowerConfig -> + BuildHandlers -> + ProjectContext -> + M ProjectResult +lowerInitMain conf handlers project = + processProject handlers project (void (lowerInitStage handlers conf project.build)) diff --git a/lib/Hix/Managed/Lower/Optimize.hs b/lib/Hix/Managed/Lower/Optimize.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Lower/Optimize.hs @@ -0,0 +1,76 @@ +module Hix.Managed.Lower.Optimize where + +import Exon (exon) + +import Hix.Data.Monad (M) +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import Hix.Data.VersionBounds (fromUpper) +import Hix.Managed.Build (processQuery) +import Hix.Managed.Cabal.Data.SolverState (solverState) +import Hix.Managed.Constraints (fromVersions) +import Hix.Managed.Data.BuildConfig (BuildConfig) +import qualified Hix.Managed.Data.Constraints +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) +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 +import Hix.Managed.Data.StageContext (StageContext (StageContext)) +import Hix.Managed.Data.StageResult (StageResult) +import Hix.Managed.Data.StageState (BuildSuccess) +import Hix.Managed.Flow (Flow, runStage_) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.Handlers.Build (BuildHandlers) +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.Report (describeIterations) +import Hix.Managed.StageResult (stageResult) + +lowerOptimizeUpdate :: Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints +lowerOptimizeUpdate _ _ PackageId {version} MutationConstraints {..} = + MutationConstraints {mutation = fromUpper version, ..} + +success :: Map MutableDep BuildSuccess -> Natural -> Text +success _ iterations = + [exon|Found optimal lower bounds for all deps after #{describeIterations iterations}.|] + +failure :: Natural -> Text +failure iterations = + [exon|Couldn't find working lower bounds for some deps after #{describeIterations iterations}.|] + +lowerOptimize :: + BuildHandlers -> + BuildConfig -> + StageContext -> + M StageResult +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 + + mutationHandlers = Mutation.handlersLower conf lowerOptimizeMode lowerOptimizeUpdate + + ext = solverState env.solverBounds env.deps (fromVersions fromUpper versions) def + +lowerOptimizeStage :: + BuildHandlers -> + BuildConfig -> + Flow () +lowerOptimizeStage handlers conf = + runStage_ "optimize" (lowerOptimize handlers conf) + +lowerOptimizeMain :: + BuildHandlers -> + ProjectContext -> + M ProjectResult +lowerOptimizeMain handlers project = + processProject handlers project (lowerOptimizeStage handlers project.build) diff --git a/lib/Hix/Managed/Lower/Stabilize.hs b/lib/Hix/Managed/Lower/Stabilize.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Lower/Stabilize.hs @@ -0,0 +1,146 @@ +module Hix.Managed.Lower.Stabilize where + +import Exon (exon) + +import Hix.Class.Map (nToMaybe, (!!)) +import Hix.Data.Monad (M) +import qualified Hix.Data.PackageId +import Hix.Data.PackageId (PackageId (PackageId)) +import qualified Hix.Data.VersionBounds +import Hix.Data.VersionBounds (VersionBounds (VersionBounds), fromLower, fromUpper) +import Hix.Managed.Build (processQuery) +import Hix.Managed.Build.Single (buildVersions) +import Hix.Managed.Cabal.Data.SolverState (solverState) +import Hix.Managed.Constraints (fromVersions) +import Hix.Managed.Data.BuildConfig (BuildConfig) +import qualified Hix.Managed.Data.Constraints +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 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 +import qualified Hix.Managed.Data.StageContext +import Hix.Managed.Data.StageContext (StageContext (StageContext)) +import Hix.Managed.Data.StageResult ( + StageFailure (FailedPrecondition), + StageResult, + StageSummary (StageFailure, StageNoAction), + ) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success), BuildSuccess) +import Hix.Managed.Flow (Flow, execStatelessStage, runStage_) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.Handlers.Build (BuildHandlers) +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.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 + Success -> StageNoAction (Just "Env builds successfully with the initial bounds.") + Failure -> + StageFailure (FailedPrecondition msg) + where + msg = + [ + "Cannot stabilize since the build with initial bounds failed.", + "Please run 'lower.init --reset' or fix the build manually." + ] + +lowerStabilizeUpdate :: Bool -> MutableId -> PackageId -> MutationConstraints -> MutationConstraints +lowerStabilizeUpdate retract candidate PackageId {name, version} MutationConstraints {..} + | retract + , depName candidate.name == name + = MutationConstraints {mutation = fromLower version, oldest = Just True, ..} + | VersionBounds {lower = Just _} <- mutation + = MutationConstraints {mutation = fromLower version, ..} + | otherwise + = MutationConstraints {mutation = fromUpper version, ..} + +success :: Map MutableDep BuildSuccess -> Natural -> Text +success _ iterations = + [exon|Found stable lower bounds for all deps after #{iter}.|] + where + iter = describeIterations iterations + +failure :: Natural -> Text +failure iterations = + [exon|Couldn't find working lower bounds for some deps after #{describeIterations iterations}.|] + +-- | This uses 'lowerInit' for the initial solver bounds, which gets translated to an extended bound treated as an +-- upper. +-- When a stable version was found, it will be set as a retracted bound, treated as a lower. +lowerStabilize :: + BuildHandlers -> + BuildConfig -> + StageContext -> + M StageResult +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)) + + mutationHandlers = Mutation.handlersLower conf lowerStabilizeMode lowerStabilizeUpdate + + ext = solverState context.env.solverBounds context.env.deps (fromVersions fromUpper context.initial) def + +stabilizeStage :: + BuildHandlers -> + BuildConfig -> + Flow () +stabilizeStage handlers conf = + runStage_ "stabilize" (lowerStabilize handlers conf) + +stabilizeIfPossible :: + BuildHandlers -> + BuildConfig -> + Flow () +stabilizeIfPossible handlers conf = + buildLowerInit >>= \case + Success -> stabilizeStage handlers conf + Failure -> unit + +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."]) + +lowerStabilizeStages :: + BuildHandlers -> + BuildConfig -> + Flow () +lowerStabilizeStages handlers conf = + validateCurrent >>= \case + Success -> unit + Failure -> stabilizeIfPossible handlers conf + +lowerStabilizeMain :: + BuildHandlers -> + ProjectContext -> + M ProjectResult +lowerStabilizeMain handlers project = + processProject handlers project (lowerStabilizeStages handlers project.build) diff --git a/lib/Hix/Managed/ManagedPackage.hs b/lib/Hix/Managed/ManagedPackage.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/ManagedPackage.hs @@ -0,0 +1,27 @@ +module Hix.Managed.ManagedPackage where + +import Hix.Class.Map (nFlatten, nKeys, nMap, nRestrictKeys, nWithoutKeys) +import Hix.Data.PackageName (LocalPackage) +import qualified Hix.Managed.Data.ManagedPackage +import Hix.Managed.Data.ManagedPackage (ManagedPackage) +import Hix.Managed.Data.Mutable (LocalRanges, MutableRanges) +import Hix.Managed.Data.Packages (Packages) +import Hix.Managed.Data.Targets (Targets, sortTargets, targetsSet) + +forTargets :: Packages ManagedPackage -> [LocalPackage] -> (Targets, LocalRanges, MutableRanges) +forTargets packages targetNames = + (targets, local, mutable) + where + mutable = nFlatten id (nMap (.mutable) targetPackages :: Packages MutableRanges) + + -- Remove the targets from the local deps + local = nWithoutKeys tset (nFlatten id (nMap (.local) targetPackages :: Packages LocalRanges)) + + targetPackages = nRestrictKeys tset packages + + tset = targetsSet targets + + targets = sortTargets (nMap nKeys allLocal) targetNames + + allLocal :: Packages LocalRanges + allLocal = nMap (.local) packages diff --git a/lib/Hix/Managed/ManagedPackageProto.hs b/lib/Hix/Managed/ManagedPackageProto.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/ManagedPackageProto.hs @@ -0,0 +1,27 @@ +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 diff --git a/lib/Hix/Managed/Overrides.hs b/lib/Hix/Managed/Overrides.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Overrides.hs @@ -0,0 +1,26 @@ +module Hix.Managed.Overrides where + +import qualified Data.Map.Strict as Map + +import Hix.Data.Monad (M) +import Hix.Data.Overrides (Override (..), Overrides (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) + +packageOverride :: + HackageHandlers -> + PackageId -> + M (PackageName, Override) +packageOverride handlers package@PackageId {name, version} = do + hash <- handlers.fetchHash package + pure (name, Override {..}) + +packageOverrides :: + HackageHandlers -> + [PackageId] -> + M Overrides +packageOverrides handlers versions = + Overrides . Map.fromList <$> traverse (packageOverride handlers) versions diff --git a/lib/Hix/Managed/Path.hs b/lib/Hix/Managed/Path.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Path.hs @@ -0,0 +1,14 @@ +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 diff --git a/lib/Hix/Managed/Process.hs b/lib/Hix/Managed/Process.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Process.hs @@ -0,0 +1,70 @@ +module Hix.Managed.Process where + +import Data.Generics.Labels () +import Distribution.Pretty (pretty) +import Exon (exon) + +import Hix.Data.EnvName (EnvName) +import Hix.Data.Monad (M) +import qualified Hix.Log as Log +import qualified Hix.Managed.Data.EnvContext +import Hix.Managed.Data.EnvContext (EnvContext) +import qualified Hix.Managed.Data.EnvRequest +import qualified Hix.Managed.Data.EnvResult +import Hix.Managed.Data.EnvResult (EnvResult (EnvResult)) +import qualified Hix.Managed.Data.ProcessState +import Hix.Managed.Data.ProcessState (ProcessState, initProcessState) +import qualified Hix.Managed.Data.ProjectContext +import Hix.Managed.Data.ProjectContext (ProjectContext) +import qualified Hix.Managed.Data.ProjectResult +import Hix.Managed.Data.ProjectResult (ProjectResult (ProjectResult)) +import Hix.Managed.Data.StageResult (StageSummary (StageNoAction)) +import Hix.Managed.EnvRequest (withEnvRequest) +import Hix.Managed.Flow (Flow, execFlow) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.Handlers.Build (BuildHandlers (BuildHandlers), Builder) +import Hix.Monad (mapAccumM) + +processEnv :: + BuildHandlers -> + Flow () -> + Builder -> + ProcessState -> + EnvContext -> + M (ProcessState, EnvResult) +processEnv build process builder state context = do + withEnvRequest build state context builder \ request -> do + Log.debug [exon|Processing env '##{context.env :: EnvName}' with initial state:|] + Log.debugP (pretty request.state) + execFlow request process + +skipResult :: StageSummary +skipResult = + StageNoAction (Just "This environment has no manageable dependencies.") + +processOrSkip :: + (ProcessState -> EnvContext -> M (ProcessState, EnvResult)) -> + ProcessState -> + Either EnvName EnvContext -> + M (ProcessState, EnvResult) +processOrSkip process state = \case + Right context -> process state context + Left env -> pure (state, EnvResult {env, state = Nothing, summaries = [skipResult]}) + +foldEnvs :: + ProjectContext -> + (ProcessState -> EnvContext -> M (ProcessState, EnvResult)) -> + M ProjectResult +foldEnvs project process = do + (final, envs) <- mapAccumM (processOrSkip process) (initProcessState project) project.envs + pure ProjectResult {envs, state = final.state} + +processProject :: + BuildHandlers -> + ProjectContext -> + Flow () -> + M ProjectResult +processProject build project process = + withBuilder \ builder -> foldEnvs project (processEnv build process builder) + where + BuildHandlers {withBuilder} = build diff --git a/lib/Hix/Managed/ProjectContext.hs b/lib/Hix/Managed/ProjectContext.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/ProjectContext.hs @@ -0,0 +1,51 @@ +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 qualified Hix.Data.Options +import Hix.Data.Options (ProjectOptions) +import Hix.Managed.BuildOutput (buildOutput, 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 qualified Hix.Managed.Handlers.Report +import qualified Hix.Managed.ProjectContextProto as ProjectContextProto +import Hix.Managed.StateFile (writeProjectState) + +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 -> + ProjectResult -> + M () +processBuildResults handlers buildConf results = do + updateProject handlers buildConf results + AppResources {output = format, target} <- M ask + outputResult (buildOutput results) target format + +withProjectContext :: + BuildHandlers -> + ProjectOptions -> + ProjectContextProto -> + (ProjectContext -> M ProjectResult) -> + M () +withProjectContext handlers opts proto use = do + project <- ProjectContextProto.validate opts proto + result <- use project + processBuildResults handlers opts.build result diff --git a/lib/Hix/Managed/ProjectContextProto.hs b/lib/Hix/Managed/ProjectContextProto.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/ProjectContextProto.hs @@ -0,0 +1,89 @@ +module Hix.Managed.ProjectContextProto where + +import Exon (exon) + +import Hix.Class.Map (nBy, nKeys, nKeysSet, nMap, nTo, (!!), (!?)) +import Hix.Data.EnvName (EnvName) +import Hix.Data.Monad (M) +import qualified Hix.Data.Options +import Hix.Data.Options (ProjectOptions) +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 qualified Hix.Managed.Data.ProjectContext +import Hix.Managed.Data.ProjectContext (ProjectContext (ProjectContext)) +import qualified Hix.Managed.Data.ProjectContextProto +import Hix.Managed.Data.ProjectContextProto (ProjectContextProto) +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) + +validateQuery :: + Packages ManagedPackage -> + RawQuery -> + M (Maybe (NonEmpty MutableDep)) +validateQuery packages (RawQuery deps) = + nonEmpty <$> traverse check deps + where + check dep | Just m <- mutables !! dep = pure m + | otherwise = clientError [exon|'##{dep}' is not a dependency of any package.|] + + mutables :: Deps MutableDep + mutables = nBy mutablesSet depName + mutablesSet = mconcat (nTo packages \ _ ManagedPackage {mutable} -> nKeysSet mutable) + +noEnvs :: Text +noEnvs = + [exon|The flake config contains no managed envs. +Most likely this means that you ran the CLI directly. +Please use one of the flake apps '.#bump', .#lower.init', '.#lower.optimize' or '.#lower.stabilize'.|] + +unknownEnv :: EnvName -> Text +unknownEnv name = + [exon|You requested to update the env '##{name}', but it is not present in the managed deps config. +Maybe this env is not enabled for managed dependencies.|] + +selectEnvs :: + Envs (Either EnvDeps EnvContext) -> + [EnvName] -> + M (NonEmpty (Either EnvName EnvContext)) +selectEnvs envs specified = + traverse valid =<< noteClient noEnvs (nonEmpty specified <|> nonEmpty (nKeys envs)) + where + valid env = noteClient (unknownEnv env) (first (const env) <$> envs !? env) + +projectContext :: + BuildConfig -> + ProjectState -> + Packages ManagedPackage -> + NonEmpty (Either EnvName EnvContext) -> + ProjectContext +projectContext build state packages envs = + ProjectContext { + build, + state, + packages, + envs + } + +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 + envTargets <- selectEnvs contexts opts.envs + pure (projectContext opts.build state packages envTargets) + where + packages = ManagedPackageProto.validate proto.packages diff --git a/lib/Hix/Managed/ProjectResult.hs b/lib/Hix/Managed/ProjectResult.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/ProjectResult.hs @@ -0,0 +1,16 @@ +module Hix.Managed.ProjectResult where + +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (FailedMutation) +import qualified Hix.Managed.Data.ProjectResult +import Hix.Managed.Data.ProjectResult (ProjectResult (ProjectResult)) +import qualified Hix.Managed.EnvResult as EnvResult +import Hix.Managed.EnvResult (DepResults, normalizeDepResults) + +grouped :: ProjectResult -> DepResults +grouped ProjectResult {envs} = + normalizeDepResults (foldMap EnvResult.grouped envs) + +failures :: ProjectResult -> [FailedMutation] +failures ProjectResult {envs} = + sortOn (.package) (EnvResult.failures =<< toList envs) diff --git a/lib/Hix/Managed/ProjectStateProto.hs b/lib/Hix/Managed/ProjectStateProto.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/ProjectStateProto.hs @@ -0,0 +1,141 @@ +module Hix.Managed.ProjectStateProto where + +import Data.Map.Merge.Strict (mapMissing, traverseMaybeMissing, traverseMissing, zipWithAMatched, zipWithMatched) +import Exon (exon) + +import Hix.Class.Map (NMap, nBy, nElems, nFromKeys, nMap, nMergeA, nTransform) +import Hix.Data.Bounds (Bounds) +import Hix.Data.EnvName (EnvName) +import Hix.Data.Monad (M) +import qualified Hix.Data.Options +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 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.Packages (Deps, Packages) +import qualified Hix.Managed.Data.ProjectState +import Hix.Managed.Data.ProjectState (ProjectState (ProjectState)) +import qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto) +import Hix.Version (upperVersion) + +invalidDep :: + ∀ a b . + LocalPackage -> + PackageName -> + a -> + M (Maybe b) +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 + +toMutable :: + NMap map MutableDep a sort => + Deps (MutableDep, a) -> + map +toMutable = nTransform \ _ -> id + +validateBounds :: + Bool -> + LocalPackage -> + ManagedPackage -> + Bounds -> + M MutableBounds +validateBounds readUpper package ManagedPackage {mutable} bounds = + toMutable <$> nMergeA stateMissing depMissing convertBound deps bounds + where + deps = packageDepsForMerge mutable + + stateMissing = mapMissing \ _ (name, range) -> (name, handleUpper range anyBounds) + + depMissing = traverseMaybeMissing (invalidDep package) + + convertBound = zipWithMatched \ _ (name, range) bound -> (name, handleUpper range bound) + + handleUpper range | readUpper, Just u <- upperVersion range = withUpper 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 Bounds -> + M (Packages MutableBounds) +validateProjectBounds readUpper = + nMergeA boundsMissing (traverseMaybeMissing invalidBoundsPackage) (zipWithAMatched (validateBounds readUpper)) + where + boundsMissing = traverseMissing \ name package -> validateBounds readUpper name package mempty + +invalidStateDep :: Text -> EnvName -> PackageName -> a -> M (Maybe b) +invalidStateDep desc env package _ = + Nothing <$ Log.warn [exon|Discarding #{desc} for unknown dep '##{package}' of env '##{env}'|] + +validateVersions :: + NMap map MutableDep (Maybe Version) sort => + Text -> + EnvName -> + Deps MutableDep -> + Versions -> + M map +validateVersions desc env deps bounds = + toMutable <$> nMergeA stateMissing envMissing matching deps bounds + where + stateMissing = mapMissing \ _ dep -> (dep, Nothing) + envMissing = traverseMaybeMissing (invalidStateDep desc env) + matching = zipWithMatched \ _ dep version -> (dep, Just version) + +-- TODO ugly +emptyVersions :: + NMap map MutableDep (Maybe Version) sort => + Deps MutableDep -> + map +emptyVersions deps = + nFromKeys (nElems deps) (const Nothing) + +invalidVersions :: Text -> EnvName -> a -> M (Maybe b) +invalidVersions desc env _ = + Nothing <$ Log.warn [exon|Discarding #{desc} for unknown env '##{env}'|] + +validateProjectVersions :: + NMap map MutableDep (Maybe Version) sort => + Text -> + Envs (Deps MutableDep) -> + Envs Versions -> + M (Envs map) +validateProjectVersions desc = + nMergeA stateMissing envMissing matching + where + stateMissing = mapMissing (const emptyVersions) + envMissing = traverseMaybeMissing (invalidVersions desc) + matching = zipWithAMatched (validateVersions desc) + +validateProjectState :: + ProjectOptions -> + Packages ManagedPackage -> + Envs EnvDeps -> + ProjectStateProto -> + M ProjectState +validateProjectState opts packages envDeps proto = do + bounds <- validateProjectBounds opts.readUpperBounds packages proto.bounds + versions <- validateProjectVersions "bound versions" depSets proto.versions + initial <- validateProjectVersions "initial versions" depSets proto.initial + pure ProjectState {overrides = proto.overrides, resolving = False, ..} + where + depSets = envDepsForMerge envDeps diff --git a/lib/Hix/Managed/QueryDep.hs b/lib/Hix/Managed/QueryDep.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/QueryDep.hs @@ -0,0 +1,36 @@ +module Hix.Managed.QueryDep where + +import Hix.Class.Map ((!!)) +import qualified Hix.Data.Overrides +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Managed.Data.Initial (Initial (Initial)) +import Hix.Managed.Data.Mutable (MutableBounds, MutableDep, depName) +import qualified Hix.Managed.Data.MutationState +import Hix.Managed.Data.MutationState (MutationState) +import qualified Hix.Managed.Data.QueryDep +import Hix.Managed.Data.QueryDep (QueryDep (QueryDep)) +import qualified Hix.Managed.Handlers.Cabal +import Hix.Managed.Handlers.Cabal (CabalHandlers) + +-- | Add the current bounds to the queried deps. +-- This is used when determining candidates. +queryDep :: + CabalHandlers -> + Initial MutationState -> + MutableBounds -> + MutableDep -> + QueryDep +queryDep cabal (Initial state) bounds package = + QueryDep { + package, + installed = cabal.installedVersion name, + current = join (state.versions !! package), + override = (.version) <$> state.overrides !! name, + bounds = fold (bounds !! package) + } + where + name = depName package + +simpleQueryDep :: MutableDep -> VersionBounds -> QueryDep +simpleQueryDep package bounds = + QueryDep {installed = Nothing, current = Nothing, override = Nothing, ..} diff --git a/lib/Hix/Managed/Report.hs b/lib/Hix/Managed/Report.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/Report.hs @@ -0,0 +1,15 @@ +module Hix.Managed.Report where + +import Exon (exon) + +plural :: + Eq a => + Num a => + a -> + Text +plural num | num == 1 = "" + | otherwise = "s" + +describeIterations :: Natural -> Text +describeIterations iterations = + [exon|#{show iterations} iteration#{plural iterations}|] diff --git a/lib/Hix/Managed/StageContext.hs b/lib/Hix/Managed/StageContext.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/StageContext.hs @@ -0,0 +1,39 @@ +module Hix.Managed.StageContext where + +import qualified Hix.Managed.Data.EnvContext +import Hix.Managed.Data.EnvRequest (EnvRequest (..)) +import qualified Hix.Managed.Data.EnvState +import Hix.Managed.Data.EnvState (EnvState (EnvState)) +import Hix.Managed.Data.Initial (Initial (Initial)) +import qualified Hix.Managed.Data.MutationState +import Hix.Managed.Data.MutationState (MutationState (MutationState)) +import Hix.Managed.Data.Query (Query (Query)) +import Hix.Managed.Data.StageContext (StageContext (..)) +import Hix.Managed.Diff (reifyBoundsChanges, reifyVersionChanges) +import qualified Hix.Managed.Handlers.Build +import Hix.Managed.QueryDep (queryDep) + +-- | Initialize the mutation versions from the persisted state, so the solver bounds are populated by the versions +-- determined in previous runs. +-- +-- @bounds@ is initialized empty because it is used only for updating based on candidates, since upper bounds differ +-- from the tested versions. +mutationState :: EnvState -> Initial MutationState +mutationState EnvState {versions, overrides} = + Initial MutationState { + bounds = mempty, + versions = reifyVersionChanges versions, + overrides, + initial = mempty + } + +stageContext :: EnvRequest -> EnvState -> StageContext +stageContext EnvRequest {context = env, builder} envState = + StageContext { + query = Query (queryDep builder.cabal state bounds <$> env.query), + initial = reifyVersionChanges envState.initial, + .. + } + where + bounds = reifyBoundsChanges envState.bounds + state = mutationState envState diff --git a/lib/Hix/Managed/StageResult.hs b/lib/Hix/Managed/StageResult.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/StageResult.hs @@ -0,0 +1,54 @@ +module Hix.Managed.StageResult where + +import qualified Data.Map.Strict as Map +import Distribution.Pretty (Pretty) + +import Hix.Class.Map (nRestrictKeys) +import Hix.Managed.Data.Mutable (MutableDep) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (failedMutation) +import qualified Hix.Managed.Data.MutationState +import Hix.Managed.Data.MutationState (MutationState (MutationState)) +import qualified Hix.Managed.Data.StageResult +import Hix.Managed.Data.StageResult ( + StageFailure (FailedMutations), + StageResult (StageResult), + StageSummary (StageFailure, StageNoAction, StageSuccess), + ) +import qualified Hix.Managed.Data.StageState +import Hix.Managed.Data.StageState (BuildSuccess, StageState (StageState)) + +stageResultWith :: + Pretty a => + (Map MutableDep BuildSuccess -> MutationState -> MutationState) -> + (Map MutableDep BuildSuccess -> Natural -> Text) -> + (Natural -> Text) -> + StageState a s -> + StageResult +stageResultWith finalize successMessage failureMessage StageState {success, failed, state, iterations} = + StageResult {state = Just (finalize success state), summary} + where + summary = + case nonEmpty (sortOn (.package) failed) of + Just failedNe -> StageFailure (FailedMutations (failureMessage iterations) (failedMutation <$> failedNe)) + Nothing | [] <- success -> StageNoAction (Just "All dependencies are up to date.") + | otherwise -> StageSuccess (successMessage success iterations) + +stageResult :: + Pretty a => + (Map MutableDep BuildSuccess -> Natural -> Text) -> + (Natural -> Text) -> + StageState a s -> + StageResult +stageResult = + stageResultWith (const id) + +stageResultInit :: + Pretty a => + (Map MutableDep BuildSuccess -> Natural -> Text) -> + (Natural -> Text) -> + StageState a s -> + StageResult +stageResultInit = + stageResultWith \ success MutationState {..} -> + MutationState {initial = nRestrictKeys (Map.keysSet success) versions, ..} diff --git a/lib/Hix/Managed/StageState.hs b/lib/Hix/Managed/StageState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/StageState.hs @@ -0,0 +1,28 @@ +module Hix.Managed.StageState where + +import qualified Data.Map.Strict as Map + +import qualified Hix.Managed.Data.MutableId +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (DepMutation, MutationResult (..)) +import Hix.Managed.Data.StageState (BuildSuccess (CandidateBuilt, Unmodified), StageState (..)) + +updateStageState :: + StageState a s -> + DepMutation a -> + MutationResult s -> + StageState a s +updateStageState old mutation = \case + MutationSuccess candidate changed state ext -> + old { + success = Map.insert candidate.name buildSuccess old.success, + state, + ext + } + where + buildSuccess | changed = CandidateBuilt candidate + | otherwise = Unmodified mutation.package + MutationKeep -> + old {success = Map.insert mutation.package (Unmodified mutation.package) old.success} + MutationFailed -> + old {failed = mutation : old.failed} diff --git a/lib/Hix/Managed/StateFile.hs b/lib/Hix/Managed/StateFile.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/StateFile.hs @@ -0,0 +1,70 @@ +module Hix.Managed.StateFile where + +import qualified Data.Map.Strict as Map +import Exon (exon) +import Path (Abs, Dir, Path) + +import Hix.Class.EncodeNix (encodeNix) +import Hix.Data.Monad (M) +import Hix.Data.NixExpr (Expr (..), ExprAttr (..)) +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.NixExpr (renderRootExpr) + +renderMap :: + Coercible k Text => + (v -> Expr) -> + Map k v -> + Expr +renderMap v = + ExprAttrs . fmap (uncurry ExprAttr . bimap coerce v) . Map.toList + +renderManaged' :: ProjectState -> Expr +renderManaged' = + encodeNix + +writeStateFile :: + Text -> + StateFileHandlers -> + Maybe (Path Abs Dir) -> + ProjectState -> + M () +writeStateFile purpose handlers tmpRoot state = do + Log.debug [exon|writing managed stated file for #{purpose}: #{renderRootExpr expr}|] + handlers.writeFile tmpRoot expr + where + expr = encodeNix state + +writeProjectState :: + StateFileHandlers -> + ProjectState -> + M () +writeProjectState handlers newState = + writeStateFile "final result persistence" handlers Nothing newState + +writeBuildStateFor :: + Text -> + StateFileHandlers -> + Path Abs Dir -> + EnvContext -> + Overrides -> + M () +writeBuildStateFor purpose handlers tmpRoot context overrides = + writeStateFile purpose handlers (Just tmpRoot) (envStateForBuild context overrides) + +writeInitialEnvState :: + StateFileHandlers -> + Path Abs Dir -> + EnvContext -> + Initial EnvState -> + M () +writeInitialEnvState handlers tmpRoot context (Initial state) = + writeBuildStateFor "env initialization" handlers tmpRoot context state.overrides diff --git a/lib/Hix/Managed/UpdateState.hs b/lib/Hix/Managed/UpdateState.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Managed/UpdateState.hs @@ -0,0 +1,67 @@ +module Hix.Managed.UpdateState where + +import Hix.Class.Map (nAdjust, nAmend, nInsert) +import Hix.Data.Overrides (Overrides) +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 qualified Hix.Managed.Data.MutationState +import Hix.Managed.Data.MutationState (MutationState) +import qualified Hix.Managed.Data.ProjectState +import Hix.Managed.Data.ProjectState (ProjectState (ProjectState)) +import Hix.Managed.Diff (applyBoundsChange, applyVersionChange, updateBoundsChanges, updateVersionChanges) + +-- | Insert the transformed 'EnvState', which contains only the bounds for the current target set and the overrides +-- for the current env. +-- +-- All data is stored as diffs in 'EnvState' (except for overrides), which are applied to the initial state. +-- +-- Since the env is intended to be exclusively used with its associated target set, we simply overwrite the existing one +-- completely. +-- +-- Bounds are supposed to be universally valid, since they qualify the source rather than a build configuration, so they +-- have to be updated in each of the env's target packages. +-- +-- @initial@ is the set of bounds that is preserved from the first run for each dependency. +-- The 'EnvState' only contains updates for them if an update for @versions@ contains @DiffAdded@, which is handled +-- in 'envStateWithMutations'. +projectStateWithEnv :: + EnvContext -> + EnvState -> + ProjectState -> + ProjectState +projectStateWithEnv context new old = + ProjectState { + bounds = mutUpdateTargets context.targets applyBoundsChange new.bounds 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), + resolving = old.resolving + } + +envStateForBuild :: + EnvContext -> + Overrides -> + ProjectState +envStateForBuild context overrides = + ProjectState { + bounds = mempty, + versions = mempty, + overrides = [(context.env, overrides)], + initial = [], + resolving = True + } + +envStateWithMutations :: + MutationState -> + EnvState -> + EnvState +envStateWithMutations new EnvState {bounds, versions, initial} = + EnvState { + bounds = updateBoundsChanges new.bounds bounds, + versions = updateVersionChanges new.versions versions, + overrides = new.overrides, + initial = updateVersionChanges new.initial initial + } diff --git a/lib/Hix/Maybe.hs b/lib/Hix/Maybe.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Maybe.hs @@ -0,0 +1,20 @@ +module Hix.Maybe where + +-- |Return 'Just' if the condition is 'True'. +justIf :: + Bool -> + a -> + Maybe a +justIf cond a = + if cond then Just a else Nothing +{-# inline justIf #-} + +-- |Version of 'maybe' that takes an action as fallback. +fromMaybeA :: + Applicative m => + m a -> + Maybe a -> + m a +fromMaybeA fallback = + maybe fallback pure +{-# inline fromMaybeA #-} diff --git a/lib/Hix/Monad.hs b/lib/Hix/Monad.hs --- a/lib/Hix/Monad.hs +++ b/lib/Hix/Monad.hs @@ -1,44 +1,185 @@ -module Hix.Monad where +module Hix.Monad ( + module Hix.Monad, + AppResources (..), + M, +) where import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) -import Control.Monad.Trans.Reader (ReaderT (runReaderT)) -import Path (Abs, Dir, Path) +import Control.Monad.Trans.Except (runExceptT, throwE, ExceptT (ExceptT)) +import Control.Monad.Trans.Reader (ReaderT (runReaderT), ask, asks) +import Control.Monad.Trans.State.Strict (StateT, get, put, runStateT) +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 qualified Path.IO as Path +import Path.IO (withSystemTempDir) +import System.IO (hClose) +import System.IO.Error (tryIOError) -import Hix.Data.Error (Error (BootstrapError, EnvError, GhciError, NewError), tryIO) +import qualified Hix.Console as Console +import Hix.Data.Error (Error (BootstrapError, Client, EnvError, GhciError, NewError)) +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 qualified Hix.Log as Log +import Hix.Log (logWith) -data Env = - Env { - cwd :: Path Abs Dir - } - deriving stock (Eq, Show, Generic) +throwM :: Error -> M a +throwM = liftE . throwE -type M a = ReaderT Env (ExceptT Error IO) a +clientError :: Text -> M a +clientError msg = throwM (Client msg) -throwM :: Error -> M a -throwM = - lift . throwE +fatalError :: Text -> M a +fatalError msg = throwM (Fatal msg) +note :: Error -> Maybe a -> M a +note err = + maybe (throwM err) pure + noteEnv :: Text -> Maybe a -> M a noteEnv err = - maybe (throwM (EnvError err)) pure + note (EnvError err) noteGhci :: Text -> Maybe a -> M a noteGhci err = - maybe (throwM (GhciError err)) pure + note (GhciError err) noteNew :: Text -> Maybe a -> M a noteNew err = - maybe (throwM (NewError err)) pure + note (NewError err) noteBootstrap :: Text -> Maybe a -> M a noteBootstrap err = - maybe (throwM (BootstrapError err)) pure + note (BootstrapError err) +noteClient :: Text -> Maybe a -> M a +noteClient err = + note (Client err) + +noteFatal :: Text -> Maybe a -> M a +noteFatal err = + note (Fatal err) + +eitherClient :: Either Text a -> M a +eitherClient = leftA clientError + +eitherFatal :: Either Text a -> M a +eitherFatal = leftA fatalError + +eitherFatalShow :: + Show b => + Text -> + Either b a -> + M a +eitherFatalShow msg = + eitherFatal . first mkMsg + where + mkMsg err = [exon|#{msg}: #{show err}|] + +whenDebug :: M () -> M () +whenDebug m = + whenM (M (asks (.debug))) do + m + +logIORef :: IORef [Text] -> LogLevel -> Text -> IO () +logIORef ref _ msg = + modifyIORef' ref (msg :) + +withLogIORef :: ((LogLevel -> Text -> IO ()) -> IO a) -> IO ([Text], a) +withLogIORef use = do + logRef <- newIORef [] + result <- use (logIORef logRef) + log <- readIORef logRef + pure (log, result) + +runMLoggerWith :: (LogLevel -> Text -> IO ()) -> GlobalOptions -> M a -> IO (Either Error a) +runMLoggerWith logger GlobalOptions {..} (M ma) = + withSystemTempDir "hix-cli" \ tmp -> + runExceptT (runReaderT ma AppResources {logger = logWith logger, ..}) + +runMLogWith :: GlobalOptions -> M a -> IO ([Text], Either Error a) +runMLogWith opts ma = + withLogIORef \ logger -> runMLoggerWith logger opts ma + +runMLog :: Path Abs Dir -> M a -> IO ([Text], Either Error a) +runMLog = runMLogWith . defaultGlobalOptions + +runMWith :: GlobalOptions -> M a -> IO (Either Error a) +runMWith = runMLoggerWith (const Console.err) + runM :: Path Abs Dir -> M a -> IO (Either Error a) -runM root ma = - runExceptT (runReaderT ma (Env root)) +runM = runMWith . defaultGlobalOptions +runMDebug :: Path Abs Dir -> M a -> IO (Either Error a) +runMDebug cwd = + runMWith (defaultGlobalOptions cwd) {GlobalOptions.verbose = True, GlobalOptions.debug = True} + +tryIOMWithM :: (Text -> M a) -> IO a -> M a +tryIOMWithM handleError ma = + liftIO (tryIOError ma) >>= \case + Right a -> pure a + Left err -> handleError (show err) + +tryIOMWith :: (Text -> Error) -> IO a -> M a +tryIOMWith mkErr ma = M (lift (tryIOWith mkErr ma)) + +tryIOMAs :: Error -> IO a -> M a +tryIOMAs err ma = do + liftIO (tryIOError ma) >>= \case + Right a -> pure a + Left exc -> do + whenDebug do + Log.error [exon|Replaced exception: #{show exc}|] + throwM err + tryIOM :: IO a -> M a -tryIOM ma = - lift (tryIO ma) +tryIOM ma = M (lift (tryIO ma)) + +catchIOM :: IO a -> (Text -> M a) -> M a +catchIOM ma handle = + liftIO (tryIOError ma) >>= \case + Right a -> pure a + Left err -> handle (show err) + +withTempDir :: String -> (Path Abs Dir -> M a) -> M a +withTempDir name use = do + AppResources {tmp} <- M 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 + Path.withTempFile tmp name \ file handle -> do + for_ content \ lns -> liftIO (Text.hPutStr handle (Text.unlines lns)) + liftIO (hClose handle) + use file + +stateM :: + Monad m => + (s -> a -> m (s, b)) -> + a -> + StateT s m b +stateM f a = do + s <- get + (s', b) <- lift (f s a) + put s' + pure b + +mapAccumM :: + Traversable t => + Monad m => + (s -> a -> m (s, b)) -> + s -> + t a -> + m (s, t b) +mapAccumM f s as = + swap <$> runStateT (traverse (stateM f) as) s + +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))) diff --git a/lib/Hix/New.hs b/lib/Hix/New.hs --- a/lib/Hix/New.hs +++ b/lib/Hix/New.hs @@ -86,7 +86,7 @@ test = { enable = true; dependencies = [ - "hedgehog >= 1.1 && < 1.3" + "hedgehog >= 1.1 && < 1.5" "tasty ^>= 1.4" "tasty-hedgehog >= 1.3 && < 1.5" ]; @@ -172,5 +172,5 @@ modNameS = pascal (toString conf.name.unProjectName) newProject :: NewProjectConfig -> M () -newProject conf = do +newProject conf = traverse_ createFile =<< newProjectFiles conf diff --git a/lib/Hix/NixExpr.hs b/lib/Hix/NixExpr.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/NixExpr.hs @@ -0,0 +1,126 @@ +module Hix.NixExpr where + +import Data.List.NonEmpty ((<|)) +import qualified Data.Text as Text +import Exon (exon) + +import Hix.Class.EncodeNix (EncodeNix (encodeNix)) +import Hix.Data.NixExpr (Expr (..), ExprAttr (ExprAttr, ExprAttrNil)) + +indent :: + Functor t => + Int -> + t Text -> + t Text +indent n = + fmap (Text.replicate n " " <>) + +withSemicolon :: NonEmpty Text -> NonEmpty Text +withSemicolon = \case + e :| [] -> + [e <> ";"] + h :| h1 : t -> h <| withSemicolon (h1 :| t) + +renderAttrs :: Int -> [ExprAttr] -> [Text] +renderAttrs ind attrs = + attrs >>= \case + ExprAttr k v -> + case renderExpr ind v of + e :| [] -> [[exon|#{k} = #{e};|]] + h :| (h1 : t) -> [exon|#{k} = #{h}|] : toList (withSemicolon (h1 :| t)) + ExprAttrNil -> + [] + +renderExpr :: Int -> Expr -> NonEmpty Text +renderExpr ind = \case + ExprNull -> ["null"] + ExprString s -> indent ind [[exon|"#{Text.replace "\"" "\\\"" s}"|]] + ExprLit e -> [e] + ExprList l -> "[" :| (indent (ind + 2) (toList . renderExpr ind =<< l)) ++ ["]"] + ExprAttrs a -> case renderAttrs ind a of + [] -> ["{}"] + as -> "{" :| indent (ind + 2) as ++ ["}"] + ExprPrefix p (renderExpr ind -> h :| t) -> + [exon|#{p} #{h}|] :| t + +renderRootExpr :: Expr -> Text +renderRootExpr = + Text.unlines . toList . renderExpr 0 + +checkEmpty :: + Text -> + Expr -> + ExprAttr +checkEmpty key = \case + ExprString value | Text.null value -> + ExprAttrNil + ExprList value | null value -> + ExprAttrNil + value -> + ExprAttr key value + +singleOpt :: + EncodeNix a => + Text -> + (e -> Maybe a) -> + e -> + ExprAttr +singleOpt key get entity = + maybe ExprAttrNil (checkEmpty key . encodeNix) (get entity) + +single :: + EncodeNix a => + Text -> + (e -> a) -> + e -> + ExprAttr +single key get = + singleOpt key (Just . get) + +multiOpt :: + EncodeNix a => + Text -> + (e -> Maybe [a]) -> + e -> + ExprAttr +multiOpt key get entity = + maybe ExprAttrNil (checkEmpty key . encodeNix) (get entity) + +multi :: + EncodeNix a => + Text -> + (e -> [a]) -> + e -> + ExprAttr +multi key get = + multiOpt key (Just . get) + +multiOrSingle :: + ∀ a e . + EncodeNix a => + Text -> + (e -> [a]) -> + e -> + ExprAttr +multiOrSingle key get entity = + check (get entity) + where + check :: [a] -> ExprAttr + check [] = ExprAttrNil + check [sing] = ExprAttr key (encodeNix sing) + check values = ExprAttr key (encodeNix values) + +mkAttrs :: [e -> ExprAttr] -> e -> [ExprAttr] +mkAttrs a e = + (fmap ($ e) a) + +notNil :: ExprAttr -> Bool +notNil = \case + ExprAttrNil -> False + _ -> True + +nonEmptyAttrs :: Text -> [ExprAttr] -> ExprAttr +nonEmptyAttrs key = + filter notNil >>> \case + [] -> ExprAttrNil + as -> ExprAttr key (ExprAttrs as) diff --git a/lib/Hix/Options.hs b/lib/Hix/Options.hs --- a/lib/Hix/Options.hs +++ b/lib/Hix/Options.hs @@ -1,9 +1,11 @@ module Hix.Options where +import Exon (exon) import Options.Applicative ( CommandFields, Mod, Parser, + auto, bashCompleter, command, completer, @@ -15,164 +17,77 @@ hsubparser, info, long, + metavar, option, prefs, progDesc, short, + showDefault, showHelpOnEmpty, showHelpOnError, + strArgument, strOption, + subparserInline, switch, value, ) -import Path (Abs, Dir, File, Path, SomeBase, parseRelDir, parseSomeDir) +import Path (Abs, Dir, File, Path, parseRelDir, parseSomeDir) import Path.IO (getCurrentDir) import Prelude hiding (Mod, mod) import qualified Hix.Data.BootstrapProjectConfig import Hix.Data.BootstrapProjectConfig (BootstrapProjectConfig (BootstrapProjectConfig)) -import Hix.Data.ComponentConfig ( - ComponentName (ComponentName), - EnvName, - ModuleName, - PackageName (PackageName), - SourceDir (SourceDir), - ) -import Hix.Data.GhciConfig (ChangeDir (ChangeDir), EnvConfig, GhciConfig, RunnerName) +import Hix.Data.ComponentConfig (ComponentName (ComponentName), ModuleName, SourceDir (SourceDir)) +import Hix.Data.EnvName (EnvName) +import Hix.Data.GhciConfig (ChangeDir (ChangeDir), RunnerName) +import Hix.Data.GlobalOptions (GlobalOptions (..)) import qualified Hix.Data.NewProjectConfig import Hix.Data.NewProjectConfig (NewProjectConfig (NewProjectConfig)) -import Hix.Data.PreprocConfig (PreprocConfig) -import Hix.Optparse (JsonConfig, absDirOption, absFileOption, jsonOption) - -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 - } - deriving stock (Show, Generic) - -data PackageSpec = - PackageSpec { - name :: PackageName, - dir :: Maybe (SomeBase Dir) - } - deriving stock (Eq, Show, Generic) - -data ComponentSpec = - ComponentSpec { - name :: ComponentName, - dir :: Maybe SourceDir - } - deriving stock (Eq, Show, Generic) - -data ComponentCoords = - ComponentCoords { - package :: Maybe PackageSpec, - component :: Maybe ComponentSpec - } - deriving stock (Eq, Show, Generic) - -data TargetSpec = - TargetForFile (Path Abs File) - | - TargetForComponent ComponentCoords - deriving stock (Eq, Show, Generic) - -data TestOptions = - TestOptions { - mod :: ModuleName, - test :: Maybe Text, - runner :: Maybe RunnerName, - cd :: ChangeDir - } - deriving stock (Eq, Show, Generic) - -data EnvRunnerOptions = - EnvRunnerOptions { - config :: Either EnvConfig JsonConfig, - root :: Maybe (Path Abs Dir), - component :: Maybe TargetSpec - } - deriving stock (Show, Generic) - -newtype ExtraGhciOptions = - ExtraGhciOptions Text - deriving stock (Eq, Show, Generic) - deriving newtype (IsString) - -newtype ExtraGhcidOptions = - ExtraGhcidOptions Text - deriving stock (Eq, Show, Generic) - deriving newtype (IsString) - -data GhciOptions = - GhciOptions { - config :: Either GhciConfig JsonConfig, - root :: Maybe (Path Abs Dir), - component :: TargetSpec, - test :: TestOptions, - extra :: Maybe ExtraGhciOptions - } - deriving stock (Show, Generic) - -data GhcidOptions = - GhcidOptions { - ghci :: GhciOptions, - extra :: Maybe ExtraGhcidOptions - } - deriving stock (Show, Generic) - -data NewOptions = - NewOptions { - config :: NewProjectConfig - } - deriving stock (Eq, Show, Generic) - -data BootstrapOptions = - BootstrapOptions { - config :: BootstrapProjectConfig - } - deriving stock (Eq, Show, Generic) - -data EnvRunnerCommandOptions = - EnvRunnerCommandOptions { - options :: EnvRunnerOptions, - test :: TestOptions, - extraGhci :: Maybe ExtraGhciOptions, - extraGhcid :: Maybe ExtraGhcidOptions - } - deriving stock (Show, Generic) - -data Command = - Preproc PreprocOptions - | - EnvRunner EnvRunnerCommandOptions - | - GhcidCmd GhcidOptions - | - GhciCmd GhciOptions - | - NewCmd NewOptions - | - BootstrapCmd BootstrapOptions - deriving stock (Show) - -data GlobalOptions = - GlobalOptions { - verbose :: Maybe Bool, - cwd :: Path Abs Dir - } - deriving stock (Eq, Show, Generic) - -data Options = - Options { - global :: GlobalOptions, - cmd :: Command - } - deriving stock (Show) +import qualified Hix.Data.Options +import Hix.Data.Options ( + BootstrapOptions (..), + BumpOptions (..), + Command (..), + ComponentCoords (ComponentCoords), + ComponentSpec (..), + EnvRunnerCommandOptions (..), + EnvRunnerOptions (EnvRunnerOptions, component, config, root), + ExtraGhciOptions, + ExtraGhcidOptions, + GhciOptions (..), + GhcidOptions (..), + LowerCommand (..), + LowerOptions (LowerOptions), + ManagedOptions (ManagedOptions), + NewOptions (..), + Options (Options), + PackageSpec (..), + PreprocOptions (PreprocOptions), + ProjectOptions (ProjectOptions), + 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 qualified Hix.Managed.Data.BuildConfig +import Hix.Managed.Data.BuildConfig (BuildConfig (BuildConfig)) +import Hix.Managed.Data.Query (RawQuery (RawQuery)) +import qualified Hix.Managed.Data.StateFileConfig +import Hix.Managed.Data.StateFileConfig (StateFileConfig (StateFileConfig)) +import Hix.Optparse ( + JsonConfig, + absDirOption, + absFileOption, + buildHandlersOption, + indexStateOption, + jsonOption, + outputFormatOption, + outputTargetOption, + relFileOption, + ) fileParser :: String -> @@ -318,6 +233,89 @@ hixUrl <- strOption (long "hix-url" <> help "The URL to the Hix repository" <> value def) 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")) + pure StateFileConfig {..} + +cabalConfigParser :: Parser CabalConfig +cabalConfigParser = do + indexState <- optional (option indexStateOption (long "index-state" <> help indexStateHelp)) + pure CabalConfig {..} + where + indexStateHelp = "The index state for Hackage, Unix stamp or date string" + +buildConfigParser :: Parser BuildConfig +buildConfigParser = do + maxIterations <- option auto (long "max-iterations" <> help maxIterationsHelp <> value 3 <> showDefault) + maxFailedPre <- option auto (long "max-failed-majors-pre" <> help maxFailedPreHelp <> value 99 <> showDefault) + maxFailedPost <- option auto (long "max-failed-majors-post" <> help maxFailedPostHelp <> value 0 <> showDefault) + lookup <- switch (long "lookup" <> short 'n' <> help "Only print latest versions (bump)") + validate <- switch (long "validate" <> help "Validate new versions, but don't update the project state") + buildOutput <- switch (long "build-output" <> help "Show output from Nix builds") + pure BuildConfig {..} + where + maxIterationsHelp = "Number of restarts when some dependencies fail" + maxFailedPreHelp = maxFailedHelp "prior to the first" + maxFailedPostHelp = maxFailedHelp "after the last" + maxFailedHelp variant = [exon|Number of majors that may fail before aborting, #{variant} success|] + +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")) + 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") + pure ProjectOptions {..} + +managedOptionsParser :: Parser ManagedOptions +managedOptionsParser = do + context <- Right <$> jsonConfigParser + project <- projectOptionsParser + stateFile <- stateFileConfigParser + handlers <- optional (option buildHandlersOption (long "handlers" <> help "Internal: Handlers for tests")) + cabal <- cabalConfigParser + pure ManagedOptions {..} + +bumpParser :: Parser BumpOptions +bumpParser = do + common <- managedOptionsParser + pure BumpOptions {..} + +lowerParser :: Parser LowerOptions +lowerParser = do + initOnly <- switch (long "init" <> help "Only initialize missing lower bounds") + reset <- switch (long "reset" <> help "Reinitialize bounds of all deps rather than just new ones") + stabilize <- switch (long "stabilize" <> help "Attempt to find working bounds if the current ones are broken") + common <- managedOptionsParser + pure LowerOptions {..} + +lowerCommands :: Mod CommandFields LowerCommand +lowerCommands = + command "init" (LowerInitCmd <$> info lowerParser (progDesc "Initialize the lower bounds")) + <> + command "optimize" (LowerOptimizeCmd <$> info lowerParser (progDesc "Optimize the lower bounds")) + <> + command "stabilize" (LowerStabilizeCmd <$> info lowerParser (progDesc "Stabilize the lower bounds")) + <> + command "auto" (LowerAutoCmd <$> info lowerParser (progDesc "Process the lower bounds")) + +lowerCommand :: Parser LowerCommand +lowerCommand = + hsubparser lowerCommands <|> (LowerAutoCmd <$> lowerParser) + +managedCommitMsgParser :: Parser (Path Abs File) +managedCommitMsgParser = + option absFileOption (long "file" <> help "The JSON file written by a managed deps app") + +managedGithubPrParser :: Parser (Path Abs File) +managedGithubPrParser = + option absFileOption (long "file" <> help "The JSON file written by a managed deps app") + commands :: Mod CommandFields Command commands = command "preproc" (Preproc <$> info preprocParser (progDesc "Preprocess a source file for use with ghcid")) @@ -330,15 +328,28 @@ <> command "new" (NewCmd <$> info newParser (progDesc "Create a new Hix project in the current directory")) <> - command "bootstrap" (BootstrapCmd <$> info bootstrapParser (progDesc "Bootstrap an existing Cabal project in the current directory")) + command "bootstrap" (BootstrapCmd <$> info bootstrapParser (progDesc bootstrapDesc)) + <> + command "bump" (BumpCmd <$> info bumpParser (progDesc "Bump the deps of a package")) + <> + command "lower" (LowerCmd <$> info lowerCommand (progDesc "Modify the lower bounds of a package")) + where + bootstrapDesc = "Bootstrap an existing Cabal project in the current directory" globalParser :: Path Abs Dir -> Parser GlobalOptions globalParser realCwd = do - verbose <- optional (switch (long "verbose" <> short 'v' <> help "Verbose output")) + verbose <- switch (long "verbose" <> short 'v' <> help "Verbose output") + debug <- switch (long "debug" <> help "Debug output") + quiet <- switch (long "quiet" <> help "Suppress info output") cwd <- option absDirOption (long "cwd" <> help "Force a different working directory" <> value realCwd) + output <- option outputFormatOption (long "output" <> help formatHelp <> value OutputNone <> metavar "format") + target <- option outputTargetOption (long "target" <> help targetHelp <> value OutputDefault <> metavar "target") pure GlobalOptions {..} + where + formatHelp = "Result output format, if commands support it" + targetHelp = "Force output to a file or stdout" appParser :: Path Abs Dir -> @@ -353,6 +364,6 @@ customExecParser parserPrefs (info (appParser realCwd <**> helper) desc) where parserPrefs = - prefs (showHelpOnEmpty <> showHelpOnError) + prefs (showHelpOnEmpty <> showHelpOnError <> subparserInline) desc = fullDesc <> header "Tools for maintaining Hix projects" diff --git a/lib/Hix/Optparse.hs b/lib/Hix/Optparse.hs --- a/lib/Hix/Optparse.hs +++ b/lib/Hix/Optparse.hs @@ -2,35 +2,40 @@ module Hix.Optparse where import Data.Aeson (Value, eitherDecodeFileStrict', eitherDecodeStrict') +import Distribution.Parsec (eitherParsec) import Exon (exon) -import Options.Applicative (ReadM, readerError) -import Options.Applicative.Types (readerAsk) +import Options.Applicative (ReadM, eitherReader) import Path (Abs, Dir, File, Path, Rel, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile, toFilePath) import qualified Text.Show as Show --- |An absolute file path option for @optparse-applicative@. +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)) + +pathOption :: + String -> + (String -> Either e a) -> + ReadM a +pathOption desc parse = + eitherReader \ raw -> + first (const [exon|not a valid #{desc} path: #{raw}|]) (parse raw) + +-- | An absolute file path option for @optparse-applicative@. absFileOption :: ReadM (Path Abs File) -absFileOption = do - raw <- readerAsk - leftA (const (readerError [exon|not a valid absolute file path: #{raw}|])) (parseAbsFile raw) +absFileOption = pathOption "absolute file" parseAbsFile --- |A relative file path option for @optparse-applicative@. +-- | A relative file path option for @optparse-applicative@. relFileOption :: ReadM (Path Rel File) -relFileOption = do - raw <- readerAsk - leftA (const (readerError [exon|not a valid relative file path: #{raw}|])) (parseRelFile raw) +relFileOption = pathOption "relative file" parseRelFile --- |A relative dir path option for @optparse-applicative@. +-- | A relative dir path option for @optparse-applicative@. absDirOption :: ReadM (Path Abs Dir) -absDirOption = do - raw <- readerAsk - leftA (const (readerError [exon|not a valid absolute dir path: #{raw}|])) (parseAbsDir raw) +absDirOption = pathOption "absolute dir" parseAbsDir --- |A relative dir path option for @optparse-applicative@. +-- | A relative dir path option for @optparse-applicative@. relDirOption :: ReadM (Path Rel Dir) -relDirOption = do - raw <- readerAsk - leftA (const (readerError [exon|not a valid relative dir path: #{raw}|])) (parseRelDir raw) +relDirOption = pathOption "relative dir" parseRelDir newtype JsonConfig = JsonConfig { unJsonConfig :: IO (Either String Value) } @@ -39,10 +44,39 @@ instance Show JsonConfig where show (JsonConfig _) = "JsonConfig" -jsonOption :: - ReadM JsonConfig -jsonOption = do - raw <- readerAsk - pure $ JsonConfig $ case parseAbsFile raw of - Just f -> eitherDecodeFileStrict' (toFilePath f) - Nothing -> pure (eitherDecodeStrict' (encodeUtf8 raw)) +jsonOption :: ReadM JsonConfig +jsonOption = + eitherReader \ raw -> do + 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 + h -> Left [exon|Invalid value for build handlers: #{h}|] + +outputFormatOption :: ReadM OutputFormat +outputFormatOption = + eitherReader \case + "none" -> Right OutputNone + "json" -> Right OutputJson + "commit-msg" -> Right OutputCommitMsg + "ga-pr" -> Right OutputGaPr + fmt -> Left [exon|Invalid output format: #{fmt}|] + +outputTargetOption :: ReadM OutputTarget +outputTargetOption = + eitherReader \case + "default" -> Right OutputDefault + "stdout" -> Right OutputStdout + 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}|] + +indexStateOption :: ReadM HackageIndexState +indexStateOption = + eitherReader \ raw -> bimap (err raw) HackageIndexState (eitherParsec raw) + where + err raw msg = [exon|Invalid index state string '#{raw}': #{msg}|] diff --git a/lib/Hix/Orphans/Version.hs b/lib/Hix/Orphans/Version.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Orphans/Version.hs @@ -0,0 +1,46 @@ +{-# options_ghc -Wno-orphans #-} + +module Hix.Orphans.Version where + +import Distribution.Version ( + LowerBound (LowerBound), + UpperBound (NoUpperBound, UpperBound), + Version, + VersionInterval (VersionInterval), + VersionRange, + asVersionIntervals, + earlierVersion, + intersectVersionRanges, + mkVersion, + orLaterVersion, + unionVersionRanges, + version0, + versionNumbers, + ) +import GHC.Exts (IsList (..)) + +instance IsList Version where + type Item Version = Int + + fromList = mkVersion + + toList = versionNumbers + +instance IsList VersionRange where + type Item VersionRange = Version + + fromList = \case + [] -> orLaterVersion version0 + [v] -> orLaterVersion v + [l, u] -> range l u + l : u : rest -> unionVersionRanges (range l u) (fromList rest) + where + range l u = intersectVersionRanges (orLaterVersion l) (earlierVersion u) + + toList range = do + VersionInterval (LowerBound v _) upper <- asVersionIntervals range + v : fromUpper upper + where + fromUpper = \case + NoUpperBound -> [] + UpperBound v _ -> [v] diff --git a/lib/Hix/OutputWriter.hs b/lib/Hix/OutputWriter.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/OutputWriter.hs @@ -0,0 +1,64 @@ +module Hix.OutputWriter where + +import qualified Data.ByteString as ByteString +import qualified Data.Text.IO as Text +import Exon (exon) +import Path (Abs, File, Path, toFilePath) + +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) + +data WriteError = + WriteError { + msg :: Text, + file :: Path Abs File + } + deriving stock (Eq, Show, Generic) + +data OutputWriter = + OutputWriter { + bytes :: ByteString -> M (), + text :: Text -> M (), + textAppend :: Text -> M () + } + +fileWriter :: (WriteError -> M ()) -> Path Abs File -> OutputWriter +fileWriter errorHandler file = + OutputWriter { + bytes = handleError . ByteString.writeFile fp, + text = handleError . Text.writeFile fp, + textAppend = handleError . Text.appendFile fp + } + where + 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}|]) + +stdoutWriter :: OutputWriter +stdoutWriter = + OutputWriter { + bytes = 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 + +outputWriter :: OutputWriter -> OutputTarget -> OutputWriter +outputWriter defaultWriter = \case + OutputFile file -> fileWriter writeError file + OutputStdout -> stdoutWriter + OutputDefault -> defaultWriter + +outputWriterGlobal :: OutputTarget -> OutputWriter +outputWriterGlobal = outputWriter stdoutWriter diff --git a/lib/Hix/Path.hs b/lib/Hix/Path.hs --- a/lib/Hix/Path.hs +++ b/lib/Hix/Path.hs @@ -5,8 +5,8 @@ import System.FilePattern.Directory (getDirectoryFiles) import System.IO.Error (tryIOError) -import qualified Hix.Monad -import Hix.Monad (Env (Env), M) +import qualified Hix.Data.Monad +import Hix.Data.Monad (AppResources (AppResources), M (M)) findFlake :: Path Abs Dir -> IO (Maybe (Path Abs Dir)) findFlake cur = @@ -17,7 +17,7 @@ inferRoot :: M (Path Abs Dir) inferRoot = do - Env {cwd} <- ask + AppResources {cwd} <- M ask fromMaybe cwd <$> liftIO (findFlake cwd) rootDir :: Maybe (Path Abs Dir) -> M (Path Abs Dir) diff --git a/lib/Hix/Preproc.hs b/lib/Hix/Preproc.hs --- a/lib/Hix/Preproc.hs +++ b/lib/Hix/Preproc.hs @@ -2,7 +2,6 @@ import Control.Lens (IndexedTraversal', has, index, ix, preview, (%~), (.~), (^..)) import Control.Lens.Regex.ByteString (Match, group, groups, match, regex) -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, throwE) import qualified Data.ByteString as ByteString import Data.ByteString (elemIndex) @@ -26,12 +25,14 @@ import Hix.Component (targetComponentOrError) import qualified Hix.Data.ComponentConfig import Hix.Data.ComponentConfig (PreludeConfig, PreludePackage (PreludePackageName, PreludePackageSpec)) -import Hix.Data.Error (Error (..), sourceError, tryIO) +import Hix.Data.Monad (M, liftE) +import Hix.Data.Options (PreprocOptions (..), TargetSpec (TargetForFile)) +import Hix.Data.PackageName (PackageName (PackageName)) import qualified Hix.Data.PreprocConfig import Hix.Data.PreprocConfig (PreprocConfig) -import Hix.Json (jsonConfig) -import Hix.Monad (M) -import Hix.Options (PreprocOptions (..), TargetSpec (TargetForFile)) +import Hix.Error (Error (..), sourceError) +import Hix.Json (jsonConfigE) +import Hix.Monad (tryIOM) import Hix.Optparse (JsonConfig) import qualified Hix.Prelude as Prelude import Hix.Prelude (Prelude (Prelude), findPrelude) @@ -43,7 +44,7 @@ fromPreludeConfig ppconf conf = Prelude (toString name) (toString conf.module_.unModuleName) local where - local = Map.member (coerce name) ppconf.packages + local = Map.member (PackageName name) ppconf.packages name = case conf.package of PreludePackageName n -> n PreludePackageSpec n -> n @@ -448,11 +449,11 @@ preprocessWith :: PreprocOptions -> CabalConfig -> M () preprocessWith opt conf = do - inLines <- lift (tryIO (ByteString.readFile (toFilePath opt.inFile))) + inLines <- tryIOM (ByteString.readFile (toFilePath opt.inFile)) dummyNumber :: Int <- randomRIO (10000, 10000000) let dummyExportName = DummyExportName [exon|Hix_Dummy_#{show dummyNumber}|] let result = preprocessModule opt.source conf dummyExportName inLines - lift (tryIO (ByteStringBuilder.writeFile (toFilePath opt.outFile) result)) + tryIOM (ByteStringBuilder.writeFile (toFilePath opt.outFile) result) fromConfig :: Maybe (Path Abs Dir) -> @@ -460,7 +461,7 @@ Either PreprocConfig JsonConfig -> M CabalConfig fromConfig cliRoot source pconf = do - conf <- either pure jsonConfig pconf + conf <- jsonConfigE PreprocError pconf target <- targetComponentOrError cliRoot Nothing conf.packages (TargetForFile source) pure CabalConfig { extensions = stringUtf8 <$> target.component.language : target.component.extensions, @@ -483,7 +484,7 @@ fromCabalFile :: Path Abs File -> M CabalConfig fromCabalFile source = - fromCabal <$> lift (buildInfoForFile source) + fromCabal <$> liftE (buildInfoForFile source) -- TODO add common stanzas preprocess :: PreprocOptions -> M () diff --git a/lib/Hix/Pretty.hs b/lib/Hix/Pretty.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Pretty.hs @@ -0,0 +1,40 @@ +module Hix.Pretty where + +import Distribution.Pretty (Pretty, pretty) +import Text.PrettyPrint (Doc, comma, punctuate, sep, text) + +showP :: + ∀ b a . + Pretty a => + IsString b => + a -> + b +showP = show . pretty + +showPM :: + ∀ b a . + Pretty a => + IsString b => + Maybe a -> + b +showPM = show . fmap pretty + +prettyL :: + ∀ t a . + Pretty a => + Foldable t => + t a -> + Doc +prettyL = sep . punctuate comma . fmap pretty . toList + +showPL :: + ∀ t b a . + Pretty a => + Foldable t => + IsString b => + t a -> + b +showPL = show . prettyL + +prettyText :: Text -> Doc +prettyText = text . toString diff --git a/lib/Hix/These.hs b/lib/Hix/These.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/These.hs @@ -0,0 +1,9 @@ +module Hix.These where + +import Data.These (These (..)) + +maybeThese :: Maybe a -> Maybe b -> Maybe (These a b) +maybeThese (Just a) (Just b) = Just (These a b) +maybeThese (Just a) Nothing = Just (This a) +maybeThese Nothing (Just b) = Just (That b) +maybeThese Nothing Nothing = Nothing diff --git a/lib/Hix/Trace.hs b/lib/Hix/Trace.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Trace.hs @@ -0,0 +1,25 @@ +module Hix.Trace where + +import Distribution.Pretty (Pretty) +import GHC.Stack (callStack) +import System.IO.Unsafe (unsafePerformIO) + +import Hix.Pretty (showP) + +trp :: + ∀ b a . + Pretty b => + HasCallStack => + b -> + a -> + a +trp b a = + unsafePerformIO (a <$ debugPrint (srcLoc callStack) (showP b)) + +trpi :: + Pretty a => + HasCallStack => + a -> + a +trpi a = + unsafePerformIO (a <$ debugPrint (srcLoc callStack) (showP a)) diff --git a/lib/Hix/Version.hs b/lib/Hix/Version.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Version.hs @@ -0,0 +1,151 @@ +{-# language MonadComprehensions #-} + +module Hix.Version where + +import Data.List.Extra (groupOnKey) +import Distribution.Version ( + Bound (ExclusiveBound), + LowerBound (LowerBound), + UpperBound (UpperBound), + Version, + VersionInterval (VersionInterval), + VersionRange, + alterVersion, + asVersionIntervals, + version0, + versionNumbers, + ) + +import qualified Hix.Data.Version +import Hix.Data.Version (Major (Major)) + +lowerVersion :: VersionRange -> Maybe Version +lowerVersion range = + [v | VersionInterval (LowerBound v _) _ <- head (asVersionIntervals range), v /= version0] + +exclusiveUpperVersion :: VersionRange -> Maybe Version +exclusiveUpperVersion range = + [v | VersionInterval _ (UpperBound v ExclusiveBound) <- last (asVersionIntervals range)] + +upperVersion :: VersionRange -> Maybe Version +upperVersion range = + [v | VersionInterval _ (UpperBound v _) <- last (asVersionIntervals range)] + +majorParts :: Version -> Maybe (Int, Int) +majorParts = + versionNumbers >>> \case + [] -> Nothing + [0] -> Nothing + [s] -> Just (s, 0) + s : m : _ -> Just (s, m) + +majorPrefix :: Version -> Maybe [Int] +majorPrefix = + majorParts >>> fmap \case + (s, m) -> [s, m] + +hasMajor :: Int -> Int -> Version -> Bool +hasMajor s m candidate = + case take 2 (versionNumbers candidate) of + [s'] -> s' == s && m == 0 + s' : m' : _ -> s' == s && m' == m + _ -> False + +minMajor :: Int -> Int -> Version -> Bool +minMajor s m candidate = + case take 2 (versionNumbers candidate) of + [s'] -> s' > s || (s' == s && m == 0) + s' : m' : _ -> s' > s || (s' == s && m' >= m) + _ -> False + +beforeMajor :: Int -> Int -> Version -> Bool +beforeMajor s m candidate = + case take 2 (versionNumbers candidate) of + [s'] -> s' < s || (s' == s && m > 0) + s' : m' : _ -> s' < s || (s' == s && m' < m) + _ -> False + +lastMajor :: [Version] -> [Version] +lastMajor = + reverse . fst . foldl step ([], (0, 0)) + where + step (z, cur) a + | Just pre <- majorParts a + , pre /= cur + = ([a], pre) + | otherwise + = (a : z, cur) + +lastMajorBefore :: Int -> Int -> [Version] -> [Version] +lastMajorBefore s m = + reverse . fst . foldl step ([], (0, 0)) + where + step (z, cur) a + | Just (s', m') <- mp + , s' > s || (s' == s && m' >= m) + = (z, cur) + | Just pre <- mp + , pre /= cur + = ([a], pre) + | otherwise + = (a : z, cur) + where + mp = majorParts a + +nextMajor :: Version -> Version +nextMajor = + alterVersion \case + [] -> [0, 1] + [s] -> [s, 1] + s : m : _ -> [s, m + 1] + +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] + _ -> [0] + +currentMajor :: Version -> Version +currentMajor = alterVersion (take 2) + +isMajor :: Int -> Int -> Major -> Bool +isMajor s m Major {prefix} = + prefix == [s, m] + +majorOlder :: Int -> Int -> Major -> Bool +majorOlder s m Major {prefix} = + prefix < [s, m] + +majorNewer :: Int -> Int -> Major -> Bool +majorNewer s m Major {prefix} = + prefix > [s, m] + +allMajors :: [Version] -> [Major] +allMajors = + mapMaybe (uncurry cons) . groupOnKey currentMajor + where + cons prefix = \case + (h : t) -> Just (Major {prefix, versions = h :| t}) + [] -> Nothing + +majorsBefore :: Int -> Int -> [Version] -> [Major] +majorsBefore s m = + takeWhile (majorOlder s m) . allMajors + +majorsFrom :: Int -> Int -> [Version] -> [Major] +majorsFrom s m = + dropWhile (majorOlder s m) . allMajors + +onlyMajor :: Int -> Int -> [Version] -> Maybe Major +onlyMajor s m = + find (isMajor s m) . allMajors + +versionsFrom :: Version -> [Version] -> [Major] +versionsFrom start = + allMajors . dropWhile (< start) + +versionsBetween :: Version -> Version -> [Version] -> [Major] +versionsBetween l u = + allMajors . takeWhile (< u) . dropWhile (< l) diff --git a/lib/Hix/Zip.hs b/lib/Hix/Zip.hs new file mode 100644 --- /dev/null +++ b/lib/Hix/Zip.hs @@ -0,0 +1,15 @@ +module Hix.Zip where + +zipApply :: (a -> b) -> [a] -> [(a, b)] +zipApply f = fmap \ a -> (a, f a) + +zipApplyA :: + Traversable t => + Applicative m => + (a -> m b) -> + t a -> + m (t (a, b)) +zipApplyA f = traverse \ a -> (a,) <$> f a + +zipApplyL :: (a -> b) -> [a] -> [(b, a)] +zipApplyL f = fmap \ a -> (f a, a) diff --git a/test/Hix/Test/BootstrapTest.hs b/test/Hix/Test/BootstrapTest.hs --- a/test/Hix/Test/BootstrapTest.hs +++ b/test/Hix/Test/BootstrapTest.hs @@ -1,8 +1,9 @@ module Hix.Test.BootstrapTest where +import qualified Data.Text as Text import qualified Data.Text.IO as Text import Exon (exon) -import Hedgehog (TestT, evalEither, (===)) +import Hedgehog (evalEither, (===)) import Path (parent, reldir, relfile, toFilePath, ()) import Path.IO (createDirIfMissing, withSystemTempDir) @@ -11,7 +12,7 @@ import Hix.Data.BootstrapProjectConfig (BootstrapProjectConfig (BootstrapProjectConfig)) import qualified Hix.Data.ProjectFile as ProjectFile import Hix.Monad (runM) -import qualified Data.Text as Text +import Hix.Test.Utils (UnitTest) cabal :: Text cabal = @@ -74,7 +75,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: base ==4.* - , hedgehog >=1.1 && <1.3 + , hedgehog >=1.1 && <1.5 , red-panda , tasty ==1.4.* , tasty-hedgehog >=1.3 && <1.5 @@ -151,7 +152,7 @@ }; tests.red-panda-test = { dependencies = [ - "hedgehog >=1.1 && <1.3" + "hedgehog >=1.1 && <1.5" "red-panda" "tasty >=1.4 && <1.5" "tasty-hedgehog >=1.3 && <1.5" @@ -173,7 +174,7 @@ } |] -test_bootstrap :: TestT IO () +test_bootstrap :: UnitTest test_bootstrap = do result <- liftIO $ withSystemTempDir "hix-unit" \ tmp -> do let diff --git a/test/Hix/Test/BoundsTest.hs b/test/Hix/Test/BoundsTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/BoundsTest.hs @@ -0,0 +1,52 @@ +module Hix.Test.BoundsTest where + +import Distribution.Version (orEarlierVersion, orLaterVersion) +import Hedgehog (Gen, Property, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +import Hix.Class.Map (nAmend1, nForKeys, nFromKeys, nMap1, nPadKeep1) +import Hix.Data.Bounds (Ranges) +import qualified Hix.Data.Dep +import Hix.Data.Dep (Dep, mkDep, withVersion) +import Hix.Data.PackageName (LocalPackage, PackageName) +import Hix.Managed.Data.Packages (Deps, Packages) + +packages :: [PackageName] +packages = ["dep1", "dep2", "dep3"] + +targets :: [LocalPackage] +targets = ["target1", "target2", "target3"] + +genBounds :: Gen Ranges +genBounds = do + keys <- Gen.subsequence packages + pure (nFromKeys keys (const dep)) + where + dep = orEarlierVersion [2, 5] + +genTargetBounds :: Gen (Packages Ranges) +genTargetBounds = do + keys <- Gen.subsequence targets + nForKeys keys (const genBounds) + +genDeps :: Deps Dep +genDeps = + nFromKeys packages \ k -> mkDep k (orLaterVersion [1, 5]) + +deps :: Packages (Deps Dep) +deps = + nFromKeys targets (const genDeps) + +prop_amendBounds :: Property +prop_amendBounds = + property do + bounds <- forAll genTargetBounds + nPadKeep1 (.version) deps bounds === nMap1 (.version) (nAmend1 withVersion bounds deps) + +test_bounds :: TestTree +test_bounds = + testGroup "bounds" [ + testProperty "pad a b === amend b a (for padded a)" prop_amendBounds + ] diff --git a/test/Hix/Test/CabalFile.hs b/test/Hix/Test/CabalFile.hs --- a/test/Hix/Test/CabalFile.hs +++ b/test/Hix/Test/CabalFile.hs @@ -27,6 +27,7 @@ build-depends: Cabal , base >=4.12 && <5 + , semigroups >=1 mixins: base hiding (Prelude) , incipit-base (IncipitBase as Prelude) diff --git a/test/Hix/Test/CabalTest.hs b/test/Hix/Test/CabalTest.hs --- a/test/Hix/Test/CabalTest.hs +++ b/test/Hix/Test/CabalTest.hs @@ -2,14 +2,9 @@ import Control.Monad.Trans.Except (runExceptT) import qualified Data.ByteString as ByteString -import Distribution.PackageDescription ( - BuildInfo (defaultExtensions), - CondTree (condTreeData), - GenericPackageDescription (condLibrary), - Library (libBuildInfo), - ) -import Hedgehog (TestT, (===)) -import Hix.Cabal (parseCabal) +import Distribution.Package (Dependency) +import qualified Distribution.PackageDescription +import Hedgehog ((===)) import Language.Haskell.Extension ( Extension (DisableExtension, EnableExtension), KnownExtension (AllowAmbiguousTypes, ApplicativeDo), @@ -17,16 +12,26 @@ import Path (relfile, toFilePath, ()) import Path.IO (withSystemTempDir) +import Hix.Cabal (parseCabal) +import qualified Hix.Data.Dep as Dep import Hix.Test.CabalFile (testCabal) +import Hix.Test.Utils (UnitTest) target :: [Extension] target = [EnableExtension AllowAmbiguousTypes, DisableExtension ApplicativeDo] -test_cabal :: TestT IO () +deps :: [Dependency] +deps = + Dep.toCabal <$> ["Cabal", "base >=4.12 && <5", "semigroups >=1"] + +test_cabal :: UnitTest test_cabal = do Right pkg <- liftIO $ withSystemTempDir "hix-unit" \ tmp -> do let cabalFile = tmp [relfile|test.cabal|] ByteString.writeFile (toFilePath cabalFile) testCabal runExceptT (parseCabal cabalFile) - Just target === (pkg.condLibrary <&> \ l -> l.condTreeData.libBuildInfo.defaultExtensions) + let lib = fold pkg.condLibrary + deps === lib.condTreeData.libBuildInfo.targetBuildDepends + deps === lib.condTreeConstraints + target === lib.condTreeData.libBuildInfo.defaultExtensions diff --git a/test/Hix/Test/GhciTest.hs b/test/Hix/Test/GhciTest.hs --- a/test/Hix/Test/GhciTest.hs +++ b/test/Hix/Test/GhciTest.hs @@ -2,7 +2,7 @@ import Control.Monad.Trans.Class (lift) import Exon (exon) -import Hedgehog (TestT, evalEither, (===)) +import Hedgehog (evalEither, (===)) import Path (Abs, Dir, File, Path, Rel, SomeBase (Rel), absdir, absfile, reldir, relfile, ()) import Path.IO (withSystemTempDir) @@ -15,14 +15,11 @@ SourceDir (SourceDir), SourceDirs (SourceDirs), ) -import Hix.Data.Error (pathText) +import Hix.Error (pathText) import Hix.Data.GhciConfig (ChangeDir (ChangeDir), EnvConfig (EnvConfig), GhciConfig (..)) import qualified Hix.Data.GhciTest as GhciTest -import Hix.Env (envRunner) -import Hix.Ghci (assemble, ghciCmdlineFromOptions, ghcidCmdlineFromOptions) -import Hix.Monad (runM) -import qualified Hix.Options as Options -import Hix.Options ( +import qualified Hix.Data.Options as Options +import Hix.Data.Options ( ComponentCoords (ComponentCoords), ComponentSpec (ComponentSpec), EnvRunnerOptions (EnvRunnerOptions), @@ -32,6 +29,10 @@ TargetSpec (TargetForComponent, TargetForFile), TestOptions (TestOptions), ) +import Hix.Env (envRunner) +import Hix.Ghci (assemble, ghciCmdlineFromOptions, ghcidCmdlineFromOptions) +import Hix.Monad (runM) +import Hix.Test.Utils (UnitTest) root :: Path Abs Dir root = @@ -126,7 +127,7 @@ path = [exon|#{dir}packages/api/test/:#{dir}packages/api/lib/:#{dir}packages/core/lib/|] dir = pathText cwd -test_ghcid :: TestT IO () +test_ghcid :: UnitTest test_ghcid = do res <- lift $ withSystemTempDir "hix-test" \ tmp -> runM root (ghcidCmdlineFromOptions tmp options) @@ -164,7 +165,7 @@ path = [exon|#{dir}packages/core/test/:#{dir}packages/api/lib/:#{dir}packages/core/lib/|] dir = pathText cwd -test_mainPackage :: TestT IO () +test_mainPackage :: UnitTest test_mainPackage = do res <- lift $ withSystemTempDir "hix-test" \ tmp -> runM root (ghciCmdlineFromOptions tmp mainOptions) @@ -182,14 +183,14 @@ component = Just (ComponentSpec "core-test" (Just (SourceDir [reldir|core-test|]))) } -runnerFor :: EnvRunner -> TargetSpec -> TestT IO () +runnerFor :: EnvRunner -> TargetSpec -> UnitTest runnerFor target spec = do res <- evalEither =<< liftIO (runM root (envRunner conf)) target === res where conf = EnvRunnerOptions (Left (EnvConfig packages defaultRunner Nothing)) Nothing (Just spec) -test_componentEnv :: TestT IO () +test_componentEnv :: UnitTest test_componentEnv = do runnerFor runner1 spec1 runnerFor runner2 spec2 @@ -208,7 +209,7 @@ where m = "Core.Test.Main" -test_moduleName :: TestT IO () +test_moduleName :: UnitTest test_moduleName = do conf <- evalEither =<< liftIO (runM root (assemble options.ghci { component = spec4 })) target_moduleName === conf.script diff --git a/test/Hix/Test/Hedgehog.hs b/test/Hix/Test/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Hedgehog.hs @@ -0,0 +1,57 @@ +module Hix.Test.Hedgehog where + +import Data.List.Extra (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 log = + for_ (zip [0 :: Natural ..] (zipWithLongest (,) target log)) \case + (i, (Just t, Just l)) -> (i, t) === (i, l) + _ | [] <- log -> fail "Result list is empty." + _ -> target === log diff --git a/test/Hix/Test/Managed/BuildOutputTest.hs b/test/Hix/Test/Managed/BuildOutputTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/BuildOutputTest.hs @@ -0,0 +1,36 @@ +module Hix.Test.Managed.BuildOutputTest where + +import qualified Data.Aeson as Aeson +import Exon (exon) +import Hedgehog ((===)) +import Test.Tasty (TestTree, testGroup) + +import Hix.Managed.BuildOutput (buildOutputFromLists) +import qualified Hix.Managed.Data.BuildOutput +import Hix.Managed.Data.BuildOutput (BuildOutput, 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" + ] + +target :: ByteString +target = + [exon|{"failed":["direct5","direct6"],"failedNames":"direct5, direct6","modified":[{"package":"direct1","range":">=1.1","version":"1.0.1"},{"package":"direct2","range":null,"version":"1.0.1"}],"modifiedNames":"direct1, direct2","unmodified":["direct3","direct4"],"unmodifiedNames":"direct3, direct4"}|] + +test_buildOutputJson :: UnitTest +test_buildOutputJson = + target === toStrict (Aeson.encode output) + +test_buildOutput :: TestTree +test_buildOutput = + testGroup "build output formats" [ + unitTest "json" test_buildOutputJson + ] diff --git a/test/Hix/Test/Managed/Bump/CandidatesTest.hs b/test/Hix/Test/Managed/Bump/CandidatesTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/Bump/CandidatesTest.hs @@ -0,0 +1,106 @@ +module Hix.Test.Managed.Bump.CandidatesTest (test_candidatesBump) where + +import Distribution.Version (Version) +import Hedgehog (evalEither, (===)) + +import Hix.Data.PackageName (PackageName) +import Hix.Data.VersionBounds (VersionBounds) +import Hix.Managed.Bump.Candidates (candidatesBump) +import qualified Hix.Managed.Data.Bump +import Hix.Managed.Data.Bump (Bump (Bump)) +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 Hix.Managed.QueryDep (simpleQueryDep) +import Hix.Monad (M, clientError) +import Hix.Test.Utils (UnitTest, runMTest) + +deps :: [(MutableDep, VersionBounds)] +deps = + [ + ("dep1", "^>=2.0"), + ("dep2", "<1.5"), + ("dep3", ">=0"), + ("dep5", "==1.0.1"), + ("dep6", "<8.4"), + ("dep7", "^>=1.1") + ] + +dep1Version :: Version +dep1Version = [2, 2, 0, 5] + +dep2Version :: Version +dep2Version = [1, 7, 14] + +dep3Version :: Version +dep3Version = [1, 0, 5] + +dep4Version :: Version +dep4Version = [2, 4, 5] + +dep5Version :: Version +dep5Version = [1, 9, 1, 0] + +dep6Version :: Version +dep6Version = [7, 3] + +dep7Version :: Version +dep7Version = [1, 1, 1] + +latestVersion :: PackageName -> M (Maybe Version) +latestVersion = + fmap Just . \case + "dep1" -> pure dep1Version + "dep2" -> pure dep2Version + "dep3" -> pure dep3Version + "dep4" -> pure dep4Version + "dep5" -> pure dep5Version + "dep6" -> pure dep6Version + "dep7" -> pure dep7Version + _ -> clientError "No such package" + +handlersTest :: BuildHandlers +handlersTest = + handlersNull {latestVersion} + +target :: [DepMutation Bump] +target = + [ + mkBump "dep6" dep6Bound dep6Version, + mkBump "dep1" dep1Bound dep1Version, + DepMutation {package = "dep7", retract = False, mutation = Bump {version = [1, 1, 1], bound = [1, 2], changed = True}}, + mkBump "dep2" dep2Bound dep2Version, + mkBump "dep5" dep5Bound dep5Version, + mkBump "dep3" dep3Bound dep3Version + ] + where + mkBump name bound newVersion = + DepMutation { + package = fromString name, + retract = False, + mutation = Bump { + version = newVersion, + bound, + changed = True + } + } + + dep1Bound = [2, 3] + + dep2Bound = [1, 8] + + dep3Bound = [1, 1] + + dep5Bound = [1, 10] + + dep6Bound = [7, 4] + +test_candidatesBump :: UnitTest +test_candidatesBump = do + mutations <- evalEither =<< liftIO do + runMTest False do + catMaybes <$> traverse (candidatesBump handlersTest) query + sortOn (.package) target === sortOn (.package) (toList mutations) + where + query = uncurry simpleQueryDep <$> deps diff --git a/test/Hix/Test/Managed/Bump/MutationTest.hs b/test/Hix/Test/Managed/Bump/MutationTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/Bump/MutationTest.hs @@ -0,0 +1,335 @@ +module Hix.Test.Managed.Bump.MutationTest where + +import qualified Data.Text as Text +import Exon (exon) +import Hedgehog ((===)) +import Test.Tasty (TestTree, testGroup) + +import Hix.Data.Error (Error (Fatal)) +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 (SourcePackages) +import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages) +import Hix.Managed.Data.Packages (Packages) +import qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Monad (M, throwM) +import Hix.NixExpr (renderRootExpr) +import Hix.Pretty (showP) +import Hix.Test.Hedgehog (eqLines) +import qualified Hix.Test.Managed.Run +import Hix.Test.Managed.Run (Result (Result), TestParams (..), bumpTest, testParams) +import Hix.Test.Utils (UnitTest, unitTest) + +packages :: Packages ManagedPackageProto +packages = + managedPackages [(("local1", "1.0"), [ + "base", + "direct1", + "direct2", + "direct3", + "direct4", + "direct5" + ])] + +installed :: InstalledPackages +installed = + [ + ("base-4.12.0.0", []), + ("direct1-1.0.1", []), + ("direct2-1.0.1", []), + ("direct3-1.0.1", []), + ("direct4-1.0.1", []), + ("direct5-1.0.1", []) + ] + +packageDb :: SourcePackages +packageDb = + [ + ("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"]) + ]) + ] + +ghcPackages :: GhcPackages +ghcPackages = GhcPackages {installed, available = packageDb} + +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])] -> 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])] -> 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])] -> 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])] -> 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])] -> pure Failure + versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) + +state :: ProjectStateProto +state = + ProjectStateProto { + bounds = [ + ("local1", [ + ("direct1", ">=0.1"), + ("direct2", ">=0.1"), + ("direct4", "^>=1.0") + ]) + ], + versions = [("fancy", [("direct4", "1.0.1")])], + overrides = [ + ("fancy", [("direct5", "direct5-1.1.1")]) + ], + initial = [], + resolving = False + } + +stateFileTarget :: Text +stateFileTarget = + [exon|{ + bounds = { + local1 = { + base = { + lower = null; + upper = "4.13"; + }; + direct1 = { + lower = "0.1"; + upper = "1.3"; + }; + direct2 = { + lower = "0.1"; + upper = "1.3"; + }; + direct3 = { + lower = null; + upper = "1.1"; + }; + direct4 = { + lower = "1.0"; + upper = "1.3"; + }; + direct5 = { + lower = null; + upper = "1.3"; + }; + }; + }; + versions = { + fancy = { + 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"; + }; + }; + initial = { + fancy = {}; + }; + overrides = { + fancy = { + direct1 = { + version = "1.2.1"; + hash = "direct1-1.2.1"; + }; + direct2 = { + version = "1.2.1"; + hash = "direct2-1.2.1"; + }; + direct4 = { + version = "1.2.1"; + hash = "direct4-1.2.1"; + }; + direct5 = { + version = "1.2.1"; + hash = "direct5-1.2.1"; + }; + }; + }; + resolving = false; +} +|] + +logTarget :: [Text] +logTarget = + Text.lines [exon| +>>> fancy +>>> Couldn't find working latest versions for some deps after 2 iterations. + 📦 direct3 +>>> Added new versions: + 📦 base 4.12.0.0 ↕ [no bounds] -> <4.13 + 📦 direct1 1.2.1 ↕ >=0.1 -> [0.1, 1.3] + 📦 direct2 1.2.1 ↕ >=0.1 -> [0.1, 1.3] + 📦 direct3 1.0.1 ↕ [no bounds] -> <1.1 + 📦 direct5 1.2.1 ↕ [no bounds] -> <1.3 +>>> Updated versions: + 📦 direct4 1.0.1 -> 1.2.1 ↕ [1.0, 1.1] -> [1.0, 1.3] +|] + +-- | Goals for these deps: +-- +-- Unless stated otherwise, packages have an installed version, 1.0.1, and a latest available version, 1.2.1, which will +-- be their candidate. +-- +-- - @base@ is marked as non-reinstallable in Cabal, so it will never produce a plan that includes a different version +-- than its installed one, 4.12.0.0. +-- Its mutation is excluded from being built by matching its name, so it will only be in the solver bounds, and +-- therefore still get a managed bound, version and initial entry in the state file, but no override. +-- +-- - @direct1@ The candidate has a dep on @direct2 ==1.2.1@, so the solver chooses 1.2.1 for both deps in the first +-- mutation, which succeeds. +-- +-- - @direct2@ has been updated to the latest version by the mutation for @direct1@ and will try the same version again, +-- resulting in success. +-- +-- - @direct3@ has the latest version 1.2.1, for which the build fails. +-- It will be tried again in the second iteration, where it will fail once more. +-- It will not be bumped, but an upper bound will be added based on its installed version, 1.0.1, as @<1.1@. +-- No override will be added to the state. +-- TODO We could use multiple condidates, between the latest version and the maximum of the prior upper bound and the +-- installed version. +-- Probably only the latest in each major. +-- +-- - @direct4@ has preexisting managed bounds, @^>=1.0@. +-- The candidate succeeds, so the lower bound will be preserved, to yield the final bounds, @>=1.0 && <1.3@. +-- It has an existing entry in @initial@, which will be preserved. +-- +-- - @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@. +test_bumpMutationBasic :: UnitTest +test_bumpMutationBasic = do + Result {stateFile, log} <- bumpTest params bumpOptimizeMain + eqLines stateFileTarget (renderRootExpr stateFile) + logTarget === drop 12 (reverse log) + where + params = (testParams False packages) { + log = True, + envs = [("fancy", ["local1"])], + ghcPackages, + state, + build + } + +packages_upToDate :: Packages ManagedPackageProto +packages_upToDate = + managedPackages [(("local1", "1.0"), ["direct1"])] + +installed_upToDate :: InstalledPackages +installed_upToDate = + [("direct1-1.0.0", [])] + +packageDb_upToDate :: SourcePackages +packageDb_upToDate = + [("direct1", [([1, 0, 1], [])])] + +ghcPackages_upToDate :: GhcPackages +ghcPackages_upToDate = GhcPackages {installed = installed_upToDate, available = packageDb_upToDate} + +state_upToDate :: ProjectStateProto +state_upToDate = + ProjectStateProto { + bounds = [("local1", [("direct1", ">=0.1 && <1.1")])], + versions = [], + overrides = [("latest", [("direct1", "direct1-1.0.1")])], + initial = [], + resolving = False + } + +build_upToDate :: Versions -> M BuildStatus +build_upToDate = \case + [("direct1", [1, 0, 1])] -> pure Success + versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) + +stateFileTarget_upToDate :: Text +stateFileTarget_upToDate = + [exon|{ + bounds = { + local1 = { + direct1 = { + lower = "0.1"; + upper = "1.1"; + }; + }; + }; + versions = { + latest = { + direct1 = "1.0.1"; + }; + }; + initial = { + latest = {}; + }; + overrides = { + latest = { + direct1 = { + version = "1.0.1"; + hash = "direct1-1.0.1"; + }; + }; + }; + resolving = false; +} +|] + +-- | This has a minimal configuration: Only one target with one dep with one version. +-- The version is already in the overrides and bounds. +-- The only thing missing is the entry in @versions@. +-- +-- In the final state, the version should have been added. +-- +-- This is a bugfix test, since at some point, the versions would not have been written back if _all_ candidates +-- resulted in @MutationKeep@ because they had been classified as up to date based on the comparison of the candidate +-- version and the preexisting override. +-- Comparing with the override was wrong to begin with, since that would fail to notice an up to date version if it was +-- installed. +-- But in general, versions from successful builds should be written to the mutation state even for @MutationKeep@. +-- However, this is only significant if the state has been tampered with between runs, since a preexisting override +-- should have a corresponding version entry. +test_bumpMutationUpToDate :: UnitTest +test_bumpMutationUpToDate = do + Result {stateFile} <- bumpTest params bumpOptimizeMain + eqLines stateFileTarget_upToDate (renderRootExpr stateFile) + where + params = (testParams False packages_upToDate) { + ghcPackages = ghcPackages_upToDate, + state = state_upToDate, + build = build_upToDate + } + +test_bumpMutation :: TestTree +test_bumpMutation = + testGroup "bump" [ + unitTest "basic" test_bumpMutationBasic, + unitTest "up to date" test_bumpMutationUpToDate + ] diff --git a/test/Hix/Test/Managed/DiffTest.hs b/test/Hix/Test/Managed/DiffTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/DiffTest.hs @@ -0,0 +1,54 @@ +module Hix.Test.Managed.DiffTest where + +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 qualified Hix.Managed.EnvResult +import Hix.Managed.EnvResult ( + BoundsModification (BoundsModification), + DepModification (DepUpdated), + DepResult (DepResult), + DepResultDetail (DepModified), + depResult, + ) +import Hix.Managed.Handlers.Report.Prod (formatDepResult) +import Hix.Test.Utils (UnitTest, unitTest) + +versionDiff1 :: VersionChange +versionDiff1 = + versionChange (Just [1, 0]) (Just [1, 5]) + +boundsDiff1 :: BoundsChange +boundsDiff1 = + boundsChange (versionBounds [1, 0] [2, 0]) (versionBounds [1, 5] [2, 0]) + +result1 :: Maybe DepResult +result1 = + depResult "dep" versionDiff1 boundsDiff1 + +target1 :: DepResult +target1 = + DepResult { + package = "dep", + version = [1, 5], + bounds = versionBounds [1, 5] [2, 0], + detail = DepModified (DepUpdated (These [1, 0] (BoundsModification (This (Just [1, 0]))))) + } + +test_boundsDiffDepResult :: UnitTest +test_boundsDiffDepResult = do + res <- evalMaybe result1 + target1 === res + formatted <- evalMaybe (formatDepResult res) + ([exon|📦 dep|], [exon|1.0 -> 1.5|], [exon|↕ [1.0, 2.0] -> [1.5, 2.0]|]) === formatted + +test_diff :: TestTree +test_diff = + testGroup "Bounds and version diffs" [ + unitTest "BoundsChange to DepResult" test_boundsDiffDepResult + ] diff --git a/test/Hix/Test/Managed/LowerAuto/MutationOptimizeTest.hs b/test/Hix/Test/Managed/LowerAuto/MutationOptimizeTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/LowerAuto/MutationOptimizeTest.hs @@ -0,0 +1,344 @@ +module Hix.Test.Managed.LowerAuto.MutationOptimizeTest where + +import Exon (exon) +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 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 (reset) +import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages) +import Hix.Managed.Data.Packages (Packages) +import qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Managed.Lower.Auto (lowerAutoMain) +import Hix.Monad (M, throwM) +import Hix.NixExpr (renderRootExpr) +import Hix.Pretty (showP) +import Hix.Test.Hedgehog (eqLines) +import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) +import Hix.Test.Utils (UnitTest, unitTest) + +packages :: Packages ManagedPackageProto +packages = + managedPackages [ + (("local1", "1.0"), [ + "direct1", + "direct2", + "direct3 <1.9" + ]) + ] + +initialState :: ProjectStateProto +initialState = + ProjectStateProto { + bounds = [ + ("local1", [ + ("direct1", [[1, 0], [2, 0]]), + ("direct2", [[1, 0], [2, 0]]) + ]) + ], + versions = [ + ("lower", [ + ("direct1", [1, 0]), + ("direct2", [1, 0]) + ]) + ], + overrides = [ + ("lower", nGen @[] [1 .. 2] override) + ], + initial = [ + ("lower", [ + ("direct1", [1, 5]), + ("direct2", [1, 5]) + ]) + ], + resolving = False + } + where + override (num :: Natural) = + ( + fromString [exon|direct#{show num}|], + Override {version = [1, 0], hash = SourceHash [exon|direct#{show num}-1.0|]} + ) + +installed :: InstalledPackages +installed = + [ + ("direct1-1.2", []), + ("direct2-1.2", []), + ("direct3-1.2", []) + ] + +packageDb :: SourcePackages +packageDb = + [ + ("direct1", versions), + ("direct2", versions), + ("direct3", versions) + ] + where + versions = + [ + ([0, 9], []), + ([1, 0], []), + ([1, 2], []), + ([1, 5], []), + ([1, 9], []) + ] + +ghcPackages :: GhcPackages +ghcPackages = GhcPackages {installed, available = packageDb} + +buildVersionsBasic :: Versions -> M BuildStatus +buildVersionsBasic = \case + versions + | Just v <- versions !! "direct2" + , v <= [1, 0] + -> pure Failure + -- direct3 initialization works only at 1.2 + | Just v <- versions !! "direct3" + , v >= [1, 5] + -> pure Failure + -- initialize direct3 + [ + ("direct1", [1, 5]), + ("direct2", [1, 5]), + ("direct3", [1, 2]) + ] -> pure Success + -- optimize direct1 + [ + ("direct1", _), + ("direct2", [1, 5]), + ("direct3", [1, 2]) + ] -> pure Success + -- optimize direct2 + [ + ("direct1", [0, 9]), + ("direct2", [1, 2]), + ("direct3", [1, 2]) + ] -> pure Success + -- optimize direct3 + [ + ("direct1", [0, 9]), + ("direct2", [1, 2]), + ("direct3", [1, 0]) + ] -> pure Success + -- optimize direct3 + [ + ("direct1", [0, 9]), + ("direct2", [1, 2]), + ("direct3", [0, 9]) + ] -> pure Success + versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) + +stateFileTargetBasic :: Text +stateFileTargetBasic = + [exon|{ + bounds = { + local1 = { + direct1 = { + lower = "0.9"; + upper = "2.0"; + }; + direct2 = { + lower = "1.2"; + upper = "2.0"; + }; + direct3 = { + lower = "0.9"; + upper = null; + }; + }; + }; + versions = { + lower = { + direct1 = "0.9"; + direct2 = "1.2"; + direct3 = "0.9"; + }; + }; + initial = { + lower = { + direct1 = "1.5"; + direct2 = "1.5"; + direct3 = "1.2"; + }; + }; + overrides = { + lower = { + direct1 = { + version = "0.9"; + hash = "direct1-0.9"; + }; + direct3 = { + version = "0.9"; + hash = "direct3-0.9"; + }; + }; + }; + resolving = false; +} +|] + +-- | Goals for these deps: +-- +-- A new dependency, @direct3@, has been added to the project, so Init resets all versions to initial and finds an +-- initial bound for the new dep. +-- Afterwards, Optimize successfully determines the best bounds. +-- +-- - @direct1@ succeeds for all versions, so its optimized bound will be 0.9. +-- Its initial bound 1.5 will be preserved. +-- +-- - @direct2@ succeeds for all versions above 1.0, so its optimized bound will be 1.2. +-- Its initial bound 1.5 will be preserved. +-- +-- - @direct3@ succeeds for all versions below 1.5, so its initial bound will be 1.2 and its optimized bound will be +-- 0.9. +test_lowerAutoMutationOptimizeBasic :: UnitTest +test_lowerAutoMutationOptimizeBasic = do + Result {stateFile} <- lowerTest params (lowerAutoMain def) + eqLines stateFileTargetBasic (renderRootExpr stateFile) + where + params = + (testParams False packages) { + ghcPackages, + state = initialState, + build = buildVersionsBasic + } + +buildVersionsReset :: Versions -> M BuildStatus +buildVersionsReset = \case + versions + | Just v <- versions !! "direct2" + , v <= [1, 0] + -> pure Failure + -- direct3 initialization works only at 1.2 + | Just v <- versions !! "direct3" + , v >= [1, 5] + -> pure Failure + -- initialize all versions (latest versions build for direct1 and direct2, so only direct3 deviates) + [ + ("direct1", [1, 9]), + ("direct2", [1, 9]), + ("direct3", [1, 2]) + ] -> pure Success + -- optimize direct1 + [ + ("direct1", _), + ("direct2", [1, 9]), + ("direct3", [1, 2]) + ] -> pure Success + -- optimize direct2, first major + [ + ("direct1", [0, 9]), + ("direct2", [1, 5]), + ("direct3", [1, 2]) + ] -> pure Success + -- optimize direct2, second major + [ + ("direct1", [0, 9]), + ("direct2", [1, 2]), + ("direct3", [1, 2]) + ] -> pure Success + -- optimize direct3, first major + [ + ("direct1", [0, 9]), + ("direct2", [1, 2]), + ("direct3", [1, 0]) + ] -> pure Success + -- optimize direct3, second major + [ + ("direct1", [0, 9]), + ("direct2", [1, 2]), + ("direct3", [0, 9]) + ] -> pure Success + versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) + +stateFileTargetReset :: Text +stateFileTargetReset = + [exon|{ + bounds = { + local1 = { + direct1 = { + lower = "0.9"; + upper = "2.0"; + }; + direct2 = { + lower = "1.2"; + upper = "2.0"; + }; + direct3 = { + lower = "0.9"; + upper = null; + }; + }; + }; + versions = { + lower = { + direct1 = "0.9"; + direct2 = "1.2"; + direct3 = "0.9"; + }; + }; + initial = { + lower = { + direct1 = "1.9"; + direct2 = "1.9"; + direct3 = "1.2"; + }; + }; + overrides = { + lower = { + direct1 = { + version = "0.9"; + hash = "direct1-0.9"; + }; + direct3 = { + version = "0.9"; + hash = "direct3-0.9"; + }; + }; + }; + resolving = false; +} +|] + +-- | Goals for these deps: +-- +-- A new dependency, @direct3@, has been added to the project and @--reset@ was specified, so all deps are completely +-- recomputed from scratch. +-- Afterwards, Optimize successfully determines the best bounds. +-- +-- - @direct1@ succeeds for all versions, so its optimized bound will be 0.9. +-- Its initial bound will be 1.9. +-- +-- - @direct2@ succeeds for all versions above 1.0, so its optimized bound will be 1.2. +-- Its initial bound will be 1.9. +-- +-- - @direct3@ succeeds for all versions below 1.5, so its initial bound will be 1.2 and its optimized bound will be +-- 0.9. +test_lowerAutoMutationOptimizeReset :: UnitTest +test_lowerAutoMutationOptimizeReset = do + Result {stateFile} <- lowerTest params (lowerAutoMain def {reset = True}) + eqLines stateFileTargetReset (renderRootExpr stateFile) + where + params = + (testParams False packages) { + ghcPackages, + state = initialState, + build = buildVersionsReset + } + +test_lowerAutoMutationOptimize :: TestTree +test_lowerAutoMutationOptimize = + testGroup "lower.auto optimize" [ + unitTest "basic" test_lowerAutoMutationOptimizeBasic, + unitTest "reset initial" test_lowerAutoMutationOptimizeReset + ] diff --git a/test/Hix/Test/Managed/LowerAuto/MutationStabilizeTest.hs b/test/Hix/Test/Managed/LowerAuto/MutationStabilizeTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/LowerAuto/MutationStabilizeTest.hs @@ -0,0 +1,202 @@ +module Hix.Test.Managed.LowerAuto.MutationStabilizeTest where + +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 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 (stabilize) +import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages) +import Hix.Managed.Data.Packages (Packages) +import qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Managed.Lower.Auto (lowerAutoMain) +import Hix.Monad (M, throwM) +import Hix.NixExpr (renderRootExpr) +import Hix.Pretty (showP) +import Hix.Test.Hedgehog (eqLines) +import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) +import Hix.Test.Utils (UnitTest) + +packages :: Packages ManagedPackageProto +packages = + managedPackages [ + (("local1", "1.0"), [ + "direct1", + "direct2", + "direct3" + ]) + ] + +installed :: InstalledPackages +installed = + [ + ("direct1-1.2", []), + ("direct2-1.2", []), + ("direct3-1.2", []) + ] + +packageDb :: SourcePackages +packageDb = + [ + ("direct1", versions), + ("direct2", versions), + ("direct3", versions) + ] + where + versions = + [ + ([0, 9], []), + ([1, 0], []), + ([1, 2], []), + ([1, 5], []), + ([1, 9], []) + ] + +ghcPackages :: GhcPackages +ghcPackages = GhcPackages {installed, available = packageDb} + +state :: ProjectStateProto +state = + ProjectStateProto { + bounds = [ + ("local1", [ + ("direct1", [[1, 0], [2, 0]]), + ("direct2", [[1, 0], [2, 0]]), + ("direct3", [[1, 0], [2, 0]]) + ]) + ], + versions = [ + ("lower", [ + ("direct1", [1, 0]), + ("direct2", [1, 0]), + ("direct3", [1, 0]) + ]) + ], + overrides = [ + ("lower", nGen @[] [1 .. 3] override) + ], + initial = [ + ("lower", [ + ("direct1", [1, 5]), + ("direct2", [1, 5]), + ("direct3", [1, 5]) + ]) + ], + resolving = False + } + where + override (num :: Natural) = + ( + fromString [exon|direct#{show num}|], + Override {version = [1, 0], hash = SourceHash [exon|direct#{show num}-1.0|]} + ) + +build :: Versions -> M BuildStatus +build = \case + versions + | Just v <- versions !! "direct2" + , v <= [1, 0] + -> pure Failure + | Just v <- versions !! "direct3" + , v <= [1, 2] + -> pure Failure + -- initial bounds + [ + ("direct1", [1, 5]), + ("direct2", [1, 5]), + ("direct3", [1, 5]) + ] -> pure Success + -- stabilizing direct1 + [ + ("direct1", [1, 0]), + ("direct2", [1, 5]), + ("direct3", [1, 5]) + ] -> pure Success + -- stabilizing direct2 and direct3 + [ + ("direct1", [1, 0]), + ("direct2", [1, 2]), + ("direct3", [1, 5]) + ] -> pure Success + versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) + +stateFileTarget :: Text +stateFileTarget = + [exon|{ + bounds = { + local1 = { + direct1 = { + lower = "1.0"; + upper = "2.0"; + }; + direct2 = { + lower = "1.2"; + upper = "2.0"; + }; + direct3 = { + lower = "1.5"; + upper = "2.0"; + }; + }; + }; + versions = { + lower = { + direct1 = "1.0"; + direct2 = "1.2"; + direct3 = "1.5"; + }; + }; + initial = { + lower = { + direct1 = "1.5"; + direct2 = "1.5"; + direct3 = "1.5"; + }; + }; + overrides = { + lower = { + direct1 = { + version = "1.0"; + hash = "direct1-1.0"; + }; + direct3 = { + version = "1.5"; + hash = "direct3-1.5"; + }; + }; + }; + resolving = false; +} +|] + +-- | Goals for these deps: +-- +-- The project was changed and the lower bounds have been invalidated. +-- LowerInit does not process mutations since all deps have initial bounds. +-- LowerStabilize is executed because the config flag is enabled. +-- +-- - @direct1@ is compatible in all versions. +-- +-- - @direct2@ has become incompatible for all versions up to 1.0. +-- The mutation handler tries 1.0 and 1.2, the latter of which succeeds. +-- +-- - @direct2@ has become incompatible for all versions up to 1.2. +-- The mutation handler tries 1.0, 1.2 and 1.5, the third of which succeeds. +test_lowerAutoMutationStabilize :: UnitTest +test_lowerAutoMutationStabilize = do + Result {stateFile} <- lowerTest params (lowerAutoMain def {stabilize = True}) + eqLines stateFileTarget (renderRootExpr stateFile) + where + params = + (testParams False packages) { + ghcPackages, + state, + build + } diff --git a/test/Hix/Test/Managed/LowerInit/MutationTest.hs b/test/Hix/Test/Managed/LowerInit/MutationTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/LowerInit/MutationTest.hs @@ -0,0 +1,438 @@ +module Hix.Test.Managed.LowerInit.MutationTest where + +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 (envs, readUpperBounds) +import qualified Hix.Data.Overrides +import Hix.Data.Overrides (Override (Override)) +import Hix.Data.Version (SourceHash (SourceHash), Versions) +import qualified Hix.Managed.Cabal.Changes +import Hix.Managed.Cabal.Changes (SolverPlan (SolverPlan)) +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, allDeps) +import Hix.Managed.Data.Constraints (EnvConstraints) +import Hix.Managed.Data.ManagedPackageProto (ManagedPackageProto, managedPackages) +import Hix.Managed.Data.Packages (Packages) +import qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Managed.Lower.Init (lowerInitMain) +import Hix.Monad (M, throwM) +import Hix.NixExpr (renderRootExpr) +import Hix.Pretty (showP) +import Hix.Test.Hedgehog (eqLines, listEqZip) +import Hix.Test.Managed.Run (Result (..), TestParams (..), lowerTest, testParams) +import Hix.Test.Utils (UnitTest) + +packages :: Packages ManagedPackageProto +packages = + managedPackages [ + (("local1", "1.0"), [ + "direct1 >5.0", + "direct2 <5.1", + "direct3", + "direct4" + ]), + (("local2", "1.0"), ["local1", "local3"]), + (("local3", "1.0"), ["local1", "direct1"]), + (("local4", "1.0"), ["direct4"]), + (("local5", "1.0"), ["direct5"]), + (("local6", "1.0"), ["direct3"]), + (("local7", "1.0"), ["local6 <2", "direct2"]), + (("local8", "1.0"), ["direct1", "direct6"]) + ] + +packageDb :: SourcePackages +packageDb = + [ + ("direct1", [ + ([1, 0, 3], ["transitive1 >=1"]), + ([1, 0, 4], ["transitive1 >=1"]), + ([1, 0, 5], ["transitive2 >=1"]) + ]), + ("direct2", allDep "transitive3 >=1" [ + ([5, 0], []), + ([5, 0, 5], []) + ]), + ("direct3", [ + ([0, 8], []), + ([1, 0, 1], []), + ([1, 3], []), + ([1, 4], []), + ([1, 5], []) + ]), + ("direct4", allDeps ["direct2 ==5.0.5", "transitive4 >=1"] [ + ([1, 0, 1], []), + ([1, 0, 2], []), + ([1, 0, 3], []), + ([1, 0, 4], []) + ]), + ("direct5", [ + ([1, 5, 1], []) + ]), + ("direct6", [ + ([1, 0, 1], []) + ]), + ("transitive1", [([1, 0, 1], [])]), + ("transitive2", [([1, 0, 1], [])]), + ("transitive3", [([1, 0, 1], [])]), + ("transitive4", [([1, 0, 1], [])]) + ] + +ghcPackages :: GhcPackages +ghcPackages = GhcPackages {installed = [], available = packageDb} + +state :: ProjectStateProto +state = + ProjectStateProto { + bounds = [ + ("local1", [ + ("direct2", [[4, 0], [4, 4]]), + ("direct3", [[1, 0, 1], [1, 5]]) + ]), + ("local5", [("direct5", [[1, 5], [1, 6]])]) + ], + versions = [ + ("lower-main", [ + ("direct1", [1, 0, 1]), + ("direct2", [4, 3, 1]), + ("direct3", [1, 0, 1]) + ]), + ("lower-unused", [ + ("direct1", [1, 0, 1]), + ("direct6", [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"})]) + ], + initial = [("lower-main", [("direct3", [1, 0, 1])])], + resolving = False + } + +build :: Versions -> M BuildStatus +build = \case + versions + | Just [1, 0, n] <- versions !! "direct1" + , n /= 5 + -> pure Failure + versions + | Just [1, 0, n] <- versions !! "direct4" + , n /= 3 + -> pure Failure + [ + ("direct1", [1, 0, 5]), + ("direct2", [5, 0, 5]), + ("direct3", [1, 0, 1]), + ("direct4", [1, 0, 3]), + ("transitive2", [1, 0, 1]), + ("transitive3", [1, 0, 1]), + ("transitive4", [1, 0, 1]) + ] -> pure Success + [ + ("direct2", [5, 0]), + ("direct3", [1, 4]), + ("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 +-- the bounds (inclusive or exclusive) to construct @VersionBounds@. +cabalTarget :: [(EnvConstraints, Maybe SolverPlan)] +cabalTarget = + [ + item1 3 1, + item1 4 1, + item1 5 2, + ([ + "direct1", + "direct2 ==5.0", + "direct3 <=1.0.1", + "direct4" + ], Nothing), + ([ + "direct1", + "direct2 ==5.0.5", + "direct3 <=1.0.1", + "direct4" + ], plan ["direct1-1.0.5", "direct2-5.0.5", "direct3-1.0.1", "direct4-1.0.4", "transitive2-1.0.1", "transitive3-1.0.1", "transitive4-1.0.1"]), + item2 1, + item2 2, + item2 3, + -- Iteration 2 + item3 3 1, + item3 4 1, + item3 5 2, + ([ + "direct1 <=1.0.5", + "direct2 <=5.0.5 && ==5.0", + "direct3 <=1.0.1", + "direct4 <=1.0.3" + ], Nothing), + ([ + "direct1 <=1.0.5", + "direct2 <=5.0.5 && ==5.0.5", + "direct3 <=1.0.1", + "direct4 <=1.0.3" + ], plan ["direct1-1.0.5", "direct2-5.0.5", "direct3-1.0.1", "direct4-1.0.3", "transitive2-1.0.1", "transitive3-1.0.1", "transitive4-1.0.1"]), + -- lower-special + ([ + "direct2 ==5.0", + "local6" + ], plan ["direct2-5.0", "direct3-1.4", "local6-1.0", "transitive3-1.0.1"]) + ] + where + item1 (v1 :: Natural) (nt :: Natural) = + ([ + fromString [exon|direct1 ==1.0.#{show v1}|], + "direct2", + "direct3 <=1.0.1", + "direct4" + ], plan [fromString [exon|direct1-1.0.#{show v1}|], "direct2-5.0.5", "direct3-1.0.1", "direct4-1.0.4", fromString [exon|transitive#{show nt}-1.0.1|], "transitive3-1.0.1", "transitive4-1.0.1"]) + + item2 (v1 :: Natural) = + ([ + "direct1", + "direct2", + "direct3 <=1.0.1", + fromString [exon|direct4 ==1.0.#{show v1}|] + ], plan ["direct1-1.0.5", "direct2-5.0.5", "direct3-1.0.1", fromString [exon|direct4-1.0.#{show v1}|], "transitive2-1.0.1", "transitive3-1.0.1", "transitive4-1.0.1"]) + + item3 (v1 :: Natural) (nt :: Natural) = + ([ + fromString [exon|direct1 <=1.0.5 && ==1.0.#{show v1}|], + "direct2 <=5.0.5", + "direct3 <=1.0.1", + "direct4 <=1.0.3" + ], plan [fromString [exon|direct1-1.0.#{show v1}|], "direct2-5.0.5", "direct3-1.0.1", "direct4-1.0.3", fromString [exon|transitive#{show nt}-1.0.1|], "transitive3-1.0.1", "transitive4-1.0.1"]) + + plan changes = Just SolverPlan {changes, matching = [], nonReinstallable = Nothing} + +stateFileTarget :: Text +stateFileTarget = + [exon|{ + bounds = { + local1 = { + direct1 = { + lower = "1.0.5"; + upper = null; + }; + direct2 = { + lower = "5.0.5"; + upper = "5.1"; + }; + direct3 = { + lower = "1.0.1"; + upper = "1.5"; + }; + direct4 = { + lower = "1.0.3"; + upper = null; + }; + }; + local2 = {}; + local3 = { + direct1 = { + lower = "1.0.5"; + upper = null; + }; + }; + local4 = { + direct4 = { + lower = "1.0.3"; + upper = null; + }; + }; + local5 = { + direct5 = { + lower = "1.5"; + upper = "1.6"; + }; + }; + local6 = { + direct3 = { + lower = "1.0.1"; + upper = "1.5"; + }; + }; + local7 = { + direct2 = { + lower = "5.0"; + upper = null; + }; + }; + local8 = { + direct1 = { + lower = null; + upper = null; + }; + direct6 = { + lower = null; + upper = null; + }; + }; + }; + versions = { + lower-main = { + direct1 = "1.0.5"; + direct2 = "5.0.5"; + direct3 = "1.0.1"; + direct4 = "1.0.3"; + }; + lower-special = { + direct2 = "5.0"; + }; + lower-unused = { + direct1 = "1.0.1"; + direct6 = "1.0.1"; + }; + }; + initial = { + lower-main = { + direct1 = "1.0.5"; + direct2 = "5.0.5"; + direct3 = "1.0.1"; + direct4 = "1.0.3"; + }; + lower-special = { + direct2 = "5.0"; + }; + lower-unused = {}; + }; + overrides = { + latest = { + direct2 = { + version = "5.0"; + hash = "direct2-5.0"; + }; + }; + lower-main = { + direct1 = { + version = "1.0.5"; + hash = "direct1-1.0.5"; + }; + direct2 = { + version = "5.0.5"; + hash = "direct2-5.0.5"; + }; + direct3 = { + version = "1.0.1"; + hash = "direct3-1.0.1"; + }; + direct4 = { + version = "1.0.3"; + hash = "direct4-1.0.3"; + }; + transitive2 = { + version = "1.0.1"; + hash = "transitive2-1.0.1"; + }; + transitive3 = { + version = "1.0.1"; + hash = "transitive3-1.0.1"; + }; + transitive4 = { + version = "1.0.1"; + hash = "transitive4-1.0.1"; + }; + }; + lower-special = { + direct2 = { + version = "5.0"; + hash = "direct2-5.0"; + }; + direct3 = { + version = "1.4"; + hash = "direct3-1.4"; + }; + transitive3 = { + version = "1.0.1"; + hash = "transitive3-1.0.1"; + }; + }; + }; + resolving = false; +} +|] + +logTarget :: [Text] +logTarget = + Text.lines [exon| +>>> lower-main +>>> Found initial lower bounds for all deps after 2 iterations. +>>> Added new versions: + 📦 direct4 1.0.3 ↕ [no bounds] -> >=1.0.3 +>>> Updated versions: + 📦 direct1 1.0.1 -> 1.0.5 ↕ [no bounds] -> >=1.0.5 + 📦 direct2 4.3.1 -> 5.0.5 ↕ [4.0, 5.1] -> [5.0.5, 5.1] + +>>> lower-special +>>> Found initial lower bounds for all deps after 1 iteration. +>>> Added new versions: + 📦 direct2 5.0 ↕ [no bounds] -> >=5.0 +|] + +-- | Goals for these deps: +-- +-- - @direct1@ will have three available versions and build successfully for the third one, 1.0.5, which will be added +-- to the overrides. Its bound will be @>=1.0.5@. +-- It also has a lower bound, 5.0, in the flake config, which is ignored. +-- +-- - @direct2@ builds successfully with its lowest version 5.0, but @direct3@ restricts its version to 5.0.5, which +-- will be in the final state as lower bound and override. +-- It has preexisting managed bounds that will be printed as a diff. +-- Its upper bound from the user config will be retained, replacing the managed bound. +-- It also has a preexisting entry in the overrides of another env, @latest@, which will be retained. +-- +-- - @direct3@ has a preexisting entry in `initial`, so it will be ignored completely as a candidate, since we want to +-- be able to run @lower.init@ after @lower.optimize@ without resetting all lower bounds to the initial states. +-- It has preexisting managed bounds that will be printed as a diff. +-- +-- - @direct4@ is a dependency of two targets that have no dependency on each other, but one of them has a stricter +-- version requirement, so that the build fails for @<= direct4-1.0.2@ in @local1@ but only for @direct4-1.0.1@ in +-- @local4@. +-- +-- - @direct5@ is a dependency of @local5@, which is not part of the target set. +-- The managed bounds for @local5@ in the initial file should be preserved and unchanged (save for version range +-- normalization), and @direct5@ should never appear in the solver and build deps. +-- +-- - @local6@ is a cross-env dependency of @local7@ and should be omitted from the overrides in @lower-special@. +-- It has a dependency on @direct3@, which is not among the direct dependencies of @lower-special@, therefore being +-- excluded from the solver params when mutating @local7@. +-- Even though @direct3@ has a lower bound in @lower-main@, 1.0.1, it is treated as a regular transitive dep, and the +-- solver chooses the latest matching version for it. +-- Since the pre-existing, exclusive, upper bound in the deps of @local6@ is 1.5, the chosen version is the +-- next-lower, 1.4. +-- This version is written to the overrides for @lower-special@, like any non-installed transitive dep. +test_lowerInitMutation :: UnitTest +test_lowerInitMutation = do + Result {..} <- lowerTest params (lowerInitMain def) + listEqZip cabalTarget cabalLog + eqLines stateFileTarget (renderRootExpr stateFile) + logTarget === drop 24 (reverse log) + where + params = + (testParams False packages) { + envs = [ + ("lower-main", ["local1", "local2", "local3", "local4", "local6"]), + ("lower-special", ["local7"]), + ("lower-unused", ["local8"]) + ], + cabalLog = True, + log = True, + ghcPackages, + state, + projectOptions = def {envs = ["lower-main", "lower-special"], readUpperBounds = True}, + build + } diff --git a/test/Hix/Test/Managed/LowerNativeTest.hs b/test/Hix/Test/Managed/LowerNativeTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/LowerNativeTest.hs @@ -0,0 +1,268 @@ +module Hix.Test.Managed.LowerNativeTest 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) +import Hix.Error (pathText) +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.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) + +-- 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 = + managedPackages [ + (("root", "1.0"), ["aeson >=2.2 && <2.3", "extra >=1.6 && <1.8"]) + ] + +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; + lower.enable = true; + }; + compat.enable = false; + ghcVersions = []; + packages = { + root = { + src = ./.; + library = { + enable = true; + dependencies = ["aeson" "extra"]; + }; + }; + }; + envs.lower.localPackage = api: api.minimal; + }); +}|] + +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 + 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 + +targetStateFileInit :: Text +targetStateFileInit = + [exon|{ + bounds = { + root = { + aeson = ">=2.2.0.0 && <2.3"; + extra = ">=1.7.7 && <1.8"; + }; + }; + overrides = { + lower = { + aeson = { + version = "2.2.0.0"; + hash = "1rxbydr7mvchhlyz2111n70db90s1zd9h6miqbbqh2kyc2l0b3pd"; + }; + bifunctors = { + version = "5.6.1"; + hash = "12k2v7334brn4v7yg3vjd6yv6sh4pzffc3d89qgc2llw7ncv4krw"; + }; + extra = { + version = "1.7.7"; + hash = "0jgcd8gw6d22ngbi0lp3ak2ghzza59nb3vssrjldwxiim0nzf71v"; + }; + integer-conversion = { + version = "0.1.0.1"; + hash = "1qy49ig5k8wcqsgjf2rkbv0dy9gpbdzg8yid1kcdn0s7vys59plj"; + }; + semialign = { + version = "1.3"; + hash = "09147lz8z79ghnpr7z08y9dd0l6c9dz9hz85avfh6z330vl25r95"; + }; + semigroupoids = { + version = "6.0.0.1"; + hash = "1fijnbfn29iwj567kdbhk67pn11ajm80p9d3hg48hppyx7yzpb2k"; + }; + text-iso8601 = { + version = "0.1"; + hash = "0zsqjrks9spakiwhbc7xi4dqsx68lb2cd4rvrin3iclyrqg3a6xg"; + }; + th-abstraction = { + version = "0.5.0.0"; + hash = "0dkilfrvk8zdn3gvyfv5zgjbwqhdf1yg90fk4byka0ib43kgkyvf"; + }; + }; + }; + initial = { + lower = { + aeson = "2.2.0.0"; + extra = "1.7.7"; + }; + }; + resolving = false; +} +|] + +targetStateFileOptimize :: Text +targetStateFileOptimize = + [exon|{ + bounds = { + root = { + aeson = ">=2.1.0.0 && <2.3"; + extra = ">=1.7.7 && <1.8"; + }; + }; + overrides = { + lower = { + OneTuple = { + version = "0.3.1"; + hash = "0mb81j6zhvzq7h9yyhi9cszrq1g5d4lv3a8wpwimcvzbyg9bdd6p"; + }; + aeson = { + version = "2.1.0.0"; + hash = "08s162yh716aaxd42k1kyv18p9nsyab42ns4340kvs6r0i8riwsi"; + }; + assoc = { + version = "1.0.2"; + hash = "1sfc21z18sf8rpsbcr77kgw7qjpm5cm1d24n5ifsm2zid88v8fs9"; + }; + attoparsec = { + version = "0.14.4"; + hash = "0y9dph5axyvr1bfcvmz6qh50bjcp50m2ljra14960anc6g74a3c8"; + }; + extra = { + version = "1.7.7"; + hash = "0jgcd8gw6d22ngbi0lp3ak2ghzza59nb3vssrjldwxiim0nzf71v"; + }; + indexed-traversable-instances = { + version = "0.1.1.2"; + hash = "1mmkklfpagv855p12dqq0r6xwg0v6dc1gj1n3nvzzy4b909ajgd0"; + }; + primitive = { + version = "0.7.4.0"; + hash = "0n7r8al9wgz4r7jzizapn1dbnkqxwx2c4lqkgfm5q5bxj8fl7g1c"; + }; + scientific = { + version = "0.3.7.0"; + hash = "09iwj0snmx7vj7x03l4vdcn76zylcgxd9pyz0yxkydgfnn3lvc08"; + }; + semialign = { + version = "1.2.0.1"; + hash = "0mpw54c3s0x70k5l52a57yhnmbgrksb3dn0vjq4m37spyzsfl1v2"; + }; + strict = { + version = "0.4.0.1"; + hash = "0xhr98m2632k2pic8q9bpnm3mp9098mmg4s66ds052b92494k49f"; + }; + these = { + version = "1.1.1.1"; + hash = "1i1nfh41vflvqxi8w8n2s35ymx2z9119dg5zmd2r23ya7vwvaka1"; + }; + vector = { + version = "0.13.1.0"; + hash = "0c1nw2sx14y29afdbwl40sk9vznx71rja5jcg14b8986778kl32d"; + }; + witherable = { + version = "0.4.2"; + hash = "1ga4al351kwcfvsdr1ngyzj4aypvl46w357jflmgxacad8iqx4ik"; + }; + }; + }; + initial = { + lower = { + aeson = "2.2.0.0"; + extra = "1.7.7"; + }; + }; + resolving = false; +} +|] + +lowerNativeTest :: M (Text, Text) +lowerNativeTest = do + root <- setupProject + let + stateFileConf = StateFileConfig { + file = [relfile|ops/managed.nix|], + projectRoot = Just root + } + envsConfig = [("lower", EnvConfig {targets = ["root"], ghc = GhcDbSystem Nothing})] + handlers <- Build.handlersProd stateFileConf envsConfig Nothing def False + let + opts = projectOptions ["lower"] + + proto0 = + ProjectContextProto { + packages, + state = ProjectStateProto mempty mempty 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 + (state1, stateFileContentInit) <- run context0 (lowerInitMain def) + -- TODO the packages here aren't updated with the result from the first run + let context1 = projectContext def state1 context0.packages context0.envs + (_, stateFileContentOptimize) <- run context1 lowerOptimizeMain + pure (stateFileContentInit, stateFileContentOptimize) + +test_lowerNative :: UnitTest +test_lowerNative = do + (stateFileContentInit, stateFileContentOptimize) <- evalEither =<< liftIO do + runMTest True lowerNativeTest + eqLines targetStateFileInit stateFileContentInit + eqLines targetStateFileOptimize stateFileContentOptimize diff --git a/test/Hix/Test/Managed/LowerOptimize/CandidatesTest.hs b/test/Hix/Test/Managed/LowerOptimize/CandidatesTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/LowerOptimize/CandidatesTest.hs @@ -0,0 +1,99 @@ +module Hix.Test.Managed.LowerOptimize.CandidatesTest where + +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Distribution.Version (Version) +import Hedgehog (evalEither, (===)) + +import Hix.Data.PackageName (PackageName) +import qualified Hix.Data.VersionBounds +import Hix.Data.VersionBounds (fromLower, fromUpper) +import qualified Hix.Managed.Cabal.Data.SolverState +import Hix.Managed.Cabal.Data.SolverState (SolverState (SolverState), solverState, updateSolverState) +import Hix.Managed.Data.Constraints (MutationConstraints (MutationConstraints), mutation) +import Hix.Managed.Data.Mutable (MutableDep) +import qualified Hix.Managed.Data.MutableId +import Hix.Managed.Data.MutableId (MutableId (MutableId)) +import qualified Hix.Managed.Data.Mutation +import Hix.Managed.Data.Mutation (BuildMutation (BuildMutation), MutationResult (MutationSuccess)) +import qualified Hix.Managed.Data.MutationState +import Hix.Managed.Data.MutationState (MutationState (MutationState)) +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) + +availableVersions :: PackageName -> M [Version] +availableVersions = \case + "dep" -> pure versions + _ -> clientError "No such package" + where + versions = s1 ++ s2 + s1 = [[1, m, n] | m <- [7 .. 9], n <- [1 .. 3]] + s2 = [[2, m, n] | m <- [0 .. 4], n <- [1 .. 3]] + +targets :: [Version] +targets = + s1 ++ s2 ++ s3 + where + s1 = [[1, 8, n] | n <- reverse [1 .. 3]] + s2 = [[1, 9, n] | n <- reverse [1 .. 2]] + s3 = [[2, m, n] | m <- [0 .. 3], n <- reverse [1 .. 3]] + +candidateVersion :: Version +candidateVersion = [1, 9, 2] + +build :: IORef [Maybe Version] -> BuildMutation -> M (Maybe MutationState) +build buildRef BuildMutation {solverState = SolverState {constraints = [("dep", MutationConstraints {mutation})]}} = do + liftIO (modifyIORef' buildRef (mutation.lower :)) + pure (result =<< mutation.lower) + where + result version + | candidateVersion == version + = Just MutationState { + bounds = [("dep", fromLower version)], + versions = [("dep", Just version)], + overrides = mempty, + initial = [] + } + | otherwise + = Nothing +build _ _ = pure Nothing + +test_candidatesOptimize :: UnitTest +test_candidatesOptimize = do + buildRef <- liftIO (newIORef []) + let + result <- liftIO $ runMTest False 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 + triedVersions <- liftIO (readIORef buildRef) + (Just <$> targets) === triedVersions + where + dep = simpleQueryDep mutable [[2, 4]] + + mstate = + MutationState { + bounds = [("dep", fromLower candidateVersion)], + versions = [(mutable, Just candidateVersion)], + overrides = mempty, + initial = [] + } + + newConstraints = [(package, mempty {mutation = fromUpper candidateVersion})] + + initialState = solverState mempty mempty constraints def + + constraints = [(package, mempty)] + + candidate = MutableId {name = mutable, version = candidateVersion} + + mutable :: MutableDep + mutable = "dep" + + package = "dep" diff --git a/test/Hix/Test/Managed/LowerOptimize/MutationTest.hs b/test/Hix/Test/Managed/LowerOptimize/MutationTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/LowerOptimize/MutationTest.hs @@ -0,0 +1,154 @@ +module Hix.Test.Managed.LowerOptimize.MutationTest where + +import Exon (exon) + +import Hix.Data.Error (Error (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 qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Managed.Lower.Optimize (lowerOptimizeMain) +import Hix.Monad (M, throwM) +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.Utils (UnitTest) + +packages :: Packages ManagedPackageProto +packages = + managedPackages [(("local1", "1.0"), ["direct1", "direct2"])] + +packageDb :: SourcePackages +packageDb = + [ + ("direct1", allDep "transitive1 >=1.0" [ + ([1, 8, 1], []), + ([1, 9, 1], []), + ([2, 0, 1], []) + ]), + ("direct2", [ + ([1, 7, 1], []), + ([1, 8, 1], []), + ([1, 9, 1], []), + ([1, 9, 2], []), + ([2, 0, 1], []) + ]), + ("transitive1", [ + ([1, 0, 1], []) + ]) + ] + +ghcPackages :: GhcPackages +ghcPackages = GhcPackages {installed = [], available = packageDb} + +state :: ProjectStateProto +state = + ProjectStateProto { + bounds = [ + ("local1", [ + ("direct1", [[2, 0, 1], [2, 1]]), + ("direct2", [[2, 0, 1], [2, 1]]) + ]) + ], + versions = [ + ("lower", [ + ("direct1", [2, 0, 1]), + ("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]) + ]) + ], + resolving = False + } + +build :: Versions -> M BuildStatus +build = \case + [("direct1", [1, 9, 1]), ("direct2", [2, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Success + [("direct1", [1, 8, 1]), ("direct2", [2, 0, 1]), ("transitive1", [1, 0, 1])] -> pure Success + [("direct1", [1, 8, 1]), ("direct2", [1, 9, 1]), ("transitive1", [1, 0, 1])] -> pure Failure + [("direct1", [1, 8, 1]), ("direct2", [1, 9, 2]), ("transitive1", [1, 0, 1])] -> pure Success + [("direct1", [1, 8, 1]), ("direct2", [1, 8, 1]), ("transitive1", [1, 0, 1])] -> pure Failure + versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) + +stateFileTarget :: Text +stateFileTarget = + [exon|{ + bounds = { + local1 = { + direct1 = { + lower = "1.8.1"; + upper = "2.1"; + }; + direct2 = { + lower = "1.9.2"; + upper = "2.1"; + }; + }; + }; + versions = { + lower = { + direct1 = "1.8.1"; + direct2 = "1.9.2"; + }; + }; + initial = { + lower = { + direct1 = "2.0.1"; + direct2 = "2.0.1"; + }; + }; + overrides = { + lower = { + direct1 = { + version = "1.8.1"; + hash = "direct1-1.8.1"; + }; + direct2 = { + version = "1.9.2"; + hash = "direct2-1.9.2"; + }; + transitive1 = { + version = "1.0.1"; + hash = "transitive1-1.0.1"; + }; + }; + }; + resolving = false; +} +|] + +-- | Goals for these deps: +-- +-- - @direct1@ has two lower majors and all of them succeed, resulting in the lowest major (1.8.1) to become the bound. +-- +-- - @direct2@ has three lower majors, the second of which fails, resulting in the highest major 1.9 to be the last one +-- tested. +-- The first version 1.9.1 also fails, resulting in 1.9.2 to become the bound. +test_lowerOptimizeMutation :: UnitTest +test_lowerOptimizeMutation = do + Result {stateFile} <- lowerTest params lowerOptimizeMain + eqLines stateFileTarget (renderRootExpr stateFile) + where + params = + (testParams False packages) { + ghcPackages, + state, + build + } diff --git a/test/Hix/Test/Managed/LowerStabilize/MutationTest.hs b/test/Hix/Test/Managed/LowerStabilize/MutationTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/LowerStabilize/MutationTest.hs @@ -0,0 +1,141 @@ +module Hix.Test.Managed.LowerStabilize.MutationTest where + +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 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 qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) +import Hix.Managed.Data.StageState (BuildStatus (Failure, Success)) +import Hix.Managed.Lower.Stabilize (lowerStabilizeMain) +import Hix.Monad (M, throwM) +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.Utils (UnitTest) + +packageDb :: SourcePackages +packageDb = + [ + ("direct1", [ + ([1, 8, 1], []), + ([1, 9, 1], []), + ([2, 0, 1], []) + ]), + ("direct2", [ + ([1, 8, 1], []), + ([1, 9, 1], []), + ([2, 0, 1], []) + ]) + ] + +ghcPackages :: GhcPackages +ghcPackages = GhcPackages {installed = [], available = packageDb} + +packages :: Packages ManagedPackageProto +packages = + managedPackages [(("local1", "1.0"), ["direct1", "direct2"])] + +state :: ProjectStateProto +state = + ProjectStateProto { + bounds = [ + ("local1", [ + ("direct1", [[1, 8, 1], [2, 1]]), + ("direct2", [[1, 8, 1], [2, 1]]) + ]) + ], + versions = [ + ("lower", [ + ("direct1", [1, 8, 1]), + ("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]) + ]) + ], + resolving = False + } + +build :: Versions -> M BuildStatus +build = \case + [("direct1", [2, 0, 1]), ("direct2", [2, 0, 1])] -> pure Success + [("direct1", [1, 8, 1]), ("direct2", [1, 8, 1])] -> pure Failure + [("direct1", [1, 8, 1]), ("direct2", [2, 0, 1])] -> pure Failure + [("direct1", [1, 9, 1]), ("direct2", [2, 0, 1])] -> pure Success + [("direct1", [1, 9, 1]), ("direct2", [1, 8, 1])] -> pure Failure + [("direct1", [1, 9, 1]), ("direct2", [1, 9, 1])] -> pure Success + [] -> throwM (Fatal "Build with no overrides") + versions -> throwM (Fatal [exon|Unexpected build plan: #{showP versions}|]) + +stateFileTarget :: Text +stateFileTarget = + [exon|{ + bounds = { + local1 = { + direct1 = { + lower = "1.9.1"; + upper = "2.1"; + }; + direct2 = { + lower = "1.9.1"; + upper = "2.1"; + }; + }; + }; + versions = { + lower = { + direct1 = "1.9.1"; + direct2 = "1.9.1"; + }; + }; + initial = { + lower = { + direct1 = "2.0.1"; + direct2 = "2.0.1"; + }; + }; + overrides = { + lower = { + direct1 = { + version = "1.9.1"; + hash = "direct1-1.9.1"; + }; + direct2 = { + version = "1.9.1"; + hash = "direct2-1.9.1"; + }; + }; + }; + resolving = false; +} +|] + +test_lowerStabilizeMutation :: UnitTest +test_lowerStabilizeMutation = do + Result {stateFile} <- lowerTest params lowerStabilizeMain + eqLines stateFileTarget (renderRootExpr stateFile) + where + params = + (testParams False packages) { + ghcPackages, + state, + build + } diff --git a/test/Hix/Test/Managed/ProjectContextProtoTest.hs b/test/Hix/Test/Managed/ProjectContextProtoTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/ProjectContextProtoTest.hs @@ -0,0 +1,287 @@ +module Hix.Test.Managed.ProjectContextProtoTest where + +import Data.Aeson (eitherDecodeStrict') +import Distribution.Version (earlierVersion, intersectVersionRanges, majorBoundVersion, orLaterVersion, thisVersion) +import Exon (exon) +import Hedgehog (evalEither, (===)) +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 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 qualified Hix.Managed.Data.ProjectContext +import Hix.Managed.Data.ProjectContext (ProjectContext (ProjectContext)) +import qualified Hix.Managed.Data.ProjectContextProto +import Hix.Managed.Data.ProjectContextProto (ProjectContextProto (ProjectContextProto)) +import qualified Hix.Managed.Data.ProjectState +import Hix.Managed.Data.ProjectState (ProjectState (ProjectState)) +import qualified Hix.Managed.Data.ProjectStateProto +import Hix.Managed.Data.ProjectStateProto (ProjectStateProto (ProjectStateProto)) +import Hix.Managed.Data.Targets (unsafeTargets) +import qualified Hix.Managed.ProjectContextProto as ProjectContextProto +import Hix.Test.Hedgehog (assertRight) +import Hix.Test.Utils (UnitTest, runMTest) + +json :: ByteString +json = + [exon|{ + "packages": { + "local1": { + "name": "local1", + "version": "1.2.1", + "deps": [ + "direct1 ^>=2.0", + { + "name": "direct2", + "version": "<1.5" + }, + "direct3", + "direct4:{internal,external} ==13.23", + "direct5 >=5.0 && <5.1" + ] + }, + "local2": { + "name": "local2", + "version": "1.1.1", + "deps": [ + "local1" + ] + }, + "local3": { + "name": "local3", + "version": "1.1.1", + "deps": [] + }, + "local4": { + "name": "local4", + "version": "1.1.1", + "deps": [ + "local2", + "direct1", + "direct2" + ] + }, + "local5": { + "name": "local5", + "version": "1.1.1", + "deps": [ + "local4", + "local3" + ] + } + }, + "state": { + "bounds": { + "local1": { + "direct1": { + "lower": null, + "upper": "2.3" + }, + "direct2": { + "upper": "1.5" + } + } + } + }, + "solverBounds": { + "direct1": ">=2.0.2" + }, + "envs": { + "lower-main": { + "targets": ["local1", "local2"], + "ghc": "/ghc" + }, + "lower-special": { + "targets": ["local3", "local4"], + "ghc": "/ghc" + } + } + }|] + +packages :: Packages ManagedPackageProto +packages = + [ + ("local1", ManagedPackageProto { + name = "local1", + version = "1.2.1", + deps = [ + mkDep "direct1" (majorBoundVersion [2, 0]), + mkDep "direct2" (earlierVersion [1, 5]), + mkDep "direct3" range0, + Dep { + package = "direct4", + version = thisVersion [13, 23] + }, + mkDep "direct5" (intersectVersionRanges (orLaterVersion [5, 0]) (earlierVersion [5, 1])) + ] + }), + ("local2", ManagedPackageProto { + name = "local2", + version = "1.1.1", + deps = ["local1"] + }), + ("local3", ManagedPackageProto { + name = "local3", + version = "1.1.1", + deps = [] + }), + ("local4", ManagedPackageProto { + name = "local4", + version = "1.1.1", + deps = ["local2", "direct1", "direct2"] + }), + ("local5", ManagedPackageProto { + name = "local5", + version = "1.1.1", + deps = ["local4", "local3"] + }) + ] + +ghc :: GhcDb +ghc = + GhcDbSystem (Just (GhcPath [absdir|/ghc|])) + +targetProto :: ProjectContextProto +targetProto = + ProjectContextProto { + packages, + state = ProjectStateProto { + bounds = [("local1", [("direct1", "<2.3"), ("direct2", "<1.5")])], + versions = [], + overrides = mempty, + initial = mempty, + resolving = False + }, + envs = [ + ("lower-main", EnvConfig {targets = ["local1", "local2"], ghc}), + ("lower-special", EnvConfig {targets = ["local3", "local4"], ghc}) + ], + buildOutputsPrefix = Nothing + } + +targetEnvs :: NonEmpty (Either EnvName EnvContext) +targetEnvs = + [ + Right EnvContext { + env = "lower-main", + ghc, + targets = unsafeTargets ["local1", "local2"], + deps = EnvDeps {mutable = ["direct1", "direct2", "direct3", "direct4", "direct5"], local = []}, + query = ["direct1", "direct2", "direct3", "direct4", "direct5"], + solverBounds = mempty + }, + Right EnvContext { + env = "lower-special", + ghc, + targets = unsafeTargets ["local3", "local4"], + deps = EnvDeps {mutable = ["direct1", "direct2"], local = ["local2"]}, + query = ["direct1", "direct2"], + solverBounds = mempty + } + ] + +targetProject :: ProjectContext +targetProject = + ProjectContext { + build = def, + packages = [ + ("local1", ManagedPackage { + package = "local1", + version = [1, 2, 1], + local = [], + mutable = [ + ("direct1", "^>=2.0"), + ("direct2", "<1.5"), + ("direct3", ">=0"), + ("direct4", "==13.23"), + ("direct5", ">=5.0 && <5.1") + ] + }), + ("local2", ManagedPackage { + package = "local2", + version = [1, 1, 1], + local = [("local1", ">=0")], + mutable = [] + }), + ("local3", ManagedPackage { + package = "local3", + version = [1, 1, 1], + local = [], + mutable = [] + }), + ("local4", ManagedPackage { + package = "local4", + version = [1, 1, 1], + local = [("local2", ">=0")], + mutable = [("direct1", ">=0"), ("direct2", ">=0")] + }), + ("local5", ManagedPackage { + package = "local5", + version = [1, 1, 1], + local = [("local3", ">=0"), ("local4", ">=0")], + mutable = [] + }) + ], + state = ProjectState { + bounds = [ + ("local1", [ + ("direct1", "<2.3"), + ("direct2", "<1.5"), + ("direct3", ">=0"), + ("direct4", ">=0"), + ("direct5", ">=0") + ]), + ("local2", []), + ("local3", []), + ("local4", [("direct1", ">=0"), ("direct2", ">=0")]), + ("local5", []) + ], + versions = [ + ("lower-main", [ + ("direct1", Nothing), + ("direct2", Nothing), + ("direct3", Nothing), + ("direct4", Nothing), + ("direct5", Nothing) + ]), + ("lower-special", [ + ("direct1", Nothing), + ("direct2", Nothing) + ]) + ], + overrides = [], + initial = [ + ("lower-main", [ + ("direct1", Nothing), + ("direct2", Nothing), + ("direct3", Nothing), + ("direct4", Nothing), + ("direct5", Nothing) + ]), + ("lower-special", [ + ("direct1", Nothing), + ("direct2", Nothing) + ]) + ], + resolving = False + }, + envs = targetEnvs + } + +test_parseProjectContextProto :: UnitTest +test_parseProjectContextProto = do + assertRight targetProto (eitherDecodeStrict' json) + project <- evalEither =<< liftIO do + runMTest False (ProjectContextProto.validate def targetProto) + targetProject === project diff --git a/test/Hix/Test/Managed/Run.hs b/test/Hix/Test/Managed/Run.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/Run.hs @@ -0,0 +1,130 @@ +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 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.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)) +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 + } + +testParams :: + Bool -> + Packages ManagedPackageProto -> + TestParams +testParams debug packages = + TestParams { + envs = [], + cabalLog = False, + log = False, + debug, + packages, + ghcPackages = GhcPackages {installed = [], available = []}, + state = def, + projectOptions = def, + build = const (pure Failure) + } + +data Result = + Result { + stateFile :: Expr, + cabalLog :: [(EnvConstraints, Maybe SolverPlan)], + log :: [Text] + } + +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 -> ProjectContext -> M ProjectResult) -> + TestT IO Result +managedTest defaultEnvName params main = + withFrozenCallStack do + (handlers0, stateFileRef, _) <- BuildHandlers.handlersUnitTest params.ghcPackages 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, result) <- liftIO (runner (withProjectContext handlers params.projectOptions context (main handlers))) + evalEither 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 + +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 diff --git a/test/Hix/Test/Managed/UnsafeIsString.hs b/test/Hix/Test/Managed/UnsafeIsString.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Managed/UnsafeIsString.hs @@ -0,0 +1,73 @@ +{-# 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.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 diff --git a/test/Hix/Test/ManagedTest.hs b/test/Hix/Test/ManagedTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/ManagedTest.hs @@ -0,0 +1,37 @@ +module Hix.Test.ManagedTest where + +import Test.Tasty (TestTree, testGroup) + +import Hix.Test.Managed.BuildOutputTest (test_buildOutput) +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.LowerAuto.MutationOptimizeTest (test_lowerAutoMutationOptimize) +import Hix.Test.Managed.LowerAuto.MutationStabilizeTest (test_lowerAutoMutationStabilize) +import Hix.Test.Managed.LowerInit.MutationTest (test_lowerInitMutation) +import Hix.Test.Managed.LowerNativeTest () +import Hix.Test.Managed.LowerOptimize.CandidatesTest (test_candidatesOptimize) +import Hix.Test.Managed.LowerOptimize.MutationTest (test_lowerOptimizeMutation) +import Hix.Test.Managed.LowerStabilize.MutationTest (test_lowerStabilizeMutation) +import Hix.Test.Managed.ProjectContextProtoTest (test_parseProjectContextProto) +import Hix.Test.Utils (unitTest) + +test_managed :: TestTree +test_managed = + testGroup "managed" [ + testGroup "candidates" [ + unitTest "bump" test_candidatesBump, + unitTest "optimize" test_candidatesOptimize + ], + testGroup "mutation build" [ + test_bumpMutation, + unitTest "lower.init" test_lowerInitMutation, + unitTest "lower.optimize" test_lowerOptimizeMutation, + unitTest "lower.stabilize" test_lowerStabilizeMutation, + unitTest "lower.auto stabilize" test_lowerAutoMutationStabilize, + test_lowerAutoMutationOptimize + ], + unitTest "parse ProjectContext" test_parseProjectContextProto, + test_buildOutput, + test_diff + ] diff --git a/test/Hix/Test/NewTest.hs b/test/Hix/Test/NewTest.hs --- a/test/Hix/Test/NewTest.hs +++ b/test/Hix/Test/NewTest.hs @@ -1,7 +1,7 @@ module Hix.Test.NewTest where import Exon (exon) -import Hedgehog (TestT, evalEither, (===)) +import Hedgehog (evalEither, (===)) import Path (absdir, relfile) import qualified Hix.Data.NewProjectConfig @@ -9,6 +9,7 @@ import Hix.Data.ProjectFile (ProjectFile (ProjectFile)) import Hix.Monad (runM) import Hix.New (license, newProjectFiles) +import Hix.Test.Utils (UnitTest) conf :: NewProjectConfig conf = @@ -47,7 +48,7 @@ test = { enable = true; dependencies = [ - "hedgehog >= 1.1 && < 1.3" + "hedgehog >= 1.1 && < 1.5" "tasty ^>= 1.4" "tasty-hedgehog >= 1.3 && < 1.5" ]; @@ -119,7 +120,7 @@ ProjectFile [relfile|test/Spider/Test/NameTest.hs|] nameTestModule ] -test_new :: TestT IO () +test_new :: UnitTest test_new = do res <- evalEither =<< liftIO (runM [absdir|/project|] (newProjectFiles conf)) target === res diff --git a/test/Hix/Test/PreprocTest.hs b/test/Hix/Test/PreprocTest.hs --- a/test/Hix/Test/PreprocTest.hs +++ b/test/Hix/Test/PreprocTest.hs @@ -8,10 +8,12 @@ Library (libBuildInfo), ) import Exon (exon) -import Hedgehog (TestT, evalMaybe, (===)) +import Hedgehog (evalMaybe, (===)) +import Path (absfile) + import Hix.Preproc (fromCabal, preprocessModule) import Hix.Test.CabalFile (testPackage, testPackageNoPrelude) -import Path (absfile) +import Hix.Test.Utils (UnitTest) pragmas :: Text pragmas = @@ -28,7 +30,7 @@ HasCallStack => ByteString -> Text -> - TestT IO () + UnitTest preprocTestNoPrelude module_ target = withFrozenCallStack do pkg <- liftIO testPackageNoPrelude @@ -40,7 +42,7 @@ HasCallStack => ByteString -> Text -> - TestT IO () + UnitTest preprocTest module_ target = withFrozenCallStack do pkg <- liftIO testPackage @@ -85,7 +87,7 @@ f = 1 |] -test_preprocInsertPrelude :: TestT IO () +test_preprocInsertPrelude :: UnitTest test_preprocInsertPrelude = preprocTest moduleInsert targetInsert @@ -134,7 +136,7 @@ f = 1 |] -test_preprocReplacePrelude :: TestT IO () +test_preprocReplacePrelude :: UnitTest test_preprocReplacePrelude = preprocTest moduleReplace targetReplace @@ -159,7 +161,7 @@ f = 1 |] -test_preprocSingleLineModule :: TestT IO () +test_preprocSingleLineModule :: UnitTest test_preprocSingleLineModule = preprocTest moduleSingleLineModule targetSingleLineModule @@ -184,7 +186,7 @@ f = 1 |] -test_preprocSelfExport :: TestT IO () +test_preprocSelfExport :: UnitTest test_preprocSelfExport = preprocTest moduleSelfExport targetSelfExport @@ -217,7 +219,7 @@ f = 1 |] -test_preprocSelfExport2 :: TestT IO () +test_preprocSelfExport2 :: UnitTest test_preprocSelfExport2 = preprocTest moduleSelfExport2 targetSelfExport2 @@ -235,7 +237,7 @@ import System.Exit (exitSuccess) |] -test_preprocNoPrelude :: TestT IO () +test_preprocNoPrelude :: UnitTest test_preprocNoPrelude = preprocTestNoPrelude moduleNoPrelude targetNoPrelude @@ -258,6 +260,6 @@ {-# line 4 "/foo/bar/Foo.hs" #-} |] -test_preprocPreludePrefix :: TestT IO () +test_preprocPreludePrefix :: UnitTest test_preprocPreludePrefix = preprocTest modulePreludePrefix targetPreludePrefix diff --git a/test/Hix/Test/Utils.hs b/test/Hix/Test/Utils.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/Utils.hs @@ -0,0 +1,42 @@ +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} diff --git a/test/Hix/Test/VersionTest.hs b/test/Hix/Test/VersionTest.hs new file mode 100644 --- /dev/null +++ b/test/Hix/Test/VersionTest.hs @@ -0,0 +1,51 @@ +module Hix.Test.VersionTest where + +import Distribution.Version (earlierVersion, intersectVersionRanges, laterVersion, orLaterVersion, unionVersionRanges) +import Hedgehog ((===)) +import Test.Tasty (TestTree, testGroup) + +import qualified Hix.Data.Version +import Hix.Data.Version (Major (Major)) +import Hix.Test.Utils (UnitTest, unitTest) +import Hix.Version (exclusiveUpperVersion, lastMajorBefore, lowerVersion, majorsBefore, versionsFrom) + +test_versionList :: UnitTest +test_versionList = + intersectVersionRanges (orLaterVersion [1, 4]) (earlierVersion [2, 3]) === [[1, 4], [2, 3]] + +test_rangeBounds :: UnitTest +test_rangeBounds = do + Just [1, 1] === lowerVersion range1 + Just [2, 3] === exclusiveUpperVersion range2 + where + range1 = intersectVersionRanges (laterVersion [0, 4]) (unionVersionRanges [[1, 1], [1, 3]] range2) + range2 = [[2, 2], [2, 3]] + +test_majors :: UnitTest +test_majors = do + [[2, 2]] === lastMajorBefore 2 3 versions + target1 === majorsBefore 2 3 versions + target2 === versionsFrom [2, 1, 2] versions + drop 1 target2 === versionsFrom [2, 1, 3] versions + where + target1 = + [ + Major {prefix = [2, 1], versions = [[2, 1, 1], [2, 1, 2]]}, + Major {prefix = [2, 2], versions = [[2, 2]]} + ] + target2 = + [ + Major {prefix = [2, 1], versions = [[2, 1, 2]]}, + Major {prefix = [2, 2], versions = [[2, 2]]}, + Major {prefix = [2, 3], versions = [[2, 3]]} + ] + + versions = [[2, 1, 1], [2, 1, 2], [2, 2], [2, 3]] + +test_version :: TestTree +test_version = + testGroup "version" [ + unitTest "fromList" test_versionList, + unitTest "bounds" test_rangeBounds, + unitTest "majors" test_majors + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,9 +1,11 @@ module Main where -import Hedgehog (TestT, property, test, withTests) +import Hix () import Hix.Test.BootstrapTest (test_bootstrap) +import Hix.Test.BoundsTest (test_bounds) import Hix.Test.CabalTest (test_cabal) import Hix.Test.GhciTest (test_componentEnv, test_ghcid, test_moduleName) +import Hix.Test.ManagedTest (test_managed) import Hix.Test.NewTest (test_new) import Hix.Test.PreprocTest ( test_preprocInsertPrelude, @@ -14,17 +16,9 @@ test_preprocSelfExport2, test_preprocSingleLineModule, ) -import Test.Tasty (TestName, TestTree, defaultMain, testGroup) -import Test.Tasty.Hedgehog (testProperty) - -unitTest :: - HasCallStack => - TestName -> - TestT IO () -> - TestTree -unitTest desc t = - withFrozenCallStack do - testProperty desc (withTests 1 (property (test t))) +import Hix.Test.Utils (unitTest) +import Hix.Test.VersionTest (test_version) +import Test.Tasty (TestTree, defaultMain, testGroup) tests :: TestTree tests = @@ -43,7 +37,10 @@ unitTest "extract module name from path" test_moduleName, unitTest "generate a project" test_new, unitTest "bootstrap a project" test_bootstrap - ] + ], + test_version, + test_bounds, + test_managed ] main :: IO ()