{-# 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.HeadHackage
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) <- 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 forall a b. (a -> b) -> a -> b
$ [Char]
"Supported GHC versions:"
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Version, NonEmpty Version)]
groupedVersions forall a b. (a -> b) -> a -> b
$ \(Version
v, NonEmpty Version
vs) -> do
                [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ Version -> [Char]
prettyMajVersion Version
v forall a. [a] -> [a] -> [a]
++ [Char]
": "
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> [Char]
display forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Version
vs)

        Command
CommandDumpConfig -> do
            [Char] -> IO ()
putStr forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall s a. DumpGrammar s a -> [[Char]]
runDG 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 forall a b. (a -> b) -> a -> b
$ [Char]
"haskell-ci " forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr forall a. [a] -> [a] -> [a]
++ [Char]
" with dependencies"
            forall k v a. Map k v -> (k -> v -> IO a) -> IO ()
ifor_ Map [Char] [Char]
dependencies forall a b. (a -> b) -> a -> b
$ \[Char]
p [Char]
v -> do
                [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"  " forall a. [a] -> [a] -> [a]
++ [Char]
p forall a. [a] -> [a] -> [a]
++ [Char]
"-" forall a. [a] -> [a] -> [a]
++ [Char]
v
  where
    groupedVersions :: [(Version, NonEmpty Version)]
    groupedVersions :: [(Version, NonEmpty Version)]
groupedVersions = forall a b. (a -> b) -> [a] -> [b]
map ((\NonEmpty Version
vs -> (forall a. NonEmpty a -> a
head NonEmpty Version
vs, NonEmpty Version
vs)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare))
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Version -> (Int, Int)
ghcMajVer)
                    forall a b. (a -> b) -> a -> b
