{-# 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
  { Stack -> [FilePath]
packages :: [FilePath],
    Stack -> Text
resolver :: Name,
    Stack -> Maybe Bool
allowNewer :: Maybe Bool,
    Stack -> Maybe Bool
saveHackageCreds :: Maybe Bool,
    Stack -> Maybe [Text]
extraDeps :: Maybe [Name],
    Stack -> Maybe Text
compiler :: Maybe Text
  }
  deriving
    ( Int -> Stack -> ShowS
[Stack] -> ShowS
Stack -> FilePath
(Int -> Stack -> ShowS)
-> (Stack -> FilePath) -> ([Stack] -> ShowS) -> Show Stack
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Stack -> ShowS
showsPrec :: Int -> Stack -> ShowS
$cshow :: Stack -> FilePath
show :: Stack -> FilePath
$cshowList :: [Stack] -> ShowS
showList :: [Stack] -> ShowS
Show,
      (forall x. Stack -> Rep Stack x)
-> (forall x. Rep Stack x -> Stack) -> Generic Stack
forall x. Rep Stack x -> Stack
forall x. Stack -> Rep Stack x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Stack -> Rep Stack x
from :: forall x. Stack -> Rep Stack x
$cto :: forall x. Rep Stack x -> Stack
to :: forall x. Rep Stack x -> Stack
Generic
    )

type VersionRegistry = Map PkgName Version

instance FromJSON Stack where
  parseJSON :: Value -> Parser Stack
parseJSON = Options -> Value -> Parser Stack
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
aesonYAMLOptions

instance ToJSON Stack where
  toJSON :: Stack -> Value
toJSON = Options -> Stack -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
aesonYAMLOptions

parseExtraDeps :: (MonadError Issue m) => [Text] -> m (Maybe VersionRegistry)
parseExtraDeps :: forall (m :: * -> *).
MonadError Issue m =>
[Text] -> m (Maybe VersionRegistry)
parseExtraDeps [] = Maybe VersionRegistry -> m (Maybe VersionRegistry)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe VersionRegistry
forall a. Maybe a
Nothing
parseExtraDeps [Text]
entries = do
  [(PkgName, Version)]
parsed <- (Text -> m (PkgName, Version)) -> [Text] -> m [(PkgName, Version)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Text -> m (PkgName, Version)
forall (m :: * -> *).
MonadError Issue m =>
Text -> m (PkgName, Version)
parseExtraDep [Text]
entries
  if [(PkgName, Version)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PkgName, Version)]
parsed then Issue -> m (Maybe VersionRegistry)
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Issue
"No valid extra dependencies found" else Maybe VersionRegistry -> m (Maybe VersionRegistry)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe VersionRegistry -> m (Maybe VersionRegistry))
-> Maybe VersionRegistry -> m (Maybe VersionRegistry)
forall a b. (a -> b) -> a -> b
$ VersionRegistry -> Maybe VersionRegistry
forall a. a -> Maybe a
Just (VersionRegistry -> Maybe VersionRegistry)
-> VersionRegistry -> Maybe VersionRegistry
forall a b. (a -> b) -> a -> b
$ [(PkgName, Version)] -> VersionRegistry
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PkgName, Version)]
parsed

parseExtraDep :: (MonadError Issue m) => Text -> m (PkgName, Version)
parseExtraDep :: forall (m :: * -> *).
MonadError Issue m =>
Text -> m (PkgName, Version)
parseExtraDep Text
entry = do
  let (Text
namePart, Text
versionPart) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"-" Text
entry
      segment :: Text
segment = Int -> Text -> Text
T.dropEnd Int
1 Text
namePart
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
segment Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
versionPart)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Issue -> m ()
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Issue
"Invalid extra-dep format: missing package segment or version part"
  PkgName
pkgName <- Text -> Either FilePath PkgName -> m PkgName
forall (m :: * -> *) a.
MonadError Issue m =>
Text -> Either FilePath a -> m a
fromEither (Text
"Invalid package name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
segment) (Text -> Either FilePath PkgName
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m PkgName
parse Text
segment)
  Version
