{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

-- | New-style @.travis.yml@ script generator using cabal 1.24's nix-style
-- tech-preview facilities.
--
-- See also <https://github.com/haskell-CI/haskell-ci>
--
-- NB: This code deliberately avoids relying on non-standard packages and
--     is expected to compile/work with at least GHC 7.0 through GHC 8.0
module HaskellCI (
    main,
    -- * for tests
    parseOptions,
    Options (..), defaultOptions,
    Config (..), GitConfig (..),
    InputType (..),
    runDiagnosticsT,
    -- ** Variants
    bashFromConfigFile,
    travisFromConfigFile,
    githubFromConfigFile,
    ) where

import HaskellCI.Prelude

import Control.Exception     (try)
import Data.List             (nubBy, sort, sortBy, (\\))
import System.Directory      (createDirectoryIfMissing, doesFileExist, setCurrentDirectory)
import System.Environment    (getArgs)
import System.Exit           (ExitCode (..), exitFailure)
import System.FilePath.Posix (takeDirectory)
import System.IO             (hClose, hPutStrLn, stderr)
import System.IO.Temp        (withSystemTempFile)
import System.Process        (readProcessWithExitCode)

import Distribution.PackageDescription (GenericPackageDescription, package, packageDescription, testedWith)
import Distribution.Text
import Distribution.Version

import qualified Data.ByteString       as BS
import qualified Data.List.NonEmpty    as NE
import qualified Data.Map              as Map
import qualified Data.Set              as S
import qualified Data.Traversable      as T
import qualified Distribution.Compiler as Compiler
import qualified Distribution.Package  as Pkg
import qualified Options.Applicative   as O

import Cabal.Parse
import Cabal.Project
import HaskellCI.Bash
import HaskellCI.Cli
import HaskellCI.Compiler
import HaskellCI.Config
import HaskellCI.Config.Dump
import HaskellCI.Diagnostics
import HaskellCI.GitConfig
import HaskellCI.GitHub
import HaskellCI.Jobs
import HaskellCI.Package
import HaskellCI.TestedWith
import HaskellCI.Travis
import HaskellCI.VersionInfo
import HaskellCI.YamlSyntax

import qualified HaskellCI.Bash.Template as Bash

-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------

main :: IO ()
main :: IO ()
main = do
    [[Char]]
argv0 <- IO [[Char]]
getArgs
    (Command
cmd, Options
opts) <- ParserPrefs
-> ParserInfo (Command, Options) -> IO (Command, Options)
forall a. ParserPrefs -> ParserInfo a -> IO a
O.customExecParser (PrefsMod -> ParserPrefs
O.prefs PrefsMod
O.subparserInline) ParserInfo (Command, Options)
cliParserInfo
    case Command
cmd of
        Command
CommandListGHC -> do
            [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Supported GHC versions:"
            [(Version, NonEmpty Version)]
-> ((Version, NonEmpty Version) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Version, NonEmpty Version)]
groupedVersions (((Version, NonEmpty Version) -> IO ()) -> IO ())
-> ((Version, NonEmpty Version) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Version
v, NonEmpty Version
vs) -> do
                [Char] -> IO ()
putStr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> [Char]
prettyMajVersion Version
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Version -> [Char]) -> [Version] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Version -> [Char]
forall a. Pretty a => a -> [Char]
display ([Version] -> [[Char]]) -> [Version] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ NonEmpty Version -> [Version]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Version
vs)

        Command
CommandDumpConfig -> do
            [Char] -> IO ()
putStr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ DumpGrammar Config Config -> [[Char]]
forall s a. DumpGrammar s a -> [[Char]]
runDG DumpGrammar Config Config
forall (c :: * -> Constraint) (g :: * -> * -> *).
(OptionsGrammar c g, Applicative (g Config), c (Identity HLintJob),
 c (Identity PackageScope), c (Identity TestedWithJobs),
 c (Identity Ubuntu), c (Identity Jobs), c (Identity CopyFields),
 c (Identity Version), c (Identity Natural),
 c (Identity Components), c Env, c Folds, c CopyFields,
 c HeadVersion, c (List FSep (Identity Installed) Installed),
 Applicative (g DoctestConfig), Applicative (g DocspecConfig),
 Applicative (g HLintConfig)) =>
g Config Config
configGrammar

        Command
CommandRegenerate -> do
            Options -> IO ()
regenerateBash Options
opts
            Options -> IO ()
regenerateGitHub Options
opts
            Options -> IO ()
regenerateTravis Options
opts

        CommandBash   [Char]
f -> [[Char]] -> [Char] -> Options -> IO ()
doBash [[Char]]
argv0 [Char]
f Options
opts
        CommandGitHub [Char]
f -> [[Char]] -> [Char] -> Options -> IO ()
doGitHub [[Char]]
argv0 [Char]
f Options
opts
        CommandTravis [Char]
f -> [[Char]] -> [Char] -> Options -> IO ()
doTravis [[Char]]
argv0 [Char]
f Options
opts

        Command
CommandVersionInfo -> do
            [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"haskell-ci " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with dependencies"
            Map [Char] [Char] -> ([Char] -> [Char] -> IO ()) -> IO ()
forall k v a. Map k v -> (k -> v -> IO a) -> IO ()
ifor_ Map [Char] [Char]
dependencies (([Char] -> [Char] -> IO ()) -> IO ())
-> ([Char] -> [Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
p [Char]
v -> do
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v
  where
    groupedVersions :: [(Version, NonEmpty Version)]
    groupedVersions :: [(Version, NonEmpty Version)]
groupedVersions = (NonEmpty Version -> (Version, NonEmpty Version))
-> [NonEmpty Version] -> [(Version, NonEmpty Version)]
forall a b. (a -> b) -> [a] -> [b]
map ((\NonEmpty Version
vs -> (NonEmpty Version -> Version
forall a. NonEmpty a -> a
head NonEmpty Version
vs, NonEmpty Version
vs)) (NonEmpty Version -> (Version, NonEmpty Version))
-> (NonEmpty Version -> NonEmpty Version)
-> NonEmpty Version
-> (Version, NonEmpty Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> Version -> Ordering)
-> NonEmpty Version -> NonEmpty Version
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy ((Version -> Version -> Ordering) -> Version -> Version -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare))
                    ([NonEmpty Version] -> [(Version, NonEmpty Version)])
-> ([Version] -> [NonEmpty Version])
-> [Version]
-> [(Version, NonEmpty Version)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> Version -> Bool) -> [Version] -> [NonEmpty Version]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
groupBy ((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Int, Int) -> (Int, Int) -> Bool)
-> (Version -> (Int, Int)) -> Version -> Version -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Version -> (Int, Int)
ghcMajVer)
                    ([Version] -> [(Version, NonEmpty Version)])
-> [Version] -> [(Version, NonEmpty Version)]
forall a b. (a -> b) -> a -> b
$ [Version] -> [Version]
forall a. Ord a => [a] -> [a]
sort [Version]
knownGhcVersions

    prettyMajVersion :: Version -> String
    prettyMajVersion :: Version -> [Char]
prettyMajVersion Version
v = case Version -> (Int, Int)
ghcMajVer Version
v of
        (Int
x, Int
y) -> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
y

    ifor_ :: Map.Map k v -> (k -> v -> IO a) -> IO ()
    ifor_ :: forall k v a. Map k v -> (k -> v -> IO a) -> IO ()
ifor_ Map k v
xs k -> v -> IO a
f = (IO () -> k -> v -> IO ()) -> IO () -> Map k v -> IO ()
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\IO ()
m k
k v
a -> IO ()
m IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (k -> v -> IO a
f k
k v
a)) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Map k v
xs

-------------------------------------------------------------------------------
-- Travis
-------------------------------------------------------------------------------

defaultTravisPath :: FilePath
defaultTravisPath :: [Char]
defaultTravisPath = [Char]
".travis.yml"

doTravis :: [String] -> FilePath -> Options -> IO ()
doTravis :: [[Char]] -> [Char] -> Options -> IO ()
doTravis [[Char]]
args [Char]
path Options
opts = do
    ByteString
contents <- [[Char]] -> Options -> [Char] -> IO ByteString
forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m, MonadMask m) =>
[[Char]] -> Options -> [Char] -> m ByteString
travisFromConfigFile [[Char]]
args Options
opts [Char]
path
    case Options -> Maybe Output