$ 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) -> forall a. Show a => a -> [Char]
show Int
x forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ 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 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (\IO ()
m k
k v
a -> IO ()
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Functor f => f a -> f ()
void (k -> v -> IO a
f k
k v
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 <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GitConfig
readGitConfig
    Project URI Void ([Char], GenericPackageDescription)
cabalFiles <- 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' <- 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (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 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     -> forall (m :: * -> *) a. Monad m => a -> m a
return (Set CompilerVersion, Project URI Void Package)
x
        Left []     -> forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"panic: checkVersions failed without errors"
        Left ([Char]
e:[[Char]]
es) -> forall (m :: * -> *) a.
MonadDiagnostics m =>
NonEmpty [Char] -> m a
putStrLnErrs ([Char]
e forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)

    let prj' :: Project URI Void Package
prj' | Config -> Bool
cfgGhcHead Config
config = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall (f :: * -> *) a b.
Functor f =>
(a -> Identity b) -> f a -> Identity (f b)
mapped 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") (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 <- 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
    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     -> forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> [Char]
displayException HsCiError
err
        Right Travis
travis -> do
            forall (m :: * -> *).
MonadDiagnostics m =>
[Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
describeJobs [Char]
"Travis-CI config" (Config -> TestedWithJobs
cfgTestedWith Config
config) JobVersions
jobVersions (forall uri opt pkg. Project uri opt pkg -> [pkg]
prjPackages Project URI Void Package
prj)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
toUTF8BS forall a b. (a -> b) -> a -> b
$
                forall ann. (ann -> [[Char]]) -> Yaml ann -> [Char]
prettyYaml forall a. a -> a
id (forall ann. (ann -> ann) -> Yaml ann -> Yaml ann
reann (Bool -> [[Char]] -> [[Char]]
travisHeader (Config -> Bool
cfgInsertVersion Config
config) [[Char]]
argv forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ forall a. ToYaml a => a -> Yaml [[Char]]
toYaml Travis
travis)
                forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unlines
                [ [Char]
""
                , [Char]
"# REGENDATA " forall a. [a] -> [a] -> [a]
++ if Config -> Bool
cfgInsertVersion Config
config then forall a. Show a => a -> [Char]
show ([Char]
haskellCIVerStr, [[Char]]
argv) else 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
    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
    forall r. [Char] -> IO r -> ([Char] -> IO r) -> IO r
withContents [Char]
fp IO ()
noTravisYml 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 forall a b. (a -> b) -> a -> b
$ [Char]
"Error: expected REGENDATA line in " forall a. [a] -> [a] -> [a]
++ [Char]
fp
            forall a. IO a
exitFailure

        Just (Maybe Version
mversion, [[Char]]
argv) -> do
            -- warn if we regenerate using older haskell-ci
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Version
mversion forall a b. (a -> b) -> a -> b
$ \Version
version -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
haskellCIVerStr) forall a b. (a -> b) -> a -> b
$ \Version
haskellCIVer ->
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
haskellCIVer forall a. Ord a => a -> a -> Bool
< Version
version) forall a b. (a -> b) -> a -> b
$ do
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
"Regenerating using older haskell-ci-" forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
"File generated using haskell-ci-" forall a. [a] -> [a] -> [a]
++ 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 forall a. Semigroup a => a -> a -> a
<> Options
opts' 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 <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GitConfig
readGitConfig
    Project URI Void ([Char], GenericPackageDescription)
cabalFiles <- 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' <- 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (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 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     -> forall (m :: * -> *) a. Monad m => a -> m a
return (Set CompilerVersion, Project URI Void Package)
x
        Left []     -> forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"panic: checkVersions failed without errors"
        Left ([Char]
e:[[Char]]
es) -> forall (m :: * -> *) a.
MonadDiagnostics m =>
NonEmpty [Char] -> m a
putStrLnErrs ([Char]
e forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)

    let prj' :: Project URI Void Package
prj' | Config -> Bool
cfgGhcHead Config
config = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall (f :: * -> *) a b.
Functor f =>
(a -> Identity b) -> f a -> Identity (f b)
mapped 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") (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

    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    -> forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> [Char]
displayException HsCiError
err
        Right Z
bashZ -> do
            forall (m :: * -> *).
MonadDiagnostics m =>
[Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
describeJobs [Char]
"Bash script" (Config -> TestedWithJobs
cfgTestedWith Config
config) JobVersions
jobVersions (forall uri opt pkg. Project uri opt pkg -> [pkg]
prjPackages Project URI Void Package
prj)
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> ByteString
toUTF8BS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Z -> IO [Char]
Bash.renderIO Z
bashZ
                { zRegendata :: [Char]
Bash.zRegendata = if Config -> Bool
cfgInsertVersion Config
config then forall a. Show a => a -> [Char]
show ([Char]
haskellCIVerStr, [[Char]]
argv) else forall a. Show a => a -> [Char]
show [[Char]]
argv
                }

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

    -- change the directory
    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
    forall r. [Char] -> IO r -> ([Char] -> IO r) -> IO r
withContents [Char]
fp IO ()
noBashScript 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 forall a b. (a -> b) -> a -> b
$ [Char]
"Error: expected REGENDATA line in " forall a. [a] -> [a] -> [a]
++ [Char]
fp
            forall a. IO a
exitFailure

        Just (Maybe Version
mversion, [[Char]]
argv) -> do
            -- warn if we regenerate using older haskell-ci
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Version
mversion forall a b. (a -> b) -> a -> b
$ \Version
version -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
haskellCIVerStr) forall a b. (a -> b) -> a -> b
$ \Version
haskellCIVer ->
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
haskellCIVer forall a. Ord a => a -> a -> Bool
< Version
version) forall a b. (a -> b) -> a -> b
$ do
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
"Regenerating using older haskell-ci-" forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
"File generated using haskell-ci-" forall a. [a] -> [a] -> [a]
++ 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 forall a. Semigroup a => a -> a -> a
<> Options
opts' 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 <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GitConfig
readGitConfig
    Project URI Void ([Char], GenericPackageDescription)
cabalFiles <- 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' <- 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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
T.mapM (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 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     -> forall (m :: * -> *) a. Monad m => a -> m a
return (Set CompilerVersion, Project URI Void Package)
x
        Left []     -> forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr [Char]
"panic: checkVersions failed without errors"
        Left ([Char]
e:[[Char]]
es) -> forall (m :: * -> *) a.
MonadDiagnostics m =>
NonEmpty [Char] -> m a
putStrLnErrs ([Char]
e forall a. a -> [a] -> NonEmpty a
:| [[Char]]
es)

    let prj' :: Project URI Void Package
prj' | Config -> Bool
cfgGhcHead Config
config = forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall (f :: * -> *) a b.
Functor f =>
(a -> Identity b) -> f a -> Identity (f b)
mapped 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") (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 <- 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
    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     -> forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> [Char]
displayException HsCiError
err
        Right GitHub
github -> do
            forall (m :: * -> *).
MonadDiagnostics m =>
[Char] -> TestedWithJobs -> JobVersions -> [Package] -> m ()
describeJobs [Char]
"GitHub config" (Config -> TestedWithJobs
cfgTestedWith Config
config) JobVersions
jobVersions (forall uri opt pkg. Project uri opt pkg -> [pkg]
prjPackages Project URI Void Package
prj)
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
toUTF8BS forall a b. (a -> b) -> a -> b
$ forall ann. (ann -> [[Char]]) -> Yaml ann -> [Char]
prettyYaml forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall ann. (ann -> ann) -> Yaml ann -> Yaml ann
reann (Bool -> [[Char]] -> [[Char]]
githubHeader (Config -> Bool
cfgInsertVersion Config
config) [[Char]]
argv forall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ forall a. ToYaml a => a -> Yaml [[Char]]
toYaml GitHub
github

regenerateGitHub :: Options -> IO ()
regenerateGitHub :: Options -> IO ()
regenerateGitHub Options
opts = do
    -- change the directory
    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
    forall r. [Char] -> IO r -> ([Char] -> IO r) -> IO r
withContents [Char]
fp IO ()
noGitHubScript 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 forall a b. (a -> b) -> a -> b
$ [Char]
"Error: expected REGENDATA line in " forall a. [a] -> [a] -> [a]
++ [Char]
fp
            forall a. IO a
exitFailure

        Just (Maybe Version
mversion, [[Char]]
argv) -> do
            -- warn if we regenerate using older haskell-ci
            forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Version
mversion forall a b. (a -> b) -> a -> b
$ \Version
version -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall a. Parsec a => [Char] -> Maybe a
simpleParsec [Char]
haskellCIVerStr) forall a b. (a -> b) -> a -> b
$ \Version
haskellCIVer ->
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
haskellCIVer forall a. Ord a => a -> a -> Bool
< Version
version) forall a b. (a -> b) -> a -> b
$ do
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
"Regenerating using older haskell-ci-" forall a. [a] -> [a] -> [a]
++ [Char]
haskellCIVerStr
                    Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
"File generated using haskell-ci-" forall a. [a] -> [a] -> [a]
++ 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 forall a. Semigroup a => a -> a -> a
<> Options
opts' forall a. Semigroup a => a -> a -> a
<> Options
opts)
  where
    fp :: [Char]
fp = [Char]
defaultGitHubPath

    noGitHubScript :: IO ()
    noGitHubScript :: IO ()
noGitHubScript = [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"No " forall a. [a] -> [a] -> [a]
++ [Char]
fp 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    = forall (m :: * -> *) a. Monad m => a -> m a
return Config
emptyConfig
findConfigFile (ConfigOpt [Char]
fp) = forall (m :: * -> *). MonadIO m => [Char] -> m Config
readConfigFile [Char]
fp
findConfigFile ConfigOpt
ConfigOptAuto  = do
    let defaultPath :: [Char]
defaultPath = [Char]
"cabal.haskell-ci"
    Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO Bool
doesFileExist [Char]
defaultPath)
    if Bool
exists
    then forall (m :: * -> *). MonadIO m => [Char] -> m Config
readConfigFile [Char]
defaultPath
    else 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 = forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[[Char]] -> ByteString -> m ByteString
patchYAML 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 = forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[[Char]] -> ByteString -> m ByteString
patchYAML 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
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
patches = forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
input
  | Bool
otherwise =
      forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> Handle -> m a) -> m a