version <- Text -> Either FilePath Version -> m Version
forall (m :: * -> *) a.
MonadError Issue m =>
Text -> Either FilePath a -> m a
fromEither (Text
"Invalid version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
versionPart) (Text -> Either FilePath Version
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Version
parse Text
versionPart)
  (PkgName, Version) -> m (PkgName, Version)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PkgName
pkgName, Version
version)

syncStackYaml :: ConfigT ()
syncStackYaml :: ConfigT ()
syncStackYaml = do
  FilePath
stackYamlPath <- Options -> FilePath
stack (Options -> FilePath) -> ConfigT Options -> ConfigT FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigT Options
forall env (m :: * -> *).
(MonadReader env m, Has env Options) =>
m Options
askOptions
  FilePath -> (Maybe Stack -> ConfigT Stack) -> ConfigT ()
forall (m :: * -> *) t.
(MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) =>
FilePath -> (Maybe t -> m t) -> m ()
rewrite_ FilePath
stackYamlPath ((Maybe Stack -> ConfigT Stack) -> ConfigT ())
-> (Maybe Stack -> ConfigT Stack) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ ConfigT Stack -> Maybe Stack -> ConfigT Stack
forall a b. a -> b -> a
const (ConfigT Stack -> Maybe Stack -> ConfigT Stack)
-> ConfigT Stack -> Maybe Stack -> ConfigT Stack
forall a b. (a -> b) -> a -> b
$ do
    BuildEnvironment {[Pkg]
buildPkgs :: [Pkg]
buildPkgs :: BuildEnvironment -> [Pkg]
buildPkgs, buildEnv :: BuildEnvironment -> BuildEnv
buildEnv = BuildEnv {Maybe Bool
Maybe [Text]
Maybe VersionRegistry
Text
Version
name :: Text
ghc :: Version
resolver :: Text
extraDeps :: Maybe VersionRegistry
exclude :: Maybe [Text]
allowNewer :: Maybe Bool
allowNewer :: BuildEnv -> Maybe Bool
exclude :: BuildEnv -> Maybe [Text]
extraDeps :: BuildEnv -> Maybe VersionRegistry
resolver :: BuildEnv -> Text
ghc :: BuildEnv -> Version
name :: BuildEnv -> Text
..}} <- Maybe Text -> ConfigT BuildEnvironment
forall env (m :: * -> *).
(MonadReader env m, Has env Matrix, Has env [WorkspaceGroup],
 Has env Cache, MonadIO m, MonadError Issue m) =>
Maybe Text -> m BuildEnvironment
getBuildEnvironment Maybe Text
forall a. Maybe a
Nothing
    Stack -> ConfigT Stack
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Stack
        { saveHackageCreds :: Maybe Bool
saveHackageCreds = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
          extraDeps :: Maybe [Text]
extraDeps = (HkgRef -> Text) -> [HkgRef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map HkgRef -> Text
forall a. Format a => a -> Text
format ([HkgRef] -> [Text])
-> (VersionRegistry -> [HkgRef]) -> VersionRegistry -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HkgRef] -> [HkgRef]
forall a. Ord a => [a] -> [a]
sort ([HkgRef] -> [HkgRef])
-> (VersionRegistry -> [HkgRef]) -> VersionRegistry -> [HkgRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRegistry -> [HkgRef]
hkgRefs (VersionRegistry -> [Text])
-> Maybe VersionRegistry -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VersionRegistry
extraDeps,
          packages :: [FilePath]
packages = (Pkg -> FilePath) -> [Pkg] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Pkg -> FilePath
pkgDirPath [Pkg]
buildPkgs,
          compiler :: Maybe Text
compiler = Maybe Text
forall a. Maybe a
Nothing,
          Maybe Bool
Text
resolver :: Text
allowNewer :: Maybe Bool
resolver :: Text
allowNewer :: Maybe Bool
..
        }

stackPath :: Maybe Name -> ConfigT FilePath
stackPath :: Maybe Text -> ConfigT FilePath
stackPath (Just Text
name) = FilePath -> ConfigT FilePath
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> ConfigT FilePath) -> FilePath -> ConfigT FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
".hwm/matrix/stack-" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
name FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
".yaml"
stackPath Maybe Text
Nothing = Options -> FilePath
stack (Options -> FilePath) -> ConfigT Options -> ConfigT FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConfigT Options
forall env (m :: * -> *).
(MonadReader env m, Has env Options) =>
m Options
askOptions