optOutput Options
opts of
        Maybe Output
Nothing              -> [Char] -> ByteString -> IO ()
BS.writeFile [Char]
defaultTravisPath ByteString
contents
        Just Output
OutputStdout    -> ByteString -> IO ()
BS.putStr ByteString
contents
        Just (OutputFile [Char]
fp) -> [Char] -> ByteString -> IO ()
BS.writeFile [Char]
fp ByteString
contents

travisFromConfigFile
    :: forall m. (MonadIO m, MonadDiagnostics m, MonadMask m)
    => [String]
    -> Options
    -> FilePath
    -> m ByteString
travisFromConfigFile :: forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m, MonadMask m) =>
[[Char]] -> Options -> [Char] -> m ByteString
travisFromConfigFile [[Char]]
args Options
opts [Char]
path = do
    GitConfig
gitconfig <- IO GitConfig -> m GitConfig
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GitConfig
readGitConfig
    Project URI Void ([Char], GenericPackageDescription)
cabalFiles <- InputType
-> [Char]
-> m (Project URI Void ([Char], GenericPackageDescription))
forall (m :: * -> *).
(MonadDiagnostics m, MonadIO m) =>
InputType
-> [Char]
-> m (Project URI Void ([Char], GenericPackageDescription))
getCabalFiles (Options -> [Char] -> InputType
optInputType' Options
opts [Char]
path) [Char]
path
    Config
config' <- ConfigOpt -> m Config
forall (m :: * -> *). MonadIO m => ConfigOpt -> m Config
findConfigFile (Options -> ConfigOpt
optConfig Options
opts)
    let config :: Config
config = Options -> Config -> Config
optConfigMorphism Options
opts Config
config'
    Project URI Void Package
pkgs <- (([Char], GenericPackageDescription) -> m Package)
-> Project URI Void ([Char], GenericPackageDescription)
-> m (Project URI Void Package)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Project URI Void a -> m (Project URI Void b)
T.mapM (Config -> ([Char], GenericPackageDescription) -> m Package
forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m) =>
Config -> ([Char], GenericPackageDescription) -> m Package
configFromCabalFile Config
config) Project URI Void ([Char], GenericPackageDescription)
cabalFiles
    (Set CompilerVersion
ghcs, Project URI Void Package
prj) <- case TestedWithJobs
-> Project URI Void Package
-> Either [[Char]] (Set CompilerVersion, Project URI Void Package)
forall a b.
TestedWithJobs
-> Project a b Package
-> Either [[Char]] (Set CompilerVersion, Project a b Package)
checkVersions (Config -> TestedWithJobs
cfgTestedWith Config
config) Project URI Void Package
pkgs of
        Right (Set CompilerVersion, Project URI Void Package)
x     -> (Set CompilerVersion, Project URI Void Package)
-> m (Set CompilerVersion, Project URI Void Package)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set CompilerVersion, Project URI Void Package)
x
        Left []     -> [Char] -> m (Set CompilerVersion, Project URI Void Package)
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"panic: checkVersions failed without errors"
        Left ([Char]
e:[[Char]]
es) -> NonEmpty [Char]
-> m (Set CompilerVersion, Project URI Void Package)
forall a. NonEmpty [Char] -> m a
forall (m :: * -> *) a.
MonadDiagnostics m =>
NonEmpty [Char] -> m a
putStrLnErrs ([Char]
e [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)

    let prj' :: Project URI Void Package
prj' | Config -> Bool
cfgGhcHead Config
config = ASetter
  (Project URI Void Package)
  (Project URI Void Package)
  (Set CompilerVersion)
  (Set CompilerVersion)
-> (Set CompilerVersion -> Set CompilerVersion)
-> Project URI Void Package
-> Project URI Void Package
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Package -> Identity Package)
-> Project URI Void Package -> Identity (Project URI Void Package)
forall (f :: * -> *) a b.
Functor f =>
(a -> Identity b) -> f a -> Identity (f b)
mapped ((Package -> Identity Package)
 -> Project URI Void Package -> Identity (Project URI Void Package))
-> ((Set CompilerVersion -> Identity (Set CompilerVersion))
    -> Package -> Identity Package)
-> ASetter
     (Project URI Void Package)
     (Project URI Void Package)
     (Set CompilerVersion)
     (Set CompilerVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (name :: Symbol) r a (f :: * -> *).
(HasField name r a, Functor f) =>
(a -> f a) -> r -> f r
field @"pkgJobs") (CompilerVersion -> Set CompilerVersion -> Set CompilerVersion
forall a. Ord a => a -> Set a -> Set a
S.insert CompilerVersion
GHCHead) Project URI Void Package
prj
             | Bool
otherwise         = Project URI Void Package
prj

    ByteString