withSystemTempFile [Char]
"yml.tmp" forall a b. (a -> b) -> a -> b
$ \[Char]
fp Handle
h -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Handle -> ByteString -> IO ()
BS.hPutStr Handle
h ByteString
input
        Handle -> IO ()
hClose Handle
h
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[Char]]
patches 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
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot find " 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ExitFailure Int
n -> forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines
                [ [Char]
"patch returned exit code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n
                , [Char]
"Stdout: " forall a. [a] -> [a] -> [a]
++ [Char]
stdOut
                , [Char]
"Stderr: " 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 <- 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 <- forall a b. (a -> Maybe b) -> [a] -> Maybe b
findMaybe (forall a. Eq a => [a] -> [a] -> Maybe [a]
afterInfix [Char]
"REGENDATA") ([Char] -> [[Char]]
lines [Char]
contents)
    forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Parsec a => [Char] -> Maybe a
simpleParsec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
l :: Maybe (String, [String]))
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
BS.readFile [Char]
path
    Project Void [Char] [Char]
prj0 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => ParseError f -> [Char]
renderParseError) forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolveError -> [Char]
renderResolveError) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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)
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => ParseError f -> [Char]
renderParseError) forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall uri opt.
Project uri opt [Char]
-> IO
     (Either
        (ParseError NonEmpty)
        (Project uri opt ([Char], GenericPackageDescription)))