createEnvYaml :: Name -> ConfigT ()
createEnvYaml :: Text -> ConfigT ()
createEnvYaml Text
target = do
  FilePath
path <- Maybe Text -> ConfigT FilePath
stackPath (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
target)
  IO () -> ConfigT ()
forall a. IO a -> ConfigT a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConfigT ()) -> IO () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
".hwm/matrix/"
  FilePath -> (Maybe Stack -> ConfigT Stack) -> ConfigT ()
forall (m :: * -> *) t.
(MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) =>
FilePath -> (Maybe t -> m t) -> m ()
rewrite_ FilePath
path ((Maybe Stack -> ConfigT Stack) -> ConfigT ())
-> (Maybe Stack -> ConfigT Stack) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ ConfigT Stack -> Maybe Stack -> ConfigT Stack
forall a b. a -> b -> a
const (ConfigT Stack -> Maybe Stack -> ConfigT Stack)
-> ConfigT Stack -> Maybe Stack -> ConfigT Stack
forall a b. (a -> b) -> a -> b
$ do
    BuildEnvironment {buildEnv :: BuildEnvironment -> BuildEnv
buildEnv = BuildEnv {Maybe Bool
Maybe [Text]
Maybe VersionRegistry
Text
Version
allowNewer :: BuildEnv -> Maybe Bool
exclude :: BuildEnv -> Maybe [Text]
extraDeps :: BuildEnv -> Maybe VersionRegistry
resolver :: BuildEnv -> Text
ghc :: BuildEnv -> Version
name :: BuildEnv -> Text
name :: Text
ghc :: Version
resolver :: Text
extraDeps :: Maybe VersionRegistry
exclude :: Maybe [Text]
allowNewer :: Maybe Bool
..}, [Pkg]
Maybe VersionRegistry
Text
buildPkgs :: BuildEnvironment -> [Pkg]
buildPkgs :: [Pkg]
buildName :: Text
buildExtraDeps :: Maybe VersionRegistry
buildResolver :: Text
buildResolver :: BuildEnvironment -> Text
buildExtraDeps :: BuildEnvironment -> Maybe VersionRegistry
buildName :: BuildEnvironment -> Text
..} <- Maybe Text -> ConfigT BuildEnvironment
forall env (m :: * -> *).
(MonadReader env m, Has env Matrix, Has env [WorkspaceGroup],
 Has env Cache, MonadIO m, MonadError Issue m) =>
Maybe Text -> m BuildEnvironment
getBuildEnvironment (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
target)
    Stack -> ConfigT Stack
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      Stack
        { saveHackageCreds :: Maybe Bool
saveHackageCreds = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False,
          extraDeps :: Maybe [Text]
extraDeps = (HkgRef -> Text) -> [HkgRef] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map HkgRef -> Text
forall a. Format a => a -> Text
format ([HkgRef] -> [Text])
-> (VersionRegistry -> [HkgRef]) -> VersionRegistry -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HkgRef] -> [HkgRef]
forall a. Ord a => [a] -> [a]
sort ([HkgRef] -> [HkgRef])
-> (VersionRegistry -> [HkgRef]) -> VersionRegistry -> [HkgRef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRegistry -> [HkgRef]
hkgRefs (VersionRegistry -> [Text])
-> Maybe VersionRegistry -> Maybe [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe VersionRegistry
buildExtraDeps,
          packages :: [FilePath]
packages = (Pkg -> FilePath) -> [Pkg] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath
"../../" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (Pkg -> FilePath) -> Pkg -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> FilePath
pkgDirPath) [Pkg]
buildPkgs,
          compiler :: Maybe Text
compiler = Maybe Text
forall a. Maybe a
Nothing,
          Maybe Bool
Text
resolver :: Text
allowNewer :: Maybe Bool
resolver :: Text
allowNewer :: Maybe Bool
..
        }