ls <- [[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
forall (m :: * -> *).
(Monad m, MonadDiagnostics m) =>
[[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
genTravisFromConfigs [[Char]]
args Config
config GitConfig
gitconfig Project URI Void Package
prj' Set CompilerVersion
ghcs
    Config -> ByteString -> m ByteString
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Config -> ByteString -> m ByteString
patchTravis Config
config ByteString
ls

genTravisFromConfigs
    :: (Monad m, MonadDiagnostics m)
    => [String]
    -> Config
    -> GitConfig
    -> Project URI Void Package
    -> Set CompilerVersion
    -> m ByteString
genTravisFromConfigs :: forall (m :: * -> *).
(Monad m, MonadDiagnostics m) =>
[[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
genTravisFromConfigs [[Char]]
argv Config
config GitConfig
_gitconfig Project URI Void Package
prj Set CompilerVersion
vs = do
    let jobVersions :: JobVersions
jobVersions = Config -> Set CompilerVersion -> JobVersions
makeJobVersions Config
config Set CompilerVersion
vs
    case [[Char]]
-> Config
-> Project URI Void Package
-> JobVersions
-> Either HsCiError Travis
makeTravis [[Char]]
argv Config
config Project URI Void Package
prj JobVersions
jobVersions of
        Left HsCiError
err     -> [Char] -> m ByteString
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char] -> m ByteString) -> [Char] -> m ByteString
forall a b. (a -> b) -> a -> b
$ HsCiError -> [Char]
forall e. Exception e => e -> [Char]
displayException HsCiError
err
        Right Travis
travis -> do
            [Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
forall (m :: * -> *).
MonadDiagnostics m =>
[Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
describeJobs [Char]
"Travis-CI config" (Config -> TestedWithJobs
cfgTestedWith Config
config) JobVersions
jobVersions (Project URI Void Package -> [Package]
forall uri opt pkg. Project uri opt pkg -> [pkg]
prjPackages Project URI Void Package
prj)
            ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
toUTF8BS ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$
                ([[Char]] -> [[Char]]) -> Yaml [[Char]] -> [Char]
forall ann. (ann -> [[Char]]) -> Yaml ann -> [Char]
prettyYaml [[Char]] -> [[Char]]
forall a. a -> a
id (([[Char]] -> [[Char]]) -> Yaml [[Char]] -> Yaml [[Char]]
forall ann. (ann -> ann) -> Yaml ann -> Yaml ann
reann (Bool -> [[Char]] -> [[Char]]
travisHeader (Config -> Bool
cfgInsertVersion Config
config) [[Char]]
argv [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++) (Yaml [[Char]] -> Yaml [[Char]]) -> Yaml [[Char]] -> Yaml [[Char]]
forall a b. (a -> b) -> a -> b
$ Travis -> Yaml [[Char]]
forall a. ToYaml a => a -> Yaml [[Char]]
toYaml Travis
travis)
                [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines
                [ [Char]
""
                , [Char]
"# REGENDATA " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if Config -> Bool
cfgInsertVersion Config
config then ([Char], [[Char]]) -> [Char]
forall a. Show a => a -> [Char]
show ([Char]
haskellCIVerStr, [[Char]]
argv) else [[Char]] -> [Char]
forall a. Show a => a -> [Char]
show [[Char]]
argv
                , [Char]
"# EOF"
                ]

regenerateTravis :: Options -> IO ()
regenerateTravis :: Options -> IO ()
regenerateTravis Options
opts = do
    let fp :: [Char]
fp = [Char]
defaultTravisPath

    -- change the directory
    Maybe [Char] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Options -> Maybe [Char]
optCwd Options
opts) [Char] -> IO ()
setCurrentDirectory

    -- read, and then change to the directory
    [Char] -> IO () -> ([Char] -> IO ()) -> IO ()
forall r. [Char] -> IO r -> ([Char] -> IO r) -> IO r
withContents [Char]
fp IO ()
noTravisYml (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
contents -> case [Char] -> Maybe (Maybe Version, [[Char]])
findRegendataArgv [Char]
contents of
        Maybe (Maybe Version, [[Char]])
Nothing     -> do
            Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error: expected REGENDATA line in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fp
            IO ()
forall a. IO a
exitFailure

        Just (Maybe Version
mversion, [[Char]]
argv) -> do
            -- warn if we regenerate using older haskell-ci
            Maybe Version -> (Version -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Version
mversion ((Version -> IO ()) -> IO ()) -> (Version -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Version
version -> Maybe Version -> (Version -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Char] -> Maybe Version
forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
haskellCIVerStr) ((Version -> IO ()) -> IO ()) -> (Version -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Version
haskellCIVer ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
haskellCIVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
version) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Regenerating using older haskell-ci-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"File generated using haskell-ci-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
version

            ([Char]
f, Options
opts') <- [[Char]] -> IO ([Char], Options)
parseOptions [[Char]]
argv
            [[Char]] -> [Char] -> Options -> IO ()
doTravis [[Char]]
argv [Char]
f ( [Char] -> Options
optionsWithOutputFile [Char]
fp Options -> Options -> Options
forall a. Semigroup a => a -> a -> a
<> Options
opts' Options -> Options -> Options
forall a. Semigroup a => a -> a -> a
<> Options
opts)
  where
    noTravisYml :: IO ()
    noTravisYml :: IO ()
noTravisYml = [Char] -> IO ()
putStrLn [Char]
"No .travis.yml, skipping travis regeneration"

-------------------------------------------------------------------------------
-- Bash
-------------------------------------------------------------------------------

defaultBashPath :: FilePath
defaultBashPath :: [Char]
defaultBashPath = [Char]
"haskell-ci.sh"

doBash :: [String] -> FilePath -> Options -> IO ()
doBash :: [[Char]] -> [Char] -> Options -> IO ()
doBash [[Char]]
args [Char]
path Options
opts = do
    ByteString
contents <- [[Char]] -> Options -> [Char] -> IO ByteString
forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m, MonadMask m) =>
[[Char]] -> Options -> [Char] -> m ByteString
bashFromConfigFile [[Char]]
args Options
opts [Char]
path
    case Options -> Maybe Output
optOutput Options
opts of
        Maybe Output
Nothing              -> [Char] -> ByteString -> IO ()
BS.writeFile [Char]
defaultBashPath ByteString
contents
        Just Output
OutputStdout    -> ByteString -> IO ()
BS.putStr ByteString
contents
        Just (OutputFile [Char]
fp) -> [Char] -> ByteString -> IO ()
BS.writeFile [Char]
fp ByteString
contents

bashFromConfigFile
    :: forall m. (MonadIO m, MonadDiagnostics m, MonadMask m)
    => [String]
    -> Options
    -> FilePath
    -> m ByteString
bashFromConfigFile :: forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m, MonadMask m) =>
[[Char]] -> Options -> [Char] -> m ByteString
bashFromConfigFile [[Char]]
args Options
opts [Char]
path = do
    GitConfig
gitconfig <- IO GitConfig -> m GitConfig
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GitConfig
readGitConfig
    Project URI Void ([Char], GenericPackageDescription)
cabalFiles <- InputType
-> [Char]
-> m (Project URI Void ([Char], GenericPackageDescription))
forall (m :: * -> *).
(MonadDiagnostics m, MonadIO m) =>
InputType
-> [Char]
-> m (Project URI Void ([Char], GenericPackageDescription))
getCabalFiles (Options -> [Char] -> InputType
optInputType' Options
opts [Char]
path) [Char]
path
    Config
config' <- ConfigOpt -> m Config
forall (m :: * -> *). MonadIO m => ConfigOpt -> m Config
findConfigFile (Options -> ConfigOpt
optConfig Options
opts)
    let config :: Config
config = Options -> Config -> Config
optConfigMorphism Options
opts Config
config'
    Project URI Void Package
pkgs <- (([Char], GenericPackageDescription) -> m Package)
-> Project URI Void ([Char], GenericPackageDescription)
-> m (Project URI Void Package)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Project URI Void a -> m (Project URI Void b)
T.mapM (Config -> ([Char], GenericPackageDescription) -> m Package
forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m) =>
Config -> ([Char], GenericPackageDescription) -> m Package
configFromCabalFile Config
config) Project URI Void ([Char], GenericPackageDescription)
cabalFiles
    (Set CompilerVersion
ghcs, Project URI Void Package
prj) <- case TestedWithJobs
-> Project URI Void Package
-> Either [[Char]] (Set CompilerVersion, Project URI Void Package)
forall a b.
TestedWithJobs
-> Project a b Package
-> Either [[Char]] (Set CompilerVersion, Project a b Package)
checkVersions (Config -> TestedWithJobs
cfgTestedWith Config
config) Project URI Void Package
pkgs of
        Right (Set CompilerVersion, Project URI Void Package)
x     -> (Set CompilerVersion, Project URI Void Package)
-> m (Set CompilerVersion, Project URI Void Package)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set CompilerVersion, Project URI Void Package)
x
        Left []     -> [Char] -> m (Set CompilerVersion, Project URI Void Package)
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"panic: checkVersions failed without errors"
        Left ([Char]
e:[[Char]]
es) -> NonEmpty [Char]
-> m (Set CompilerVersion, Project URI Void Package)
forall a. NonEmpty [Char] -> m a
forall (m :: * -> *) a.
MonadDiagnostics m =>
NonEmpty [Char] -> m a
putStrLnErrs ([Char]
e [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)

    let prj' :: Project URI Void Package
prj' | Config -> Bool
cfgGhcHead Config
config = ASetter
  (Project URI Void Package)
  (Project URI Void Package)
  (Set CompilerVersion)
  (Set CompilerVersion)
-> (Set CompilerVersion -> Set CompilerVersion)
-> Project URI Void Package
-> Project URI Void Package
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Package -> Identity Package)
-> Project URI Void Package -> Identity (Project URI Void Package)
forall (f :: * -> *) a b.
Functor f =>
(a -> Identity b) -> f a -> Identity (f b)
mapped ((Package -> Identity Package)
 -> Project URI Void Package -> Identity (Project URI Void Package))
-> ((Set CompilerVersion -> Identity (Set CompilerVersion))
    -> Package -> Identity Package)
-> ASetter
     (Project URI Void Package)
     (Project URI Void Package)
     (Set CompilerVersion)
     (Set CompilerVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (name :: Symbol) r a (f :: * -> *).
(HasField name r a, Functor f) =>
(a -> f a) -> r -> f r
field @"pkgJobs") (CompilerVersion -> Set CompilerVersion -> Set CompilerVersion
forall a. Ord a => a -> Set a -> Set a
S.insert CompilerVersion
GHCHead) Project URI Void Package
prj
             | Bool
otherwise         = Project URI Void Package
prj

    [[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
forall (m :: * -> *).
(Monad m, MonadIO m, MonadDiagnostics m) =>
[[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
genBashFromConfigs [[Char]]
args Config
config GitConfig
gitconfig Project URI Void Package
prj' Set CompilerVersion
ghcs

genBashFromConfigs
    :: (Monad m, MonadIO m, MonadDiagnostics m)
    => [String]
    -> Config
    -> GitConfig
    -> Project URI Void Package
    -> Set CompilerVersion
    -> m ByteString
genBashFromConfigs :: forall (m :: * -> *).
(Monad m, MonadIO m, MonadDiagnostics m) =>
[[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
genBashFromConfigs [[Char]]
argv Config
config GitConfig
_gitconfig Project URI Void Package
prj Set CompilerVersion
vs = do
    let jobVersions :: JobVersions
jobVersions = Config -> Set CompilerVersion -> JobVersions
makeJobVersions Config
config Set CompilerVersion
vs
    case [[Char]]
-> Config
-> Project URI Void Package
-> JobVersions
-> Either HsCiError Z
makeBash [[Char]]
argv Config
config Project URI Void Package
prj JobVersions
jobVersions of
        Left HsCiError
err    -> [Char] -> m ByteString
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char] -> m ByteString) -> [Char] -> m ByteString
forall a b. (a -> b) -> a -> b
$ HsCiError -> [Char]
forall e. Exception e => e -> [Char]
displayException HsCiError
err
        Right Z
bashZ -> do
            [Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
forall (m :: * -> *).
MonadDiagnostics m =>
[Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
describeJobs [Char]
"Bash script" (Config -> TestedWithJobs
cfgTestedWith Config
config) JobVersions
jobVersions (Project URI Void Package -> [Package]
forall uri opt pkg. Project uri opt pkg -> [pkg]
prjPackages Project URI Void Package
prj)
            ([Char] -> ByteString) -> m [Char] -> m ByteString
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> ByteString
toUTF8BS (m [Char] -> m ByteString) -> m [Char] -> m ByteString
forall a b. (a -> b) -> a -> b
$ IO [Char] -> m [Char]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> m [Char]) -> IO [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ Z -> IO [Char]
Bash.renderIO Z
bashZ
                { Bash.zRegendata = if cfgInsertVersion config then show (haskellCIVerStr, argv) else show argv
                }

regenerateBash :: Options -> IO ()
regenerateBash :: Options -> IO ()
regenerateBash Options
opts = do
    let fp :: [Char]
fp = [Char]
defaultBashPath

    -- change the directory
    Maybe [Char] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Options -> Maybe [Char]
optCwd Options
opts) [Char] -> IO ()
setCurrentDirectory

    -- read, and then change to the directory
    [Char] -> IO () -> ([Char] -> IO ()) -> IO ()
forall r. [Char] -> IO r -> ([Char] -> IO r) -> IO r
withContents [Char]
fp IO ()
noBashScript (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
contents -> case [Char] -> Maybe (Maybe Version, [[Char]])
findRegendataArgv [Char]
contents of
        Maybe (Maybe Version, [[Char]])
Nothing     -> do
            Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error: expected REGENDATA line in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fp
            IO ()
forall a. IO a
exitFailure

        Just (Maybe Version
mversion, [[Char]]
argv) -> do
            -- warn if we regenerate using older haskell-ci
            Maybe Version -> (Version -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Version
mversion ((Version -> IO ()) -> IO ()) -> (Version -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Version
version -> Maybe Version -> (Version -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Char] -> Maybe Version
forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
haskellCIVerStr) ((Version -> IO ()) -> IO ()) -> (Version -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Version
haskellCIVer ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
haskellCIVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
version) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Regenerating using older haskell-ci-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"File generated using haskell-ci-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
version

            ([Char]
f, Options
opts') <- [[Char]] -> IO ([Char], Options)
parseOptions [[Char]]
argv
            [[Char]] -> [Char] -> Options -> IO ()
doBash [[Char]]
argv [Char]
f ( [Char] -> Options
optionsWithOutputFile [Char]
fp Options -> Options -> Options
forall a. Semigroup a => a -> a -> a
<> Options
opts' Options -> Options -> Options
forall a. Semigroup a => a -> a -> a
<> Options
opts)
  where
    noBashScript :: IO ()
    noBashScript :: IO ()
noBashScript = [Char] -> IO ()
putStrLn [Char]
"No haskell-ci.sh, skipping bash regeneration"

-------------------------------------------------------------------------------
-- GitHub actions
-------------------------------------------------------------------------------

defaultGitHubPath :: FilePath
defaultGitHubPath :: [Char]
defaultGitHubPath = [Char]
".github/workflows/haskell-ci.yml"

doGitHub :: [String] -> FilePath -> Options -> IO ()
doGitHub :: [[Char]] -> [Char] -> Options -> IO ()
doGitHub [[Char]]
args [Char]
path Options
opts = do
    ByteString
contents <- [[Char]] -> Options -> [Char] -> IO ByteString
forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m, MonadMask m) =>
[[Char]] -> Options -> [Char] -> m ByteString
githubFromConfigFile [[Char]]
args Options
opts [Char]
path
    case Options -> Maybe Output
optOutput Options
opts of
        Maybe Output
Nothing              -> do
            [Char] -> IO ()
createDir [Char]
defaultGitHubPath
            [Char] -> ByteString -> IO ()
BS.writeFile [Char]
defaultGitHubPath ByteString
contents
        Just Output
OutputStdout    -> ByteString -> IO ()
BS.putStr ByteString
contents
        Just (OutputFile [Char]
fp) -> do
            [Char] -> IO ()
createDir [Char]
fp
            [Char] -> ByteString -> IO ()
BS.writeFile [Char]
fp ByteString
contents
  where
    createDir :: [Char] -> IO ()
createDir [Char]
p = Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> [Char]
takeDirectory [Char]
p)

githubFromConfigFile
    :: forall m. (MonadIO m, MonadDiagnostics m, MonadMask m)
    => [String]
    -> Options
    -> FilePath
    -> m ByteString
githubFromConfigFile :: forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m, MonadMask m) =>
[[Char]] -> Options -> [Char] -> m ByteString
githubFromConfigFile [[Char]]
args Options
opts [Char]
path = do
    GitConfig
gitconfig <- IO GitConfig -> m GitConfig
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GitConfig
readGitConfig
    Project URI Void ([Char], GenericPackageDescription)
cabalFiles <- InputType
-> [Char]
-> m (Project URI Void ([Char], GenericPackageDescription))
forall (m :: * -> *).
(MonadDiagnostics m, MonadIO m) =>
InputType
-> [Char]
-> m (Project URI Void ([Char], GenericPackageDescription))
getCabalFiles (Options -> [Char] -> InputType
optInputType' Options
opts [Char]
path) [Char]
path
    Config
config' <- ConfigOpt -> m Config
forall (m :: * -> *). MonadIO m => ConfigOpt -> m Config
findConfigFile (Options -> ConfigOpt
optConfig Options
opts)
    let config :: Config
config = Options -> Config -> Config
optConfigMorphism Options
opts Config
config'
    Project URI Void Package
pkgs <- (([Char], GenericPackageDescription) -> m Package)
-> Project URI Void ([Char], GenericPackageDescription)
-> m (Project URI Void Package)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Project URI Void a -> m (Project URI Void b)
T.mapM (Config -> ([Char], GenericPackageDescription) -> m Package
forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m) =>
Config -> ([Char], GenericPackageDescription) -> m Package
configFromCabalFile Config
config) Project URI Void ([Char], GenericPackageDescription)
cabalFiles
    (Set CompilerVersion
ghcs, Project URI Void Package
prj) <- case TestedWithJobs
-> Project URI Void Package
-> Either [[Char]] (Set CompilerVersion, Project URI Void Package)
forall a b.
TestedWithJobs
-> Project a b Package
-> Either [[Char]] (Set CompilerVersion, Project a b Package)
checkVersions (Config -> TestedWithJobs
cfgTestedWith Config
config) Project URI Void Package
pkgs of
        Right (Set CompilerVersion, Project URI Void Package)
x     -> (Set CompilerVersion, Project URI Void Package)
-> m (Set CompilerVersion, Project URI Void Package)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Set CompilerVersion, Project URI Void Package)
x
        Left []     -> [Char] -> m (Set CompilerVersion, Project URI Void Package)
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"panic: checkVersions failed without errors"
        Left ([Char]
e:[[Char]]
es) -> NonEmpty [Char]
-> m (Set CompilerVersion, Project URI Void Package)
forall a. NonEmpty [Char] -> m a
forall (m :: * -> *) a.
MonadDiagnostics m =>
NonEmpty [Char] -> m a
putStrLnErrs ([Char]
e [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)

    let prj' :: Project URI Void Package
prj' | Config -> Bool
cfgGhcHead Config
config = ASetter
  (Project URI Void Package)
  (Project URI Void Package)
  (Set CompilerVersion)
  (Set CompilerVersion)
-> (Set CompilerVersion -> Set CompilerVersion)
-> Project URI Void Package
-> Project URI Void Package
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Package -> Identity Package)
-> Project URI Void Package -> Identity (Project URI Void Package)
forall (f :: * -> *) a b.
Functor f =>
(a -> Identity b) -> f a -> Identity (f b)
mapped ((Package -> Identity Package)
 -> Project URI Void Package -> Identity (Project URI Void Package))
-> ((Set CompilerVersion -> Identity (Set CompilerVersion))
    -> Package -> Identity Package)
-> ASetter
     (Project URI Void Package)
     (Project URI Void Package)
     (Set CompilerVersion)
     (Set CompilerVersion)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (name :: Symbol) r a (f :: * -> *).
(HasField name r a, Functor f) =>
(a -> f a) -> r -> f r
field @"pkgJobs") (CompilerVersion -> Set CompilerVersion -> Set CompilerVersion
forall a. Ord a => a -> Set a -> Set a
S.insert CompilerVersion
GHCHead) Project URI Void Package
prj
             | Bool
otherwise         = Project URI Void Package
prj

    ByteString
ls <- [[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
forall (m :: * -> *).
(Monad m, MonadIO m, MonadDiagnostics m) =>
[[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
genGitHubFromConfigs [[Char]]
args Config
config GitConfig
gitconfig Project URI Void Package
prj' Set CompilerVersion
ghcs
    Config -> ByteString -> m ByteString
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Config -> ByteString -> m ByteString
patchGitHub Config
config ByteString
ls

genGitHubFromConfigs
    :: (Monad m, MonadIO m, MonadDiagnostics m)
    => [String]
    -> Config
    -> GitConfig
    -> Project URI Void Package
    -> Set CompilerVersion
    -> m ByteString
genGitHubFromConfigs :: forall (m :: * -> *).
(Monad m, MonadIO m, MonadDiagnostics m) =>
[[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> Set CompilerVersion
-> m ByteString
genGitHubFromConfigs [[Char]]
argv Config
config GitConfig
gitconfig Project URI Void Package
prj Set CompilerVersion
vs = do
    let jobVersions :: JobVersions
jobVersions = Config -> Set CompilerVersion -> JobVersions
makeJobVersions Config
config Set CompilerVersion
vs
    case [[Char]]
-> Config
-> GitConfig
-> Project URI Void Package
-> JobVersions
-> Either HsCiError GitHub
makeGitHub [[Char]]
argv Config
config GitConfig
gitconfig Project URI Void Package
prj JobVersions
jobVersions of
        Left HsCiError
err     -> [Char] -> m ByteString
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char] -> m ByteString) -> [Char] -> m ByteString
forall a b. (a -> b) -> a -> b
$ HsCiError -> [Char]
forall e. Exception e => e -> [Char]
displayException HsCiError
err
        Right GitHub
github -> do
            [Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
forall (m :: * -> *).
MonadDiagnostics m =>
[Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
describeJobs [Char]
"GitHub config" (Config -> TestedWithJobs
cfgTestedWith Config
config) JobVersions
jobVersions (Project URI Void Package -> [Package]
forall uri opt pkg. Project uri opt pkg -> [pkg]
prjPackages Project URI Void Package
prj)
            ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
toUTF8BS ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> [[Char]]) -> Yaml [[Char]] -> [Char]
forall ann. (ann -> [[Char]]) -> Yaml ann -> [Char]
prettyYaml [[Char]] -> [[Char]]
forall a. a -> a
id (Yaml [[Char]] -> [Char]) -> Yaml [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> [[Char]]) -> Yaml [[Char]] -> Yaml [[Char]]
forall ann. (ann -> ann) -> Yaml ann -> Yaml ann
reann (Bool -> [[Char]] -> [[Char]]
githubHeader (Config -> Bool
cfgInsertVersion Config
config) [[Char]]
argv [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++) (Yaml [[Char]] -> Yaml [[Char]]) -> Yaml [[Char]] -> Yaml [[Char]]
forall a b. (a -> b) -> a -> b
$ GitHub -> Yaml [[Char]]
forall a. ToYaml a => a -> Yaml [[Char]]
toYaml GitHub
github

regenerateGitHub :: Options -> IO ()
regenerateGitHub :: Options -> IO ()
regenerateGitHub Options
opts = do
    -- change the directory
    Maybe [Char] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Options -> Maybe [Char]
optCwd Options
opts) [Char] -> IO ()
setCurrentDirectory

    -- read, and then change to the directory
    [Char] -> IO () -> ([Char] -> IO ()) -> IO ()
forall r. [Char] -> IO r -> ([Char] -> IO r) -> IO r
withContents [Char]
fp IO ()
noGitHubScript (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
contents -> case [Char] -> Maybe (Maybe Version, [[Char]])
findRegendataArgv [Char]
contents of
        Maybe (Maybe Version, [[Char]])
Nothing     -> do
            Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error: expected REGENDATA line in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fp
            IO ()
forall a. IO a
exitFailure

        Just (Maybe Version
mversion, [[Char]]
argv) -> do
            -- warn if we regenerate using older haskell-ci
            Maybe Version -> (Version -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Version
mversion ((Version -> IO ()) -> IO ()) -> (Version -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Version
version -> Maybe Version -> (Version -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([Char] -> Maybe Version
forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
haskellCIVerStr) ((Version -> IO ()) -> IO ()) -> (Version -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Version
haskellCIVer ->
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
haskellCIVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
version) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Regenerating using older haskell-ci-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"File generated using haskell-ci-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
version

            ([Char]
f, Options
opts') <- [[Char]] -> IO ([Char], Options)
parseOptions [[Char]]
argv
            [[Char]] -> [Char] -> Options -> IO ()
doGitHub [[Char]]
argv [Char]
f ( [Char] -> Options
optionsWithOutputFile [Char]
fp Options -> Options -> Options
forall a. Semigroup a => a -> a -> a
<> Options
opts' Options -> Options -> Options
forall a. Semigroup a => a -> a -> a
<> Options
opts)
  where
    fp :: [Char]
fp = [Char]
defaultGitHubPath

    noGitHubScript :: IO ()
    noGitHubScript :: IO ()
noGitHubScript = [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"No " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", skipping GitHub config regeneration"

-------------------------------------------------------------------------------
-- Config file
-------------------------------------------------------------------------------

findConfigFile :: MonadIO m => ConfigOpt -> m Config
findConfigFile :: forall (m :: * -> *). MonadIO m => ConfigOpt -> m Config
findConfigFile ConfigOpt
ConfigOptNo    = Config -> m Config
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
emptyConfig
findConfigFile (ConfigOpt [Char]
fp) = [Char] -> m Config
forall (m :: * -> *). MonadIO m => [Char] -> m Config
readConfigFile [Char]
fp
findConfigFile ConfigOpt
ConfigOptAuto  = do
    let defaultPath :: [Char]
defaultPath = [Char]
"cabal.haskell-ci"
    Bool
exists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO Bool
doesFileExist [Char]
defaultPath)
    if Bool
exists
    then [Char] -> m Config
forall (m :: * -> *). MonadIO m => [Char] -> m Config
readConfigFile [Char]
defaultPath
    else Config -> m Config
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Config
emptyConfig

-------------------------------------------------------------------------------
-- Patches
-------------------------------------------------------------------------------

patchTravis
    :: (MonadIO m, MonadMask m)
    => Config -> ByteString -> m ByteString
patchTravis :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Config -> ByteString -> m ByteString
patchTravis = [[Char]] -> ByteString -> m ByteString
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[[Char]] -> ByteString -> m ByteString
patchYAML ([[Char]] -> ByteString -> m ByteString)
-> (Config -> [[Char]]) -> Config -> ByteString -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> [[Char]]
cfgTravisPatches

patchGitHub
    :: (MonadIO m, MonadMask m)
    => Config -> ByteString -> m ByteString
patchGitHub :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Config -> ByteString -> m ByteString
patchGitHub = [[Char]] -> ByteString -> m ByteString
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[[Char]] -> ByteString -> m ByteString
patchYAML ([[Char]] -> ByteString -> m ByteString)
-> (Config -> [[Char]]) -> Config -> ByteString -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> [[Char]]
cfgGitHubPatches

-- | Adjust the generated YAML output with patch files, if specified.
-- We do this in a temporary file in case the user did not pass --output (as
-- it would be awkward to patch the generated output otherwise).
patchYAML
    :: (MonadIO m, MonadMask m)
    => [FilePath] -> ByteString -> m ByteString
patchYAML :: forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[[Char]] -> ByteString -> m ByteString
patchYAML [[Char]]
patches ByteString
input
  | [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
patches = ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
input
  | Bool
otherwise =
      [Char] -> ([Char] -> Handle -> m ByteString) -> m ByteString
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> Handle -> m a) -> m a
withSystemTempFile [Char]
"yml.tmp" (([Char] -> Handle -> m ByteString) -> m ByteString)
-> ([Char] -> Handle -> m ByteString) -> m ByteString
forall a b. (a -> b) -> a -> b
$ \[Char]
fp Handle
h -> IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ do
        Handle -> ByteString -> IO ()
BS.hPutStr Handle
h ByteString
input
        Handle -> IO ()
hClose Handle
h
        [[Char]] -> ([Char] -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
patches (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
applyPatch [Char]
fp
        [Char] -> IO ByteString
BS.readFile [Char]
fp
  where
    applyPatch :: FilePath -- ^ The temporary file path to patch
               -> FilePath -- ^ The path of the .patch file
               -> IO ()
    applyPatch :: [Char] -> [Char] -> IO ()
applyPatch [Char]
temp [Char]
patch = do
        Bool
exists <- [Char] -> IO Bool
doesFileExist [Char]
patch
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot find " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
patch
        (ExitCode
ec, [Char]
stdOut, [Char]
stdErr) <- [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode
            [Char]
"patch" [ [Char]
"--input", [Char]
patch
            , [Char]
"--silent"
            , [Char]
temp
            ] [Char]
""
        case ExitCode
ec of
            ExitCode
ExitSuccess -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ExitFailure Int
n -> [Char] -> IO ()
forall a. [Char] -> IO a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
                [ [Char]
"patch returned exit code " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n
                , [Char]
"Stdout: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
stdOut
                , [Char]
"Stderr: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
stdErr
                ]

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

withContents
    :: FilePath            -- ^ filepath
    -> IO r                -- ^ what to do when file don't exist
    -> (String -> IO r)    -- ^ continuation
    -> IO r
withContents :: forall r. [Char] -> IO r -> ([Char] -> IO r) -> IO r
withContents [Char]
path IO r
no [Char] -> IO r
kont = do
    Either IOError ByteString
e <- IO ByteString -> IO (Either IOError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try ([Char] -> IO ByteString
BS.readFile [Char]
path) :: IO (Either IOError BS.ByteString)
    case Either IOError ByteString
e of
        Left IOError
_         -> IO r
no
        Right ByteString
contents -> [Char] -> IO r
kont (ByteString -> [Char]
fromUTF8BS ByteString
contents)

-- | Find @REGENDATA@ in a string
findRegendataArgv :: String -> Maybe (Maybe Version, [String])
findRegendataArgv :: [Char] -> Maybe (Maybe Version, [[Char]])
findRegendataArgv [Char]
contents = do
    [Char]
l <- ([Char] -> Maybe [Char]) -> [[Char]] -> Maybe [Char]
forall a b. (a -> Maybe b) -> [a] -> Maybe b
findMaybe ([Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
afterInfix [Char]
"REGENDATA") ([Char] -> [[Char]]
lines [Char]
contents)
    ([Char] -> Maybe Version)
-> ([Char], [[Char]]) -> (Maybe Version, [[Char]])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Char] -> Maybe Version
forall a. Parsec a => [Char] -> Maybe a
simpleParsec (([Char], [[Char]]) -> (Maybe Version, [[Char]]))
-> Maybe ([Char], [[Char]]) -> Maybe (Maybe Version, [[Char]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Maybe ([Char], [[Char]])
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
l :: Maybe (String, [String]))
        Maybe (Maybe Version, [[Char]])
-> Maybe (Maybe Version, [[Char]])
-> Maybe (Maybe Version, [[Char]])
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) Maybe Version
forall a. Maybe a
Nothing ([[Char]] -> (Maybe Version, [[Char]]))
-> Maybe [[Char]] -> Maybe (Maybe Version, [[Char]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Maybe [[Char]]
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
l :: Maybe [String])

-- | Read project file and associated .cabal files.
getCabalFiles
    :: (MonadDiagnostics m, MonadIO m)
    => InputType
    -> FilePath
    -> m (Project URI Void (FilePath, GenericPackageDescription))
getCabalFiles :: forall (m :: * -> *).
(MonadDiagnostics m, MonadIO m) =>
InputType
-> [Char]
-> m (Project URI Void ([Char], GenericPackageDescription))
getCabalFiles InputType
InputTypeProject [Char]
path = do
    ByteString
contents <- IO ByteString -> m ByteString
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString) -> IO ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
    Project Void [Char] [Char]
prj0 <- (ParseError NonEmpty -> m (Project Void [Char] [Char]))
-> (Project Void [Char] [Char] -> m (Project Void [Char] [Char]))
-> Either (ParseError NonEmpty) (Project Void [Char] [Char])
-> m (Project Void [Char] [Char])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m (Project Void [Char] [Char])
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char] -> m (Project Void [Char] [Char]))
-> (ParseError NonEmpty -> [Char])
-> ParseError NonEmpty
-> m (Project Void [Char] [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError NonEmpty -> [Char]
forall (f :: * -> *). Foldable f => ParseError f -> [Char]
renderParseError) Project Void [Char] [Char] -> m (Project Void [Char] [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ParseError NonEmpty) (Project Void [Char] [Char])
 -> m (Project Void [Char] [Char]))
-> Either (ParseError NonEmpty) (Project Void [Char] [Char])
-> m (Project Void [Char] [Char])
forall a b. (a -> b) -> a -> b
$ [Char]
-> ByteString
-> Either (ParseError NonEmpty) (Project Void [Char] [Char])
parseProject [Char]
path ByteString
contents
    Project URI Void [Char]
prj1 <- (ResolveError -> m (Project URI Void [Char]))
-> (Project URI Void [Char] -> m (Project URI Void [Char]))
-> Either ResolveError (Project URI Void [Char])
-> m (Project URI Void [Char])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m (Project URI Void [Char])
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char] -> m (Project URI Void [Char]))
-> (ResolveError -> [Char])
-> ResolveError
-> m (Project URI Void [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolveError -> [Char]
renderResolveError) Project URI Void [Char] -> m (Project URI Void [Char])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResolveError (Project URI Void [Char])
 -> m (Project URI Void [Char]))
-> m (Either ResolveError (Project URI Void [Char]))
-> m (Project URI Void [Char])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either ResolveError (Project URI Void [Char]))
-> m (Either ResolveError (Project URI Void [Char]))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char]
-> Project Void [Char] [Char]
-> IO (Either ResolveError (Project URI Void [Char]))
resolveProject [Char]
path Project Void [Char] [Char]
prj0)
    (ParseError NonEmpty
 -> m (Project URI Void ([Char], GenericPackageDescription)))
-> (Project URI Void ([Char], GenericPackageDescription)
    -> m (Project URI Void ([Char], GenericPackageDescription)))
-> Either
     (ParseError NonEmpty)
     (Project URI Void ([Char], GenericPackageDescription))
-> m (Project URI Void ([Char], GenericPackageDescription))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m (Project URI Void ([Char], GenericPackageDescription))
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char]
 -> m (Project URI Void ([Char], GenericPackageDescription)))
-> (ParseError NonEmpty -> [Char])
-> ParseError NonEmpty
-> m (Project URI Void ([Char], GenericPackageDescription))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError NonEmpty -> [Char]
forall (f :: * -> *). Foldable f => ParseError f -> [Char]
renderParseError) Project URI Void ([Char], GenericPackageDescription)
-> m (Project URI Void ([Char], GenericPackageDescription))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either
   (ParseError NonEmpty)
   (Project URI Void ([Char], GenericPackageDescription))
 -> m (Project URI Void ([Char], GenericPackageDescription)))
-> m (Either
        (ParseError NonEmpty)
        (Project URI Void ([Char], GenericPackageDescription)))
-> m (Project URI Void ([Char], GenericPackageDescription))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO
  (Either
     (ParseError NonEmpty)
     (Project URI Void ([Char], GenericPackageDescription)))
-> m (Either
        (ParseError NonEmpty)
        (Project URI Void ([Char], GenericPackageDescription)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Project URI Void [Char]
-> IO
     (Either
        (ParseError NonEmpty)
        (Project URI Void ([Char], GenericPackageDescription)))
forall uri opt.
Project uri opt [Char]
-> IO
     (Either
        (ParseError NonEmpty)
        (Project uri opt ([Char], GenericPackageDescription)))
readPackagesOfProject Project URI Void [Char]
prj1)
getCabalFiles InputType
InputTypePackage [Char]
path = do
    Either
  (ParseError NonEmpty)
  (Project URI Void ([Char], GenericPackageDescription))
e <- IO
  (Either
     (ParseError NonEmpty)
     (Project URI Void ([Char], GenericPackageDescription)))
-> m (Either
        (ParseError NonEmpty)
        (Project URI Void ([Char], GenericPackageDescription)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      (ParseError NonEmpty)
      (Project URI Void ([Char], GenericPackageDescription)))
 -> m (Either
         (ParseError NonEmpty)
         (Project URI Void ([Char], GenericPackageDescription))))
-> IO
     (Either
        (ParseError NonEmpty)
        (Project URI Void ([Char], GenericPackageDescription)))
-> m (Either
        (ParseError NonEmpty)
        (Project URI Void ([Char], GenericPackageDescription)))
forall a b. (a -> b) -> a -> b
$ Project URI Void [Char]
-> IO
     (Either
        (ParseError NonEmpty)
        (Project URI Void ([Char], GenericPackageDescription)))
forall uri opt.
Project uri opt [Char]
-> IO
     (Either
        (ParseError NonEmpty)
        (Project uri opt ([Char], GenericPackageDescription)))
readPackagesOfProject (Project URI Void [Char]
forall c b a. Project c b a
emptyProject Project URI Void [Char]
-> (Project URI Void [Char] -> Project URI Void [Char])
-> Project URI Void [Char]
forall a b. a -> (a -> b) -> b
& forall (name :: Symbol) r a (f :: * -> *).
(HasField name r a, Functor f) =>
(a -> f a) -> r -> f r
field @"prjPackages" (([[Char]] -> Identity [[Char]])
 -> Project URI Void [Char] -> Identity (Project URI Void [Char]))
-> [[Char]] -> Project URI Void [Char] -> Project URI Void [Char]
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [[Char]
path])
    (ParseError NonEmpty
 -> m (Project URI Void ([Char], GenericPackageDescription)))
-> (Project URI Void ([Char], GenericPackageDescription)
    -> m (Project URI Void ([Char], GenericPackageDescription)))
-> Either
     (ParseError NonEmpty)
     (Project URI Void ([Char], GenericPackageDescription))
-> m (Project URI Void ([Char], GenericPackageDescription))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> m (Project URI Void ([Char], GenericPackageDescription))
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char]
 -> m (Project URI Void ([Char], GenericPackageDescription)))
-> (ParseError NonEmpty -> [Char])
-> ParseError NonEmpty
-> m (Project URI Void ([Char], GenericPackageDescription))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError NonEmpty -> [Char]
forall (f :: * -> *). Foldable f => ParseError f -> [Char]
renderParseError) Project URI Void ([Char], GenericPackageDescription)
-> m (Project URI Void ([Char], GenericPackageDescription))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Either
  (ParseError NonEmpty)
  (Project URI Void ([Char], GenericPackageDescription))
e

-------------------------------------------------------------------------------
-- Config
-------------------------------------------------------------------------------

configFromCabalFile
    :: (MonadIO m, MonadDiagnostics m)
    => Config -> (FilePath, GenericPackageDescription) -> m Package
configFromCabalFile :: forall (m :: * -> *).
(MonadIO m, MonadDiagnostics m) =>
Config -> ([Char], GenericPackageDescription) -> m Package
configFromCabalFile Config
cfg ([Char]
cabalFile, GenericPackageDescription
gpd) = do
    let compilers :: [(CompilerFlavor, VersionRange)]
compilers = PackageDescription -> [(CompilerFlavor, VersionRange)]
testedWith (PackageDescription -> [(CompilerFlavor, VersionRange)])
-> PackageDescription -> [(CompilerFlavor, VersionRange)]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd
        pkgNameStr :: [Char]
pkgNameStr = PackageName -> [Char]
forall a. Pretty a => a -> [Char]
display (PackageName -> [Char]) -> PackageName -> [Char]
forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
Pkg.pkgName (PackageIdentifier -> PackageName)
-> PackageIdentifier -> PackageName
forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
package (PackageDescription -> PackageIdentifier)
-> PackageDescription -> PackageIdentifier
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd

    let unknownComps :: [CompilerFlavor]
unknownComps = [CompilerFlavor] -> [CompilerFlavor]
forall a. Eq a => [a] -> [a]
nub [ CompilerFlavor
c | (CompilerFlavor
c,VersionRange
_) <- [(CompilerFlavor, VersionRange)]
compilers, CompilerFlavor
c CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
/= CompilerFlavor
Compiler.GHC, CompilerFlavor
c CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
/= CompilerFlavor
Compiler.GHCJS ]

        ghcVerConstrs :: [VersionRange]
ghcVerConstrs   = [ VersionRange
vc | (CompilerFlavor
Compiler.GHC,VersionRange
vc) <- [(CompilerFlavor, VersionRange)]
compilers ]
        ghcVerConstrs' :: VersionRange
ghcVerConstrs'  = VersionRange -> VersionRange
simplifyVersionRange (VersionRange -> VersionRange) -> VersionRange -> VersionRange
forall a b. (a -> b) -> a -> b
$ (VersionRange -> VersionRange -> VersionRange)
-> VersionRange -> [VersionRange] -> VersionRange
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr VersionRange -> VersionRange -> VersionRange
unionVersionRanges VersionRange
noVersion [VersionRange]
ghcVerConstrs
        specificGhcVers :: [Version]
specificGhcVers = [Version] -> [Version]
forall a. Eq a => [a] -> [a]
nub ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ (VersionRange -> Maybe Version) -> [VersionRange] -> [Version]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VersionRange -> Maybe Version
isSpecificVersion [VersionRange]
ghcVerConstrs

        ghcjsVerConstrs :: [VersionRange]
ghcjsVerConstrs   = [ VersionRange
vc | (CompilerFlavor
Compiler.GHCJS,VersionRange
vc) <- [(CompilerFlavor, VersionRange)]
compilers ]
        ghcjsVerConstrs' :: VersionRange
ghcjsVerConstrs'  = VersionRange -> VersionRange
simplifyVersionRange (VersionRange -> VersionRange) -> VersionRange -> VersionRange
forall a b. (a -> b) -> a -> b
$ (VersionRange -> VersionRange -> VersionRange)
-> VersionRange -> [VersionRange] -> VersionRange
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr VersionRange -> VersionRange -> VersionRange
unionVersionRanges VersionRange
noVersion [VersionRange]
ghcjsVerConstrs
        specificGhcjsVers :: [Version]
specificGhcjsVers = [Version] -> [Version]
forall a. Eq a => [a] -> [a]
nub ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ (VersionRange -> Maybe Version) -> [VersionRange] -> [Version]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VersionRange -> Maybe Version
isSpecificVersion [VersionRange]
ghcjsVerConstrs

        twoDigitGhcVerConstrs :: [Version]
twoDigitGhcVerConstrs = (VersionRange -> Maybe Version) -> [VersionRange] -> [Version]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VersionRange -> Maybe Version
isTwoDigitGhcVersion [VersionRange]
ghcVerConstrs :: [Version]

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
twoDigitGhcVerConstrs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall (m :: * -> *). MonadDiagnostics m => [Char] -> m ()
putStrLnWarn ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"'tested-with:' uses two digit GHC versions (which don't match any existing GHC version): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Version -> [Char]) -> [Version] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Version -> [Char]
forall a. Pretty a => a -> [Char]
display [Version]
twoDigitGhcVerConstrs)
        [Char] -> m ()
forall (m :: * -> *). MonadDiagnostics m => [Char] -> m ()
putStrLnInfo ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Either use wild-card format, for example 'tested-with: GHC ==7.10.*' or a specific existing version 'tested-with: GHC ==7.10.3'"

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(CompilerFlavor, VersionRange)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(CompilerFlavor, VersionRange)]
compilers) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
                     [ [Char]
"empty or missing top-level 'tested-with:' definition in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cabalFile [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" file; example definition:"
                     , [Char]
""
                     , [Char]
"tested-with: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [ [Char]
"GHC==" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
display Version
v | Version
v <- [Version]
lastStableGhcVers ]
                     ])

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([CompilerFlavor] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CompilerFlavor]
unknownComps) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall (m :: * -> *). MonadDiagnostics m => [Char] -> m ()
putStrLnWarn ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ignoring unsupported compilers mentioned in tested-with: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [CompilerFlavor] -> [Char]
forall a. Show a => a -> [Char]
show [CompilerFlavor]
unknownComps

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([VersionRange] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VersionRange]
ghcVerConstrs) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"'tested-with:' doesn't mention any 'GHC' version"

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VersionRange -> Bool
isNoVersion VersionRange
ghcVerConstrs') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"'tested-with:' describes an empty version range for 'GHC'"

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (VersionRange -> Bool
isAnyVersion VersionRange
ghcVerConstrs') (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"'tested-with:' allows /any/ 'GHC' version"

    let unknownGhcVers :: [Version]
unknownGhcVers = [Version] -> [Version]
forall a. Ord a => [a] -> [a]
sort ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ [Version]
specificGhcVers [Version] -> [Version] -> [Version]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Version]
knownGhcVersions
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
unknownGhcVers) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char]
"'tested-with:' specifically refers to unknown 'GHC' versions: "
                     [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Version -> [Char]) -> [Version] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Version -> [Char]
forall a. Pretty a => a -> [Char]
display [Version]
unknownGhcVers) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                     [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Known GHC versions: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Version -> [Char]) -> [Version] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Version -> [Char]
forall a. Pretty a => a -> [Char]
display [Version]
knownGhcVersions))

    let unknownGhcjsVers :: [Version]