readPackagesOfProject (forall c b a. Project c b a
emptyProject 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" forall s t a b. ASetter s t a b -> b -> s -> t
.~ [[Char]
path])
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). Foldable f => ParseError f -> [Char]
renderParseError) 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 forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd
        pkgNameStr :: [Char]
pkgNameStr = forall a. Pretty a => a -> [Char]
display forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
Pkg.pkgName forall a b. (a -> b) -> a -> b
$ PackageDescription -> PackageIdentifier
package forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
packageDescription GenericPackageDescription
gpd

    let unknownComps :: [CompilerFlavor]
unknownComps = forall a. Eq a => [a] -> [a]
nub [ CompilerFlavor
c | (CompilerFlavor
c,VersionRange
_) <- [(CompilerFlavor, VersionRange)]
compilers, CompilerFlavor
c forall a. Eq a => a -> a -> Bool
/= CompilerFlavor
Compiler.GHC, CompilerFlavor
c 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 forall a b. (a -> 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 = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> 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 = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe VersionRange -> Maybe Version
isSpecificVersion [VersionRange]
ghcjsVerConstrs

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

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
twoDigitGhcVerConstrs) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). MonadDiagnostics m => [Char] -> m ()
putStrLnWarn forall a b. (a -> b) -> a -> b
$ [Char]
"'tested-with:' uses two digit GHC versions (which don't match any existing GHC version): " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> [Char]
display [Version]
twoDigitGhcVerConstrs)
        forall (m :: * -> *). MonadDiagnostics m => [Char] -> m ()
putStrLnInfo 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'"

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

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

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

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

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

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

    let unknownGhcjsVers :: [Version]
unknownGhcjsVers = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ [Version]
specificGhcjsVers forall a. Eq a => [a] -> [a] -> [a]
\\ [Version]
knownGhcjsVersions
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
unknownGhcjsVers) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. MonadDiagnostics m => [Char] -> m a
putStrLnErr ([Char]
"'tested-with:' specifically refers to unknown 'GHCJS' versions: "
                     forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> [Char]
display [Version]
unknownGhcjsVers) forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                     forall a. [a] -> [a] -> [a]
++ [Char]
"Known GHCJS versions: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map 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   = forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> VersionRange -> Bool
`withinRange` VersionRange
ghcVerConstrs') [Version]
knownGhcVersions'
    let testedGhcjsVersions :: [Version]
testedGhcjsVersions = forall a. (a -> Bool) -> [a] -> [a]
filter (Version -> VersionRange -> Bool
`withinRange` VersionRange
ghcjsVerConstrs') [Version]
knownGhcjsVersions

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Version]
testedGhcVersions) forall a b. (a -> b) -> a -> b
$ do
        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 = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$
            [ Version -> CompilerVersion
GHC Version
v
            | Version
v <- [Version]
testedGhcVersions
            ] 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

    forall (m :: * -> *) a. Monad m => a -> m a
return Package
pkg
  where
    lastStableGhcVers :: [Version]
lastStableGhcVers
        = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Version -> (Int, Int)
ghcMajVer)
        forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare)
        forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> CompilerVersion -> Bool
previewGHC VersionRange
defaultHeadHackage forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> CompilerVersion
GHC)
        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 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 = forall a. a -> Maybe a
Just Version
v
        t Version
_                             = forall a. Maybe a
Nothing

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