runStack :: [String] -> ConfigT (Bool, String)
runStack :: [FilePath] -> ConfigT (Bool, FilePath)
runStack [FilePath]
args = do
  (ExitCode
code, FilePath
_, FilePath
out) <- IO (ExitCode, FilePath, FilePath)
-> ConfigT (ExitCode, FilePath, FilePath)
forall a. IO a -> ConfigT a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath
-> [FilePath] -> FilePath -> IO (ExitCode, FilePath, FilePath)
readProcessWithExitCode FilePath
"stack" [FilePath]
args FilePath
"")
  case ExitCode
code of
    ExitSuccess {} -> (Bool, FilePath) -> ConfigT (Bool, FilePath)
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, FilePath
out)
    ExitFailure {} -> (Bool, FilePath) -> ConfigT (Bool, FilePath)
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, FilePath
out)

sdist :: Pkg -> ConfigT [Issue]
sdist :: Pkg -> ConfigT [Issue]
sdist Pkg
pkg = do
  let issueTopic :: Text
issueTopic = Pkg -> Text
pkgMemberId Pkg
pkg
      issueMessage :: Text
issueMessage = Text
"stack sdist detected Issues. No packages were published."
  (Bool
isSuccess, FilePath
out) <- [FilePath] -> ConfigT (Bool, FilePath)
runStack [FilePath
"sdist", PkgName -> FilePath
forall a. ToString a => a -> FilePath
toString (Pkg -> PkgName
pkgName Pkg
pkg)]
  let severity :: Maybe Severity
severity = if Bool
isSuccess then FilePath -> Maybe Severity
findIssue FilePath
out else Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
SeverityError
  case Maybe Severity
severity of
    Maybe Severity
Nothing -> [Issue] -> ConfigT [Issue]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just Severity
issueSeverity -> do
      FilePath
issueFile <- Text -> [(Text, Text)] -> Text -> ConfigT FilePath
forall (m :: * -> *).
MonadIO m =>
Text -> [(Text, Text)] -> Text -> m FilePath
log Text
"sdist" [(Text
"COMMAND", Text
"stack sdist " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PkgName -> Text
forall a. Format a => a -> Text
format (Pkg -> PkgName
pkgName Pkg
pkg)), (Text
"SEVERITY", Severity -> Text
forall b a. (Show a, IsString b) => a -> b
show Severity
issueSeverity)] (FilePath -> Text
pack FilePath
out)
      let issueDetails :: Maybe IssueDetails
issueDetails = IssueDetails -> Maybe IssueDetails
forall a. a -> Maybe a
Just GenericIssue {FilePath
issueFile :: FilePath
issueFile :: FilePath
issueFile}
       in [Issue] -> ConfigT [Issue]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Issue {Maybe IssueDetails
Text
Severity
issueTopic :: Text
issueMessage :: Text
issueSeverity :: Severity
issueDetails :: Maybe IssueDetails
issueDetails :: Maybe IssueDetails
issueMessage :: Text
issueSeverity :: Severity
issueTopic :: Text
..}]

upload :: Pkg -> ConfigT (Status, [Issue])
upload :: Pkg -> ConfigT (Status, [Issue])
upload Pkg
pkg = do
  (Bool
isSuccess, FilePath
out) <- [FilePath] -> ConfigT (Bool, FilePath)
runStack [FilePath
"upload", PkgName -> FilePath
forall a. ToString a => a -> FilePath
toString (Pkg -> PkgName
pkgName Pkg
pkg)]
  ( if Bool
isSuccess
      then (Status, [Issue]) -> ConfigT (Status, [Issue])
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status
Checked, [])
      else
        ( do
            (Status, [Issue]) -> ConfigT (Status, [Issue])
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              ( Status
Invalid,
                [ Issue
                    { issueTopic :: Text
issueTopic = Pkg -> Text
pkgMemberId Pkg
pkg,
                      issueMessage :: Text
issueMessage = Text
"Package publishing failed:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
indentBlockNum Int
4 (Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
out),
                      issueSeverity :: Severity
issueSeverity = Severity
SeverityError,
                      issueDetails :: Maybe IssueDetails
issueDetails = IssueDetails -> Maybe IssueDetails
forall a. a -> Maybe a
Just GenericIssue {issueFile :: FilePath
issueFile = Pkg -> FilePath
pkgYamlPath Pkg
pkg}
                    }
                ]
              )
        )
    )