unknownGhcjsVers = [Version] -> [Version]
forall a. Ord a => [a] -> [a]
sort ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ [Version]
specificGhcjsVers [Version] -> [Version] -> [Version]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Version]
knownGhcjsVersions
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
unknownGhcjsVers) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char]
"'tested-with:' specifically refers to unknown 'GHCJS' versions: "
                     [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Version -> [Char]) -> [Version] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Version -> [Char]
forall a. Pretty a => a -> [Char]
display [Version]
unknownGhcjsVers) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                     [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Known GHCJS versions: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Version -> [Char]) -> [Version] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Version -> [Char]
forall a. Pretty a => a -> [Char]
display [Version]
knownGhcjsVersions))

    let knownGhcVersions' :: [Version]
knownGhcVersions'
            | Config -> Bool
cfgLastInSeries Config
cfg = [Version] -> [Version]
filterLastMajor [Version]
knownGhcVersions
            | Bool
otherwise           = [Version]
knownGhcVersions

    let testedGhcVersions :: [Version]
testedGhcVersions   = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> VersionRange -> Bool
`withinRange` VersionRange
ghcVerConstrs') [Version]
knownGhcVersions'
    let testedGhcjsVersions :: [Version]
testedGhcjsVersions = (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> VersionRange -> Bool
`withinRange` VersionRange
ghcjsVerConstrs') [Version]
knownGhcjsVersions

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Version] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
testedGhcVersions) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"no known GHC version is allowed by the 'tested-with' specification"

    let compilerRange :: Set CompilerVersion
        compilerRange :: Set CompilerVersion
