packages feed

hwm (empty) → 0.0.1

raw patch · 38 files changed

+4023/−0 lines, 38 filesdep +Cabaldep +Globdep +aeson

Dependencies added: Cabal, Glob, aeson, ansi-terminal, async, base, base16-bytestring, bytestring, containers, cryptohash-sha256, directory, filepath, hpack, hwm, modern-uri, mtl, optparse-applicative, process, relude, req, stm, text, time, transformers, typed-process, unordered-containers, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,19 @@+# Changelog++All notable changes to this project will be documented in this file.++For detailed release notes, see [GitHub Releases](https://github.com/nalchevanidze/hwm/releases).++## 0.0.1 - 2026-02-15++### Initial Release++* Core workspace management from single `hwm.yaml` configuration+* Automatic generation of `stack.yaml`, `package.yaml`, `.cabal`, and `hie.yaml`+* Multi-GHC build matrix support with environment switching+* Centralized dependency registry with version bounds+* Package status checking and synchronization+* Dependency update checking (`hwm outdated`)+* Atomic version bumping across workspace+* Coordinated Hackage publishing+* Zero-config onboarding from existing Stack projects (`hwm init`)
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2026 Daviti Nalchevanidze++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,87 @@+# HWM: Haskell Workspace Manager++**HWM is not a build tool.** It is the missing link that orchestrates the tools you already use.++Haskell has excellent build systems (`stack`, `cabal`, `nix`) and a powerful IDE (`hls`), but they don't talk to each other in a monorepo. HWM bridges this gap by acting as a **single source of truth**, automatically generating and synchronizing the configuration files those tools expect.++## The Problem++In a typical Haskell monorepo:++* **Dependency Drift:** Different packages use different versions of the same dependency+* **Matrix Complexity:** Testing multiple GHC versions requires maintaining separate config files+* **Broken IDEs:** Adding modules breaks HLS until you manually update `hie.yaml`+* **Release Friction:** Releasing requires manually bumping versions across dozens of files++## The Solution++You define the "what" in `hwm.yaml`. HWM handles the "how."++```yaml+name: my-project+version: 0.1.0++workspace:+  - name: libs+    prefix: my-app+    members: [core, api, client]++registry:+  - aeson >= 2.0 && < 3.0+  - text  >= 2.0 && < 3.0++matrix:+  default-environment: stable+  environments:+    - { name: stable, ghc: 9.6.3, resolver: lts-22.6 }+    - { name: nightly, ghc: 9.10.1, resolver: nightly-2024-05-22 }+```++One command regenerates everything:++```bash+hwm sync+```++HWM generates and keeps in sync:+* `stack.yaml` / `cabal.project`+* `package.yaml` files → `.cabal` files+* `hie.yaml` for HLS+* Build matrix configurations++## Quick Start++```bash+# Install+stack install hwm+# or+cabal install hwm++# In an existing Stack project+hwm init+hwm sync+hwm run build+```++## Key Commands++* `hwm status` - Check if generated files are in sync+* `hwm sync` - Regenerate all configuration files+* `hwm run <script>` - Run scripts across build matrix+* `hwm outdated` - Check for dependency updates+* `hwm version <bump>` - Atomically bump versions+* `hwm publish <group>` - Publish to Hackage++## Full Documentation++📚 **[Complete Documentation & Examples →](https://github.com/nalchevanidze/hwm)**++Visit the GitHub repository for:+* Detailed configuration reference+* Architecture documentation+* Contributing guidelines+* Examples and use cases++## Origin++HWM was born out of necessity to manage the [Morpheus GraphQL](https://github.com/morpheusgraphql/morpheus-graphql) ecosystem with 15+ packages across multiple GHC versions.
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import qualified HWM.CLI.App as App++main :: IO ()+main = App.main
+ hwm.cabal view
@@ -0,0 +1,135 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           hwm+version:        0.0.1+synopsis:       Haskell Workspace Manager - Orchestrates Stack, Cabal, and HLS+description:    HWM (Haskell Workspace Manager) manages multi-package Haskell projects by+                generating and synchronizing configuration files for Stack, Cabal, Hpack, and HLS+                from a single source of truth (hwm.yaml). It handles dependency management,+                build matrices across GHC versions, and coordinated package releases.+category:       Development+homepage:       https://github.com/nalchevanidze/hwm#readme+bug-reports:    https://github.com/nalchevanidze/hwm/issues+author:         Daviti Nalchevanidze+maintainer:     d.nalchevanidze@gmail.com+copyright:      (c) 2026 Daviti Nalchevanidze+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/nalchevanidze/hwm++library+  exposed-modules:+      HWM.CLI.App+      HWM.CLI.Command+      HWM.CLI.Command.Init+      HWM.CLI.Command.Outdated+      HWM.CLI.Command.Publish+      HWM.CLI.Command.Run+      HWM.CLI.Command.Status+      HWM.CLI.Command.Sync+      HWM.CLI.Command.Version+      HWM.Core.Common+      HWM.Core.Formatting+      HWM.Core.Has+      HWM.Core.Options+      HWM.Core.Parsing+      HWM.Core.Pkg+      HWM.Core.Result+      HWM.Core.Version+      HWM.Domain.Bounds+      HWM.Domain.Config+      HWM.Domain.ConfigT+      HWM.Domain.Dependencies+      HWM.Domain.Matrix+      HWM.Domain.Workspace+      HWM.Integrations.Toolchain.Cabal+      HWM.Integrations.Toolchain.Hie+      HWM.Integrations.Toolchain.Lib+      HWM.Integrations.Toolchain.Package+      HWM.Integrations.Toolchain.Stack+      HWM.Runtime.Cache+      HWM.Runtime.Files+      HWM.Runtime.Logging+      HWM.Runtime.Process+      HWM.Runtime.UI+  other-modules:+      Paths_hwm+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      Cabal >=3.8 && <=3.16.1.0+    , Glob >=0.7.0 && <1.0.0+    , aeson >=1.4.4 && <3.0.0+    , ansi-terminal >=0.11.3 && <=1.1.5+    , async >=2.2.4 && <2.3.0+    , base >=4.7.0 && <5.0.0+    , base16-bytestring >=1.0.0 && <2.0.0+    , bytestring >=0.10.4 && <=0.12.2.0+    , containers >=0.4.2.1 && <=0.8+    , cryptohash-sha256 >=0.11.100 && <=0.11.102.1+    , directory >=1.0 && <=1.3.10.1+    , filepath >=1.1.0 && <=1.5.5.0+    , hpack >=0.36.0 && <=0.39.1+    , modern-uri >=0.1.0.0 && <1.0.0+    , mtl >=2.0.0 && <2.6.0+    , optparse-applicative >=0.12.0 && <0.20.0+    , process >=1.0.0 && <2.0.0+    , relude >=0.3.0 && <2.0.0+    , req >=3.0.0 && <=3.13.4+    , stm >=2.4 && <2.6.0+    , text >=1.2.3 && <3.0.0+    , time >=1.9.2 && <2.0.0+    , transformers >=0.5.6 && <0.7.0+    , typed-process >=0.1.0 && <0.4.0+    , unordered-containers >=0.2.8 && <0.3.0+    , yaml >=0.8.32 && <1.0.0+  default-language: Haskell2010++executable hwm+  main-is: Main.hs+  other-modules:+      Paths_hwm+  hs-source-dirs:+      app+  ghc-options: -Wall+  build-depends:+      Cabal >=3.8 && <=3.16.1.0+    , Glob >=0.7.0 && <1.0.0+    , aeson >=1.4.4 && <3.0.0+    , ansi-terminal >=0.11.3 && <=1.1.5+    , async >=2.2.4 && <2.3.0+    , base >=4.7.0 && <5.0.0+    , base16-bytestring >=1.0.0 && <2.0.0+    , bytestring >=0.10.4 && <=0.12.2.0+    , containers >=0.4.2.1 && <=0.8+    , cryptohash-sha256 >=0.11.100 && <=0.11.102.1+    , directory >=1.0 && <=1.3.10.1+    , filepath >=1.1.0 && <=1.5.5.0+    , hpack >=0.36.0 && <=0.39.1+    , hwm >=0.0.0 && <0.1.0+    , modern-uri >=0.1.0.0 && <1.0.0+    , mtl >=2.0.0 && <2.6.0+    , optparse-applicative >=0.12.0 && <0.20.0+    , process >=1.0.0 && <2.0.0+    , relude >=0.3.0 && <2.0.0+    , req >=3.0.0 && <=3.13.4+    , stm >=2.4 && <2.6.0+    , text >=1.2.3 && <3.0.0+    , time >=1.9.2 && <2.0.0+    , transformers >=0.5.6 && <0.7.0+    , typed-process >=0.1.0 && <0.4.0+    , unordered-containers >=0.2.8 && <0.3.0+    , yaml >=0.8.32 && <1.0.0+  default-language: Haskell2010
+ src/HWM/CLI/App.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.App+  ( main,+  )+where++import Data.Text (pack)+import HWM.CLI.Command+  ( Command (..),+    Options (..),+    currentVersion,+    defaultOptions,+    runCommand,+  )+import HWM.CLI.Command.Init (InitOptions (..))+import HWM.CLI.Command.Run (ScriptOptions (..))+import HWM.Core.Common (Name)+import HWM.Core.Parsing (Parse (..), parseOptions)+import Options.Applicative+  ( Parser,+    argument,+    command,+    customExecParser,+    fullDesc,+    help,+    helper,+    info,+    long,+    metavar,+    prefs,+    progDesc,+    short,+    showHelpOnError,+    strArgument,+    subparser,+    switch,+  )+import Options.Applicative.Builder (str, strOption)+import Relude hiding (ByteString, fix)++-- Helper for building commands (unchanged, just added type signature clarity)+commands :: [(String, String, Parser a)] -> Parser a+commands =+  subparser+    . mconcat+    . map+      ( \(name, desc, value) ->+          command name (info (helper <*> value) (fullDesc <> progDesc desc))+      )++flag :: Char -> String -> String -> Parser Bool+flag s l h = switch (long l <> short s <> help h)++run :: Parser a -> IO a+run app =+  customExecParser+    (prefs showHelpOnError)+    ( info+        (helper <*> app)+        (fullDesc <> progDesc "HWM - Haskell Workspace Manager for Monorepos")+    )++parseScriptOptions :: Parser Name -> Parser ScriptOptions+parseScriptOptions name =+  ScriptOptions+    <$> name+    <*> fmap parseOptions (many (strOption (long "target" <> short 't' <> metavar "TARGET" <> help "Limit to package (core) or group (libs)")))+    <*> fmap parseOptions (many (strOption (long "env" <> short 'e' <> metavar "ENV" <> help "Run in specific env (use 'all' for full matrix)")))+    <*> many (argument (pack <$> str) (metavar "ARGS..." <> help "Arguments to forward to the script"))++parseInitOptions :: Parser InitOptions+parseInitOptions =+  InitOptions+    <$> flag 'f' "force" "Force override existing hwm.yaml"+    <*> optional (argument str (metavar "NAME" <> help "Optional project name (defaults to current directory name)"))++parseCommand :: Parser Command+parseCommand =+  commands+    [ ( "sync",+        "Regenerate stack.yaml and .cabal files. Optional: switch environment.",+        Sync <$> optional (argument str (metavar "ENV" <> help "Switch to a specific environment (e.g., legacy, stable)"))+      ),+      ( "version",+        "Show version or bump it (patch | minor | major).",+        Version <$> optional (argument (str >>= parse) (metavar "BUMP" <> help "Version bump type or specific version number"))+      ),+      ( "outdated",+        "Check for newer dependencies on Hackage.",+        Outdated <$> switch (long "fix" <> short 'f' <> help "Write changes to hwm.yaml")+      ),+      ( "publish",+        "Upload packages to Hackage/Registry.",+        Publish <$> optional (argument str (metavar "GROUP" <> help "Name of the workspace group to publish (default: all)"))+      ),+      ( "run",+        "Run a script defined in hwm.yaml",+        Run <$> parseScriptOptions (argument (pack <$> str) (metavar "SCRIPT" <> help "Name of the script to run"))+      ),+      ( "status",+        "Show the current environment, version, and sync status.",+        pure Status+      ),+      ( "init",+        "Initialize a new HWM workspace by scanning the current directory.",+        Init <$> parseInitOptions+      )+    ]+    <|> (Run <$> parseScriptOptions (strArgument (metavar "SCRIPT")))++data Input = Input+  { v :: Bool,+    q :: Bool,+    cmd :: Maybe Command+  }+  deriving (Show)++parseInput :: IO Input+parseInput =+  run+    $ Input+    <$> flag 'v' "version" "Show HWM version number"+    <*> flag 'q' "quiet" "Run quietly with minimal output"+    <*> optional parseCommand++main :: IO ()+main = do+  Input {v, q, cmd} <- parseInput+  if v+    then putStrLn ("HWM v" ++ currentVersion)+    else case cmd of+      Just c -> runCommand c (defaultOptions {quiet = q})+      Nothing -> do+        putStrLn "HWM: Missing command.\nTry 'hwm --help' for usage."+        exitFailure
+ src/HWM/CLI/Command.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command+  ( Options (..),+    Command (..),+    currentVersion,+    defaultOptions,+    Bump (..),+    runCommand,+  )+where++import Data.Version (showVersion)+import HWM.CLI.Command.Init (InitOptions (..), initWorkspace)+import HWM.CLI.Command.Outdated (runOutdated)+import HWM.CLI.Command.Publish (publish)+import HWM.CLI.Command.Run (ScriptOptions, runScript)+import HWM.CLI.Command.Status (showStatus)+import HWM.CLI.Command.Sync (sync)+import HWM.CLI.Command.Version (runVersion)+import HWM.Core.Common (Name)+import HWM.Core.Options (Options (..), defaultOptions)+import HWM.Core.Version (Bump (..))+import HWM.Domain.ConfigT (ConfigT, runConfigT)+import qualified Paths_hwm as CLI+import Relude hiding (fix)++data Command+  = Sync {tag :: Maybe Name}+  | Publish {groupName :: Maybe Name}+  | Version {bump :: Maybe Bump}+  | Outdated {fix :: Bool}+  | Run {runOptions :: ScriptOptions}+  | Status+  | Init {initOptions :: InitOptions}+  deriving (Show)++currentVersion :: String+currentVersion = showVersion CLI.version++command :: Command -> ConfigT ()+command Publish {groupName} = publish groupName+command Version {bump} = runVersion bump+command Outdated {fix} = runOutdated fix+command Sync {tag} = sync tag+command Run {runOptions} = runScript runOptions+command Status = showStatus+command Init {} = pure ()++runCommand :: Command -> Options -> IO ()+runCommand Init {initOptions} ops = initWorkspace initOptions ops >> runConfigT showStatus ops+runCommand cmd ops = runConfigT (command cmd) ops
+ src/HWM/CLI/Command/Init.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Init (initWorkspace, InitOptions (..)) where++import Control.Monad.Except (MonadError (..))+import Data.List+import HWM.Core.Common (Name)+import HWM.Core.Formatting (Color (Cyan), Format (format), chalk, padDots)+import HWM.Core.Options (Options (..))+import HWM.Core.Pkg (Pkg (..), scanPkgs)+import HWM.Core.Result (Issue)+import HWM.Core.Version (Version)+import HWM.Domain.Bounds (versionBounds)+import HWM.Domain.Config (Config (..), defaultScripts)+import HWM.Domain.ConfigT (resolveResultUI, saveConfig)+import HWM.Domain.Workspace (buildWorkspaceGroups)+import HWM.Integrations.Toolchain.Package (deriveRegistry)+import HWM.Integrations.Toolchain.Stack (buildMatrix, scanStackFiles)+import HWM.Runtime.Files (forbidOverride)+import HWM.Runtime.UI (MonadUI, putLine, runUI, section)+import Relude hiding (exitWith, notElem)+import System.Directory (getCurrentDirectory)+import System.FilePath+  ( normalise,+    takeFileName,+    (</>),+  )++size :: Int+size = 24++data InitOptions = InitOptions+  { forceOverride :: Bool,+    projectName :: Maybe Text+  }+  deriving (Show)++initWorkspace :: InitOptions -> Options -> IO ()+initWorkspace InitOptions {..} opts = runUI $ resolveResultUI $ do+  root <- liftIO getCurrentDirectory+  let name = fromMaybe (deriveName root) projectName+  section "init" $ do+    unless forceOverride $ forbidOverride (normalise (root </> hwm opts))+    stacks <- scanStackFiles opts root+    scanning "stack.yaml" stacks+    pkgs <- scanPkgs root+    scanning "packages" pkgs+    when (null pkgs) $ throwError "No packages listed in stack.yaml. Add at least one package before running 'hwm init'"+    (registry, graph) <- deriveRegistry pkgs+    version <- deriveVersion (map pkgVersion pkgs)+    matrix <- buildMatrix pkgs stacks+    workspace <- buildWorkspaceGroups graph pkgs+    saveConfig+      Config+        { bounds = versionBounds version,+          scripts = defaultScripts,+          ..+        }+      opts+    putLine $ padDots size "save (config)" <> chalk Cyan "hwm.yaml"++scanning :: (MonadUI m, Foldable t) => Text -> t a -> m ()+scanning name ls = putLine (padDots size ("scan (" <> name <> ")") <> format (length ls) <> " found")++deriveName :: FilePath -> Name+deriveName path =+  let candidate = takeFileName path+   in if null candidate then "workspace" else toText candidate++deriveVersion :: (MonadError Issue m) => [Version] -> m Version+deriveVersion+  versions+    | null versions = throwError "No package versions found for inference"+    | otherwise = pure $ maximum versions
+ src/HWM/CLI/Command/Outdated.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Outdated (runOutdated) where++import HWM.Core.Formatting (Color (..), Format (..), chalk, genMaxLen, padDots)+import HWM.Core.Result (Issue (..), MonadIssue (..), Severity (SeverityWarning))+import HWM.Domain.Bounds (printUpperBound, updateDepBounds)+import HWM.Domain.Config (Config (registry))+import HWM.Domain.ConfigT (ConfigT, config, updateConfig)+import HWM.Domain.Dependencies (Dependency (..), toDependencyList, traverseDeps)+import HWM.Integrations.Toolchain.Package (syncPackages)+import HWM.Runtime.Cache (clearVersions)+import HWM.Runtime.UI (indent, putLine, section, sectionConfig, sectionTableM)+import Relude++runOutdated :: Bool -> ConfigT ()+runOutdated autoFix = do+  sectionTableM 0 "update dependencies" [("mode", pure $ chalk Cyan (if autoFix then "auto-fix" else "check"))]++  clearVersions+  originalRegistry <- asks (registry . config)+  section "registry" $ pure ()+  registry' <- traverseDeps updateDepBounds originalRegistry++  let updates = map snd $ filter (uncurry (/=)) (zip (toDependencyList originalRegistry) (toDependencyList registry'))+  let maxLen = genMaxLen (map (format . name) updates)++  if null updates+    then do+      indent 1 $ putLine "all dependencies are up to date."+    else do+      indent 1 $ for_ updates $ \Dependency {..} -> putLine $ padDots maxLen (format name) <> "↑ " <> printUpperBound bounds++      if autoFix+        then ((\cf -> pure $ cf {registry = registry'}) `updateConfig`) $ do+          sectionConfig 0 [("hwm.yaml", pure $ chalk Green "✓")]+          syncPackages+        else+          injectIssue+            ( Issue+                { issueDetails = Nothing,+                  issueMessage = "Found " <> show (length updates) <> " outdated dependencies: Run 'hwm outdated --fix' to update.",+                  issueTopic = "registry",+                  issueSeverity = SeverityWarning+                }+            )
+ src/HWM/CLI/Command/Publish.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Publish (publish) where++import Control.Monad.Error.Class (MonadError (..))+import qualified Data.Text as T+import HWM.Core.Common (Name)+import HWM.Core.Formatting+  ( Color (..),+    Format (..),+    chalk,+    genMaxLen,+    padDots,+    statusIcon,+  )+import HWM.Core.Pkg (Pkg (..))+import HWM.Core.Result (Issue)+import HWM.Domain.ConfigT (ConfigT, askVersion, askWorkspaceGroups)+import HWM.Domain.Workspace (WorkspaceGroup, canPublish, memberPkgs, pkgGroupName, selectGroup)+import HWM.Integrations.Toolchain.Stack (sdist, upload)+import HWM.Runtime.UI (printSummary, putLine, section, sectionTableM, sectionWorkspace)+import Relude hiding (intercalate)++failIssues :: [Issue] -> ConfigT ()+failIssues [] = pure ()+failIssues issues = do+  printSummary issues+  liftIO exitFailure++collectGroups :: Maybe Name -> [WorkspaceGroup] -> ConfigT [WorkspaceGroup]+collectGroups Nothing ws = pure $ filter canPublish ws+collectGroups (Just target) ws = do+  groups <- traverse (`selectGroup` ws) [target]+  let notPublishable = filter (not . canPublish) groups+  for_ notPublishable $ \g ->+    throwError $ fromString $ toString $ "Target group \"" <> pkgGroupName g <> "\" cannot be published. Check workspace group configuration."+  pure groups++publish :: Maybe Name -> ConfigT ()+publish target = do+  ws <- askWorkspaceGroups+  groups <- collectGroups target ws+  version <- askVersion+  when (null groups) $ throwError "No publishable groups found. Check workspace group configuration."++  sectionTableM+    0+    "publish"+    [ ("version", pure $ chalk Magenta (format version)),+      ("target", pure $ chalk Cyan (format (T.intercalate ", " (map pkgGroupName groups)))),+      ("registry", pure "hackage")+    ]++  issues <- traverse memberPkgs groups >>= traverse sdist . concat+  failIssues (concat issues)++  sectionWorkspace $ for_ groups $ \g ->+    section (chalk Bold (pkgGroupName g)) $ do+      pkgs <- memberPkgs g+      for_ pkgs $ \pkg -> do+        (status, publishIssues) <- upload pkg+        putLine $ "└── " <> padDots (genMaxLen (map pkgMemberId pkgs)) (pkgMemberId pkg) <> statusIcon status+        failIssues publishIssues
+ src/HWM/CLI/Command/Run.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Run+  ( runScript,+    ScriptOptions (..),+  )+where++import Control.Concurrent.Async+import Control.Monad.Error.Class (MonadError (..))+import Data.List (intersect)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Traversable (for)+import HWM.Core.Common (Name)+import HWM.Core.Formatting (Color (..), Format (..), Status (Checked, Invalid), chalk, genMaxLen, padDots, statusIcon)+import HWM.Core.Pkg (Pkg (..))+import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..))+import HWM.Domain.Config (Config (..))+import HWM.Domain.ConfigT (ConfigT, askWorkspaceGroups, config)+import HWM.Domain.Matrix (BuildEnvironment (..), getBuildEnvironment, getBuildEnvroments)+import HWM.Domain.Workspace (resolveTargets)+import HWM.Integrations.Toolchain.Stack (createEnvYaml, stackPath)+import HWM.Runtime.Cache (prepareDir)+import HWM.Runtime.Logging (logError, logRoot)+import HWM.Runtime.Process (inheritRun, silentRun)+import HWM.Runtime.UI (putLine, runSpinner, sectionEnvironments, sectionWorkspace, statusIndicator)+import Relude++data ScriptOptions = ScriptOptions+  { scriptName :: Name,+    scriptTargets :: [Name],+    scriptEnvs :: [Name],+    scriptOptions :: [Text]+  }+  deriving (Show)++getEnvs :: [Name] -> ConfigT [BuildEnvironment]+getEnvs ["all"] = getBuildEnvroments+getEnvs names = for names (getBuildEnvironment . Just)++runScript :: ScriptOptions -> ConfigT ()+runScript ScriptOptions {..} = do+  prepareDir logRoot+  cfg <- asks config+  case M.lookup scriptName (scripts cfg) of+    Just script -> do+      envs <- getEnvs scriptEnvs+      ws <- askWorkspaceGroups+      targets <- fmap (S.toList . S.fromList) (resolveTargets ws scriptTargets)+      for_ envs (createEnvYaml . buildName)+      let multi = length envs > 1+      let cmdTemplate = if null scriptOptions then script else T.unwords (script : scriptOptions)+      let padding = genMaxLen (map format envs)+      let run = runCommand padding multi cmdTemplate targets++      if multi+        then do+          when multi $ do+            sectionWorkspace $ do+              putLine $ padDots 16 "targets" <> if null scriptTargets then chalk Yellow "None (Global Scope)" else chalk Cyan (T.unwords scriptTargets)+            sectionEnvironments (for_ (map buildName envs) (run . Just))+        else run Nothing+    Nothing -> throwError $ fromString $ toString $ "Script not found: " <> scriptName++runCommand :: Int -> Bool -> Text -> [Pkg] -> Maybe Name -> ConfigT ()+runCommand padding multi scripts targets envName = do+  benv@BuildEnvironment {..} <- getBuildEnvironment envName+  let supported = targets `intersect` buildPkgs+  cmd <- resolveCommand scripts supported+  yamlPath <- stackPath envName+  if multi+    then do+      let env = format benv+      (success, content) <- silentRun yamlPath cmd (async (runSpinner padding env))+      statusIndicator padding env (statusIcon (if success then Checked else Invalid))+      unless success $ do+        path <- logError buildName [("ENVIRONMENT", format benv), ("COMMAND", format cmd)] content+        throwError+          Issue+            { issueTopic = buildName,+              issueMessage = "Command failed",+              issueSeverity = SeverityError,+              issueDetails = Just CommandIssue {issueCommand = format cmd, issueLogFile = path}+            }+      putLine ""+    else do+      sectionWorkspace $ do+        putLine $ padDots 16 "targets" <> if null supported then chalk Yellow "None (Global Scope)" else chalk Cyan (T.unwords $ format . pkgName <$> supported)+      sectionEnvironments $ putLine $ format benv+      putLine ""+      putLine ("❯ " <> cmd)+      inheritRun yamlPath cmd+      putLine ""++resolveCommand :: Text -> [Pkg] -> ConfigT Text+resolveCommand cmd targets = do+  let hasPlaceholder = "{TARGET}" `T.isInfixOf` cmd+      hasTargets = not (null targets)+      targetsStr = T.unwords (map (format . pkgName) targets)+  let result = case (hasPlaceholder, hasTargets) of+        (True, True) -> Right $ T.replace "{TARGET}" targetsStr cmd+        (True, False) -> Left "Missing Target! This command requires specific targets (e.g. --target app1)."+        (False, True) -> Left "Target Not Allowed! This command is Global-only and does not support specific targets."+        (False, False) -> Right cmd+  case result of+    Left err -> throwError $ fromString err+    Right c -> pure c
+ src/HWM/CLI/Command/Status.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Status (showStatus) where++import HWM.Core.Formatting (Color (..), Format (..), chalk, genMaxLen, monadStatus, padDots, statusIcon, subPathSign)+import HWM.Core.Pkg (Pkg (..))+import qualified HWM.Domain.Config as C+import HWM.Domain.ConfigT (ConfigT, config)+import HWM.Domain.Matrix (getBuildEnvironment, getBuildEnvroments, printEnvironments)+import HWM.Domain.Workspace (memberPkgs, pkgGroupName)+import HWM.Integrations.Toolchain.Package (validatePackage)+import HWM.Runtime.UI (putLine, sectionTableM, sectionWorkspace)+import Relude++-- | Main status command - displays project info and package statuses+showStatus :: ConfigT ()+showStatus = do+  cfg <- asks config+  active <- getBuildEnvironment Nothing+  environments <- getBuildEnvroments+  sectionTableM+    0+    "project"+    [ ("name", pure $ chalk Magenta (C.name cfg)),+      ("version", pure $ chalk Green (format $ C.version cfg))+    ]+  printEnvironments active environments+  sectionWorkspace+    $ for_ (C.workspace cfg)+    $ \g -> do+      putLine ""+      putLine $ "• " <> chalk Bold (pkgGroupName g)+      pkgs <- memberPkgs g+      let maxLen = genMaxLen (map pkgMemberId pkgs)+      for_ pkgs $ \pkg -> do+        status <- monadStatus (validatePackage pkg)+        putLine $ subPathSign <> padDots maxLen (pkgMemberId pkg) <> statusIcon status
+ src/HWM/CLI/Command/Sync.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Sync (sync) where++import HWM.Core.Common (Name)+import HWM.Core.Formatting (Color (..), Format (..), chalk)+import HWM.Domain.ConfigT (ConfigT)+import HWM.Domain.Matrix (BuildEnvironment (..), getBuildEnvironment)+import HWM.Integrations.Toolchain.Hie (syncHie)+import HWM.Integrations.Toolchain.Package (syncPackages)+import HWM.Integrations.Toolchain.Stack (syncStackYaml)+import HWM.Runtime.Cache (Registry (..), updateRegistry)+import HWM.Runtime.UI (sectionConfig, sectionTableM)+import Relude++sync :: Maybe Name -> ConfigT ()+sync tag = do+  env <- getBuildEnvironment tag+  updateRegistry $ \reg -> reg {currentEnv = buildName env}+  sectionTableM+    0+    "sync"+    [ ("enviroment", pure $ chalk Cyan $ format env),+      ("resolver", pure $ buildResolver env)+    ]+  sectionConfig+    0+    [ ("stack.yaml", syncStackYaml $> chalk Green "✓"),+      ("hie.yaml", syncHie $> chalk Green "✓")+    ]+  syncPackages
+ src/HWM/CLI/Command/Version.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.CLI.Command.Version+  ( runVersion,+  )+where++import HWM.Core.Formatting (Color (..), Format (..), chalk)+import HWM.Core.Version (Bump, nextVersion)+import HWM.Domain.Bounds (versionBounds)+import HWM.Domain.Config (Config (..))+import HWM.Domain.ConfigT (ConfigT, config, updateConfig)+import HWM.Integrations.Toolchain.Package (syncPackages)+import HWM.Runtime.UI (putLine, sectionConfig, sectionTableM)+import Relude++size :: Int+size = 16++bumpVersion :: Bump -> Config -> ConfigT Config+bumpVersion bump Config {..} = do+  let version' = nextVersion bump version+  sectionTableM+    size+    ("bump version (" <> format bump <> ")")+    [ ("from", pure $ format version),+      ("to", pure $ chalk Cyan (format version'))+    ]++  let bounds' = versionBounds version'+  pure Config {version = version', bounds = bounds', ..}++runVersion :: Maybe Bump -> ConfigT ()+runVersion (Just bump) = (bumpVersion bump `updateConfig`) $ do+  sectionConfig size [("hwm.yaml", pure $ chalk Green "✓")]+  syncPackages+runVersion Nothing = do+  putLine . format . version =<< asks config+  exitSuccess
+ src/HWM/Core/Common.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Common+  ( Name,+    Check (..),+  )+where++import Data.Text (Text)++-- | Shared alias for human-readable identifiers (e.g. cache names).+type Name = Text++-- | Capability gate for validations that report issues inside a monad.+class Check m a where+  check :: a -> m ()
+ src/HWM/Core/Formatting.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Formatting+  ( Color (..),+    chalk,+    formatStatus,+    Status (..),+    padDots,+    genMaxLen,+    separator,+    deriveStatus,+    statusFromSeverity,+    statusIcon,+    isOk,+    displayStatus,+    Format (..),+    availableOptions,+    renderSummaryStatus,+    subPathSign,+    slugify,+    commonPrefix,+    indentBlockNum,+    indentBlock,+    formatTable,+    formatList,+    monadStatus,+  )+where++import Data.Aeson (Value, encode)+import Data.ByteString.Lazy.Char8 (unpack)+import Data.Foldable (maximum)+import qualified Data.List as List+import Data.Text (pack)+import qualified Data.Text as T+import HWM.Core.Result (MonadIssue (catchIssues), Severity (..))+import Relude++data Color+  = Red+  | Green+  | Yellow+  | Gray+  | Magenta+  | Cyan+  | Dim+  | Bold+  | White+  | None+  | RedBackground+  | GreenBackground+  | YellowBackground+  | BrightRed+  | BrightGreen+  | BrightYellow++toColor :: Color -> Text+toColor c = "\x1b[" <> T.pack (show (colorCode c)) <> "m"++colorCode :: Color -> Int+colorCode Red = 31+colorCode Green = 32+colorCode Yellow = 33+colorCode Cyan = 36+colorCode Magenta = 95+colorCode Gray = 90+colorCode Dim = 2+colorCode None = 0+colorCode Bold = 1+colorCode RedBackground = 41+colorCode GreenBackground = 42+colorCode YellowBackground = 43+colorCode BrightRed = 91+colorCode BrightGreen = 92+colorCode BrightYellow = 93+colorCode White = 37++chalk :: Color -> Text -> Text+chalk c x = toColor c <> x <> toColor None++data Status = Checked | Updated | Warning | Invalid+  deriving (Show, Eq, Ord)++deriveStatus :: [Status] -> Status+deriveStatus [] = Checked+deriveStatus statuses = maximum statuses++-- | Convert issue severity to status+statusFromSeverity :: Maybe Severity -> Status+statusFromSeverity (Just SeverityError) = Invalid+statusFromSeverity (Just SeverityWarning) = Warning+statusFromSeverity Nothing = Checked++monadStatus :: (Functor m, MonadIssue m) => m b -> m Status+monadStatus x = statusFromSeverity . fst <$> catchIssues x++displayStatus :: [(Text, Status)] -> Text+displayStatus ls =+  let status = deriveStatus (map snd ls)+   in if isOk status then statusIcon status else formatStatus ls++padDots :: Int -> Text -> Text+padDots width s = s <> " " <> chalk Dim (T.replicate (max 0 (width - T.length s)) ".") <> " "++isOk :: Status -> Bool+isOk Checked = True+isOk Updated = True+isOk _ = False++labelColor :: Status -> Color+labelColor Checked = Dim+labelColor Updated = Dim+labelColor Warning = Yellow+labelColor Invalid = Red++statusIcon :: Status -> Text+statusIcon s = case s of+  Checked -> chalk Green "✓"+  Updated -> chalk Cyan "⟳"+  Invalid -> chalk Red "✖"+  Warning -> chalk Yellow "!"++formatStatus :: [(Text, Status)] -> Text+formatStatus = T.intercalate (chalk Dim " ") . map formatItem . sortBy (comparing (Down . snd)) . filter ((/= Checked) . snd)+  where+    formatItem (label, s) = statusIcon s <> " " <> chalk (labelColor s) label++genMaxLen :: [Text] -> Int+genMaxLen names = if null names then 16 else maximum (map T.length names) + 4++separator :: Int -> Text+separator size = chalk Gray $ T.replicate size "─"++class Format a where+  format :: a -> Text++instance Format Int where+  format = show++instance Format String where+  format = pack++instance Format Text where+  format = id++instance Format Value where+  format = format . unpack . encode++availableOptions :: (Format a) => [a] -> Text+availableOptions xs = "Available options: " <> T.intercalate ", " (map format xs)++boxed :: Color -> Text -> Text+boxed color text = chalk Bold "• " <> block <> " " <> chalk color text <> " " <> block+  where+    block = chalk color "▌"++renderSummaryStatus :: Status -> Text+renderSummaryStatus Warning = boxed BrightYellow "warning"+renderSummaryStatus Invalid = boxed Red "errors"+renderSummaryStatus _ = boxed BrightGreen "success"++subPathSign :: Text+subPathSign = chalk Dim "└─- "++slugify :: Text -> Text+slugify = T.map replaceChar . T.toLower+  where+    replaceChar c+      | c == ' ' = '-'+      | c == '_' = '-'+      | c == '.' = '-'+      | otherwise = c++commonPrefix :: [Text] -> (Maybe Text, [Text])+commonPrefix [] = (Nothing, [])+commonPrefix [name] = (Nothing, [name])+commonPrefix names =+  refine names (T.dropWhileEnd (== '-') (List.foldl1' pairwisePrefix names))+  where+    pairwisePrefix a b = maybe "" (\(prefix, _, _) -> prefix) (T.commonPrefixes a b)+    refine _ candidate | T.null candidate = (Nothing, names)+    refine sources candidate+      | all (matches candidate) sources = (Just candidate, map (dropPrefix candidate) sources)+      | otherwise = refine sources (shrink candidate)+    matches prefix name+      | prefix == name = True+      | prefix `T.isPrefixOf` name = startsWithHyphen (T.drop (T.length prefix) name)+      | otherwise = False+    startsWithHyphen remainder =+      case T.uncons remainder of+        Nothing -> True+        Just ('-', _) -> True+        _ -> False+    shrink prefix =+      case T.breakOnEnd "-" prefix of+        (rest, _) | T.null rest -> ""+        (rest, _) -> T.dropWhileEnd (== '-') rest++    dropPrefix prefix text =+      let name = fromMaybe "" (T.stripPrefix prefix text)+       in if T.null name+            then "."+            else fromMaybe name (T.stripPrefix "-" name)++indentBlockNum :: Int -> Text -> Text+indentBlockNum i = indentBlock (T.replicate i " ")++indentBlock :: Text -> Text -> Text+indentBlock prefix text+  | T.null text = text+  | otherwise =+      let linesList = T.lines text+          indented = map (prefix <>) linesList+          joined = T.intercalate "\n" indented+       in if T.isSuffixOf "\n" text+            then joined <> "\n"+            else joined++type Table = [Row]++type Row = [Text]++getSizes :: Table -> [Int]+getSizes xs = map size (transpose xs)+  where+    size :: Row -> Int+    size = maximum . map T.length++printRow :: [Int] -> Row -> Text+printRow sizes ls =+  T.strip+    $ T.intercalate "  "+    $ zipWith (\item s -> T.justifyLeft s ' ' item) ls sizes++formatTable :: [Text] -> [Text]+formatTable deps = sort $ map (printRow (getSizes table)) table+  where+    table = map words deps++formatList :: (Format a) => Text -> [a] -> Text+formatList x = T.intercalate x . map format
+ src/HWM/Core/Has.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Has+  ( Has (..),+    askEnv,+    HasAll,+  )+where++import Relude++class Has env a where+  obtain :: env -> a++askEnv :: (MonadReader env m, Has env a) => m a+askEnv = asks obtain++type family HasAll env (xs :: [Type]) :: Constraint where+  HasAll _ '[] = ()+  HasAll env (x ': xs) = (Has env x, HasAll env xs)
+ src/HWM/Core/Options.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Options+  ( Options (..),+    defaultOptions,+    askOptions,+  )+where++import HWM.Core.Has (Has (..))+import Relude++askOptions :: (MonadReader env m, Has env Options) => m Options+askOptions = asks obtain++data Options = Options+  { hie :: FilePath,+    hwm :: FilePath,+    stack :: FilePath,+    quiet :: Bool+  }++defaultOptions :: Options+defaultOptions =+  Options+    { hwm = "./hwm.yaml",+      hie = "./hie.yaml",+      stack = "./stack.yaml",+      quiet = False+    }
+ src/HWM/Core/Parsing.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Parsing+  ( parseField,+    fromByteString,+    firstWord,+    removeHead,+    unconsM,+    sepBy,+    fromToString,+    SourceText,+    genUrl,+    Parse (..),+    parseOptions,+  )+where++import Data.ByteString.Char8 (unpack)+import Data.Char (isSeparator)+import Data.Text+  ( break,+    drop,+    intercalate,+    pack,+    singleton,+    splitOn,+    strip,+    uncons,+  )+import qualified Data.Text as T+import Relude hiding+  ( break,+    drop,+    head,+    intercalate,+    isPrefixOf,+    null,+    uncons,+    words,+  )++type SourceText = Text++parseOptions :: [Text] -> [Text]+parseOptions raw = raw >>= (map T.strip . T.splitOn ",")++parseField :: SourceText -> (SourceText, SourceText)+parseField = second (strip . drop 1) . breakAt (== ':')++firstWord :: SourceText -> (SourceText, SourceText)+firstWord = breakAt isSeparator++fromByteString :: ByteString -> SourceText+fromByteString = pack . unpack++ignoreSpaces :: SourceText -> SourceText+ignoreSpaces = T.filter (not . isSeparator)++breakAt :: (Char -> Bool) -> SourceText -> (SourceText, SourceText)+breakAt f = bimap strip strip . break f . strip++sepBy :: (MonadFail m, Parse a) => SourceText -> SourceText -> m [a]+sepBy sep = traverse parse . splitOn sep . ignoreSpaces++removeHead :: Char -> SourceText -> (Bool, SourceText)+removeHead should txt = maybe (False, txt) has (uncons txt)+  where+    has (x, xs)+      | x == should = (True, xs)+      | otherwise = (False, txt)++unconsM :: (MonadFail m) => String -> SourceText -> m (SourceText, SourceText)+unconsM m x = first singleton <$> maybe (fail $ m <> "<>: " <> toString x) pure (uncons x)++fromToString :: (ToString a) => a -> SourceText+fromToString = pack . toString++genUrl :: Text -> [Text] -> Text+genUrl domain = intercalate "/" . (domain :)++class Parse a where+  parse :: (MonadFail m) => Text -> m a++instance Parse Int where+  parse t =+    maybe (fail $ "Could not parse Int: '" <> toString t <> "'!") pure (readMaybe $ toString t)
+ src/HWM/Core/Pkg.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Pkg+  ( Pkg (..),+    PkgName,+    makePkg,+    pkgFile,+    pkgYamlPath,+    pkgId,+    scanPkgs,+  )+where++import Control.Monad.Except+import Data.Aeson (FromJSON (..), ToJSONKey)+import Data.Aeson.Types (FromJSONKey)+import qualified Data.Map as Map+import Data.Text (intercalate)+import Data.Traversable (for)+import Data.Yaml.Aeson (ToJSON)+import HWM.Core.Common (Name)+import HWM.Core.Formatting+import HWM.Core.Parsing (Parse (..))+import HWM.Core.Result (Issue)+import HWM.Core.Version (Version)+import HWM.Runtime.Files (cleanRelativePath, readYaml)+import Relude hiding (Undefined, intercalate)+import System.FilePath (makeRelative, takeDirectory)+import System.FilePath.Glob (glob)+import System.FilePath.Posix (joinPath, normalise, takeFileName, (</>))++data PkgInfo = PkgInfo {name :: PkgName, version :: Version}+  deriving (Generic, FromJSON, Show)++data Pkg = Pkg+  { pkgName :: PkgName,+    pkgVersion :: Version,+    pkgGroup :: Name,+    pkgMemberId :: Name,+    pkgDirPath :: FilePath+  }+  deriving (Show, Ord, Eq)++packageYamlFileName :: String+packageYamlFileName = "package.yaml"++-- Helper to ensure "package.yaml" is only appended if not already present+ensurePackageYaml :: FilePath -> FilePath+ensurePackageYaml path+  | takeFileName path == packageYamlFileName = path+  | otherwise = normalise $ path </> packageYamlFileName++pkgYamlPath :: Pkg -> FilePath+pkgYamlPath pkg = pkgFile pkg packageYamlFileName++getPkgInfo :: (MonadError Issue m, MonadIO m) => FilePath -> m PkgInfo+getPkgInfo = readYaml . normalise . ensurePackageYaml++pkgFile :: Pkg -> FilePath -> FilePath+pkgFile Pkg {..} file = normalise $ joinPath [pkgDirPath, file]++pkgId :: Pkg -> Text+pkgId Pkg {pkgGroup, pkgMemberId} = pkgGroup <> "/" <> pkgMemberId++toPkg :: PkgInfo -> Name -> Name -> FilePath -> Pkg+toPkg PkgInfo {name, version} groupName memberName dir =+  Pkg+    { pkgName = name,+      pkgVersion = version,+      pkgGroup = groupName,+      pkgMemberId = if memberName == "." then "(root)" else memberName,+      pkgDirPath = dir+    }++makePkg :: (MonadIO m, MonadError Issue m) => Text -> Maybe FilePath -> Maybe Name -> Name -> m Pkg+makePkg groupName root prefix memberName = do+  let pkgDirPath = resolvePath root (resolvePrefix prefix memberName)+  json <- getPkgInfo pkgDirPath+  pure $ toPkg json groupName memberName pkgDirPath++resolvePrefix :: Maybe Text -> Text -> Text+resolvePrefix prefix name = intercalate "-" (maybeToList prefix <> [name | name /= "."])++resolvePath :: (ToString a) => Maybe String -> a -> FilePath+resolvePath root path = normalise (joinPath (maybeToList (cleanRelativePath root) <> [toString path]))++scanPkgInfos :: (MonadIO m, MonadError Issue m) => FilePath -> m (Map FilePath PkgInfo)+scanPkgInfos root = do+  paths <- map (makeRelative root) <$> liftIO (glob $ normalise "./**/**/package.yaml")+  pkgInfos <- traverse getPkgInfo paths+  pure $ Map.fromList (zip paths pkgInfos)++scanPkgs :: (MonadIO m, MonadError Issue m) => FilePath -> m [Pkg]+scanPkgs root = do+  infos <- scanPkgInfos root+  for (Map.toList infos) $ \(path, info) -> do+    let pkgDir = takeDirectory path+    let memberName = toText $ takeFileName pkgDir+    let groupName = maybe "" toText $ cleanRelativePath (Just (takeDirectory pkgDir))+    pure $ toPkg info groupName memberName pkgDir++newtype PkgName = PkgName Text+  deriving newtype+    ( FromJSON,+      ToJSON,+      Show,+      Ord,+      Eq,+      FromJSONKey,+      ToJSONKey,+      ToString+    )++instance Format PkgName where+  format (PkgName x) = x++instance Parse PkgName where+  parse = pure . PkgName
+ src/HWM/Core/Result.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Result+  ( Result (..),+    ResultT (..),+    Issue (..),+    MonadIssue (..),+    Severity (..),+    IssueDetails (..),+    fromEither,+  )+where++import Control.Monad.Except (MonadError (..))+import Data.Foldable (Foldable (..))+import Data.Text.Lazy.Builder ()+import Relude++data Severity = SeverityWarning | SeverityError+  deriving (Show, Eq, Ord)++data IssueDetails+  = CommandIssue+      { issueCommand :: Text,+        issueLogFile :: FilePath+      }+  | GenericIssue+      { issueFile :: FilePath+      }+  | DependencyIssue+      { issueDependencies :: [(Text, Text, Text, Text)],+        issueFile :: FilePath+      }+  deriving (Show, Eq, Ord)++data Issue = Issue+  { issueTopic :: Text,+    issueSeverity :: Severity,+    issueMessage :: Text,+    issueDetails :: Maybe IssueDetails+  }+  deriving (Show, Eq, Ord)++instance IsString Issue where+  fromString s =+    Issue+      { issueTopic = "general",+        issueSeverity = SeverityError,+        issueMessage = fromString s,+        issueDetails = Nothing+      }++class MonadIssue m where+  injectIssue :: Issue -> m ()+  catchIssues :: m a -> m (Maybe Severity, a)+  mapIssue :: (Issue -> Issue) -> m a -> m a++instance MonadIssue (Result Issue) where+  injectIssue issue = Success () [issue]+  catchIssues m@(Success _ ls) = do+    let l = if null ls then Nothing else Just (maximum $ map issueSeverity ls)+     in (l,) <$> m+  catchIssues m@Failure {} = (Just SeverityError,) <$> m+  mapIssue f (Success x ls) = Success x (map f ls)+  mapIssue f (Failure e) = Failure (f <$> e)++instance (Monad m) => MonadIssue (ResultT m) where+  injectIssue issue = ResultT $ pure $ Success () [issue]+  catchIssues (ResultT m) = ResultT $ catchIssues <$> m+  mapIssue f (ResultT m) = ResultT $ mapIssue f <$> m++data Result er a+  = Success {result :: a, issues :: [er]}+  | Failure {failure :: NonEmpty er}+  deriving (Functor)++instance Applicative (Result er) where+  pure = (`Success` [])+  Success f w1 <*> Success x w2 = Success (f x) (w1 <> w2)+  Failure (e :| es) <*> Success _ e' = Failure (e :| (es <> e'))+  Failure e <*> Failure e' = Failure (e <> e')+  Success _ e' <*> Failure (e :| es) = Failure (e :| (es <> e'))++instance Monad (Result er) where+  return = pure+  Success v w1 >>= fm = case fm v of+    (Success x w2) -> Success x (w1 <> w2)+    Failure e -> Failure e+  Failure e >>= _ = Failure e++instance MonadError er (Result er) where+  throwError = Failure . pure+  catchError (Failure e) f = f (head e)+  catchError x _ = x++newtype ResultT (m :: Type -> Type) a = ResultT+  { runResultT :: m (Result Issue a)+  }+  deriving (Functor)++instance (Applicative m) => Applicative (ResultT m) where+  pure = ResultT . pure . pure+  ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) app1 app2++instance (Monad m) => Monad (ResultT m) where+  return = pure+  (ResultT m1) >>= mFunc = ResultT $ do+    rs <- m1+    case rs of+      Success value w1 -> do+        result' <- runResultT (mFunc value)+        case result' of+          Success value' w2 -> pure $ Success value' (w1 <> w2)+          Failure e -> pure $ Failure e+      Failure e -> pure $ Failure e++instance MonadTrans ResultT where+  lift = ResultT . fmap pure++instance (Monad m) => MonadError Issue (ResultT m) where+  throwError = ResultT . pure . throwError+  catchError (ResultT mx) f = ResultT (mx >>= catchResultError)+    where+      catchResultError (Failure e) = runResultT (f (head e))+      catchResultError x = pure x++instance (MonadIO m) => MonadIO (ResultT m) where+  liftIO = lift . liftIO++fromEither :: (MonadError Issue m) => Text -> Either String a -> m a+fromEither context = either (throwError . fromString . ((toString context <> ": ") <>)) pure
+ src/HWM/Core/Version.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Core.Version+  ( Version,+    Bump (..),+    askVersion,+    nextVersion,+    dropPatch,+    parseGHCVersion,+  )+where++import Data.Aeson+  ( FromJSON (..),+    ToJSON (..),+    Value (..),+  )+import qualified Data.Text as T+import GHC.Show (Show (..))+import HWM.Core.Formatting (Format (..), formatList)+import HWM.Core.Has (Has (obtain))+import HWM.Core.Parsing (Parse (..), fromToString, sepBy)+import Relude hiding (show)++data Version = Version+  { major :: Int,+    minor :: Int,+    revision :: [Int]+  }+  deriving+    ( Generic,+      Eq+    )++askVersion :: (MonadReader env m, Has env Version) => m Version+askVersion = asks obtain++getNumber :: [Int] -> Int+getNumber (n : _) = n+getNumber [] = 0++nextVersion :: Bump -> Version -> Version+nextVersion Major Version {..} = Version {major = major + 1, minor = 0, revision = [0], ..}+nextVersion Minor Version {..} = Version {minor = minor + 1, revision = [0], ..}+nextVersion Patch Version {..} = Version {revision = [getNumber revision + 1], ..}++dropPatch :: Version -> Version+dropPatch Version {..} = Version {revision = [0], ..}++compareSeries :: (Ord a) => [a] -> [a] -> Ordering+compareSeries [] _ = EQ+compareSeries _ [] = EQ+compareSeries (x : xs) (y : ys)+  | x == y = compareSeries xs ys+  | otherwise = compare x y++instance Format Version where+  format = formatList "." . toSeries++instance Parse Version where+  parse s = either (fail . toString . (prefix <>)) pure (sepBy "." s >>= fromSeries)+    where+      prefix = "invalid version(" <> s <> ")" <> ": "++fromSeries :: (MonadFail m) => [Int] -> m Version+fromSeries [] = fail "version should have at least one number!"+fromSeries [major] = pure Version {major, minor = 0, revision = []}+fromSeries (major : (minor : revision)) = pure Version {..}++toSeries :: Version -> [Int]+toSeries Version {..} = [major, minor] <> revision++instance ToString Version where+  toString = toString . format++instance Ord Version where+  compare a b = compareSeries (toSeries a) (toSeries b)++instance Show Version where+  show = toString++instance ToText Version where+  toText = fromToString++instance FromJSON Version where+  parseJSON (String s) = parse s+  parseJSON (Number n) = parse (fromToString $ show n)+  parseJSON v = fail $ "version should be either true or string" <> toString (format v)++instance ToJSON Version where+  toJSON = String . toText++data Bump+  = Major+  | Minor+  | Patch+  deriving+    ( Generic,+      Eq+    )++instance Parse Bump where+  parse "major" = pure Major+  parse "minor" = pure Minor+  parse "patch" = pure Patch+  parse v = fail $ "Invalid bump type: " <> toString (fromToString v)++instance ToString Bump where+  toString Major = "major"+  toString Minor = "minor"+  toString Patch = "patch"++instance Format Bump where+  format Major = "major"+  format Minor = "minor"+  format Patch = "patch"++instance Show Bump where+  show = toString++instance ToText Bump where+  toText = fromToString++instance FromJSON Bump where+  parseJSON (String s) = parse s+  parseJSON v = fail $ "Invalid bump type: " <> show v++instance ToJSON Bump where+  toJSON = String . toText++parseGHCVersion :: (MonadFail m) => Text -> m Version+parseGHCVersion text = parse (fromMaybe text (T.stripPrefix "ghc-" text))
+ src/HWM/Domain/Bounds.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Domain.Bounds+  ( Bounds,+    BoundsByName,+    versionBounds,+    updateDepBounds,+    getBound,+    Bound (..),+    Restriction (..),+    printUpperBound,+    hasBounds,+    boundsScore,+    boundsBetter,+  )+where++import Control.Monad.Except (MonadError)+import Data.Aeson+  ( FromJSON (..),+    ToJSON (..),+    Value (..),+  )+import Data.List (maximum, minimum)+import HWM.Core.Formatting (Format (..), formatList)+import HWM.Core.Has (Has)+import HWM.Core.Parsing (Parse (..), fromToString, removeHead, sepBy, unconsM)+import HWM.Core.Pkg (PkgName)+import HWM.Core.Result (Issue)+import HWM.Core.Version (Bump (..), Version, dropPatch, nextVersion)+import HWM.Runtime.Cache (Cache, getVersions)+import Relude++data Restriction = Min | Max deriving (Show, Eq, Ord)++instance Parse Restriction where+  parse ">" = pure Min -- > 0.7.0+  parse "<" = pure Max -- <  1.0.0+  parse x = fail ("unsorted bound type" <> toString x)++instance ToString Restriction where+  toString Min = ">" -- >  0.7.0+  toString Max = "<" -- <  1.0.0++instance ToText Restriction where+  toText = fromToString++data Bound = Bound+  { restriction :: Restriction,+    orEquals :: Bool,+    version :: Version+  }+  deriving (Show, Eq)++instance Format Bound where+  format Bound {..} = unwords $ (toText restriction <> eq) : [toText version]+    where+      eq = if orEquals then "=" else ""++instance Ord Bound where+  compare a b =+    compare (version a) (version b)+      <> compare (restriction a) (restriction b)+      <> compare (orEquals a) (orEquals b)++instance Parse Bound where+  parse txt = do+    (ch, str) <- unconsM "unsorted bound type" txt+    let (orEquals, value) = removeHead '=' str+    restriction <- parse ch+    version <- parse value+    pure Bound {..}++newtype Bounds = Bounds [Bound]+  deriving (Generic, Show, Eq)++type BoundsByName = '[]++instance Parse Bounds where+  parse "" = pure $ Bounds []+  parse str = Bounds <$> sepBy "&&" str++instance Format Bounds where+  format (Bounds xs) = formatList " && " $ sort xs++instance ToString Bounds where+  toString = toString . format++instance FromJSON Bounds where+  parseJSON (String p) = parse p+  parseJSON v = fail $ fromString ("cant parse Bounds expected string got" <> toString (format v))++instance ToJSON Bounds where+  toJSON = String . fromToString++versionBounds :: Version -> Bounds+versionBounds version =+  Bounds+    [ Bound Min True (dropPatch version),+      Bound Max False (nextVersion Minor version)+    ]++getBound :: Restriction -> Bounds -> [Bound]+getBound v (Bounds xs) = maybeToList $ find (\Bound {..} -> restriction == v) xs++printUpperBound :: Bounds -> Text+printUpperBound bounds = case getBound Max bounds of+  [Bound {version}] -> format version+  _ -> ""++hasBounds :: Bounds -> Bool+hasBounds b =+  let lower = getBound Min b+      upper = getBound Max b+   in not (null lower && null upper)++boundsScore :: Bounds -> Int+boundsScore b = length (getBound Min b) + length (getBound Max b)++boundsBetter :: Bounds -> Bounds -> Bool+boundsBetter a b = boundsScore a > boundsScore b++getLatest :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> m Bound+getLatest = fmap (Bound Max True . head) . getVersions++updateDepBounds :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> Bounds -> m Bounds+updateDepBounds name bounds = do+  latest <- getLatest name+  let upper = getBound Max bounds+  let newVersion = maximum (latest : upper)+  _min <- initiateMin name bounds+  pure (Bounds (_min <> [newVersion]))++initiateMin :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> Bounds -> m [Bound]+initiateMin name bounds = do+  let mi = getBound Min bounds+  if null mi+    then do+      ls <- fmap (Bound Min True) <$> getVersions name+      pure [minimum ls]+    else pure mi
+ src/HWM/Domain/Config.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Domain.Config+  ( Config (..),+    getRule,+    defaultScripts,+  )+where++import Control.Monad.Except (MonadError)+import Data.Aeson (FromJSON (..), ToJSON (toJSON), genericParseJSON, genericToJSON)+import qualified Data.Map as Map+import HWM.Core.Common (Check (..), Name)+import HWM.Core.Has (Has)+import HWM.Core.Pkg+import HWM.Core.Result (Issue)+import HWM.Core.Version (Version)+import HWM.Domain.Bounds (Bounds)+import HWM.Domain.Dependencies (Dependencies, getBounds)+import HWM.Domain.Matrix (Matrix (..))+import HWM.Domain.Workspace (PkgRegistry, WorkspaceGroup)+import HWM.Runtime.Cache (Cache)+import HWM.Runtime.Files (aesonYAMLOptions)+import Relude++data Config = Config+  { name :: Name,+    version :: Version,+    bounds :: Bounds,+    workspace :: [WorkspaceGroup],+    matrix :: Matrix,+    registry :: Dependencies,+    scripts :: Map Name Text+  }+  deriving+    ( Generic,+      Show+    )++getRule :: (MonadError Issue m) => PkgName -> PkgRegistry -> Config -> m Bounds+getRule depName ps Config {..}+  | Map.member depName ps = pure bounds+  | otherwise = getBounds depName registry++instance FromJSON Config where+  parseJSON = genericParseJSON aesonYAMLOptions++instance ToJSON Config where+  toJSON = genericToJSON aesonYAMLOptions++instance+  ( MonadError Issue m,+    MonadReader env m,+    Has env Cache,+    Has env [WorkspaceGroup],+    Has env Matrix,+    MonadIO m+  ) =>+  Check m Config+  where+  check Config {..} = check matrix++defaultScripts :: Map Name Text+defaultScripts =+  Map.fromList+    [ ("build", "stack build --fast"),+      ("test", "stack test {TARGET} --fast"),+      ("install", "stack install"),+      ("lint", "curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s ."),+      ("clean", "find . -name \"*.cabal\" -exec rm -rf {} \\; && stack clean")+    ]
+ src/HWM/Domain/ConfigT.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use lambda-case" #-}++module HWM.Domain.ConfigT+  ( ConfigT (..),+    runConfigT,+    VersionMap,+    updateConfig,+    Env (..),+    unpackConfigT,+    askCache,+    askMatrix,+    askPackages,+    askWorkspaceGroups,+    askVersion,+    saveConfig,+    resolveResultUI,+  )+where++import Control.Monad.Error.Class+import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString.Base16 as Base16+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import HWM.Core.Common (Check (..))+import HWM.Core.Formatting (Format (..))+import HWM.Core.Has (Has (..))+import HWM.Core.Options (Options (..))+import HWM.Core.Pkg (Pkg)+import HWM.Core.Result (Issue (..), MonadIssue (..), Result (..), ResultT, runResultT)+import HWM.Core.Version (Version, askVersion)+import HWM.Domain.Config (Config (..))+import HWM.Domain.Matrix (Matrix (..))+import HWM.Domain.Workspace (PkgRegistry, WorkspaceGroup, memberPkgs, pkgRegistry)+import HWM.Runtime.Cache (Cache, VersionMap, loadCache, saveCache)+import HWM.Runtime.Files (addHash, readYaml, rewrite_)+import HWM.Runtime.UI (MonadUI (..), UIT, printSummary, runUI)+import Relude++data Env (m :: Type -> Type) = Env+  { options :: Options,+    config :: Config,+    cache :: Cache,+    pkgs :: PkgRegistry+  }++type ConfigEnv = Env IO++newtype ConfigT (a :: Type) = ConfigT+  { _runConfigT :: ReaderT ConfigEnv (ResultT (UIT IO)) a+  }+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadReader ConfigEnv,+      MonadError Issue,+      MonadIO+    )++instance Has (Env m) Options where+  obtain = options++instance Has (Env m) Cache where+  obtain = cache++instance Has (Env m) Config where+  obtain = config++instance Has (Env m) [WorkspaceGroup] where+  obtain Env {config} = workspace config++instance Has (Env m) Matrix where+  obtain Env {config} = matrix config++instance Has (Env m) Version where+  obtain Env {config} = version config++instance Has (Env m) PkgRegistry where+  obtain = pkgs++instance MonadUI ConfigT where+  uiWrite txt = do+    Options {quiet} <- asks options+    unless quiet $ liftIO $ putStr (toString txt)+  uiIndentLevel = ConfigT $ lift uiIndentLevel+  uiWithIndent f (ConfigT (ReaderT action)) = ConfigT $ ReaderT (uiWithIndent f . action)++getFileHash :: FilePath -> IO (Maybe Text)+getFileHash filePath = do+  content <- T.decodeUtf8 <$> readFileBS filePath+  case T.lines content of+    (firstLine : _) ->+      case T.stripPrefix "# hash: " firstLine of+        Just hash -> pure (Just hash)+        Nothing -> pure Nothing+    [] -> pure Nothing++debug :: Text -> ConfigT ()+debug _ = pure ()++instance MonadIssue ConfigT where+  injectIssue = ConfigT . lift . injectIssue+  catchIssues (ConfigT action) = ConfigT $ ReaderT (catchIssues . runReaderT action)+  mapIssue f (ConfigT action) = ConfigT $ ReaderT $ \env -> mapIssue f (runReaderT action env)++computeHash :: Config -> Text+computeHash cfg =+  let hashInput = T.encodeUtf8 (T.pack (show (environments $ matrix cfg)))+      hashBytes = SHA256.hash hashInput+   in T.decodeUtf8 (Base16.encode hashBytes)++hasHashChanged :: Config -> Maybe Text -> Bool+hasHashChanged _ Nothing = True+hasHashChanged cfg (Just storedHash) = storedHash /= computeHash cfg++checkConfig :: ConfigT ()+checkConfig = do+  cfg <- asks config+  ops <- asks options+  check cfg+  debug $ "save " <> format (hwm ops)+  saveConfig cfg ops++saveConfig :: (MonadError Issue m, MonadIO m) => Config -> Options -> m ()+saveConfig config ops = do+  let file = hwm ops+  rewrite_ file (const $ pure config)+  addHash file (computeHash config)++updateConfig :: (Config -> ConfigT Config) -> ConfigT b -> ConfigT b+updateConfig f m = do+  config' <- asks config >>= f+  local (\e -> e {config = config'}) (checkConfig >> m)++runConfigT :: ConfigT () -> Options -> IO ()+runConfigT m opts@Options {..} = do+  config <- resolveResultTSilent (readYaml hwm)+  cache <- loadCache (defaultEnvironment (matrix config))+  changed <- hasHashChanged config <$> getFileHash hwm+  pkgs <- resolveResultTSilent (pkgRegistry (workspace config))+  let env = Env {options = opts, config, cache, pkgs}+      resultT = unpackConfigT (if changed then checkConfig >> m else m) env+  resolveResultT resultT cache++resolveResultT :: ResultT (UIT IO) a -> Cache -> IO ()+resolveResultT resT cache =+  runUI+    ( runResultT resT >>= \r ->+        case r of+          Success {..} -> do+            liftIO $ saveCache cache+            printSummary issues+          Failure {..} -> do+            printSummary (toList failure)+            exitFailure+    )++resolveResultTSilent :: ResultT IO a -> IO a+resolveResultTSilent m = do+  r <- runResultT m+  case r of+    Success {..} -> pure result+    Failure {..} -> runUI (printSummary (toList failure)) >> exitFailure++resolveResultUI :: ResultT (UIT IO) a -> UIT IO a+resolveResultUI m = do+  r <- runResultT m+  case r of+    Success {..} -> pure result+    Failure {..} -> printSummary (toList failure) >> exitFailure++unpackConfigT :: ConfigT a -> ConfigEnv -> ResultT (UIT IO) a+unpackConfigT (ConfigT action) = runReaderT action++askCache :: ConfigT Cache+askCache = asks cache++askWorkspaceGroups :: ConfigT [WorkspaceGroup]+askWorkspaceGroups = asks (workspace . config)++askMatrix :: ConfigT Matrix+askMatrix = asks (matrix . config)++askPackages :: ConfigT [Pkg]+askPackages = do+  groups <- askWorkspaceGroups+  concat <$> traverse memberPkgs groups
+ src/HWM/Domain/Dependencies.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Domain.Dependencies+  ( Dependencies,+    Dependency (..),+    getBounds,+    traverseDeps,+    toDependencyList,+    fromDependencyList,+    mergeDependencies,+    normalizeDependencies,+    externalRegistry,+    DependencyGraph (..),+    sortByDependencyHierarchy,+  )+where++import Control.Monad.Error.Class (MonadError (..))+import Data.Aeson+  ( FromJSON (..),+    ToJSON (toJSON),+  )+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import HWM.Core.Formatting (Format (..), formatTable, subPathSign)+import HWM.Core.Parsing (Parse (..), firstWord)+import HWM.Core.Pkg (Pkg (..), PkgName)+import HWM.Core.Result (Issue (..), Severity (..))+import HWM.Domain.Bounds (Bounds, boundsBetter, hasBounds)+import HWM.Runtime.Files (select)+import Relude hiding+  ( Undefined,+    break,+    drop,+    fromList,+    length,+    null,+    show,+    toList,+  )++data Dependency = Dependency+  { name :: PkgName,+    bounds :: Bounds+  }+  deriving (Show, Eq)++instance Parse Dependency where+  parse =+    (\(name, txt) -> Dependency <$> parse name <*> parse txt)+      . firstWord++instance Format Dependency where+  format Dependency {..} = format name <> " " <> format bounds++newtype Dependencies = Dependencies {unpackDeps :: Map PkgName Bounds}+  deriving (Show)++getBounds :: (MonadError Issue m) => PkgName -> Dependencies -> m Bounds+getBounds name = select "Package " name . unpackDeps++traverseDeps :: (Applicative f) => (PkgName -> Bounds -> f Bounds) -> Dependencies -> f Dependencies+traverseDeps f (Dependencies xs) = Dependencies <$> Map.traverseWithKey f xs++initDependencies :: [Dependency] -> Dependencies+initDependencies = Dependencies . Map.fromList . map toDuple+  where+    toDuple (Dependency a b) = (a, b)++toDependencyList :: Dependencies -> [Dependency]+toDependencyList (Dependencies m) = map (uncurry Dependency) $ Map.toList m++instance FromJSON Dependencies where+  parseJSON v = initDependencies <$> (parseJSON v >>= traverse parse . sort)++instance ToJSON Dependencies where+  toJSON = toJSON . formatTable . map format . toDependencyList++fromDependencyList :: [Dependency] -> Dependencies+fromDependencyList = initDependencies++mergeDependencies :: [Dependency] -> [Dependency]+mergeDependencies = Map.elems . foldl' step Map.empty+  where+    step acc dep =+      Map.insertWith prefer (name dep) dep acc+    prefer new old = if boundsBetter (bounds new) (bounds old) then new else old++normalizeDependencies :: [Dependency] -> [Dependency]+normalizeDependencies = filter (hasBounds . bounds) . mergeDependencies++externalRegistry :: [PkgName] -> [Dependency] -> Dependencies+externalRegistry internalPkgs deps =+  let externals = filter isExternal (normalizeDependencies deps)+   in fromDependencyList (sortOn name externals)+  where+    internals = Set.fromList internalPkgs+    isExternal dep = not (Set.member (name dep) internals)++newtype DependencyGraph = DependencyGraph (Map PkgName [PkgName])++instance Format DependencyGraph where+  format graph = T.intercalate "\n" (map (formatTree 0) (toTree graph))++formatTree :: Int -> Tree -> Text+formatTree depth (Node pkg deps) = newLine <> format pkg <> children+  where+    newLine | depth == 0 = "\n    • " | otherwise = "\n  " <> T.replicate depth "  " <> subPathSign+    children = T.intercalate "" (map (formatTree (depth + 1)) deps)++data Tree = Node PkgName [Tree]++toTree :: DependencyGraph -> [Tree]+toTree (DependencyGraph graph) =+  let allPkgs = Map.keysSet graph <> foldMap Set.fromList (Map.elems graph)+      dependentPkgs = foldMap Set.fromList (Map.elems graph)+      rootPkgs = Set.toList (Set.difference allPkgs dependentPkgs)+   in map (buildTree graph Set.empty) rootPkgs++buildTree :: Map PkgName [PkgName] -> Set PkgName -> PkgName -> Tree+buildTree graph visited pkg =+  if Set.member pkg visited+    then Node pkg []+    else+      let deps = Map.findWithDefault [] pkg graph+          newVisited = Set.insert pkg visited+          childTrees = map (buildTree graph newVisited) deps+       in Node pkg childTrees++topologicalSort :: DependencyGraph -> Either [PkgName] [PkgName]+topologicalSort (DependencyGraph graph) = goFunc [] initialZero indegreeMap+  where+    nodes = Map.keysSet graph <> foldMap Set.fromList (Map.elems graph)+    indegreeMap = foldl' updateIndegree baseIndegree (Map.toList graph)+    baseIndegree = Map.fromSet (const (0 :: Int)) nodes+    updateIndegree acc (_, deps) = foldl' increment acc deps+    increment acc dep = Map.insertWith (+) dep 1 acc+    initialZero = Set.fromList [pkg | (pkg, deg) <- Map.toList indegreeMap, deg == 0]++    goFunc acc zeros indegrees+      | Set.null zeros =+          case Map.keys (Map.filter (> 0) indegrees) of+            [] -> Right (reverse acc)+            cycleNodes -> Left cycleNodes+      | otherwise =+          let (pkg, remainingZeros) = Set.deleteFindMin zeros+              neighbours = Map.findWithDefault [] pkg graph+              (nextZeros, nextIndegrees) = foldl' reduce (remainingZeros, indegrees) neighbours+           in goFunc (pkg : acc) nextZeros nextIndegrees++    reduce (zeros, indegrees) neighbour =+      let deg = Map.findWithDefault 0 neighbour indegrees - 1+          updatedIndegrees = Map.insert neighbour deg indegrees+          updatedZeros = if deg == 0 then Set.insert neighbour zeros else zeros+       in (updatedZeros, updatedIndegrees)++sortByDependencyHierarchy :: (MonadError Issue m) => DependencyGraph -> [Pkg] -> m [Pkg]+sortByDependencyHierarchy graph ns = do+  case topologicalSort graph of+    Left depCycle ->+      let cycleNames = intercalate " -> " (map toString depCycle)+       in throwError+            Issue+              { issueTopic = "dependency-resolution",+                issueSeverity = SeverityError,+                issueMessage = fromString $ "Dependency cycle detected: " <> cycleNames,+                issueDetails = Nothing+              }+    Right sortedNames ->+      let indexes = Map.fromList (zip sortedNames [0 ..] :: [(PkgName, Int)])+          findIndex pkg = Map.findWithDefault maxBound (pkgName pkg) indexes+       in pure $ sortOn (Down . findIndex) ns
+ src/HWM/Domain/Matrix.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Domain.Matrix+  ( BuildEnv (..),+    Matrix (..),+    BuildEnvironment (..),+    getBuildEnvroments,+    getBuildEnvironment,+    hkgRefs,+    printEnvironments,+  )+where++import Control.Monad.Except (MonadError (..))+import Data.Aeson+  ( FromJSON (..),+    ToJSON (toJSON),+    genericParseJSON,+    genericToJSON,+  )+import Data.List ((\\))+import qualified Data.Map as M+import Data.Traversable (for)+import HWM.Core.Common+  ( Check (..),+    Name,+  )+import HWM.Core.Formatting (Color (..), Format (..), availableOptions, chalk)+import HWM.Core.Has (Has, HasAll, askEnv)+import HWM.Core.Pkg (Pkg (..), PkgName, pkgId)+import HWM.Core.Result (Issue)+import HWM.Core.Version (Version)+import HWM.Domain.Workspace (WorkspaceGroup, memberPkgs)+import HWM.Runtime.Cache (Cache, Registry (currentEnv), VersionMap, getRegistry, getVersions)+import HWM.Runtime.Files (aesonYAMLOptions)+import HWM.Runtime.UI (MonadUI, forTable, sectionEnvironments)+import Relude++type Extras = VersionMap++data Matrix = Matrix+  { defaultEnvironment :: Name,+    environments :: [BuildEnv]+  }+  deriving+    ( Generic,+      Show+    )++instance FromJSON Matrix where+  parseJSON = genericParseJSON aesonYAMLOptions++instance ToJSON Matrix where+  toJSON = genericToJSON aesonYAMLOptions++instance+  ( MonadError Issue m,+    MonadReader env m,+    Has env Matrix,+    Has env [WorkspaceGroup],+    Has env Cache,+    MonadIO m+  ) =>+  Check m Matrix+  where+  check Matrix {..} = traverse_ check environments++data BuildEnv = BuildEnv+  { name :: Name,+    ghc :: Version,+    resolver :: Name,+    extraDeps :: Maybe Extras,+    exclude :: Maybe [Text],+    allowNewer :: Maybe Bool+  }+  deriving+    ( Generic,+      Show,+      Ord,+      Eq+    )++instance FromJSON BuildEnv where+  parseJSON = genericParseJSON aesonYAMLOptions++instance ToJSON BuildEnv where+  toJSON = genericToJSON aesonYAMLOptions++instance+  ( MonadError Issue m,+    MonadReader env m,+    Has env [WorkspaceGroup],+    Has env Cache,+    MonadIO m+  ) =>+  Check m BuildEnv+  where+  check BuildEnv {..} =+    sequence_+      [ traverse_ check (maybe [] hkgRefs extraDeps),+        checkPkgNames exclude+      ]++checkPkgNames ::+  ( MonadError Issue m,+    MonadReader env m,+    Has env [WorkspaceGroup],+    MonadIO m+  ) =>+  Maybe [Text] ->+  m ()+checkPkgNames ls = do+  known <- map pkgId <$> askAllPackages+  let unknown = fromMaybe [] ls \\ known+  unless (null unknown) (throwError $ fromString ("unknown packages: " <> show unknown))++data BuildEnvironment = BuildEnvironment+  { buildEnv :: BuildEnv,+    buildPkgs :: [Pkg],+    buildName :: Name,+    buildExtraDeps :: Maybe Extras,+    buildResolver :: Name+  }+  deriving+    ( Generic,+      Show,+      Ord,+      Eq+    )++instance Format BuildEnvironment where+  format BuildEnvironment {..} = buildName <> " (" <> format (ghc buildEnv) <> ")"++getBuildEnvroments ::+  ( MonadReader env m,+    Has env Matrix,+    Has env [WorkspaceGroup],+    MonadIO m,+    MonadError Issue m+  ) =>+  m [BuildEnvironment]+getBuildEnvroments = do+  envs <- environments <$> askEnv+  for envs $ \env -> do+    pkgs <- askAllPackages+    pure+      BuildEnvironment+        { buildEnv = env,+          buildPkgs = excludePkgs env pkgs,+          buildName = name env,+          buildExtraDeps = extraDeps env,+          buildResolver = resolver env+        }+  where+    excludePkgs build = filter (\p -> pkgId p `notElem` fromMaybe [] (exclude build))++getBuildEnvironment ::+  ( MonadReader env m,+    Has env Matrix,+    Has env [WorkspaceGroup],+    Has env Cache,+    MonadIO m,+    MonadError Issue m+  ) =>+  Maybe Name ->+  m BuildEnvironment+getBuildEnvironment targetNameInput = do+  targetName <- maybe (currentEnv <$> getRegistry) pure targetNameInput+  envs <- getBuildEnvroments+  maybe+    (throwError $ fromString $ toString ("No matching Environment for input '" <> targetName <> "'! " <> availableOptions (map buildName envs)))+    pure+    $ find ((targetName ==) . buildName) envs++data HkgRef = HkgRef+  { pkgName :: PkgName,+    pkgVersion :: Version+  }+  deriving (Eq, Ord)++instance+  ( MonadError Issue m,+    MonadReader env m,+    HasAll env [[WorkspaceGroup], Cache],+    MonadIO m+  ) =>+  Check m HkgRef+  where+  check HkgRef {..} = getVersions pkgName >>= checkElem (pkgVersion ==) . toList+    where+      checkElem f xs =+        if isJust (find f xs)+          then pure ()+          else+            throwError+              $ fromString+              $ toString+                ("No matching version for '" <> format pkgVersion <> "'! " <> availableOptions xs)++hkgRefs :: VersionMap -> [HkgRef]+hkgRefs = map (uncurry HkgRef) . M.toList++instance Format HkgRef where+  format HkgRef {..} = format pkgName <> "-" <> format pkgVersion++askGroups :: (MonadReader env m, Has env [WorkspaceGroup]) => m [WorkspaceGroup]+askGroups = askEnv++askAllPackages ::+  ( MonadReader env m,+    Has env [WorkspaceGroup],+    MonadIO m,+    MonadError Issue m+  ) =>+  m [Pkg]+askAllPackages = do+  groups <- askGroups+  concat <$> traverse memberPkgs groups++printEnvironments :: (MonadUI m) => BuildEnvironment -> [BuildEnvironment] -> m ()+printEnvironments active environments =+  sectionEnvironments $ forTable 0 environments $ \env ->+    ( format env,+      if env == active+        then chalk Cyan (buildResolver env <> " (active)")+        else chalk Gray (buildResolver env)+    )
+ src/HWM/Domain/Workspace.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Domain.Workspace+  ( WorkspaceGroup (..),+    pkgGroupName,+    pkgRegistry,+    PkgRegistry,+    memberPkgs,+    resolveTargets,+    selectGroup,+    canPublish,+    buildWorkspaceGroups,+  )+where++import Control.Monad.Error.Class+import Data.Aeson+  ( FromJSON (..),+    Options (..),+    ToJSON (toJSON),+    genericToJSON,+  )+import Data.Aeson.Types+  ( defaultOptions,+  )+import Data.List (groupBy)+import qualified Data.Map as Map+import qualified Data.Text as T+import HWM.Core.Common (Name)+import HWM.Core.Formatting (availableOptions, commonPrefix, slugify)+import HWM.Core.Pkg (Pkg (..), PkgName, makePkg)+import HWM.Core.Result+import HWM.Domain.Dependencies (DependencyGraph, sortByDependencyHierarchy)+import HWM.Runtime.Files (cleanRelativePath)+import Relude++data WorkspaceGroup = WorkspaceGroup+  { name :: Name,+    dir :: Maybe FilePath,+    members :: [Name],+    prefix :: Maybe Text,+    publish :: Maybe Bool+  }+  deriving+    ( Generic,+      FromJSON,+      Show+    )++instance ToJSON WorkspaceGroup where+  toJSON = genericToJSON defaultOptions {omitNothingFields = True}++memberPkgs :: (MonadIO m, MonadError Issue m) => WorkspaceGroup -> m [Pkg]+memberPkgs WorkspaceGroup {..} = traverse (makePkg name dir prefix) members++pkgGroupName :: WorkspaceGroup -> Name+pkgGroupName WorkspaceGroup {..} = name++type PkgRegistry = Map PkgName WorkspaceGroup++resolveGroup :: (MonadIO m, MonadError Issue m) => WorkspaceGroup -> m PkgRegistry+resolveGroup g = Map.fromList . map ((,g) . pkgName) <$> memberPkgs g++pkgRegistry :: (MonadIO m, MonadError Issue m) => [WorkspaceGroup] -> m PkgRegistry+pkgRegistry = fmap Map.unions . traverse resolveGroup++parseTarget :: Text -> (Text, Maybe Text)+parseTarget input = case T.breakOn "/" input of+  (pkg, "") -> (pkg, Nothing) -- No slash found+  (grp, rest) -> (grp, Just (T.drop 1 rest)) -- Drop the "/"++resolveTargets :: (MonadIO m, MonadError Issue m) => [WorkspaceGroup] -> [Name] -> m [Pkg]+resolveTargets ws names = concat <$> traverse (resolveTarget ws) names++resolveTarget :: (MonadIO m, MonadError Issue m) => [WorkspaceGroup] -> Text -> m [Pkg]+resolveTarget ws target = do+  let (g, n) = parseTarget target+  members <- selectGroup g ws >>= memberPkgs+  resolveT members n++selectGroup :: (MonadError Issue m) => Name -> [WorkspaceGroup] -> m WorkspaceGroup+selectGroup name groups =+  maybe (throwError $ fromString $ toString ("Workspace group \"" <> name <> "\" not found! " <> availableOptions (map pkgGroupName groups))) pure (find ((== name) . pkgGroupName) groups)++resolveT :: (MonadError Issue m) => [Pkg] -> Maybe Name -> m [Pkg]+resolveT pkgs Nothing = pure pkgs+resolveT pkgs (Just target) =+  case find (\p -> target == pkgMemberId p) pkgs of+    Just p -> pure [p]+    Nothing -> throwError $ fromString $ toString $ "Target not found: " <> target++canPublish :: WorkspaceGroup -> Bool+canPublish WorkspaceGroup {publish} = fromMaybe False publish++buildWorkspaceGroups :: (Monad m, MonadError Issue m) => DependencyGraph -> [Pkg] -> m [WorkspaceGroup]+buildWorkspaceGroups graph = fmap concat . traverse groupToWorkspace . groupBy sameGroup . sortOn pkgGroup+  where+    sameGroup left right = pkgGroup left == pkgGroup right+    groupToWorkspace [] = pure []+    groupToWorkspace (pkg : pkgs) = do+      sortPkgs <- sortByDependencyHierarchy graph (pkg : pkgs)+      let (prefix, members) = commonPrefix (map pkgMemberId sortPkgs)+      pure+        [ WorkspaceGroup+            { name = if T.null (pkgGroup pkg) then "libs" else slugify (pkgGroup pkg),+              dir = cleanRelativePath (Just $ toString (pkgGroup pkg)),+              members,+              prefix = prefix,+              publish = derivePublish (pkgGroup pkg : members)+            }+        ]++derivePublish :: [Name] -> Maybe Bool+derivePublish names+  | any (`elem` nonPublish) loweredNames = Nothing+  | otherwise = Just True+  where+    loweredNames = map T.toLower names+    nonPublish = ["examples", "example", "bench", "benchmarks"]
+ src/HWM/Integrations/Toolchain/Cabal.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Integrations.Toolchain.Cabal+  ( syncCabal,+    validateHackage,+  )+where++import Data.Foldable (Foldable (..))+import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage)+import Distribution.Simple.PackageDescription (readGenericPackageDescription)+import Distribution.Verbosity (normal)+import HWM.Core.Formatting (Status (..))+import HWM.Core.Pkg (Pkg (..), pkgYamlPath)+import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..))+import HWM.Domain.ConfigT (ConfigT)+import Hpack (Result (..), defaultOptions, hpackResult, setProgramName, setTarget)+import qualified Hpack as H+import Hpack.Config (ProgramName (..))+import Relude++-- | Translate Cabal warnings into formatting status for downstream reporting.+toStatus :: PackageCheck -> Status+toStatus p+  | isError p = Invalid+  | otherwise = Warning++isError :: PackageCheck -> Bool+isError PackageDistInexcusable {} = True+isError PackageBuildImpossible {} = True+isError PackageBuildWarning {} = False+isError PackageDistSuspiciousWarn {} = False+isError PackageDistSuspicious {} = False++validateHackage :: Pkg -> FilePath -> ConfigT [Status]+validateHackage pkg cabalFilePath = do+  gpd <- liftIO $ readGenericPackageDescription normal cabalFilePath+  let ls = checkPackage gpd Nothing+  for_ ls $ \l -> do+    injectIssue+      ( Issue+          { issueMessage = "Invalid package: " <> show l,+            issueSeverity = if isError l then SeverityError else SeverityWarning,+            issueTopic = pkgMemberId pkg,+            issueDetails = Just GenericIssue {issueFile = cabalFilePath}+          }+      )+  pure (map toStatus ls)++syncCabal :: Pkg -> ConfigT Status+syncCabal pkg = do+  let programName = ProgramName $ toString $ pkgName pkg+  let ops = setTarget (pkgYamlPath pkg) $ setProgramName programName defaultOptions+  Result {..} <- liftIO $ hpackResult ops+  ls <- validateHackage pkg resultCabalFile++  s <- case resultStatus of+    H.OutputUnchanged -> pure Checked+    _ -> pure Updated+  pure $ maximum (s : ls)
+ src/HWM/Integrations/Toolchain/Hie.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Integrations.Toolchain.Hie+  ( syncHie,+  )+where++import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object)+import qualified Data.Map as M+import HWM.Core.Common (Name)+import HWM.Core.Formatting (Format (..))+import HWM.Core.Options (Options (..), askOptions)+import HWM.Core.Pkg (Pkg (..), PkgName, pkgFile, pkgYamlPath)+import HWM.Domain.ConfigT (ConfigT, askPackages)+import HWM.Integrations.Toolchain.Lib (Libraries, Library (..))+import HWM.Integrations.Toolchain.Package (Package (..))+import HWM.Runtime.Files (readYaml, rewrite_)+import Relude++data Component = Component+  { path :: FilePath,+    component :: Name+  }+  deriving+    ( ToJSON,+      FromJSON,+      Generic,+      Show+    )++data Components = Components+  { stackYaml :: FilePath,+    components :: [Component]+  }+  deriving+    ( ToJSON,+      FromJSON,+      Generic,+      Show+    )++packHie :: Components -> Value+packHie value = object [("cradle", object [("stack", toJSON value)])]++(<:>) :: (Semigroup a, IsString a) => a -> a -> a+(<:>) name tag = name <> ":" <> tag++genComponents :: Pkg -> ConfigT [Component]+genComponents path = do+  Package {..} <- readYaml (pkgYamlPath path)+  pure+    $ comp name "lib" library+    <> compGroup name "test" tests+    <> compGroup name "exe" executables+    <> compGroup name "bench" benchmarks+  where+    compGroup :: PkgName -> Text -> Maybe Libraries -> [Component]+    compGroup name tag = concatMap mkComp . concatMap M.toList . maybeToList+      where+        mkComp (k, lib) = comp name (tag <:> k) (Just lib)+    comp :: PkgName -> Text -> Maybe Library -> [Component]+    comp name tag (Just Library {sourceDirs}) =+      [ Component+          { path = "./" <> pkgFile path (toString sourceDirs),+            component = format name <:> tag+          }+      ]+    comp _ _ _ = []++syncHie :: ConfigT ()+syncHie = do+  Options {..} <- askOptions+  components <- concat <$> (askPackages >>= traverse genComponents)+  rewrite_ hie (const $ pure $ packHie Components {stackYaml = stack, components})
+ src/HWM/Integrations/Toolchain/Lib.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Integrations.Toolchain.Lib+  ( Library (..),+    updateDependencies,+    updateLibrary,+    updateLibraries,+    checkDependencies,+    checkLibrary,+    checkLibraries,+    BoundsDiff,+    Libraries,+  )+where++#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.KeyMap (delete)+# else+import Data.HashMap.Lazy (delete)+#endif+import Control.Monad.Except (catchError)+import Data.Aeson.Types+  ( FromJSON (..),+    GFromJSON,+    Object,+    Parser,+    ToJSON (..),+    Value (..),+    Zero,+    genericParseJSON,+    genericToJSON,+    withObject,+  )+import qualified Data.Map.Strict as Map+import GHC.Generics (Generic (..))+import HWM.Core.Common (Name)+import HWM.Core.Formatting (Format (..))+import HWM.Core.Pkg (PkgName)+import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..))+import HWM.Domain.Bounds (Bounds)+import HWM.Domain.Config (getRule)+import HWM.Domain.ConfigT (ConfigT, config, pkgs)+import HWM.Domain.Dependencies (Dependencies, Dependency (..), fromDependencyList, toDependencyList)+import HWM.Runtime.Files (aesonYAMLOptions)+import Relude++type Libraries = Map Name Library++type BoundsDiff = (Text, PkgName, Bounds, Bounds)++data Library = Library+  { sourceDirs :: Name,+    dependencies :: Maybe Dependencies,+    __unknownFields :: Maybe Object+  }+  deriving+    ( Show,+      Generic+    )++instance FromJSON Library where+  parseJSON = fromObject (\t o -> t {__unknownFields = o})++instance ToJSON Library where+  toJSON t = Object (toObject (genericToJSON aesonYAMLOptions t) <> fromMaybe mempty (__unknownFields t))++fromObject :: (Generic a, GFromJSON Zero (Rep a)) => (a -> Maybe Object -> a) -> Value -> Parser a+fromObject f v = do+  t <- genericParseJSON aesonYAMLOptions v+  o <- withObject "Lib" pure v+  pure (f t (Just o))++toObject :: Value -> Object+toObject (Object x) = delete "__unknown-fields" x+toObject _ = mempty++updateDependency :: PkgName -> ConfigT Bounds+updateDependency name = do+  cfg <- asks config+  pkgs <- asks pkgs+  getRule name pkgs cfg++-- | Process dependencies with error handling - shared logic for both check and update+processDependencies :: Text -> Text -> FilePath -> Dependencies -> (Dependency -> Maybe Bounds -> Maybe a) -> ConfigT [a]+processDependencies memberId scope path deps processor = go [] [] (toDependencyList deps)+  where+    go results issues [] = do+      -- Inject accumulated dependency issues at the end+      unless (null issues)+        $ injectIssue+          Issue+            { issueTopic = memberId,+              issueMessage = show (length issues) <> " dependency issue(s) in " <> scope,+              issueSeverity = SeverityWarning,+              issueDetails =+                Just+                  DependencyIssue+                    { issueDependencies = issues,+                      issueFile = path+                    }+            }+      pure (reverse results)+    go results issues (dep@(Dependency depName depBounds) : rest) = do+      result <- catchError (Just <$> updateDependency depName) (\_ -> pure Nothing)+      let (newIssues, maybeItem) = case result of+            Nothing -> ((scope, format depName, format depBounds, "unknown") : issues, processor dep Nothing)+            Just expected -> (issues, processor dep (Just expected))+      case maybeItem of+        Nothing -> go results newIssues rest+        Just item -> go (item : results) newIssues rest++updateDependencies :: Text -> Text -> FilePath -> Dependencies -> ConfigT Dependencies+updateDependencies memberId scope path deps = do+  updated <- processDependencies memberId scope path deps $ \(Dependency depName depBounds) maybeExpected ->+    case maybeExpected of+      Nothing -> Just (Dependency depName depBounds) -- Preserve original when lookup fails+      Just expected -> Just (Dependency depName expected)+  -- Return updated dependencies using fromDependencyList+  pure $ fromDependencyList updated++checkDependencies :: Text -> Text -> FilePath -> Dependencies -> ConfigT [BoundsDiff]+checkDependencies memberId scope path deps =+  processDependencies memberId scope path deps $ \(Dependency depName depBounds) maybeExpected ->+    case maybeExpected of+      Nothing -> Nothing -- Skip unknown dependencies in diff+      Just expected ->+        if depBounds == expected+          then Nothing+          else Just (scope, depName, depBounds, expected)++updateLibrary :: Text -> Text -> FilePath -> Library -> ConfigT Library+updateLibrary memberId scope path Library {..} = do+  newDependencies <- traverse (updateDependencies memberId scope path) dependencies+  pure $ Library {dependencies = newDependencies, ..}++checkLibrary :: Text -> Text -> FilePath -> Library -> ConfigT [BoundsDiff]+checkLibrary _ _ _ Library {dependencies = Nothing} = pure []+checkLibrary memberId scope path Library {dependencies = Just deps} =+  checkDependencies memberId scope path deps++updateLibraries :: Text -> Text -> FilePath -> Maybe Libraries -> ConfigT (Maybe Libraries)+updateLibraries _ _ _ Nothing = pure Nothing+updateLibraries memberId scope path (Just libs) = do+  updated <- traverse (\(name, lib) -> (name,) <$> updateLibrary memberId (scope <> ":" <> name) path lib) (Map.toList libs)+  pure $ Just $ Map.fromList updated++checkLibraries :: Text -> Text -> FilePath -> Libraries -> ConfigT [BoundsDiff]+checkLibraries memberId scope path libs = concat <$> traverse step (Map.toList libs)+  where+    step (name, lib) = checkLibrary memberId (scope <> ":" <> name) path lib
+ src/HWM/Integrations/Toolchain/Package.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Integrations.Toolchain.Package+  ( Package (..),+    BoundsDiff,+    syncPackages,+    deriveRegistry,+    packageDiffs,+    validatePackage,+  )+where++import Control.Monad.Except (MonadError (..))+import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON)+import qualified Data.Map as Map+import qualified Data.Set as Set+import HWM.Core.Formatting (Color (..), Format (..), chalk, displayStatus, genMaxLen, padDots, subPathSign)+import HWM.Core.Pkg (Pkg (..), PkgName, pkgMemberId, pkgYamlPath)+import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..))+import HWM.Core.Version (Version)+import HWM.Domain.ConfigT (ConfigT, askVersion, askWorkspaceGroups)+import HWM.Domain.Dependencies (Dependencies, Dependency (Dependency), DependencyGraph (DependencyGraph), externalRegistry, normalizeDependencies, toDependencyList)+import HWM.Domain.Workspace (memberPkgs, pkgGroupName)+import HWM.Integrations.Toolchain.Cabal (syncCabal)+import HWM.Integrations.Toolchain.Lib+  ( BoundsDiff,+    Libraries,+    Library (..),+    checkDependencies,+    checkLibraries,+    checkLibrary,+    updateDependencies,+    updateLibraries,+    updateLibrary,+  )+import HWM.Runtime.Files (aesonYAMLOptions, readYaml, rewrite_, statusM)+import HWM.Runtime.UI (putLine, sectionWorkspace)+import Relude++data Package = Package+  { name :: PkgName,+    version :: Version,+    library :: Maybe Library,+    dependencies :: Dependencies,+    tests :: Maybe Libraries,+    executables :: Maybe Libraries,+    benchmarks :: Maybe Libraries,+    internalLibraries :: Maybe Libraries,+    foreignLibraries :: Maybe Libraries+  }+  deriving (Show, Generic)++instance FromJSON Package where+  parseJSON = genericParseJSON aesonYAMLOptions++instance ToJSON Package where+  toJSON = genericToJSON aesonYAMLOptions++updatePackage :: Pkg -> Maybe Package -> ConfigT Package+updatePackage pkg Nothing =+  throwError+    $ Issue+      { issueTopic = pkgMemberId pkg,+        issueMessage = "could not find package file",+        issueSeverity = SeverityWarning,+        issueDetails = Just GenericIssue {issueFile = pkgYamlPath pkg}+      }+updatePackage pkg (Just Package {..}) = do+  let path = pkgYamlPath pkg+      pkgId = pkgMemberId pkg+  newLibrary <- traverse (updateLibrary pkgId "library" path) library+  newTests <- updateLibraries pkgId "tests" path tests+  newExecutables <- updateLibraries pkgId "executables" path executables+  newBenchmarks <- updateLibraries pkgId "benchmarks" path benchmarks+  newInternalLibraries <- updateLibraries pkgId "internal" path internalLibraries+  newForeignLibraries <- updateLibraries pkgId "foreign" path foreignLibraries+  newDependencies <- updateDependencies pkgId "dependencies" path dependencies+  newVersion <- askVersion+  pure+    $ Package+      { version = newVersion,+        library = newLibrary,+        tests = newTests,+        executables = newExecutables,+        benchmarks = newBenchmarks,+        internalLibraries = newInternalLibraries,+        foreignLibraries = newForeignLibraries,+        dependencies = newDependencies,+        ..+      }++-- | Determine whether a package already matches the expected configuration.+packageDiffs :: Text -> FilePath -> Package -> ConfigT [BoundsDiff]+packageDiffs memberId path Package {..} = do+  depsDiffs <- checkDependencies memberId "dependencies" path dependencies+  libraryDiffs <- traverseLibrary "library" library+  testsDiffs <- traverseLibraries "tests" tests+  executablesDiffs <- traverseLibraries "executables" executables+  benchmarksDiffs <- traverseLibraries "benchmarks" benchmarks+  internalDiffs <- traverseLibraries "internal" internalLibraries+  foreignDiffs <- traverseLibraries "foreign" foreignLibraries+  pure+    ( depsDiffs+        <> libraryDiffs+        <> testsDiffs+        <> executablesDiffs+        <> benchmarksDiffs+        <> internalDiffs+        <> foreignDiffs+    )+  where+    traverseLibrary :: Text -> Maybe Library -> ConfigT [BoundsDiff]+    traverseLibrary _ Nothing = pure []+    traverseLibrary scope (Just lib) = checkLibrary memberId scope path lib++    traverseLibraries :: Text -> Maybe Libraries -> ConfigT [BoundsDiff]+    traverseLibraries _ Nothing = pure []+    traverseLibraries scope (Just libs) = checkLibraries memberId scope path libs++syncPackages :: ConfigT ()+syncPackages = sectionWorkspace $ do+  groups <- askWorkspaceGroups+  for_ groups $ \g -> do+    putLine ""+    putLine $ "• " <> chalk Bold (pkgGroupName g)+    dirs <- memberPkgs g+    let maxLen = genMaxLen (map pkgMemberId dirs)+    for_ dirs $ \pkg -> do+      let path = pkgYamlPath pkg+      package <- statusM path (rewrite_ path (updatePackage pkg))+      cabal <- syncCabal pkg+      putLine+        ( subPathSign+            <> padDots maxLen (pkgMemberId pkg)+            <> displayStatus [("pkg", package), ("cabal", cabal)]+        )++collectPackageDependencies :: Package -> [Dependency]+collectPackageDependencies Package {..} =+  normalizeDependencies+    ( toDependencyList dependencies+        <> collectLibrary library+        <> collectLibraries tests+        <> collectLibraries executables+        <> collectLibraries benchmarks+        <> collectLibraries internalLibraries+        <> collectLibraries foreignLibraries+    )+  where+    collectLibrary :: Maybe Library -> [Dependency]+    collectLibrary Nothing = []+    collectLibrary (Just Library {dependencies = Nothing}) = []+    collectLibrary (Just Library {dependencies = Just deps}) = toDependencyList deps++    collectLibraries :: Maybe Libraries -> [Dependency]+    collectLibraries Nothing = []+    collectLibraries (Just libs) = concatMap (collectLibrary . Just) (Map.elems libs)++deriveRegistry :: (Monad m, MonadError Issue m, MonadIO m) => [Pkg] -> m (Dependencies, DependencyGraph)+deriveRegistry pkgs = do+  packages <- traverse (readYaml . pkgYamlPath) pkgs+  let graph = deriveDependencyGraph packages+  let deps = externalRegistry (map pkgName pkgs) $ concatMap collectPackageDependencies packages+  pure (deps, graph)++collectCriticalDependencies :: Package -> [Dependency]+collectCriticalDependencies Package {..} = normalizeDependencies (toDependencyList dependencies <> collectLibrary library)+  where+    collectLibrary :: Maybe Library -> [Dependency]+    collectLibrary Nothing = []+    collectLibrary (Just Library {dependencies = Nothing}) = []+    collectLibrary (Just Library {dependencies = Just deps}) = toDependencyList deps++deriveDependencyGraph :: [Package] -> DependencyGraph+deriveDependencyGraph pkgs = DependencyGraph $ Map.fromList [(name pkg, internalDeps pkg) | pkg <- pkgs]+  where+    internalNames = Set.fromList (map name pkgs)+    internalDeps pkg = mapMaybe selectInternal (collectCriticalDependencies pkg)+    selectInternal (Dependency depName _) =+      if Set.member depName internalNames then Just depName else Nothing++-- | Validate package against expected version and configuration+validatePackage :: Pkg -> ConfigT ()+validatePackage pkg = do+  let path = pkgYamlPath pkg+      pkgId = pkgMemberId pkg++  currentPkg <- readYaml path :: ConfigT Package+  expectedVersion <- askVersion++  let currentVersion = version currentPkg+      versionMatch = currentVersion == expectedVersion+  diffs <- packageDiffs pkgId path currentPkg++  unless versionMatch+    $ injectIssue+      Issue+        { issueTopic = pkgId,+          issueMessage = "version mismatch: " <> format currentVersion <> " → " <> format expectedVersion,+          issueSeverity = SeverityWarning,+          issueDetails = Just GenericIssue {issueFile = path}+        }++  unless (null diffs)+    $ injectIssue+      Issue+        { issueTopic = pkgId,+          issueMessage =+            let baseMsg =+                  if versionMatch+                    then "package out of sync (run 'hwm sync' to fix)"+                    else "package configuration diverged from expected (run 'hwm sync')"+                diffCount = length diffs+                countSuffix = if diffCount > 0 then " (" <> show diffCount <> " dependencies differ)" else ""+             in baseMsg <> countSuffix,+          issueSeverity = SeverityWarning,+          issueDetails =+            Just+              DependencyIssue+                { issueDependencies = map (\(scope, depName, actual, expected) -> (scope, format depName, format actual, format expected)) diffs,+                  issueFile = path+                }+        }
+ src/HWM/Integrations/Toolchain/Stack.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Integrations.Toolchain.Stack+  ( Stack (..),+    syncStackYaml,+    createEnvYaml,+    stackPath,+    sdist,+    upload,+    parseExtraDeps,+    scanStackFiles,+    buildMatrix,+  )+where++import Control.Monad.Except+import Data.Aeson+  ( FromJSON (..),+    ToJSON (..),+    genericParseJSON,+    genericToJSON,+  )+import qualified Data.Map as Map+import Data.Text (pack)+import qualified Data.Text as T+import HWM.Core.Common (Name)+import HWM.Core.Formatting (Format (..), Status (..), indentBlockNum, slugify)+import HWM.Core.Options (Options (..), askOptions)+import HWM.Core.Parsing (Parse (..))+import HWM.Core.Pkg (Pkg (..), PkgName, pkgId, pkgYamlPath)+import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..), fromEither)+import HWM.Core.Version (Version, parseGHCVersion)+import HWM.Domain.ConfigT (ConfigT)+import HWM.Domain.Matrix (BuildEnv (..), BuildEnvironment (..), Matrix (..), getBuildEnvironment, hkgRefs)+import HWM.Runtime.Cache (getSnapshotGHC)+import HWM.Runtime.Files (aesonYAMLOptions, readYaml, rewrite_)+import HWM.Runtime.Logging (log)+import Relude hiding (head, tail)+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.Exit (ExitCode (..))+import System.FilePath (dropExtension, (</>))+import System.FilePath.Glob (compile, globDir1)+import System.FilePath.Posix (takeFileName)+import System.Process (readProcessWithExitCode)++data Stack = Stack+  { packages :: [FilePath],+    resolver :: Name,+    allowNewer :: Maybe Bool,+    saveHackageCreds :: Maybe Bool,+    extraDeps :: Maybe [Name],+    compiler :: Maybe Text+  }+  deriving+    ( Show,+      Generic+    )++type VersionRegistry = Map PkgName Version++instance FromJSON Stack where+  parseJSON = genericParseJSON aesonYAMLOptions++instance ToJSON Stack where+  toJSON = genericToJSON aesonYAMLOptions++parseExtraDeps :: (MonadError Issue m) => [Text] -> m (Maybe VersionRegistry)+parseExtraDeps [] = pure Nothing+parseExtraDeps entries = do+  parsed <- traverse parseExtraDep entries+  if null parsed then throwError "No valid extra dependencies found" else pure $ Just $ Map.fromList parsed++parseExtraDep :: (MonadError Issue m) => Text -> m (PkgName, Version)+parseExtraDep entry = do+  let (namePart, versionPart) = T.breakOnEnd "-" entry+      segment = T.dropEnd 1 namePart+  when (T.null segment || T.null versionPart)+    $ throwError "Invalid extra-dep format: missing package segment or version part"+  pkgName <- fromEither ("Invalid package name: " <> segment) (parse segment)+  version <- fromEither ("Invalid version: " <> versionPart) (parse versionPart)+  pure (pkgName, version)++syncStackYaml :: ConfigT ()+syncStackYaml = do+  stackYamlPath <- stack <$> askOptions+  rewrite_ stackYamlPath $ const $ do+    BuildEnvironment {buildPkgs, buildEnv = BuildEnv {..}} <- getBuildEnvironment Nothing+    pure+      Stack+        { saveHackageCreds = Just False,+          extraDeps = map format . sort . hkgRefs <$> extraDeps,+          packages = map pkgDirPath buildPkgs,+          compiler = Nothing,+          ..+        }++stackPath :: Maybe Name -> ConfigT FilePath+stackPath (Just name) = pure $ ".hwm/matrix/stack-" <> toString name <> ".yaml"+stackPath Nothing = stack <$> askOptions++createEnvYaml :: Name -> ConfigT ()+createEnvYaml target = do+  path <- stackPath (Just target)+  liftIO $ createDirectoryIfMissing True ".hwm/matrix/"+  rewrite_ path $ const $ do+    BuildEnvironment {buildEnv = BuildEnv {..}, ..} <- getBuildEnvironment (Just target)+    pure+      Stack+        { saveHackageCreds = Just False,+          extraDeps = map format . sort . hkgRefs <$> buildExtraDeps,+          packages = map (("../../" <>) . pkgDirPath) buildPkgs,+          compiler = Nothing,+          ..+        }++runStack :: [String] -> ConfigT (Bool, String)+runStack args = do+  (code, _, out) <- liftIO (readProcessWithExitCode "stack" args "")+  case code of+    ExitSuccess {} -> pure (True, out)+    ExitFailure {} -> pure (False, out)++sdist :: Pkg -> ConfigT [Issue]+sdist pkg = do+  let issueTopic = pkgMemberId pkg+      issueMessage = "stack sdist detected Issues. No packages were published."+  (isSuccess, out) <- runStack ["sdist", toString (pkgName pkg)]+  let severity = if isSuccess then findIssue out else Just SeverityError+  case severity of+    Nothing -> pure []+    Just issueSeverity -> do+      issueFile <- log "sdist" [("COMMAND", "stack sdist " <> format (pkgName pkg)), ("SEVERITY", show issueSeverity)] (pack out)+      let issueDetails = Just GenericIssue {issueFile}+       in pure [Issue {..}]++upload :: Pkg -> ConfigT (Status, [Issue])+upload pkg = do+  (isSuccess, out) <- runStack ["upload", toString (pkgName pkg)]+  ( if isSuccess+      then pure (Checked, [])+      else+        ( do+            pure+              ( Invalid,+                [ Issue+                    { issueTopic = pkgMemberId pkg,+                      issueMessage = "Package publishing failed:" <> indentBlockNum 4 ("\n\n" <> T.pack out),+                      issueSeverity = SeverityError,+                      issueDetails = Just GenericIssue {issueFile = pkgYamlPath pkg}+                    }+                ]+              )+        )+    )++findIssue :: String -> Maybe Severity+findIssue str =+  let ls = map T.strip $ T.lines $ T.toLower $ T.pack str+   in case find ("error:" `T.isInfixOf`) ls of+        Just _ -> Just SeverityError+        Nothing -> case find ("warning:" `T.isInfixOf`) ls of+          Just _ -> Just SeverityWarning+          Nothing -> Nothing++scanStackFiles :: (MonadIO m, MonadError Issue m) => Options -> FilePath -> m (NonEmpty (Name, Stack))+scanStackFiles opts root = do+  let defaultPath = root </> stack opts+  defaultExists <- liftIO $ doesFileExist defaultPath+  variantPaths <- liftIO $ globDir1 (compile "stack-*.yaml") root+  stacks <- traverse loadEnv ([defaultPath | defaultExists] <> variantPaths)+  case stacks of+    [] -> throwError "No stack.yaml found in current directory. Run 'stack init' first or ensure you're in a Stack project"+    (defaultEnv : envs) -> pure (defaultEnv :| envs)+  where+    loadEnv path = do+      seConfig <- readYaml path+      let stackName = fromMaybe "default" (deriveEnviromentName path)+      pure (stackName, seConfig)++deriveEnviromentName :: FilePath -> Maybe Text+deriveEnviromentName path = slugify <$> T.stripPrefix "stack-" (toText (dropExtension (takeFileName path)))++buildMatrix :: (MonadIO m, MonadError Issue m) => [Pkg] -> NonEmpty (Name, Stack) -> m Matrix+buildMatrix pkgs (defaultEnv :| envs) = do+  environments <- sortOn ghc <$> traverse (inferBuildEnv pkgs) (defaultEnv : envs)+  pure Matrix {defaultEnvironment = fst defaultEnv, environments}++inferBuildEnv :: (MonadIO m, MonadError Issue m) => [Pkg] -> (Name, Stack) -> m BuildEnv+inferBuildEnv allPkgs (name, Stack {extraDeps = deps, ..}) = do+  ghc <- maybe (getSnapshotGHC resolver) (fromEither "GHC Parsing" . parseGHCVersion) compiler+  extraDeps <- parseExtraDeps (fromMaybe [] deps)+  let excludeList = filter ((`notElem` packages) . pkgDirPath) allPkgs+      exclude = if null excludeList then Nothing else Just (map pkgId excludeList)+  pure BuildEnv {..}
+ src/HWM/Runtime/Cache.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Runtime.Cache+  ( Cache,+    Registry (..),+    askCache,+    getRegistry,+    updateRegistry,+    modifyCache,+    loadCache,+    saveCache,+    getVersions,+    Versions,+    VersionMap,+    clearVersions,+    prepareDir,+    getSnapshotGHC,+    Snapshot (..),+  )+where++import qualified Control.Concurrent.STM as STM+import Control.Monad.Except (MonadError (..))+import Data.Aeson (FromJSON, ToJSON, eitherDecode, (.:))+import qualified Data.Aeson as Aeson+import Data.Aeson.Types (withObject)+import qualified Data.ByteString.Lazy as BL+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Text as T+import Data.Yaml (decodeEither', prettyPrintParseException)+import HWM.Core.Common (Name)+import HWM.Core.Formatting (Format (..))+import HWM.Core.Has (Has, askEnv)+import HWM.Core.Parsing (genUrl)+import HWM.Core.Pkg (PkgName)+import HWM.Core.Result (Issue, Result (..), ResultT (..))+import HWM.Core.Version (Version, parseGHCVersion)+import HWM.Runtime.Files (select)+import Network.HTTP.Req (GET (..), LbsResponse, NoReqBody (..), Option, Req, Url, defaultHttpConfig, lbsResponse, req, responseBody, runReq, useURI)+import Relude+import System.Directory (createDirectoryIfMissing, doesFileExist)+import Text.URI (mkURI)++askCache :: (MonadReader env m, Has env Cache) => m Cache+askCache = askEnv++data Registry = Registry+  { currentEnv :: Name,+    versions :: Map PkgName Versions+  }+  deriving (Generic, Show, FromJSON, ToJSON)++newtype Cache = Cache (STM.TVar Registry)++type Versions = NonEmpty Version++type VersionMap = Map PkgName Version++cacheDir :: FilePath+cacheDir = ".hwm/cache"++path :: FilePath+path = cacheDir <> "/state.json"++initRegistry :: Name -> Registry+initRegistry t = Registry {currentEnv = t, versions = mempty}++loadCache :: Name -> IO Cache+loadCache t = do+  exists <- doesFileExist path+  vm <-+    if exists+      then do+        bs <- BL.readFile path+        case Aeson.decode bs of+          Just vm' -> pure vm'+          Nothing -> pure (initRegistry t)+      else pure (initRegistry t)+  Cache <$> STM.newTVarIO vm++readCache :: Cache -> IO Registry+readCache (Cache tvar) = STM.readTVarIO tvar++modifyCache :: (MonadIO m) => Cache -> (Registry -> Registry) -> m ()+modifyCache (Cache tvar) f = liftIO $ STM.atomically $ STM.modifyTVar' tvar f++saveCache :: Cache -> IO ()+saveCache cache = do+  vm <- readCache cache+  createDirectoryIfMissing True cacheDir+  BL.writeFile path (Aeson.encode vm)++getRegistry :: (MonadReader env m, Has env Cache, MonadIO m) => m Registry+getRegistry = do+  Cache tvar <- askCache+  liftIO $ STM.readTVarIO tvar++updateRegistry :: (MonadReader env m, Has env Cache, MonadIO m) => (Registry -> Registry) -> m ()+updateRegistry f = do+  c <- askCache+  modifyCache c f++clearVersions :: (MonadReader env m, Has env Cache, MonadIO m) => m ()+clearVersions = updateRegistry (\reg -> reg {versions = mempty})++getReq :: (Url s, Option s) -> Req LbsResponse+getReq (u, o) = req GET u NoReqBody lbsResponse o++parse :: (MonadError Issue m) => Text -> m (Req LbsResponse)+parse url = do+  uri <- maybe (throwError $ fromString $ "Invalid Endpoint: " <> toString url <> "!") pure (mkURI url >>= useURI)+  pure (either getReq getReq uri)++http :: (MonadError Issue m, MonadIO m) => Text -> [Text] -> m BL.ByteString+http dom p = do+  request <- parse (genUrl dom p)+  responseBody <$> liftIO (runReq defaultHttpConfig request)++hackage :: (MonadIO m, MonadError Issue m) => Text -> m (Map Name (NonEmpty Version))+hackage name = http "https://hackage.haskell.org/package" [format name, "preferred.json"] >>= either (throwError . fromString) pure . eitherDecode++getVersions :: (MonadIO m, MonadError Issue m, MonadReader env m, Has env Cache) => PkgName -> m Versions+getVersions name = do+  Cache tvar <- askCache+  r <- liftIO $ STM.readTVarIO tvar+  case Map.lookup name (versions r) of+    Just vs -> pure vs+    Nothing -> do+      vs <- hackage (format name) >>= select "Field" "normal-version"+      modifyCache (Cache tvar) (\reg -> reg {versions = Map.singleton name vs <> versions reg})+      pure vs++prepareDir :: (MonadIO m) => FilePath -> m ()+prepareDir dir = liftIO $ createDirectoryIfMissing True dir++newtype Snapshot = Snapshot {snapshotCompiler :: Text}+  deriving (Show)++instance FromJSON Snapshot where+  parseJSON = withObject "Snapshot" $ \v -> Snapshot <$> (v .: "resolver" >>= (.: "compiler"))++genName :: (MonadError Issue m) => Text -> m [Text]+genName resolver+  | Just ltsNum <- T.stripPrefix "lts-" resolver = buildSegments "lts" "." ltsNum+  | Just nightlyDate <- T.stripPrefix "nightly-" resolver = buildSegments "nightly" "-" nightlyDate+  | otherwise = throwError $ fromString $ "Unsupported resolver: " <> toString resolver+  where+    buildSegments prefix delimiter value =+      case NE.nonEmpty (T.splitOn delimiter value) of+        Nothing -> throwError $ fromString $ "Malformed resolver: " <> toString resolver+        Just parts ->+          let segments = NE.init parts+              lastPart = NE.last parts+           in pure (prefix : segments <> [lastPart <> ".yaml"])++getSnapshotGHC :: (MonadIO m, MonadError Issue m) => Text -> m Version+getSnapshotGHC name = do+  pathSegments <- genName name+  body <- runResultT (http "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master" pathSegments)+  case body of+    Failure {failure} -> throwError $ fromString $ "HTTP Error: " <> show failure+    Success {result} -> case decodeEither' (BL.toStrict result) of+      Left err -> throwError $ fromString $ "Snapshot Error: " <> prettyPrintParseException err+      Right snapshot -> either (throwError . fromString) pure (parseGHCVersion (snapshotCompiler snapshot))
+ src/HWM/Runtime/Files.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Runtime.Files+  ( readYaml,+    rewrite_,+    statusM,+    aesonYAMLOptions,+    select,+    remove,+    addHash,+    forbidOverride,+    cleanRelativePath,+  )+where++import Control.Exception (catch, throwIO, tryJust)+import Control.Monad.Error.Class (MonadError (..))+import Data.Aeson+  ( FromJSON (..),+    Object,+    Options (..),+    ToJSON (..),+    Value (..),+    defaultOptions,+  )+import Data.ByteString (readFile, writeFile)+import Data.Char (isUpper, toLower)+import Data.List (elemIndex, stripPrefix)+import Data.Map (lookup)+import Data.Text (toTitle)+import qualified Data.Text.Encoding as T+import Data.Yaml (decodeThrow)+import Data.Yaml.Pretty (defConfig, encodePretty, setConfCompare, setConfDropNull)+import HWM.Core.Formatting+import HWM.Core.Result (Issue)+import Relude hiding (readFile, writeFile)+import System.Directory (doesFileExist, removeFile)+import System.FilePath (joinPath, splitDirectories)+import System.IO.Error (isDoesNotExistError)++printException :: SomeException -> String+printException = show++safeIO :: IO a -> IO (Either String a)+safeIO = tryJust (Just . printException)++remove :: (MonadIO m) => FilePath -> m ()+remove file = liftIO $ removeFile file `catch` (\e -> unless (isDoesNotExistError e) (throwIO e))++safeRead :: (MonadIO m) => FilePath -> m (Either String ByteString)+safeRead = liftIO . safeIO . readFile++safeWrite :: (MonadIO m) => FilePath -> ByteString -> m (Either String ())+safeWrite file content = liftIO $ safeIO (writeFile file content)++serializeYaml :: (ToJSON a) => a -> ByteString+serializeYaml =+  encodePretty+    $ setConfDropNull True+    $ setConfCompare compareFields defConfig++data Yaml t = Yaml+  { getData :: t,+    rawValue :: Object+  }+  deriving (Generic)++instance (FromJSON t) => FromJSON (Yaml t) where+  parseJSON v = Yaml <$> parseJSON v <*> parseJSON v++instance (ToJSON t) => ToJSON (Yaml t) where+  toJSON (Yaml t v) = Object (toObject (toJSON t) <> v)++toObject :: Value -> Object+toObject (Object x) = x+toObject _ = mempty++mapYaml :: (Functor m) => (Maybe t -> m t) -> Maybe (Yaml t) -> m (Yaml t)+mapYaml f (Just (Yaml v props)) = (`Yaml` props) <$> f (Just v)+mapYaml f Nothing = (`Yaml` mempty) <$> f Nothing++fromEither :: (MonadError Issue m, FromJSON b, MonadIO m) => Either a ByteString -> m (Maybe b)+fromEither = either (const $ pure Nothing) (fmap Just . liftIO . decodeThrow)++withThrow :: (MonadError Issue m) => m (Either String a) -> m a+withThrow x = x >>= either (throwError . fromString) pure++rewrite_ :: (MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) => FilePath -> (Maybe t -> m t) -> m ()+rewrite_ pkg f = do+  original <- safeRead pkg+  yaml <- fromEither original >>= mapYaml f+  withThrow (safeWrite pkg (serializeYaml yaml))++statusM :: (MonadIO m) => FilePath -> m t -> m Status+statusM pkg m = do+  before <- safeRead pkg+  _ <- m+  after <- safeRead pkg+  pure (if before == after then Checked else Updated)++readYaml :: (MonadError Issue m, MonadIO m, FromJSON a) => FilePath -> m a+readYaml = withThrow . safeRead >=> (liftIO . decodeThrow)++fields :: [Text]+fields =+  map+    toTitle+    [ "name",+      "version",+      "github",+      "license",+      "author",+      "category",+      "synopsis",+      "maintainer",+      "homepage",+      "copyright",+      "license-file",+      "description",+      "bounds",+      "ghc",+      "resolver",+      "packages",+      "workspace",+      "builds",+      "extra-source-files",+      "data-files",+      "main",+      "source-dirs",+      "ghc-options",+      "dependencies",+      "library",+      "executables",+      "include",+      "exclude",+      "allow-newer",+      "save-hackage-creds",+      "extra-deps",+      "stackYaml",+      "components",+      "path",+      "component"+    ]++toPriority :: Text -> Int+toPriority = fromMaybe (length fields) . (`elemIndex` fields)++mapTuple :: (a -> b) -> (b -> b -> c) -> a -> a -> c+mapTuple f g a b = g (f a) (f b)++compareFields :: Text -> Text -> Ordering+compareFields = mapTuple toTitle (mapTuple toPriority compare <> compare)++toKebabCase :: String -> String+toKebabCase = concatMap toKebab+  where+    toKebab x+      | isUpper x = ['-', toLower x]+      | otherwise = [x]++aesonYAMLOptions :: Options+aesonYAMLOptions = defaultOptions {fieldLabelModifier = toKebabCase, omitNothingFields = True}++select :: (MonadError Issue m, Format t, Ord t) => Text -> t -> Map t a -> m a+select e k = maybe (throwError $ fromString $ "Unknown " <> toString e <> ": " <> toString (format k) <> "!") pure . lookup k++addHash :: (MonadIO m) => FilePath -> Text -> m ()+addHash filePath hash = do+  content <- liftIO $ T.decodeUtf8 <$> readFileBS filePath+  let contentWithHash = "# hash: " <> hash <> "\n" <> content+  liftIO $ writeFileBS filePath (T.encodeUtf8 contentWithHash)++forbidOverride :: (MonadIO m, MonadError e m, IsString e) => FilePath -> m ()+forbidOverride path = do+  exists <- liftIO $ doesFileExist path+  when exists $ throwError $ fromString $ "File \"" <> path <> "\" already exists!"++cleanRelativePath :: Maybe String -> Maybe String+cleanRelativePath Nothing = Nothing+cleanRelativePath (Just "") = Nothing+cleanRelativePath (Just "./") = Nothing+cleanRelativePath (Just ".") = Nothing+cleanRelativePath (Just name) =+  Just+    $ joinPath+    $ splitDirectories+    $ fromMaybe name (stripPrefix "./" name)
+ src/HWM/Runtime/Logging.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Runtime.Logging+  ( logRoot,+    logPath,+    log,+    logError,+  )+where++import Data.Time (getCurrentTime)+import HWM.Core.Common (Name)+import Relude+import qualified System.IO as TIO++logRoot :: FilePath+logRoot = ".hwm/logs"++logPath :: Name -> FilePath+logPath name = logRoot <> "/" <> toString name <> ".log"++log :: (MonadIO m) => Name -> [(Text, Text)] -> Text -> m FilePath+log name table content = do+  timestamp <- liftIO getCurrentTime+  let logInfo = [("TIMESTAMP", show timestamp)]+  let path = logPath name+  let boxTop = "┌──────────────────────────────────────────────────────────"+      boxBottom = "└──────────────────────────────────────────────────────────"+      rows = map (\(k, v) -> "│ " <> k <> ": " <> v) (table <> logInfo)+      header = unlines (boxTop : rows <> [boxBottom, "", content, ""])+  liftIO $ TIO.appendFile path (toString header)+  pure path++logError :: (MonadIO m) => Name -> [(Text, Text)] -> Text -> m FilePath+logError name table = log name (table <> [("TYPE", "ERROR")])
+ src/HWM/Runtime/Process.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Runtime.Process+  ( silentRun,+    inheritRun,+  )+where++import Control.Concurrent.Async+import qualified Data.Text as T+import GHC.IO (evaluate)+import Relude+import System.Environment (getEnvironment)+import qualified System.IO as TIO+import System.Process.Typed++provideYamlPath :: (MonadIO m) => String -> m [(String, String)]+provideYamlPath yamlPath = do+  currentEnv <- liftIO getEnvironment+  pure (("STACK_YAML", yamlPath) : currentEnv)++silentRun :: (MonadIO m) => FilePath -> Text -> IO (Async a) -> m (Bool, Text)+silentRun yamlPath cmd spinnerM = do+  targetEnv <- provideYamlPath yamlPath+  let pc = setEnv targetEnv $ setStdout createPipe $ setStderr createPipe $ shell (toString cmd)+  liftIO+    $ withProcessWait pc+    $ \p -> do+      spinner <- spinnerM+      status <- waitExitCode p+      errCapture <- async $ do+        content <- TIO.hGetContents (getStderr p)+        evaluate (force content)+      cancel spinner+      rawLogsText <- wait errCapture+      let logsText = T.pack rawLogsText+      case status of+        ExitSuccess -> do+          pure (True, logsText)+        _ -> do+          pure (False, logsText)++inheritRun :: (MonadIO m) => FilePath -> Text -> m ()+inheritRun yamlPath cmd = do+  targetEnv <- provideYamlPath yamlPath+  let processConfig = setEnv targetEnv $ proc "/bin/sh" ["-c", toString cmd]+  liftIO (runProcess_ processConfig)
+ src/HWM/Runtime/UI.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module HWM.Runtime.UI+  ( MonadUI (..),+    UIT,+    runUIT,+    runUI,+    putLine,+    indent,+    section,+    sectionWorkspace,+    sectionEnvironments,+    sectionConfig,+    sectionTableM,+    forTable,+    printSummary,+    statusIndicator,+    runSpinner,+  )+where++import Control.Concurrent (threadDelay)+import Control.Monad.Error.Class (MonadError)+import Control.Monad.Except (MonadError (..))+import Data.List (groupBy, maximum)+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import HWM.Core.Formatting (Color (..), Format (..), Status (..), chalk, indentBlockNum, padDots, renderSummaryStatus, subPathSign)+import HWM.Core.Result+  ( Issue (..),+    IssueDetails (..),+    ResultT (..),+    Severity (..),+  )+import Relude+import System.Console.ANSI (clearLine, setCursorColumn)++data UIContext m = UIContext+  { uiWriter :: Text -> m (),+    uiIndent :: Int+  }++newtype UIT m a = UIT {_unUIT :: ReaderT (UIContext m) m a}+  deriving newtype (Functor, Applicative, Monad, MonadIO)++instance MonadTrans UIT where+  lift = UIT . lift++instance (MonadError err m) => MonadError err (UIT m) where+  throwError = UIT . lift . throwError+  catchError (UIT action) handler = UIT $ ReaderT $ \ctx ->+    catchError (runReaderT action ctx) (\e -> runReaderT (_unUIT (handler e)) ctx)++runUIT :: (Monad m) => (Text -> m ()) -> UIT m a -> m a+runUIT writer (UIT action) =+  let ctx = UIContext {uiWriter = writer, uiIndent = 0}+   in runReaderT action ctx++runUI :: UIT IO a -> IO a+runUI = runUIT (putStr . toString)++class (Monad m) => MonadUI m where+  uiWrite :: Text -> m ()+  uiIndentLevel :: m Int+  uiWithIndent :: (Int -> Int) -> m a -> m a++instance (Monad m) => MonadUI (UIT m) where+  uiWrite txt = UIT $ do+    UIContext {uiWriter} <- ask+    lift (uiWriter txt)+  uiIndentLevel = UIT $ asks uiIndent+  uiWithIndent f (UIT action) = UIT $ local adjust action+    where+      adjust ctx = ctx {uiIndent = f (uiIndent ctx)}++instance (MonadUI m) => MonadUI (ResultT m) where+  uiWrite txt = lift (uiWrite txt)+  uiIndentLevel = lift uiIndentLevel+  uiWithIndent f (ResultT action) = ResultT $ uiWithIndent f action++putLine :: (MonadUI m) => Text -> m ()+putLine txt = do+  level <- uiIndentLevel+  uiWrite (indentBlockNum level (txt <> "\n"))++indent :: (MonadUI m) => Int -> m a -> m a+indent amount = uiWithIndent (+ amount)++sectionWithIcon :: (MonadUI m) => Text -> Text -> m a -> m ()+sectionWithIcon emoji title action = do+  putLine ""+  putLine (emoji <> " " <> chalk Bold title)+  indent 1 action $> ()++section :: (MonadUI m) => Text -> m a -> m ()+section = sectionWithIcon "•"++sectionWorkspace :: (MonadUI m) => m a -> m ()+sectionWorkspace = sectionWithIcon "./" "workspace"++sectionEnvironments :: (MonadUI m) => m a -> m ()+sectionEnvironments = section "environments"++tableM :: (MonadUI m) => Int -> [(Text, m Text)] -> m ()+tableM minSize rows = traverse_ formatRow rows+  where+    maxLabelLen = maximum (minSize : map (T.length . fst) rows) + 2+    formatRow (label, valueM) = do+      value <- valueM+      putLine $ padDots maxLabelLen label <> value++sectionTableM :: (MonadUI m) => Int -> Text -> [(Text, m Text)] -> m ()+sectionTableM size title = section title . tableM size++sectionConfig :: (MonadUI m) => Int -> [(Text, m Text)] -> m ()+sectionConfig size = section "config" . tableM size++forTable :: (MonadUI m) => Int -> [a] -> (a -> (Text, Text)) -> m ()+forTable minSize rows f =+  tableM minSize (map (second pure . f) rows)++isError :: Issue -> Bool+isError i = issueSeverity i == SeverityError++renderSummaryLines :: [Issue] -> [Text]+renderSummaryLines [] = ["", renderSummaryStatus Checked, ""]+renderSummaryLines issues =+  let headerLine =+        if any isError issues+          then renderSummaryStatus Invalid+          else renderSummaryStatus Warning+      grouped = groupBy ((==) `on` issueTopic) (sortOn issueTopic issues)+      renderGroup [] = []+      renderGroup pkgIssues@(Issue {issueTopic = header} : _) =+        let l1 = "  "+            step = l1 <> subPathSign <> chalk Dim "• "+            l2 = l1 <> "    " <> subPathSign+            headerText = l1 <> chalk Dim "• " <> chalk Bold header+            renderIssue Issue {issueDetails = Nothing, issueSeverity, issueMessage} =+              [step <> chalk (levelColor issueSeverity) issueMessage]+            renderIssue Issue {issueDetails = Just (GenericIssue {issueFile}), issueSeverity, issueMessage} =+              [ step <> chalk (levelColor issueSeverity) issueMessage,+                l2 <> chalk Dim ("file: " <> format issueFile)+              ]+            renderIssue Issue {issueDetails = Just (CommandIssue {issueCommand, issueLogFile}), issueSeverity, issueMessage} =+              let cmd =+                    if T.length issueCommand > 60+                      then T.take 60 issueCommand <> chalk Dim "..."+                      else issueCommand+               in [ step <> chalk (levelColor issueSeverity) (issueMessage <> ": ") <> cmd,+                    l2 <> chalk Dim ("logs: " <> format issueLogFile)+                  ]+            renderIssue Issue {issueDetails = Just (DependencyIssue {issueDependencies, issueFile}), issueSeverity, issueMessage} =+              let groupedDeps = Map.toList $ Map.fromListWith (++) [(scope, [(depName, actual, expected)]) | (scope, depName, actual, expected) <- issueDependencies]+                  depLines = concatMap formatGroup groupedDeps+                  formatGroup (scope, deps) =+                    (l2 <> chalk Dim "• " <> chalk Dim scope) : map formatDepLine deps+                  formatDepLine (depName, actual, expected) =+                    l1 <> "        " <> subPathSign <> depName <> ": " <> chalk Dim (actual <> " → " <> expected)+               in step <> chalk (levelColor issueSeverity) issueMessage+                    : l2 <> chalk Dim ("file: " <> format issueFile)+                    : depLines+            detailLines = concatMap renderIssue pkgIssues+         in headerText : detailLines+   in ["", headerLine, ""] <> concatMap renderGroup grouped <> [""]++levelColor :: Severity -> Color+levelColor SeverityError = Red+levelColor SeverityWarning = Yellow++printSummary :: (MonadUI m) => [Issue] -> m ()+printSummary = traverse_ putLine . renderSummaryLines++statusIndicator :: (MonadIO m) => Int -> Text -> Text -> m ()+statusIndicator padding prefix msg = do+  liftIO clearLine+  liftIO $ setCursorColumn 0+  liftIO $ putStr $ toString $ "  " <> padDots padding prefix <> msg+  liftIO $ hFlush stdout++runSpinner :: (MonadIO m) => Int -> Text -> m ()+runSpinner padding prefix = loop ["◜", "◠", "◝", "◞", "◡", "◟"]+  where+    loop (f : fs) = do+      statusIndicator padding prefix f+      liftIO $ threadDelay 200000 -- 200ms+      loop (fs ++ [f])+    loop [] = pure ()