findIssue :: String -> Maybe Severity
findIssue :: FilePath -> Maybe Severity
findIssue FilePath
str =
  let ls :: [Text]
ls = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
str
   in case (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text
"error:" Text -> Text -> Bool
`T.isInfixOf`) [Text]
ls of
        Just Text
_ -> Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
SeverityError
        Maybe Text
Nothing -> case (Text -> Bool) -> [Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text
"warning:" Text -> Text -> Bool
`T.isInfixOf`) [Text]
ls of
          Just Text
_ -> Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
SeverityWarning
          Maybe Text
Nothing -> Maybe Severity
forall a. Maybe a
Nothing

scanStackFiles :: (MonadIO m, MonadError Issue m) => Options -> FilePath -> m (NonEmpty (Name, Stack))
scanStackFiles :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Options -> FilePath -> m (NonEmpty (Text, Stack))
scanStackFiles Options
opts FilePath
root = do
  let defaultPath :: FilePath
defaultPath = FilePath
root FilePath -> ShowS
</> Options -> FilePath
stack Options
opts
  Bool
defaultExists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
defaultPath
  [FilePath]
variantPaths <- IO [FilePath] -> m [FilePath]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> m [FilePath]) -> IO [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ Pattern -> FilePath -> IO [FilePath]
globDir1 (FilePath -> Pattern
compile FilePath
"stack-*.yaml") FilePath
root
  [(Text, Stack)]
stacks <- (FilePath -> m (Text, Stack)) -> [FilePath] -> m [(Text, Stack)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FilePath -> m (Text, Stack)
forall {m :: * -> *} {b}.
(MonadError Issue m, MonadIO m, FromJSON b) =>
FilePath -> m (Text, b)
loadEnv ([FilePath
defaultPath | Bool
defaultExists] [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
<> [FilePath]
variantPaths)
  case [(Text, Stack)]
stacks of
    [] -> Issue -> m (NonEmpty (Text, Stack))
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Issue
"No stack.yaml found in current directory. Run 'stack init' first or ensure you're in a Stack project"
    ((Text, Stack)
defaultEnv : [(Text, Stack)]
envs) -> NonEmpty (Text, Stack) -> m (NonEmpty (Text, Stack))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text, Stack)
defaultEnv (Text, Stack) -> [(Text, Stack)] -> NonEmpty (Text, Stack)
forall a. a -> [a] -> NonEmpty a
:| [(Text, Stack)]
envs)
  where
    loadEnv :: FilePath -> m (Text, b)
loadEnv FilePath
path = do
      b
seConfig <- FilePath -> m b
forall (m :: * -> *) a.
(MonadError Issue m, MonadIO m, FromJSON a) =>
FilePath -> m a
readYaml FilePath
path
      let stackName :: Text
stackName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"default" (FilePath -> Maybe Text
deriveEnviromentName FilePath
path)
      (Text, b) -> m (Text, b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
stackName, b
seConfig)

deriveEnviromentName :: FilePath -> Maybe Text
deriveEnviromentName :: FilePath -> Maybe Text
deriveEnviromentName FilePath
path = Text -> Text
slugify (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
"stack-" (FilePath -> Text
forall a. ToText a => a -> Text
toText (ShowS
dropExtension (ShowS
takeFileName FilePath
path)))

buildMatrix :: (MonadIO m, MonadError Issue m) => [Pkg] -> NonEmpty (Name, Stack) -> m Matrix
buildMatrix :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[Pkg] -> NonEmpty (Text, Stack) -> m Matrix
buildMatrix [Pkg]
pkgs ((Text, Stack)
defaultEnv :| [(Text, Stack)]
envs) = do
  [BuildEnv]
environments <- (BuildEnv -> Version) -> [BuildEnv] -> [BuildEnv]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn BuildEnv -> Version
ghc ([BuildEnv] -> [BuildEnv]) -> m [BuildEnv] -> m [BuildEnv]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text, Stack) -> m BuildEnv) -> [(Text, Stack)] -> m [BuildEnv]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Pkg] -> (Text, Stack) -> m BuildEnv
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[Pkg] -> (Text, Stack) -> m BuildEnv
inferBuildEnv [Pkg]
pkgs) ((Text, Stack)
defaultEnv (Text, Stack) -> [(Text, Stack)] -> [(Text, Stack)]
forall a. a -> [a] -> [a]
: [(Text, Stack)]
envs)
  Matrix -> m Matrix
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Matrix {defaultEnvironment :: Text
defaultEnvironment = (Text, Stack) -> Text
forall a b. (a, b) -> a
fst (Text, Stack)
defaultEnv, [BuildEnv]
environments :: [BuildEnv]
environments :: [BuildEnv]
environments}