compilerRange = [CompilerVersion] -> Set CompilerVersion
forall a. Ord a => [a] -> Set a
S.fromList ([CompilerVersion] -> Set CompilerVersion)
-> [CompilerVersion] -> Set CompilerVersion
forall a b. (a -> b) -> a -> b
$
            [ Version -> CompilerVersion
GHC Version
v
            | Version
v <- [Version]
testedGhcVersions
            ] [CompilerVersion] -> [CompilerVersion] -> [CompilerVersion]
forall a. [a] -> [a] -> [a]
++
            [ Version -> CompilerVersion
GHCJS Version
v
            | Version
v <- [Version]
testedGhcjsVersions
            ]

    let pkg :: Package
pkg = [Char]
-> Set CompilerVersion
-> [Char]
-> GenericPackageDescription
-> Package
Pkg [Char]
pkgNameStr Set CompilerVersion
compilerRange ([Char] -> [Char]
takeDirectory [Char]
cabalFile) GenericPackageDescription
gpd

    Package -> m Package
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Package
pkg
  where
    lastStableGhcVers :: [Version]
lastStableGhcVers
        = (Version -> Version -> Bool) -> [Version] -> [Version]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Int, Int) -> (Int, Int) -> Bool)
-> (Version -> (Int, Int)) -> Version -> Version -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Version -> (Int, Int)
ghcMajVer)
        ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ (Version -> Version -> Ordering) -> [Version] -> [Version]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Version -> Version -> Ordering) -> Version -> Version -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Version -> Version -> Ordering
