{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
#if !defined(MIN_VERSION_Cabal)
# define MIN_VERSION_Cabal(x,y,z) 0
#endif
module MakeTravisYml (
main,
Result (..),
Diagnostic (..),
parseOptsNoCommands,
formatDiagnostic, formatDiagnostics,
travisFromConfigFile, MakeTravisOutput, Options (..), defOptions, options,
) where
import Control.Applicative as App ((<$>),(<|>), pure)
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Control.Monad (void, when, unless, filterM, liftM, liftM2, forM_, mzero, foldM, join)
import Data.Char (isSpace, isUpper, toLower)
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import Data.Function
import Data.List
import Data.Maybe
import Data.Monoid as Mon (Monoid (..), Endo (..))
import Data.Either (partitionEithers)
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Map as M
import System.Console.GetOpt
import System.Directory (doesDirectoryExist, getDirectoryContents, doesFileExist)
import System.Environment
import System.Exit
import System.FilePath.Posix ((</>), takeDirectory, takeFileName, takeExtension)
import System.IO
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Writer
import Text.Read (readMaybe)
import Distribution.Compiler (CompilerFlavor(..))
import Distribution.Package hiding (Package, pkgName)
import qualified Distribution.Package as Pkg
import Distribution.PackageDescription (GenericPackageDescription,packageDescription, testedWith, package, condLibrary, condTestSuites)
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import qualified Distribution.PackageDescription as PD
import qualified Distribution.ParseUtils as PU
import Distribution.Text
import Distribution.Version
#if MIN_VERSION_Cabal(2,2,0)
import Distribution.PackageDescription.Parsec (readGenericPackageDescription)
#elif MIN_VERSION_Cabal(2,0,0)
import Distribution.PackageDescription.Parse (readGenericPackageDescription)
#else
import Distribution.PackageDescription.Parse (readPackageDescription)
import Distribution.Verbosity (Verbosity)
#endif
import Distribution.Compat.ReadP
( ReadP, (<++), (+++), between, char, many1, munch1
, pfail, readP_to_S, readS_to_P, look
, satisfy, sepBy, sepBy1, gather, munch, skipSpaces)
#ifdef MIN_VERSION_ShellCheck
import ShellCheck.Checker (checkScript)
import qualified ShellCheck.Interface as SC
import qualified ShellCheck.Formatter.Format as SC
import qualified ShellCheck.Formatter.TTY as SC.TTY
import System.IO.Unsafe (unsafePerformIO)
#endif
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup (..))
#else
import Data.Monoid ((<>))
#endif
#if !(MIN_VERSION_Cabal(2,0,0))
readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription = readPackageDescription
mkVersion :: [Int] -> Version
mkVersion vn = Version vn []
versionNumbers :: Version -> [Int]
versionNumbers (Version vn _) = vn
#endif
knownGhcVersions :: [Version]
knownGhcVersions = fmap mkVersion
[ [7,0,1], [7,0,2], [7,0,3], [7,0,4]
, [7,2,1], [7,2,2]
, [7,4,1], [7,4,2]
, [7,6,1], [7,6,2], [7,6,3]
, [7,8,1], [7,8,2], [7,8,3], [7,8,4]
, [7,10,1], [7,10,2], [7,10,3]
, [8,0,1], [8,0,2]
, [8,2,1], [8,2,2]
, [8,4,1], [8,4,2], [8,4,3]
, [8,6,1]
]
ghcAlpha :: Maybe Version
ghcAlpha = Just (mkVersion [8,6,1])
cabalVerMap :: [((Int, Int), Maybe Version)]
cabalVerMap = fmap (fmap (fmap mkVersion))
[ ((7, 0), Just [2,2])
, ((7, 2), Just [2,2])
, ((7, 4), Just [2,2])
, ((7, 6), Just [2,2])
, ((7, 8), Just [2,2])
, ((7,10), Just [2,2])
, ((8, 0), Just [2,2])
, ((8, 2), Just [2,2])
, ((8, 4), Just [2,2])
]
defaultHLintVersion :: VersionRange
defaultHLintVersion = withinVersion (mkVersion [2,1])
defaultDoctestVersion :: VersionRange
defaultDoctestVersion = withinVersion (mkVersion [0,16])
sh :: String -> String
sh = sh'
[ 2034
, 2086
]
sh' :: [Integer] -> String -> String
#ifndef MIN_VERSION_ShellCheck
sh' _ = shImpl
#else
sh' excl cmd = unsafePerformIO $ do
res <- checkScript iface spec
case res of
(SC.CheckResult _ []) -> return (shImpl cmd)
_ -> SC.onResult scFormatter res iface >> fail "ShellCheck!"
where
iface = SC.SystemInterface $ \n -> return $ Left $ "cannot read file: " ++ n
spec = SC.emptyCheckSpec { SC.csFilename = "stdin"
, SC.csScript = cmd
, SC.csExcludedWarnings = excl
, SC.csShellTypeOverride = Just SC.Sh
}
scFormatter :: SC.Formatter
scFormatter = unsafePerformIO (SC.TTY.format (SC.FormatterOptions SC.ColorAlways))
#endif
shImpl :: String -> String
shImpl cmd
| ':' `elem` cmd = " - " ++ show cmd
| otherwise = " - " ++ cmd
comment :: String -> String
comment = (" # " ++)
type MakeTravisOutput = Result Diagnostic [String]
data Diagnostic
= Info String
| Warn String
| Error String
deriving (Eq, Show)
formatDiagnostics :: [Diagnostic] -> String
formatDiagnostics = unlines . map formatDiagnostic
formatDiagnostic :: Diagnostic -> String
formatDiagnostic (Error s) = "*ERROR* " ++ s
formatDiagnostic (Warn s) = "*WARNING* " ++ s
formatDiagnostic (Info s) = "*INFO* " ++ s
type YamlWriter m a = MaybeT (WriterT MakeTravisOutput m) a
putStrLnErr :: Monad m => String -> YamlWriter m a
putStrLnErr m = do
lift . tell $ Failure [Error m]
mzero
putStrLnErrs :: Monad m => [String] -> YamlWriter m ()
putStrLnErrs [] = return ()
putStrLnErrs ms = do
lift (tell (Failure (map Error ms)))
mzero
putStrLnWarn, putStrLnInfo :: Monad m => String -> YamlWriter m ()
putStrLnWarn m = lift . tell $ Success [Warn m] []
putStrLnInfo m = lift . tell $ Success [Info m] []
tellStrLn :: Monad m => String -> YamlWriter m ()
tellStrLn str = lift . tell $ success [str]
tellStrLns :: Monad m => [String] -> YamlWriter m ()
tellStrLns = lift . tell . success
foldedTellStrLns
:: Monad m
=> Fold
-> String
-> Set Fold
-> YamlWriter m ()
-> YamlWriter m ()
foldedTellStrLns label = foldedTellStrLns' label ""
foldedTellStrLns'
:: Monad m
=> Fold
-> String
-> String
-> Set Fold
-> YamlWriter m ()
-> YamlWriter m ()
foldedTellStrLns' label pfx prettyLabel labels output
| label `S.notMember` labels = output
| otherwise = tellStrLns [prologue] >> output >> tellStrLns epilogue
where
prologue = mconcat
[ " - echo ", prettyLabel
, " && echo -en 'travis_fold:start:", showFold' label, "\\\\r'" ]
epilogue = [" - echo -en 'travis_fold:end:" ++ showFold' label ++ "\\\\r'" ]
showFold' l = showFold l ++ if null pfx then "" else "-" ++ pfx
afterInfix :: Eq a => [a] -> [a] -> Maybe [a]
afterInfix needle haystack = findMaybe (afterPrefix needle) (tails haystack)
afterPrefix :: Eq a => [a] -> [a] -> Maybe [a]
afterPrefix needle haystack
| needle `isPrefixOf` haystack = Just (drop (length needle) haystack)
| otherwise = Nothing
findMaybe :: (a -> Maybe b) -> [a] -> Maybe b
findMaybe f = foldr (\a b -> f a App.<|> b) Nothing
maybeReadP :: ReadP a a -> String -> Maybe a
maybeReadP p s = listToMaybe $
[ x
| (x, rest) <- readP_to_S p s
, all isSpace rest
]
main :: IO ()
main = do
argv <- getArgs
(opts,argv',configFile,xpkgs) <- parseOpts argv
genTravisFromConfigFile (argv',opts) configFile xpkgs
parseOpts :: [String] -> IO (Options, [String], FilePath, [String])
parseOpts argv = case argv of
(cmd : argv') | cmd `isPrefixOf` "regenerate" -> do
let fp = fromMaybe ".travis.yml" $ listToMaybe argv'
ls <- fmap lines (readFile fp >>= evaluate . force)
case findArgv ls of
Nothing -> dieCli [Error $ "expected REGENDATA line in " ++ fp ++ "\n"]
Just argv'' -> parseOpts argv''
[cmd] | cmd `isPrefixOf` "list-ghc" -> do
putStrLn $ "Supported GHC versions:"
forM_ groupedVersions $ \(v, vs) -> do
putStr $ prettyMajVersion v ++ ": "
putStrLn $ intercalate ", " (map display vs)
exitSuccess
_ -> parseOptsNoCommands argv
where
groupedVersions :: [(Version, [Version])]
groupedVersions = map ((\vs -> (head vs, vs)) . sortBy (flip compare))
. groupBy ((==) `on` ghcMajVer)
$ sort knownGhcVersions
prettyMajVersion :: Version -> String
prettyMajVersion v
| Just v == ghcAlpha = "alpha"
| otherwise = case ghcMajVer v of (x,y) -> show x ++ "." ++ show y
findArgv :: [String] -> Maybe [String]
findArgv ls = do
l <- findMaybe (afterInfix "REGENDATA") ls
readMaybe l
parseOptsNoCommands :: [String] -> IO (Options, [String], FilePath, [String])
parseOptsNoCommands argv = case getOpt Permute options argv of
(opts',configFile:xpkgs,[]) -> do
opts <- foldOptions defOptions opts'
return (opts,argv,configFile,xpkgs)
(_,_,[]) -> dieCli [Error "expected .cabal or cabal.project file as first non-option argument\n"]
(_,_,errs) -> dieCli (map Error errs)
where
foldOptions :: Options -> [Result Diagnostic (Options -> Options)] -> IO Options
foldOptions def opts = case foldOptions' def opts of
Success ws x -> do
hPutStr stderr (formatDiagnostics ws)
return x
Failure errs -> dieCli errs
foldOptions' :: Options -> [Result e (Options -> Options)] -> Result e Options
foldOptions' opts = fmap (`appEndo` opts) . F.foldMap (fmap Endo)
dieCli :: [Diagnostic] -> IO a
dieCli errs = hPutStrLn stderr (usageMsg errs) >> exitFailure
where
usageMsg errs' = formatDiagnostics errs' ++ usageInfo h options ++ ex
h = intercalate "\n"
[ "Usage: runghc make_travis_yml_2.hs [OPTIONS] <cabal-file | cabal.project> <extra-apt-packages...>"
, ""
, "Available commands:"
, " regenerate [TRAVIS.YAML] Regenerate the file using the magic command in it. Default .travis.yml"
, " list-ghc List GHC versions supported by this version of make-travis-yml"
, ""
, "Available options:"
]
ex = unlines
[ ""
, "Example:"
, " runghc make_travis_yml_2.hs -o .travis.yml someProject.cabal liblzma-dev"
]
runYamlWriter :: Maybe FilePath -> YamlWriter IO () -> IO ()
runYamlWriter mfp m = do
result <- execWriterT (runMaybeT m)
case result of
Failure (formatDiagnostics -> errors) -> hPutStr stderr errors >> exitFailure
Success (formatDiagnostics -> warnings) (unlines -> contents) -> do
contents' <- evaluate (force contents)
hPutStr stderr warnings
case mfp of
Nothing -> putStr contents'
Just fp -> writeFile fp contents'
ghcMajVer :: Version -> (Int,Int)
ghcMajVer v
| x:y:_ <- versionNumbers v = (x,y)
| otherwise = error $ "panic: ghcMajVer called with " ++ show v
previewGHC :: Maybe Version -> Bool
previewGHC = maybe True $ \v -> Just v == ghcAlpha || odd (snd (ghcMajVer v))
dispGhcVersion :: Maybe Version -> String
dispGhcVersion = maybe "head" display
data Package = Pkg
{ pkgName :: String
, pkgDir :: FilePath
, pkgGpd :: GenericPackageDescription
} deriving (Eq, Show)
genTravisFromConfigFile :: ([String],Options) -> FilePath -> [String] -> IO ()
genTravisFromConfigFile args@(_, opts) path xpkgs =
runYamlWriter (optOutput opts) $ travisFromConfigFile args path xpkgs
travisFromConfigFile
:: MonadIO m
=> ([String],Options)
-> FilePath
-> [String]
-> YamlWriter m ()
travisFromConfigFile args@(_, opts) path xpkgs = do
cabalFiles <- getCabalFiles
config' <- maybe (return emptyConfig) readConfigFile (optConfig opts)
let config = optConfigMorphism opts config'
pkgs <- T.mapM (configFromCabalFile config opts) cabalFiles
(ghcs, prj) <- checkVersions pkgs
genTravisFromConfigs args xpkgs isCabalProject config prj ghcs
where
checkVersions
:: MonadIO m
=> Project (Package, Set Version)
-> YamlWriter m (Set Version, Project Package)
checkVersions prj | null (prjPackages prj) = putStrLnErr "Error reading cabal file(s)!"
checkVersions prj = do
let (errors, names) = F.foldl' collectConfig mempty prj
putStrLnErrs errors
return (allVersions, prj { prjPackages = names })
where
allVersions = F.foldMap snd prj
collectConfig
:: ([String], [Package])
-> (Package, Set Version)
-> ([String], [Package])
collectConfig aggregate (pkg, testWith) =
aggregate <> (errors, [pkg])
where
symDiff a b = S.union a b `S.difference` S.intersection a b
diff = symDiff testWith allVersions
missingVersions = map display $ S.toList diff
errors | S.null diff = []
| otherwise = App.pure $ mconcat
[ pkgName pkg
, " is missing tested-with annotations for: "
] ++ intercalate "," missingVersions
isCabalProject :: Maybe FilePath
isCabalProject
| "cabal.project" `isPrefixOf` takeFileName path = Just path
| otherwise = Nothing
getCabalFiles :: MonadIO m => YamlWriter m (Project FilePath)
getCabalFiles
| isNothing isCabalProject = return (Project [path] Nothing Nothing)
| otherwise = do
contents <- liftIO $ readFile path
pkgs <- either putStrLnErr return $ parseProjectFile path contents
overPrjPackages concat `liftM` T.mapM findProjectPackage pkgs
rootdir = takeDirectory path
findProjectPackage :: MonadIO m => String -> YamlWriter m [FilePath]
findProjectPackage pkglocstr = do
mfp <- checkisFileGlobPackage pkglocstr `mplusMaybeT`
checkIsSingleFilePackage pkglocstr
maybe (putStrLnErr $ "bad package location: " ++ pkglocstr) return mfp
checkIsSingleFilePackage pkglocstr = do
let abspath = rootdir </> pkglocstr
isFile <- liftIO $ doesFileExist abspath
isDir <- liftIO $ doesDirectoryExist abspath
if | isFile && takeExtension pkglocstr == ".cabal" -> return (Just [abspath])
| isDir -> checkisFileGlobPackage (pkglocstr </> "*.cabal")
| otherwise -> return Nothing
checkisFileGlobPackage pkglocstr =
case filter (null . snd) $ readP_to_S parseFilePathGlobRel pkglocstr of
[(g, "")] -> do
files <- liftIO $ expandRelGlob rootdir g
let files' = filter ((== ".cabal") . takeExtension) files
if null files' then return Nothing else return (Just files')
_ -> return Nothing
mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
mplusMaybeT ma mb = do
mx <- ma
case mx of
Nothing -> mb
Just x -> return (Just x)
configFromCabalFile
:: MonadIO m => Config -> Options -> FilePath -> YamlWriter m (Package, Set Version)
configFromCabalFile cfg opts cabalFile = do
gpd <- liftIO $ readGenericPackageDescription maxBound cabalFile
let compilers = testedWith $ packageDescription gpd
pkgNameStr = display $ Pkg.pkgName $ package $ packageDescription gpd
let unknownComps = nub [ c | (c,_) <- compilers, c /= GHC ]
ghcVerConstrs = [ vc | (GHC,vc) <- compilers ]
ghcVerConstrs' = simplifyVersionRange $ foldr unionVersionRanges noVersion ghcVerConstrs
twoDigitGhcVerConstrs = mapMaybe isTwoDigitGhcVersion ghcVerConstrs :: [Version]
specificGhcVers = nub $ mapMaybe isSpecificVersion ghcVerConstrs
unless (null twoDigitGhcVerConstrs) $ do
putStrLnWarn $ "'tested-with:' uses two digit GHC versions (which don't match any existing GHC version): " ++ intercalate ", " (map display twoDigitGhcVerConstrs)
putStrLnInfo $ "Either use wild-card format, for example 'tested-with: GHC ==7.10.*' or a specific existing version 'tested-with: GHC ==7.10.3'"
when (null compilers) $ do
putStrLnErr (unlines $
[ "empty or missing top-level 'tested-with:' definition in " ++ cabalFile ++ " file; example definition:"
, ""
, "tested-with: " ++ intercalate ", " [ "GHC==" ++ display v | v <- lastStableGhcVers ]
])
unless (null unknownComps) $ do
putStrLnWarn $ "ignoring unsupported compilers mentioned in tested-with: " ++ show unknownComps
when (null ghcVerConstrs) $ do
putStrLnErr "'tested-with:' doesn't mention any 'GHC' version"
when (isNoVersion ghcVerConstrs') $ do
putStrLnErr "'tested-with:' describes an empty version range for 'GHC'"
when (isAnyVersion ghcVerConstrs') $ do
putStrLnErr "'tested-with:' allows /any/ 'GHC' version"
let unknownGhcVers = sort $ specificGhcVers \\ knownGhcVersions
unless (null unknownGhcVers) $ do
putStrLnErr ("'tested-with:' specifically refers to unknown 'GHC' versions: "
++ intercalate ", " (map display unknownGhcVers) ++ "\n"
++ "Known GHC versions: " ++ intercalate ", " (map display knownGhcVersions))
let knownGhcVersions'
| cfgLastInSeries cfg = filterLastMajor knownGhcVersions
| otherwise = knownGhcVersions
let testedGhcVersions = filter (`withinRange` ghcVerConstrs') knownGhcVersions'
when (null testedGhcVersions) $ do
putStrLnErr "no known GHC version is allowed by the 'tested-with' specification"
forM_ (optCollections opts) $ \c -> do
let v = collToGhcVer c
unless (v `elem` testedGhcVersions) $
putStrLnErr $ unlines
[ "collection " ++ c ++ " requires GHC " ++ display v
, "add 'tested-width: GHC == " ++ display v ++ "' to your .cabal file"
]
let pkg = Pkg pkgNameStr (takeDirectory cabalFile) gpd
return (pkg, S.fromList testedGhcVersions)
where
lastStableGhcVers
= nubBy ((==) `on` ghcMajVer)
$ sortBy (flip compare)
$ filter (not . previewGHC . Just)
$ knownGhcVersions
isTwoDigitGhcVersion :: VersionRange -> Maybe Version
isTwoDigitGhcVersion vr = isSpecificVersion vr >>= t
where
t v | [_,_] <- versionNumbers v = Just v
t _ = Nothing
filterLastMajor = map maximum . groupBy ((==) `on` ghcMajVer)
genTravisFromConfigs
:: Monad m
=> ([String], Options)
-> [String]
-> Maybe FilePath
-> Config
-> Project Package
-> Set Version
-> YamlWriter m ()
genTravisFromConfigs (argv,opts) xpkgs isCabalProject config prj@Project { prjPackages = pkgs } versions' = do
let folds = cfgFolds config
putStrLnInfo $
"Generating Travis-CI config for testing for GHC versions: " ++ ghcVersions
unless (null $ optOsx opts) $ do
putStrLnInfo $ "Also OSX jobs for: " ++ ghcOsxVersions
unless (S.null omittedOsxVersions) $
putStrLnWarn $ "Not all GHC versions specified with --osx are generated: " ++ ghcOmittedOsxVersions
tellStrLns
[ "# This Travis job script has been generated by a script via"
, "#"
, "# runghc make_travis_yml_2.hs " ++ unwords [ "'" ++ a ++ "'" | a <- argv ]
, "#"
, "# For more information, see https://github.com/haskell-CI/haskell-ci"
, "#"
, "language: c"
, "sudo: false"
, ""
, "git:"
, " submodules: false # whether to recursively clone submodules"
, ""
]
let projectName = fromMaybe (pkgName $ head pkgs) (cfgProjectName config)
unless (null $ cfgIrcChannels config) $ tellStrLns $
[ "notifications:"
, " irc:"
, " channels:"
] ++
[ " - \"" ++ chan ++ "\"" | chan <- cfgIrcChannels config ] ++
[ " skip_join: true"
, " template:"
, " - \"\\x0313" ++ projectName ++ "\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\""
, ""
]
unless (null $ cfgOnlyBranches config) $ tellStrLns $
[ "branches:"
, " only:"
] ++
[ " - " ++ branch
| branch <- cfgOnlyBranches config
] ++
[ ""
]
when (cfgCache config) $ tellStrLns
[ "cache:"
, " directories:"
, " - $HOME/.cabal/packages"
, " - $HOME/.cabal/store"
]
when (cfgCache config && not (null (optOsx opts))) $ tellStrLns
[ " - $HOME/.ghc-install"
]
when (cfgCache config) $ tellStrLns
[ ""
, "before_cache:"
, " - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log"
, " # remove files that are regenerated by 'cabal update'"
, " - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*"
, " - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json"
, " - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache"
, " - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar"
, " - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx"
, ""
, " - rm -rfv $HOME/.cabal/packages/head.hackage"
, ""
]
tellStrLn "matrix:"
tellStrLn " include:"
let colls = [ (collToGhcVer cid,cid) | cid <- reverse $ optCollections opts ]
let tellJob :: Monad m => Bool -> Maybe Version -> YamlWriter m ()
tellJob osx gv = do
let cvs = dispGhcVersion $ cfgCabalInstallVersion config <|> (lookupCabVer =<< gv)
gvs = dispGhcVersion gv
xpkgs' = concatMap (',':) xpkgs
colls' = [ cid | (v,cid) <- colls, Just v == gv ]
tellStrLns
[ " - compiler: \"ghc-" <> gvs <> "\""
, if | Just e <- gv >>= \v -> M.lookup v (cfgEnv config)
-> " env: " ++ e
| previewGHC gv -> " env: GHCHEAD=true"
| null colls' -> " # env: TEST=--disable-tests BENCH=--disable-benchmarks"
| otherwise -> " env: 'COLLECTIONS=" ++ intercalate "," colls' ++ "'"
, " addons: {apt: {packages: [ghc-ppa-tools,cabal-install-" <> cvs <> ",ghc-" <> gvs <> xpkgs' <> "], sources: [hvr-ghc]}}"
]
when osx $ tellStrLns
[ " os: osx"
]
F.forM_ (reverse $ S.toList versions) $ tellJob False
F.forM_ (reverse $ S.toList osxVersions) $ tellJob True . Just
let allowFailures = headGhcVers `S.union` S.map Just (cfgAllowFailures config)
unless (S.null allowFailures) $ do
tellStrLn ""
tellStrLn " allow_failures:"
F.forM_ allowFailures $ \gv -> do
let gvs = dispGhcVersion gv
tellStrLn $ concat [ " - compiler: \"ghc-", gvs, "\"" ]
tellStrLns
[ ""
, "before_install:"
, sh "HC=${CC}"
, sh' [2034,2039] "HCPKG=${HC/ghc/ghc-pkg}"
, sh "unset CC"
, sh "ROOTDIR=$(pwd)"
, sh "mkdir -p $HOME/.local/bin"
]
let haskellOnMacos = "https://haskell.futurice.com/haskell-on-macos.py"
if null (optOsx opts)
then tellStrLns
[ sh "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
]
else tellStrLns
[ sh $ "if [ \"$(uname)\" = \"Darwin\" ]; then brew update; brew upgrade python@3; curl " ++ haskellOnMacos ++ " | python3 - --make-dirs --install-dir=$HOME/.ghc-install --cabal-alias=head install cabal-install-head ${HC}; fi"
, sh $ "if [ \"$(uname)\" = \"Darwin\" ]; then PATH=$HOME/.ghc-install/ghc/bin:$HOME/local/bin:$PATH; else PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH; fi"
]
tellStrLns
[ sh $ "HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\\.([0-9]+)\\.([0-9]+).*/\\1 * 10000 + \\2 * 100 + \\3/') ))"
, sh "echo $HCNUMVER"
]
unless (null colls) $
tellStrLn " - IFS=', ' read -a COLLS <<< \"$COLLECTIONS\""
tellStrLns
[ ""
, "install:"
, sh "cabal --version"
, sh "echo \"$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]\""
, sh "BENCH=${BENCH---enable-benchmarks}"
, sh "TEST=${TEST---enable-tests}"
, sh "HADDOCK=${HADDOCK-true}"
, sh "UNCONSTRAINED=${UNCONSTRAINED-true}"
, sh "NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}"
, sh "GHCHEAD=${GHCHEAD-false}"
]
tellStrLns
[ sh "travis_retry cabal update -v"
, sh "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
, sh "rm -fv cabal.project cabal.project.local"
]
case cfgJobs config of
(Just n, _) -> tellStrLns
[ sh $ "sed -i.bak 's/^-- jobs:.*/jobs: " ++ show n ++ "/' ${HOME}/.cabal/config"
]
_ -> return ()
case cfgJobs config of
(_, Just m) -> tellStrLns
[ sh $ "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j" ++ show m ++ "/' ${HOME}/.cabal/config; fi"
]
_ -> return ()
unless (S.null headGhcVers) $ tellStrLns
[ " # Overlay Hackage Package Index for GHC HEAD: https://github.com/hvr/head.hackage"
, " - |"
, " if $GHCHEAD; then"
, " sed -i 's/-- allow-newer: .*/allow-newer: *:base/' ${HOME}/.cabal/config"
, " for pkg in $($HCPKG list --simple-output); do pkg=$(echo $pkg | sed 's/-[^-]*$//'); sed -i \"s/allow-newer: /allow-newer: *:$pkg, /\" ${HOME}/.cabal/config; done"
, ""
, " echo 'repository head.hackage' >> ${HOME}/.cabal/config"
, " echo ' url: http://head.hackage.haskell.org/' >> ${HOME}/.cabal/config"
, " echo ' secure: True' >> ${HOME}/.cabal/config"
, " echo ' root-keys: 07c59cb65787dedfaef5bd5f987ceb5f7e5ebf88b904bbd4c5cbdeb2ff71b740' >> ${HOME}/.cabal/config"
, " echo ' 2e8555dde16ebd8df076f1a8ef13b8f14c66bad8eafefd7d9e37d0ed711821fb' >> ${HOME}/.cabal/config"
, " echo ' 8f79fd2389ab2967354407ec852cbe73f2e8635793ac446d09461ffb99527f6e' >> ${HOME}/.cabal/config"
, " echo ' key-threshold: 3' >> ${HOME}/.cabal.config"
, ""
, " grep -Ev -- '^\\s*--' ${HOME}/.cabal/config | grep -Ev '^\\s*$'"
, ""
, " cabal new-update head.hackage -v"
, " fi"
]
tellStrLns
[ sh "grep -Ev -- '^\\s*--' ${HOME}/.cabal/config | grep -Ev '^\\s*$'"
]
let doctestVersionConstraint
| isAnyVersion (cfgDoctestVersion config) = ""
| otherwise = " --constraint='doctest " ++ display (cfgDoctestVersion config) ++ "'"
when (cfgDoctest config) $ tellStrLns
[ sh $ "if [ $HCNUMVER -ge 80000 ]; then cabal new-install -w ${HC} -j2 --symlink-bindir=$HOME/.local/bin doctest" ++ doctestVersionConstraint ++ "; fi"
]
let hlintVersionConstraint
| isAnyVersion (cfgHLintVersion config) = ""
| otherwise = " --constraint='hlint " ++ display (cfgHLintVersion config) ++ "'"
when (cfgHLint config) $ tellStrLns
[ sh $ "if [ $HCNUMVER -eq 80403 ]; then cabal new-install -w ${HC} -j2 --symlink-bindir=$HOME/.local/bin hlint" ++ hlintVersionConstraint ++ "; fi"
]
generateCabalProject False
let pkgFilter = intercalate " | " $ map (wrap.pkgName) pkgs
wrap s = "grep -Fv \"" ++ s ++ " ==\""
unless (null colls) $ tellStrLns
[ " - for COLL in \"${COLLS[@]}\"; do"
, " echo \"== collection $COLL ==\";"
, " ghc-travis collection ${COLL} > /dev/null || break;"
, " ghc-travis collection ${COLL} | " ++ pkgFilter ++ " > cabal.project.freeze;"
, " grep ' collection-id' cabal.project.freeze;"
, " rm -rf dist-newstyle/;"
, " cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file=\"" ++ projectFile ++ "\" --dep -j2 all;"
, " done"
, ""
]
forM_ pkgs $ \Pkg{pkgDir} -> tellStrLns
[ " - if [ -f \"" ++ pkgDir ++ "/configure.ac\" ]; then"
, " (cd \"" ++ pkgDir ++ "\" && autoreconf -i);"
, " fi"
]
let quotedRmPaths =
".ghc.environment.*"
++ " " ++
quotedPaths (\Pkg{pkgDir} -> pkgDir ++ "/dist")
tellStrLns
[ sh $ "rm -f cabal.project.freeze"
]
when (cfgInstallDeps config) $ do
tellStrLns
[ sh $ "cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file=\"" ++ projectFile ++"\" --dep -j2 all"
]
when (cfgNoTestsNoBench config) $ tellStrLns
[ sh $ "cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file=\"" ++ projectFile ++ "\" --dep -j2 all"
]
tellStrLns
[ sh $ "rm -rf " ++ quotedRmPaths
, sh $ "DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)"
]
tellStrLns
[ ""
, "# Here starts the actual work to be performed for the package under test;"
, "# any command which exits with a non-zero exit code causes the build to fail."
, "script:"
, " # test that source-distributions can be generated"
]
foldedTellStrLns FoldSDist "Packaging..." folds $ do
forM_ pkgs $ \Pkg{pkgDir} -> tellStrLns
[ sh $ "(cd \"" ++ pkgDir ++ "\" && cabal sdist)"
]
let tarFiles = quotedPaths $ \Pkg{pkgDir,pkgName} ->
pkgDir </> "dist" </> pkgName ++ "-*.tar.gz"
foldedTellStrLns FoldUnpack "Unpacking..." folds $ do
tellStrLns
[ sh $ "mv " ++ tarFiles ++ " ${DISTDIR}/"
, sh $ "cd ${DISTDIR} || false"
, sh $ "find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \\;"
]
generateCabalProject True
when (cfgNoTestsNoBench config) $ foldedTellStrLns FoldBuild "Building..." folds $ tellStrLns
[ comment "this builds all libraries and executables (without tests/benchmarks)"
, sh "cabal new-build -w ${HC} --disable-tests --disable-benchmarks all"
]
tellStrLns [""]
foldedTellStrLns FoldBuildEverything
"Building with tests and benchmarks..." folds $ tellStrLns
[ comment "build & run tests, build benchmarks"
, sh "cabal new-build -w ${HC} ${TEST} ${BENCH} all"
]
when hasTests $
foldedTellStrLns FoldTest "Testing..." folds $ tellStrLns
[ sh $ mconcat
[ "if [ \"x$TEST\" = \"x--enable-tests\" ]; then "
, if cfgNoise config
then "cabal "
else "(set -o pipefail; cabal -vnormal+nowrap+markoutput "
, "new-test -w ${HC} ${TEST} ${BENCH} all"
, if cfgNoise config
then ""
else " 2>&1 | sed '/^-----BEGIN CABAL OUTPUT-----$/,/^-----END CABAL OUTPUT-----$/d' )"
, "; fi"
]
]
tellStrLns [""]
when (cfgDoctest config) $ do
let doctestOptions = unwords $ cfgDoctestOptions config
tellStrLns [ comment "doctest" ]
foldedTellStrLns FoldDoctest "Doctest..." folds $ do
forM_ pkgs $ \Pkg{pkgName,pkgGpd} -> do
let args = doctestArgs pkgGpd
args' = unwords args
unless (null args) $ tellStrLns
[ sh $ "if [ $HCNUMVER -ge 80000 ]; then (cd " ++ pkgName ++ "-* && doctest " ++ doctestOptions ++ " " ++ args' ++ "); fi"
]
tellStrLns [ "" ]
when (cfgHLint config) $ do
let "" <+> ys = ys
xs <+> "" = xs
xs <+> ys = xs ++ " " ++ ys
prependSpace "" = ""
prependSpace xs = " " ++ xs
let hlintOptions = prependSpace $ maybe "" ("-h ${ROOTDIR}/" ++) (cfgHLintYaml config) <+> unwords (cfgHLintOptions config)
tellStrLns [ comment "hlint" ]
foldedTellStrLns FoldHLint "HLint.." folds $ do
forM_ pkgs $ \Pkg{pkgName,pkgGpd} -> do
let args = doctestArgs pkgGpd
args' = unwords args
unless (null args) $ tellStrLns
[ sh $ "if [ $HCNUMVER -eq 80403 ]; then (cd " ++ pkgName ++ "-* && hlint" ++ hlintOptions ++ " " ++ args' ++ "); fi"
]
tellStrLns [ "" ]
when (cfgCheck config) $
foldedTellStrLns FoldCheck "cabal check..." folds $ do
tellStrLns [ comment "cabal check" ]
forM_ pkgs $ \Pkg{pkgName} -> tellStrLns
[ sh $ "(cd " ++ pkgName ++ "-* && cabal check)"
]
tellStrLns [ "" ]
when hasLibrary $
foldedTellStrLns FoldHaddock "Haddock..." folds $ tellStrLns
[ comment "haddock"
, sh "rm -rf ./dist-newstyle"
, sh "if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo \"Skipping haddock generation\";fi"
, ""
]
unless (null colls) $
foldedTellStrLns FoldStackage "Stackage builds..." folds $ tellStrLns
[ " # try building & testing for package collections"
, " - for COLL in \"${COLLS[@]}\"; do"
, " echo \"== collection $COLL ==\";"
, " ghc-travis collection ${COLL} > /dev/null || break;"
, " ghc-travis collection ${COLL} | " ++ pkgFilter ++ " > cabal.project.freeze;"
, " grep ' collection-id' cabal.project.freeze;"
, " rm -rf dist-newstyle/;"
, " cabal new-build -w ${HC} ${TEST} ${BENCH} all || break;"
, " if [ \"x$TEST\" = \"x--enable-tests\" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all || break; fi;"
, " done"
, ""
]
when (cfgUnconstrainted config) $ foldedTellStrLns FoldBuildInstalled
"Building without installed constraints for packages in global-db..." folds $ tellStrLns
[ comment "Build without installed constraints for packages in global-db"
, sh' [2046, 2086] $ unwords
[ "if $UNCONSTRAINED;"
, "then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all;"
, "else echo \"Not building without installed constraints\"; fi"
]
, ""
]
let constraintSets = cfgConstraintSets config
unless (null constraintSets) $ do
tellStrLns
[ comment "Constraint sets"
, sh "rm -rf cabal.project.local"
, ""
]
forM_ constraintSets $ \cs -> do
let name = csName cs
let constraintFlags = concatMap (\x -> " --constraint='" ++ x ++ "'") (csConstraints cs)
tellStrLns [ comment "Constraint set " ++ name ]
foldedTellStrLns' FoldConstraintSets name ("Constraint set " ++ name) folds $ tellStrLns
[ sh' [2086] $ "if " ++ ghcVersionPredicate (csGhcVersions cs) ++ "; then cabal new-build -w ${HC} --disable-tests --disable-benchmarks" ++ constraintFlags ++ " all; else echo skipping...; fi"
, ""
]
tellStrLns [""]
tellStrLns
[ "# REGENDATA " ++ show argv
, "# EOF"
]
return ()
where
hasTests = F.any (\Pkg{pkgGpd} -> not . null $ condTestSuites pkgGpd) pkgs
hasLibrary = F.any (\Pkg{pkgGpd} -> isJust $ condLibrary pkgGpd) pkgs
headGhcVers = S.filter previewGHC versions
generateCabalProject dist = do
tellStrLns
[ sh $ "printf 'packages: " ++ cabalPaths ++ "\\n' > cabal.project"
]
F.forM_ (prjConstraints prj) $ \xs -> do
let s = concat (lines xs)
tellStrLns
[ sh $ "echo 'constraints: " ++ s ++ "' >> cabal.project"
]
F.forM_ (prjAllowNewer prj) $ \xs -> do
let s = concat (lines xs)
tellStrLns
[ sh $ "echo 'allow-newer: " ++ s ++ "' >> cabal.project"
]
unless (null (cfgLocalGhcOptions config)) $ forM_ pkgs $ \Pkg{pkgName} -> do
let s = unwords $ map (show . PU.showToken) $ cfgLocalGhcOptions config
tellStrLns
[ sh $ "echo 'package " ++ pkgName ++ "' >> cabal.project"
, sh $ "echo ' ghc-options: " ++ s ++ "' >> cabal.project"
]
tellStrLns
[ sh $ "touch cabal.project.local"
, sh $ unwords
[ "if ! $NOINSTALLEDCONSTRAINTS; then"
, "for pkg in $($HCPKG list --simple-output); do"
, "echo $pkg"
, concatMap (\Pkg{pkgName} -> " | grep -vw -- " ++ pkgName) pkgs
, "| sed 's/^/constraints: /'"
, "| sed 's/-[^-]*$/ installed/'"
, ">> cabal.project.local; done; fi"
]
]
tellStrLns
[ sh $ "cat cabal.project || true"
, sh $ "cat cabal.project.local || true"
]
where
cabalPaths
| dist = quotedPaths $ \Pkg{pkgName} -> pkgName ++ "-*/*.cabal"
| otherwise = quotedPaths $ \Pkg{pkgDir} -> pkgDir
projectFile :: FilePath
projectFile = fromMaybe "cabal.project" isCabalProject
quotedPaths :: (Package -> FilePath) -> String
quotedPaths f = unwords $ map (f . quote) pkgs
where
quote pkg = pkg{ pkgDir = "\"" ++ pkgDir pkg ++ "\"" }
showVersions :: Set (Maybe Version) -> String
showVersions = unwords . map dispGhcVersion . S.toList
osxVersions' :: Set Version
osxVersions' = S.fromList $ mapMaybe simpleParse $ optOsx opts
versions :: Set (Maybe Version)
versions
| cfgGhcHead config = S.insert Nothing $ S.map Just versions'
| otherwise = S.map Just versions'
ghcVersions :: String
ghcVersions = showVersions versions
osxVersions, omittedOsxVersions :: Set Version
(osxVersions, omittedOsxVersions) = S.partition (`S.member` versions') osxVersions'
ghcOsxVersions :: String
ghcOsxVersions = showVersions $ S.map Just osxVersions
ghcOmittedOsxVersions :: String
ghcOmittedOsxVersions = showVersions $ S.map Just omittedOsxVersions
lookupCabVer :: Version -> Maybe Version
lookupCabVer v = join $ lookup (ghcMajVer v) cabalVerMap
doctestArgs :: GenericPackageDescription -> [String]
doctestArgs gpd = case PD.library $ flattenPackageDescription gpd of
Nothing -> []
Just l -> exts ++ dirsOrMods
where
bi = PD.libBuildInfo l
dirsOrMods
| null (PD.hsSourceDirs bi) = map display (PD.exposedModules l)
| otherwise = PD.hsSourceDirs bi
exts = map (("-X" ++) . display) (PD.defaultExtensions bi)
collToGhcVer :: String -> Version
collToGhcVer cid = case simpleParse cid of
Nothing -> error ("invalid collection-id syntax " ++ show cid)
Just (PackageIdentifier n (versionNumbers -> v))
| display n /= "lts" -> error ("unknown collection " ++ show cid)
| isPrefixOf [0] v -> mkVersion [7,8,3]
| isPrefixOf [1] v -> mkVersion [7,8,4]
| isPrefixOf [2] v -> mkVersion [7,8,4]
| isPrefixOf [3] v -> mkVersion [7,10,2]
| isPrefixOf [4] v -> mkVersion [7,10,3]
| isPrefixOf [5] v -> mkVersion [7,10,3]
| isPrefixOf [6] v -> mkVersion [7,10,3]
| isPrefixOf [7] v -> mkVersion [8,0,1]
| otherwise -> error ("unknown collection " ++ show cid)
parseJobsQ :: ReadP r (Maybe Int, Maybe Int)
parseJobsQ = nm <++ m <++ n <++ return (Nothing, Nothing)
where
nm = do
x <- parseInt
_ <- char ':'
y <- parseInt
return (Just x, Just y)
m = do
_ <- char ':'
y <- parseInt
return (Nothing, Just y)
n = do
x <- parseInt
return (Just x, Nothing)
data Project a = Project
{ prjPackages :: [a]
, prjConstraints :: Maybe String
, prjAllowNewer :: Maybe String
}
deriving (Show, Functor, F.Foldable, T.Traversable)
overPrjPackages :: ([a] -> [b]) -> Project a -> Project b
overPrjPackages f prj = prj { prjPackages = f (prjPackages prj) }
emptyProject :: Project [a]
emptyProject = Project [] Nothing Nothing
parseProjectFile :: FilePath -> String -> Either String (Project String)
parseProjectFile path contents =
case PU.parseFields legacyProjectConfigFieldDescrs emptyProject contents of
PU.ParseOk _ x -> Right x
PU.ParseFailed err -> Left $ case PU.locatedErrorMsg err of
(l, msg) -> "ERROR " ++ path ++ ":" ++ show l ++ ": " ++ msg
legacyProjectConfigFieldDescrs :: [PU.FieldDescr (Project String)]
legacyProjectConfigFieldDescrs =
[ PU.listField "packages"
(error "we don't pretty print")
parsePackageLocationTokenQ
prjPackages
(\x prj -> prj { prjPackages = x })
, PU.simpleField "constraints"
(error "we don't pretty print")
(fmap Just PU.parseFreeText)
prjConstraints
(\x prj -> prj { prjConstraints = maybeAlt2 commaConcat (prjConstraints prj) x })
, PU.simpleField "allow-newer"
(error "we don't pretty print")
(fmap Just PU.parseFreeText)
prjAllowNewer
(\x prj -> prj { prjAllowNewer = maybeAlt2 commaConcat (prjAllowNewer prj) x })
]
where
maybeAlt2 _ Nothing x = x
maybeAlt2 _ x Nothing = x
maybeAlt2 f (Just x) (Just y) = Just (f x y)
commaConcat x y
| all isSpace x = y
| all isSpace y = x
| otherwise = x ++ ", " ++ y
data Options = Options
{ optCollections :: [String]
, optOutput :: Maybe FilePath
, optOsx :: [String]
, optConfig :: Maybe FilePath
, optConfigMorphism :: Config -> Config
}
defOptions :: Options
defOptions = Options
{ optCollections = []
, optOutput = Nothing
, optOsx = []
, optConfig = Nothing
, optConfigMorphism = id
}
options :: [OptDescr (Result Diagnostic (Options -> Options))]
options =
[ Option [] ["no-cache"]
(NoArg $ successCM $ \cfg -> cfg { cfgCache = False })
"disable Travis caching"
, Option [] ["no-cabal-noise"]
(NoArg $ successCM $ \cfg -> cfg { cfgNoise = False })
"remove cabal noise from test output"
, Option [] ["no-cabal-check"]
(NoArg $ successCM $ \cfg -> cfg { cfgCheck = False })
"Disable cabal check"
, Option [] ["no-install-dependencies"]
(NoArg $ successCM $ \cfg -> cfg { cfgInstallDeps = False })
"Disable installing dependencies in a seperate step"
, Option [] ["no-no-tests-no-bench"]
(NoArg $ successCM $ \cfg -> cfg { cfgNoTestsNoBench = False })
"Don't build with --no-tests --no-benchmarks"
, Option [] ["no-unconstrained"]
(NoArg $ successCM $ \cfg -> cfg { cfgUnconstrainted = False })
"Build also without 'installed' constraints"
, Option [] ["ghc-head"]
(NoArg $ successCM $ \cfg -> cfg { cfgGhcHead = True })
"Build also with ghc-head"
, Option ['c'] ["collection"]
(ReqArg (success' $ \arg opts -> opts { optCollections = arg : optCollections opts }) "CID")
"enable package collection(s) (e.g. 'lts-7'), use multiple times for multiple collections"
, Option ['f'] ["fold"]
(flip OptArg "FOLDS" $ \arg -> case arg of
Nothing -> successCM $ \cfg -> cfg { cfgFolds = S.fromList possibleFolds }
Just arg' -> case maybeReadP parseFoldQ arg' of
Nothing -> Failure [Error $ "cannot parse --fold argument: " ++ arg' ++ "\n"]
Just f -> successCM $ \cfg -> cfg { cfgFolds = f (cfgFolds cfg) })
("build output(s) to fold, use multiple times for multiple folds. No argument defaults to 'all'. Possible values: all, all-but-test, " ++ intercalate ", " (map showFold possibleFolds))
, Option [] ["irc-channel"]
(ReqArg (successCM' $ \arg cfg -> cfg { cfgIrcChannels = arg : cfgIrcChannels cfg }) "HOST#CHANNEL")
"enable IRC notifcations to given channel (e.g. 'irc.freenode.org#haskell-lens'), use multiple times for multiple channels"
, Option ['n'] ["name"]
(ReqArg (successCM' $ \arg cfg -> cfg { cfgProjectName = Just arg }) "NAME")
"project name (used for IRC notifications), defaults to package name or name of first package listed in cabal.project file"
, Option ['b'] ["branch"]
(ReqArg (successCM' $ \arg cfg -> cfg { cfgOnlyBranches = arg : cfgOnlyBranches cfg }) "BRANCH")
"enable builds only for specific brances, use multiple times for multiple branches"
, Option ['o'] ["output"]
(ReqArg (success' $ \arg opts -> opts { optOutput = Just arg }) "OUTPUT")
"output file (stdout if omitted)"
, Option [] ["config"]
(OptArg (success' $ \arg opts -> opts { optConfig = Just $ fromMaybe "cabal.make-travis-yml" arg }) "CONFIG")
"config file, currently used only to specify constraint sets"
, Option [] ["osx"]
(ReqArg (success' $ \arg opts -> opts { optOsx = arg : optOsx opts }) "GHC")
"generate osx build job with ghc version"
, Option ['j'] ["jobs"]
(reqArgReadP parseJobsQ (\jobs cfg -> cfg { cfgJobs = jobs }) "JOBS")
"jobs (N:M - cabal:ghc)"
, Option [] ["local-ghc-options"]
(reqArgReadP parseOptsQ (\xs cfg -> cfg { cfgLocalGhcOptions = xs }) "OPTIONS")
"--ghc-options for local packages"
, Option ['d'] ["doctest"]
(NoArg $ successCM $ \cfg -> cfg { cfgDoctest = True })
"Run doctest using .ghc.environment files."
, Option [] ["doctest-options"]
(reqArgReadP parseOptsQ (\xs cfg -> cfg { cfgDoctestOptions = xs }) "OPTIONS")
"Additional doctest options."
, Option [] ["doctest-version"]
(reqArgReadP parse (\arg cfg -> cfg { cfgDoctestVersion = arg }) "VERSION")
"Doctest version range"
, Option ['l'] ["hlint"]
(NoArg $ successCM $ \cfg -> cfg { cfgHLint = True })
"Run hlint (only on GHC-8.4.3 target)"
, Option [] ["hlint-yaml"]
(ReqArg (successCM' $ \arg cfg -> cfg { cfgHLintYaml = Just arg }) "HLINT.YAML")
"Relative path to .hlint.yaml."
, Option [] ["hlint-options"]
(reqArgReadP parseOptsQ (\xs cfg -> cfg { cfgHLintOptions = xs }) "OPTIONS")
"Additional hlint options."
, Option [] ["hlint-version"]
(reqArgReadP parse (\arg cfg -> cfg { cfgHLintVersion = arg }) "VERSION")
"HLint version range"
, Option [] ["cabal-install-version"]
(reqArgReadP parse (\arg cfg -> cfg { cfgCabalInstallVersion = Just arg }) "VERSION")
"cabal-install version for all jobs, overrides default"
, Option [] ["cabal-install-head"]
(NoArg $ successCM $ \cfg -> cfg { cfgCabalInstallVersion = Nothing })
"Use cabal-install-head for all jobs, overrides default"
, Option [] ["env"]
(reqArgReadP envP (\(k, v) cfg -> cfg { cfgEnv = M.insert k v (cfgEnv cfg) }) "ENVDECL")
"Environment (e.g. `8.0.2:HADDOCK=false`)"
, Option [] ["allow-failure"]
(reqArgReadP parse (\arg cfg -> cfg { cfgAllowFailures = S.insert arg (cfgAllowFailures cfg) }) "GHCVERSION")
"Allow failures of particular GHC version"
, Option [] ["last-in-series"]
(NoArg $ successCM $ \cfg -> cfg { cfgLastInSeries = True })
"[Discouraged] Assume there are only GHCs last in major series: 8.0.* will match only 8.2.2"
]
where
overCM f opts = opts
{ optConfigMorphism = f . optConfigMorphism opts
}
success' f arg = success (f arg)
successCM = success . overCM
successCM' f arg = successCM (f arg)
reqArgReadP :: ReadP a a -> (a -> Config -> Config) -> String -> ArgDescr (Result Diagnostic (Options -> Options))
reqArgReadP p f n = flip ReqArg n $ \arg -> case maybeReadP p arg of
Nothing -> Failure [Error $ "cannot parse: " ++ arg ]
Just x -> successCM' f x
envP :: ReadP r (Version, String)
envP = do
ghc <- parse
skipSpaces
_ <- char ':'
skipSpaces
v <- munch (const True)
return (ghc, v)
data Result e a
= Success [e] a
| Failure [e]
deriving (Eq, Show, Functor)
success :: a -> Result e a
success = Success []
instance Monoid a => Mon.Monoid (Result e a) where
mempty = success mempty
#if MIN_VERSION_base(4,9,0)
mappend = (<>)
instance Monoid a => Semigroup (Result e a) where
Failure err1 <> Failure err2 = Failure $ err1 <> err2
Failure err1 <> Success err2 _ = Failure $ err1 <> err2
Success err1 _ <> Failure err2 = Failure $ err1 <> err2
Success l1 o1 <> Success l2 o2 = Success (mappend l1 l2) (mappend o1 o2)
#else
Failure err1 `mappend` Failure err2 = Failure $ err1 `mappend` err2
Failure err1 `mappend` Success err2 _ = Failure $ err1 `mappend` err2
Success err1 _ `mappend` Failure err2 = Failure $ err1 `mappend` err2
Success l1 o1 `mappend` Success l2 o2 = Success (mappend l1 l2) (mappend o1 o2)
#endif
data Fold
= FoldSDist
| FoldUnpack
| FoldBuild
| FoldBuildInstalled
| FoldBuildEverything
| FoldTest
| FoldHaddock
| FoldStackage
| FoldCheck
| FoldDoctest
| FoldHLint
| FoldConstraintSets
deriving (Eq, Ord, Show, Enum, Bounded)
showFold :: Fold -> String
showFold = dashise . drop 4 . show
where
dashise = intercalate "-" . map (map toLower) . split
split [] = []
split xs0 =
let (ys, xs1) = span isUpper xs0
(zs, xs2) = break isUpper xs1
in (ys ++ zs) : split xs2
possibleFolds :: [Fold]
possibleFolds = [minBound .. maxBound]
parseFoldQ :: ReadP r (Set Fold -> Set Fold)
parseFoldQ = do
t <- PU.parseTokenQ
case t of
"all" -> return $ const $ S.fromList possibleFolds
"all-but-test" -> return $ const $ S.delete FoldTest $ S.fromList possibleFolds
n -> case M.lookup n ps of
Just n' -> return (S.insert n')
Nothing -> fail $ "Illegal fold name: " ++ n
where
ps = M.fromList $ map (\x -> (showFold x, x)) possibleFolds
data Config = Config
{ cfgCabalInstallVersion :: Maybe Version
, cfgHLint :: !Bool
, cfgHLintYaml :: !(Maybe FilePath)
, cfgHLintVersion :: !VersionRange
, cfgHLintOptions :: [String]
, cfgJobs :: (Maybe Int, Maybe Int)
, cfgDoctest :: !Bool
, cfgDoctestOptions :: [String]
, cfgDoctestVersion :: !VersionRange
, cfgLocalGhcOptions :: [String]
, cfgConstraintSets :: [ConstraintSet]
, cfgCache :: !Bool
, cfgCheck :: !Bool
, cfgNoise :: !Bool
, cfgNoTestsNoBench :: !Bool
, cfgUnconstrainted :: !Bool
, cfgInstallDeps :: !Bool
, cfgOnlyBranches :: [String]
, cfgIrcChannels :: [String]
, cfgProjectName :: Maybe String
, cfgFolds :: Set Fold
, cfgGhcHead :: !Bool
, cfgEnv :: M.Map Version String
, cfgAllowFailures :: S.Set Version
, cfgLastInSeries :: !Bool
}
deriving (Show)
emptyConfig :: Config
emptyConfig = Config
{ cfgCabalInstallVersion = Nothing
, cfgHLint = False
, cfgHLintYaml = Nothing
, cfgHLintVersion = defaultHLintVersion
, cfgHLintOptions = []
, cfgJobs = (Nothing, Nothing)
, cfgDoctest = False
, cfgDoctestOptions = []
, cfgDoctestVersion = defaultDoctestVersion
, cfgLocalGhcOptions = []
, cfgConstraintSets = []
, cfgCache = True
, cfgCheck = True
, cfgNoise = True
, cfgNoTestsNoBench = True
, cfgUnconstrainted = True
, cfgInstallDeps = True
, cfgOnlyBranches = []
, cfgIrcChannels = []
, cfgProjectName = Nothing
, cfgFolds = S.empty
, cfgGhcHead = False
, cfgEnv = M.empty
, cfgAllowFailures = S.empty
, cfgLastInSeries = False
}
configFieldDescrs :: [PU.FieldDescr Config]
configFieldDescrs =
[ PU.simpleField "jobs"
(error "we don't pretty print")
parseJobsQ
cfgJobs
(\x cfg -> cfg { cfgJobs = x })
, PU.boolField "hlint"
cfgHLint
(\b cfg -> cfg { cfgHLint = b })
, PU.simpleField "hlint-yaml"
(error "we don't pretty print")
(fmap Just PU.parseFilePathQ)
cfgHLintYaml
(\x cfg -> cfg { cfgHLintYaml = x })
, PU.simpleField "hlint-version"
(error "we don't pretty print")
parse
cfgHLintVersion
(\x cfg -> cfg { cfgHLintVersion = x })
, PU.boolField "doctest"
cfgDoctest
(\b cfg -> cfg { cfgDoctest = b })
, PU.simpleField "doctest-options"
(error "we don't pretty print")
parseOptsQ
cfgDoctestOptions
(\x cfg -> cfg { cfgDoctestOptions = cfgDoctestOptions cfg ++ x })
, PU.simpleField "doctest-version"
(error "we don't pretty print")
parse
cfgDoctestVersion
(\x cfg -> cfg { cfgDoctestVersion = x })
, PU.simpleField "cabal-install-version"
(error "we don't pretty print")
(fmap Just parse)
cfgCabalInstallVersion
(\x cfg -> cfg { cfgCabalInstallVersion = x })
, PU.simpleField "local-ghc-options"
(error "we don't pretty print")
parseOptsQ
cfgLocalGhcOptions
(\x cfg -> cfg { cfgLocalGhcOptions = cfgLocalGhcOptions cfg ++ x })
, PU.boolField "cache"
cfgCache
(\b cfg -> cfg { cfgCache = b })
, PU.boolField "cabal-noise"
cfgNoise
(\b cfg -> cfg { cfgNoise = b })
, PU.boolField "cabal-check"
cfgCheck
(\b cfg -> cfg { cfgCheck = b })
, PU.boolField "install-dependencies-step"
cfgInstallDeps
(\b cfg -> cfg { cfgInstallDeps = b })
, PU.boolField "no-tests-no-benchmarks"
cfgNoTestsNoBench
(\b cfg -> cfg { cfgNoTestsNoBench = b })
, PU.boolField "unconstrained-step"
cfgUnconstrainted
(\b cfg -> cfg { cfgUnconstrainted = b })
, PU.listField "irc-channels"
(error "we don't pretty print")
PU.parseTokenQ
cfgIrcChannels
(\x cfg -> cfg { cfgIrcChannels = x })
, PU.simpleField "name"
(error "we don't pretty print")
(fmap Just PU.parseTokenQ)
cfgProjectName
(\x cfg -> cfg { cfgProjectName = x })
, PU.listField "branches"
(error "we don't pretty print")
PU.parseTokenQ
cfgOnlyBranches
(\x cfg -> cfg { cfgOnlyBranches = x })
, PU.simpleField "folds"
(error "we don't pretty print")
(sepBy parseFoldQ (munch1 isSpace))
(\cfg -> [\_ -> cfgFolds cfg])
(\x cfg -> cfg { cfgFolds = foldl' (flip id) (cfgFolds cfg) x })
, PU.boolField "ghc-head"
cfgGhcHead
(\b cfg -> cfg { cfgGhcHead = b })
]
parseOptsQ :: ReadP r [String]
parseOptsQ = sepBy PU.parseTokenQ' (munch1 isSpace)
readConfigFile :: MonadIO m => FilePath -> YamlWriter m Config
readConfigFile path = do
contents <- liftIO $ readFile path
parseConfigFile path contents
parseConfigFile :: Monad m => FilePath -> String -> YamlWriter m Config
parseConfigFile path contents = toWriter $ do
fields' <- PU.readFields contents
let (fields, sections) = partitionEithers (map classify fields')
config <- accumFields configFieldDescrs emptyConfig fields
go config sections
where
toWriter r = case r of
PU.ParseOk ws x -> do
forM_ ws $ \w -> putStrLnWarn (PU.showPWarning path w)
return x
PU.ParseFailed err -> case PU.locatedErrorMsg err of
(l, msg) -> putStrLnErr $ path ++ ":" ++ show l ++ ": " ++ msg
classify x@PU.IfBlock {} = Right x
classify x@PU.Section {} = Right x
classify x@PU.F {} = Left x
go :: Config -> [PU.Field] -> PU.ParseResult Config
go cfg [] = return cfg
go _cfg (PU.IfBlock {} : _fields) = fail "if conditional found"
go cfg (PU.F {} : fields) = go cfg fields
go cfg (PU.Section line name arg subfields : fields)
| name == "constraint-set" = do
cs <- accumFields constraintSetFieldDescrs (emptyConstraintSet arg) subfields
let cfg' = cfg { cfgConstraintSets = cfgConstraintSets cfg ++ [cs] }
go cfg' fields
| otherwise = do
PU.warning $ "Unknown section " ++ name ++ " on line " ++ show line
go cfg fields
data ConstraintSet = ConstraintSet
{ csName :: String
, csGhcVersions :: VersionRange
, csConstraints :: [String]
}
deriving (Show)
emptyConstraintSet :: String -> ConstraintSet
emptyConstraintSet n = ConstraintSet n anyVersion []
constraintSetFieldDescrs :: [PU.FieldDescr ConstraintSet]
constraintSetFieldDescrs =
[ PU.listField "constraints"
(error "we don't pretty print")
(parseHaskellString <++ munch1 (`notElem` [',', '"']))
csConstraints
(\c cs -> cs { csConstraints = csConstraints cs ++ c })
, PU.simpleField "ghc"
(error "we don't pretty print")
Distribution.Text.parse
csGhcVersions
(\c cs -> cs { csGhcVersions = c })
]
ghcVersionPredicate :: VersionRange -> String
ghcVersionPredicate = conj . asVersionIntervals
where
conj = intercalate " || " . map disj
disj :: VersionInterval -> String
disj (LowerBound v InclusiveBound, UpperBound u InclusiveBound)
| v == u = "[ $HCNUMVER -eq " ++ f v ++ " ]"
disj (lb, NoUpperBound) = lower lb
disj (lb, UpperBound v b) = lower lb ++ " && " ++ upper v b
lower (LowerBound v InclusiveBound) = "[ $HCNUMVER -ge " ++ f v ++ " ]"
lower (LowerBound v ExclusiveBound) = "[ $HCNUMVER -gt " ++ f v ++ " ]"
upper v InclusiveBound = "[ $HCNUMVER -le " ++ f v ++ " ]"
upper v ExclusiveBound = "[ $HCNUMVER -lt " ++ f v ++ " ]"
f v = case versionNumbers v of
[] -> "0"
[x] -> show (x * 10000)
[x,y] -> show (x * 10000 + y * 100)
(x:y:z:_) -> show (x * 10000 + y * 100 + z)
accumFields :: [PU.FieldDescr a] -> a -> [PU.Field] -> PU.ParseResult a
accumFields fields = foldM setField
where
fieldMap = M.fromList
[ (name, f) | f@(PU.FieldDescr name _ _) <- fields ]
setField accum (PU.F line name value) = case M.lookup name fieldMap of
Just (PU.FieldDescr _ _ set) -> set line value accum
Nothing -> do
PU.warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
return accum
setField accum f = do
PU.warning ("Unrecognized stanza on line " ++ show (PU.lineNo f))
return accum
parsePackageLocationTokenQ :: ReadP r String
parsePackageLocationTokenQ = parseHaskellString <++ parsePackageLocationToken
where
parsePackageLocationToken :: ReadP r String
parsePackageLocationToken = fmap fst (gather outerTerm)
where
outerTerm = alternateEither1 outerToken (braces innerTerm)
innerTerm = alternateEither innerToken (braces innerTerm)
outerToken = void $ munch1 outerChar
innerToken = void $ munch1 innerChar
outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')
innerChar c = not (isSpace c || c == '{' || c == '}')
braces = between (char '{') (char '}')
alternateEither, alternateEither1,
alternatePQs, alternate1PQs, alternateQsP, alternate1QsP
:: ReadP r () -> ReadP r () -> ReadP r ()
alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p
alternateEither p q = alternateEither1 p q +++ return ()
alternate1PQs p q = p >> alternateQsP q p
alternatePQs p q = alternate1PQs p q +++ return ()
alternate1QsP q p = many1 q >> alternatePQs p q
alternateQsP q p = alternate1QsP q p +++ return ()
parseHaskellString :: ReadP r String
parseHaskellString = readS_to_P reads
parseInt :: ReadP r Int
parseInt = readS_to_P reads
data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
deriving (Eq, Show)
data FilePathGlobRel
= GlobDir Glob FilePathGlobRel
| GlobFile Glob
| GlobDirTrailing
deriving (Eq, Show)
type Glob = [GlobPiece]
data GlobPiece = WildCard
| Literal String
| Union [Glob]
deriving (Eq, Show)
data FilePathRoot
= FilePathRelative
| FilePathRoot FilePath
| FilePathHomeDir
deriving (Eq, Show)
parseFilePathGlobRel :: ReadP r FilePathGlobRel
parseFilePathGlobRel =
parseGlob >>= \globpieces ->
asDir globpieces
<++ asTDir globpieces
<++ asFile globpieces
where
asDir glob = do dirSep
GlobDir glob <$> parseFilePathGlobRel
asTDir glob = do dirSep
return (GlobDir glob GlobDirTrailing)
asFile glob = return (GlobFile glob)
dirSep = void (char '/')
+++ (do _ <- char '\\'
following <- look
case following of
(c:_) | isGlobEscapedChar c -> pfail
_ -> return ())
parseGlob :: ReadP r Glob
parseGlob = many1 parsePiece
where
parsePiece = literal +++ wildcard +++ union'
wildcard = char '*' >> return WildCard
union' = between (char '{') (char '}') $
fmap Union (sepBy1 parseGlob (char ','))
literal = Literal `fmap` litchars1
litchar = normal +++ escape
normal = satisfy (\c -> not (isGlobEscapedChar c)
&& c /= '/' && c /= '\\')
escape = char '\\' >> satisfy isGlobEscapedChar
litchars1 :: ReadP r [Char]
litchars1 = liftM2 (:) litchar litchars
litchars :: ReadP r [Char]
litchars = litchars1 <++ return []
isGlobEscapedChar :: Char -> Bool
isGlobEscapedChar '*' = True
isGlobEscapedChar '{' = True
isGlobEscapedChar '}' = True
isGlobEscapedChar ',' = True
isGlobEscapedChar _ = False
expandRelGlob :: MonadIO m => FilePath -> FilePathGlobRel -> m [FilePath]
expandRelGlob root glob0 = liftIO $ go glob0 ""
where
go (GlobFile glob) dir = do
entries <- getDirectoryContents (root </> dir)
let files = filter (matchGlob glob) entries
return (map (dir </>) files)
go (GlobDir glob globPath) dir = do
entries <- getDirectoryContents (root </> dir)
subdirs <- filterM (\subdir -> doesDirectoryExist
(root </> dir </> subdir))
$ filter (matchGlob glob) entries
concat App.<$> mapM (\subdir -> go globPath (dir </> subdir)) subdirs
go GlobDirTrailing dir = return [dir]
matchGlob :: Glob -> FilePath -> Bool
matchGlob = goStart
where
go, goStart :: [GlobPiece] -> String -> Bool
goStart (WildCard:_) ('.':_) = False
goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)
globs
goStart rest cs = go rest cs
go [] "" = True
go (Literal lit:rest) cs
| Just cs' <- stripPrefix lit cs
= go rest cs'
| otherwise = False
go [WildCard] "" = True
go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs
go [] (_:_) = False
go (_:_) "" = False