inferBuildEnv :: (MonadIO m, MonadError Issue m) => [Pkg] -> (Name, Stack) -> m BuildEnv
inferBuildEnv :: forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[Pkg] -> (Text, Stack) -> m BuildEnv
inferBuildEnv [Pkg]
allPkgs (Text
name, Stack {extraDeps :: Stack -> Maybe [Text]
extraDeps = Maybe [Text]
deps, [FilePath]
Maybe Bool
Maybe Text
Text
packages :: Stack -> [FilePath]
resolver :: Stack -> Text
allowNewer :: Stack -> Maybe Bool
saveHackageCreds :: Stack -> Maybe Bool
compiler :: Stack -> Maybe Text
packages :: [FilePath]
resolver :: Text
allowNewer :: Maybe Bool
saveHackageCreds :: Maybe Bool
compiler :: Maybe Text
..}) = do
  Version
ghc <- m Version -> (Text -> m Version) -> Maybe Text -> m Version
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> m Version
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
Text -> m Version
getSnapshotGHC Text
resolver) (Text -> Either FilePath Version -> m Version
forall (m :: * -> *) a.
MonadError Issue m =>
Text -> Either FilePath a -> m a
fromEither Text
"GHC Parsing" (Either FilePath Version -> m Version)
-> (Text -> Either FilePath Version) -> Text -> m Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either FilePath Version
forall (m :: * -> *). MonadFail m => Text -> m Version
parseGHCVersion) Maybe Text
compiler
  Maybe VersionRegistry
extraDeps <- [Text] -> m (Maybe VersionRegistry)
forall (m :: * -> *).
MonadError Issue m =>
[Text] -> m (Maybe VersionRegistry)
parseExtraDeps ([Text] -> Maybe [Text] -> [Text]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Text]
deps)
  let excludeList :: [Pkg]
excludeList = (Pkg -> Bool) -> [Pkg] -> [Pkg]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> [FilePath] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [FilePath]
packages) (FilePath -> Bool) -> (Pkg -> FilePath) -> Pkg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> FilePath
pkgDirPath) [Pkg]
allPkgs
      exclude :: Maybe [Text]
exclude = if [Pkg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pkg]
excludeList then Maybe [Text]
forall a. Maybe a
Nothing else [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just ((Pkg -> Text) -> [Pkg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Pkg -> Text
pkgId [Pkg]
excludeList)
  BuildEnv -> m BuildEnv
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BuildEnv {Maybe Bool
Maybe [Text]
Maybe VersionRegistry
Text
Version
allowNewer :: Maybe Bool
exclude :: Maybe [Text]
extraDeps :: Maybe VersionRegistry
resolver :: Text
ghc :: Version
name :: Text
name :: Text
resolver :: Text
allowNewer :: Maybe Bool
ghc :: Version
extraDeps :: Maybe VersionRegistry
exclude :: Maybe [Text]
..}