forall a. Ord a => a -> a -> Ordering
compare)
        ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ (Version -> Bool) -> [Version] -> [Version]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Version -> Bool) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompilerVersion -> Bool
isPreviewGHC (CompilerVersion -> Bool)
-> (Version -> CompilerVersion) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> CompilerVersion
GHC)
        ([Version] -> [Version]) -> [Version] -> [Version]
forall a b. (a -> b) -> a -> b
$ [Version]
knownGhcVersions

    isTwoDigitGhcVersion :: VersionRange -> Maybe Version
    isTwoDigitGhcVersion :: VersionRange -> Maybe Version
isTwoDigitGhcVersion VersionRange
vr = VersionRange -> Maybe Version
isSpecificVersion VersionRange
vr Maybe Version -> (Version -> Maybe Version) -> Maybe Version
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Version -> Maybe Version
t
      where
        t :: Version -> Maybe Version
t Version
v | [Int
_,Int
_] <- Version -> [Int]
versionNumbers Version
v = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
        t Version
_                             = Maybe Version
forall a. Maybe a
Nothing

    filterLastMajor :: [Version] -> [Version]
filterLastMajor = (NonEmpty Version -> Version) -> [NonEmpty Version] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty Version -> Version
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([NonEmpty Version] -> [Version])
-> ([Version] -> [NonEmpty Version]) -> [Version] -> [Version]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> Version -> Bool) -> [Version] -> [NonEmpty Version]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
groupBy ((Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((Int, Int) -> (Int, Int) -> Bool)
-> (Version -> (Int, Int)) -> Version -> Version -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Version -> (Int, Int)
ghcMajVer)