Skip to content

Instantly share code, notes, and snippets.

@tomjaguarpaw
Created June 30, 2017 17:43
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save tomjaguarpaw/cf31a6e6320ce3ba86dd53be8121f6db to your computer and use it in GitHub Desktop.
{-# LANGUAGE RecordWildCards, PatternGuards, ViewPatterns #-}
module Cabal(run, readCabal, extractCabal) where
import Control.Monad.Extra
import Control.Exception.Extra
import Data.Char
import Data.List.Extra
import Data.Maybe
import Data.Functor
import Data.Tuple.Extra
import System.Directory.Extra
import System.IO.Extra
import System.FilePath
import System.Process.Extra
import Arguments
import Prelude
-- | GHC releases I test with
ghcReleases = ["7.4.2","7.6.3","7.8.4","7.10.3","8.0.2"]
-- | The next version of GHC that has not yet been released
-- (might test it in Travis, but won't be in the tested-with)
ghcNext = "8.2.1"
---------------------------------------------------------------------
-- COMMANDS
-- | Check the .cabal file is well formed
cabalCheck :: IO ()
cabalCheck = do
-- a lot of the warnings aren't real problems, so whitelist some
(_, res) <- systemOutput "cabal check"
let allowed = ["No errors or warnings could be found in the package."
,"These warnings may cause trouble when distributing the package:"
,"* 'ghc-options: -main-is' is not portable."
,""]
let bad = lines res \\ allowed
when (bad /= []) $ error $ unlines $ "Cabal check gave bad warnings:" : map show bad
checkCabalFile
checkReadme
-- checkGhci
checkTravis
-- checkAppveyor
checkGhci :: IO ()
checkGhci = do
let warns = words "-fwarn-unused-binds -fwarn-unused-imports"
src <- words <$> readFile' ".ghci"
unless ("-W" `elem` src || all (`elem` src) warns) $
error $ "The .ghci file does not enough of " ++ unwords ("-W":warns)
checkTravis :: IO ()
checkTravis = do
tests <- testedWith
let requirePrefix =
["sudo: required"
,"env:"] ++
["- GHCVER=" ++ t | t <- reverse tests ++ [ghcNext]] ++
["- GHCVER=head"
,"script:"
]
let requireAnywhere =
["- curl -sL https://raw.github.com/tomjaguarpaw/neil/master/travis.sh | sh"]
src <- readFile' ".travis.yml"
let got = filter (not . null) $
replace ["matrix:"," allow_failures:"] [] $
replace [" - env: GHCVER=head"] [] $
map (trimEnd . takeWhile (/= '#')) $ lines src
when ("allow_failures:" `isInfixOf` src) $ putStrLn $ "Warning: .travis.yml allows failures with GHC HEAD"
unless (requirePrefix `isPrefixOf` got && requireAnywhere `isInfixOf` got) $
error $ unlines $
[".travis.yml file mismatch","Wanted:"] ++ requirePrefix ++ requireAnywhere ++
["Got:"] ++ got
checkAppveyor :: IO ()
checkAppveyor = do
let required =
["build: off"
,"cache: \"c:\\\\sr -> appveyor.yml\""
,"test_script:"
,"- ps: Invoke-Expression (Invoke-WebRequest 'https://raw.githubusercontent.com/ndmitchell/neil/master/appveyor.ps1')"]
whenM (doesFileExist "appveyor.yml") $ do
src <- map (trimEnd . takeWhile (/= '#')) . lines <$> readFile' "appveyor.yml"
let missing = required \\ src
when (missing /= []) $
fail $ unlines $ "Missing some important lines in appveyor.yml" : missing
undocumented :: [String]
undocumented =
["derive" -- I plan to stop maintaining it
,"safe" -- The lack of documentation is deliberate, since the pattern is more important
,"nsis" -- Issue to fix it at https://github.com/ndmitchell/nsis/issues/5
,"bake" -- Issue to fix it at https://github.com/ndmitchell/bake/issues/38
]
-- | Check every function exported is also documented
checkHoogle :: IO ()
checkHoogle = whenM (doesDirectoryExist "dist/doc/html") $ do
xs <- listContents "dist/doc/html"
-- I don't care that Derive isn't fully documented
forM_ xs $ \x -> do
let file = x </> takeFileName x <.> "txt"
contents <- readFileUTF8' file
-- look for two lines in a row not separated by comments
let bad = missingDocs $ wordsBy ("--" `isPrefixOf`) $
filter (\x -> not $ any (`isPrefixOf` x) docWhitelist) $
filter (not . null) $ map trim $ lines contents
if bad == [] then
putStrLn $ "Hoogle check successful for " ++ file
else do
putStr $ unlines $ "Bad hoogle:" : bad
if (takeFileName x `elem` undocumented) then
putStrLn $ "Lack of complete documentation is known for " ++ file
else
error "Found bad Hoogle entries"
docWhitelist :: [String]
docWhitelist =
["infix ","infixl ","infixr "
,"instance "
,"@version "
,"(==)","(/=)","fromString " -- not documented in base
,"class Hashable ","hashWithSalt ","hash ","unit "
-- don't seem to end up present when exported through Shake on Travis
]
-- | Given a set of definitions, each preceeded by docs, return the bad definitions.
-- Generally that's any non-leading definition, but don't require docs on constructors or selectors.
missingDocs :: [[String]] -> [String]
missingDocs xss = f "" $ concat [(True,x) : map ((,) False) xs | x:xs <- xss]
where
isCtor (x:xs) | isUpper x = True
isCtor ('[':x:xs) | isUpper x = True -- later Haddock sometimes writes constructors [Foo]
isCtor _ = False
isSelector ctor x
| Just (fields,result) <- unsnoc $ parseType ctor
, [first,rest] <- parseType x
, first == result
, rest `elem` fields
= True
isSelector _ _ = False
f ctor ((doc,x):xs) =
[x | not $ doc || isCtor x || isSelector ctor x] ++
f (if isCtor x then x else ctor) xs
f ctor [] = []
parseType :: String -> [String]
parseType = map trim . splitOn "->" . drop 2 . snd . breakOn "::"
-- | Run some commands in a temporary directory with the unpacked cabal
withSDist :: IO a -> IO a
withSDist run = withTempDir $ \tdir -> do
system_ "git diff --stat --exit-code"
local <- map normalise . lines <$> systemOutput_ "git ls-files . --others"
system_ $ "cabal configure --builddir=" ++ tdir
system_ $ "cabal sdist --builddir=" ++ tdir
files <- getDirectoryContents tdir
let tarball = head $ [x | x <- files, ".tar.gz" `isSuffixOf` x]
withCurrentDirectory tdir $ system_ $ "tar -xf " ++ tarball
lst <- listFilesRecursive tdir
let bad = local `intersect` map (normalise . drop (length tdir + length tarball - 5)) lst
when (bad /= []) $
error $ unlines $ "The following files are not checked in, but are in the dist" : bad
let binary = [".png",".gz",".bat",".zip",".gif",""]
bad <- flip filterM lst $ \file ->
return (takeExtension file `notElem` binary) &&^
fmap ('\r' `elem`) (readFileBinary' file)
when (bad /= []) $ do
error $ unlines $ "The following files have \\r characters in, Windows newlines?" : bad
withCurrentDirectory (tdir </> dropExtension (dropExtension $ takeFileName tarball)) run
run :: Arguments -> Maybe (IO ())
run Test{..} = Just $ do
test <- cabalCheck
runTest <- maybe (return True) (fmap ("test-suite" `isInfixOf`) . readFile) =<< findCabal
ghcVer <- fst . line1 <$> systemOutput_ "ghc --numeric-version"
withSDist $ do
system_ "cabal install --only-dependencies --enable-tests"
system_ $ "cabal configure --enable-tests --disable-library-profiling " ++
"--ghc-option=-rtsopts " ++
"--ghc-option=-fwarn-unused-binds --ghc-option=-fwarn-unused-imports " ++
"--ghc-option=-fwarn-tabs " ++
(if no_warnings then "" else "--ghc-option=-Werror")
system_ "cabal build"
system_ "cabal haddock --hoogle"
-- when (ghcVer `notElem` ["7.4.2","7.6.3","7.8.4"]) $ do
-- -- earlier Haddock's forget to document class members in the --hoogle
-- checkHoogle
when runTest $ system_ "cabal test --show-details=streaming"
when install $ do
system_ "cabal copy"
system_ "cabal register"
run Check{..} = Just $ withCurrentDirectory path cabalCheck
run Sdist = Just $ do
cabalCheck
tested <- testedWith
withSDist $ do
system_ "cabal clean"
system_ "cabal install --only-dependencies"
system_ $ "cabal configure --ghc-option=-fwarn-unused-imports --disable-library-profiling " ++
"--ghc-option=-Werror " ++
-- Ignore warnings in Cabal generated files :(
"--ghc-option=-fno-warn-warnings-deprecations --ghc-option=-fno-warn-unsupported-calling-conventions"
system_ "cabal build"
system_ "cabal haddock"
system_ "cabal sdist"
putStrLn $ "Ready to release! (remember to neil tag after uploading)"
run Docs{..} = Just $ do
src <- readCabal
let ver = extractCabal "version" src
let name = extractCabal "name" src
system_ $ "cabal haddock --hoogle --html --hyperlink-source " ++
"--contents-location=/package/" ++ name
withTempDir $ \dir -> do
system_ $ "cp -R dist/doc/html/" ++ name ++ " \"" ++ dir ++ "/" ++ name ++ "-" ++ ver ++ "-docs\""
files <- listFilesRecursive dir
forM_ files $ \file -> when (takeExtension file == ".html") $ do
system_ $ "chmod u+w " ++ (dir </> file)
src <- readFileBinary' $ dir </> file
src <- return $ filter (/= '\r') src -- filter out \r, due to CPP bugs
src <- return $ fixFileLinks $ fixHashT src
writeFileBinary (dir </> file) src
system_ $ "tar cvz -C " ++ dir ++ " --format=ustar -f " ++ dir ++ "/" ++ name ++ "-" ++ ver ++ "-docs.tar.gz " ++ name ++ "-" ++ ver ++ "-docs"
system_ $ "curl -X PUT -H \"Content-Type: application/x-tar\" " ++
"-H \"Content-Encoding: gzip\" " ++
"-u " ++ username ++ " " ++
"--data-binary \"@" ++ dir ++ "/" ++ name ++ "-" ++ ver ++ "-docs.tar.gz\" " ++
host ++ "/package/" ++ name ++ "-" ++ ver ++ "/docs"
run _ = Nothing
fixHashT :: String -> String
fixHashT (stripPrefix ".html#t:" -> Just (x:xs)) | not $ isUpper x = ".html#v:" ++ fixHashT (x:xs)
fixHashT (x:xs) = x : fixHashT xs
fixHashT [] = []
fixFileLinks :: String -> String
fixFileLinks (stripPrefix "<a href=\"file://" -> Just xs)
| (a,'\"':b) <- break (== '\"') xs
, modu <- takeFileName a
, pkg <- dropEnd 1 $ dropWhileEnd (/= '-') $ takeFileName $ dropHTML $ takeDirectory a
= "<a href=\"/package/" ++ pkg ++ "/docs/" ++ modu ++ "\"" ++ fixFileLinks b
where dropHTML x = if takeFileName x == "html" then takeDirectory x else x
fixFileLinks xs@(stripPrefix "<a href=\"file://" -> Just _) = error $ "Unable to remove file link, " ++ take 200 xs
fixFileLinks (x:xs) = x : fixFileLinks xs
fixFileLinks [] = []
testedWith :: IO [String]
testedWith = do
src <- readCabal
return $ concat [ map f $ words $ map (\x -> if x == ',' then ' ' else x) $ drop 12 x
| x <- lines src, "tested-with:" `isPrefixOf` x]
where
f x | Just rest <- stripPrefix "GHC==" x = rest
| otherwise = error $ "Invalid tested-with, " ++ x
checkReadme :: IO ()
checkReadme = do
name <- takeBaseName . fromMaybe (error "Couldn't find cabal file") <$> findCabal
src <- fmap lines $ readFile "README.md"
cabal <- fmap lines readCabal
let project = owner ("https://github.com/" ++ ownerGithub src ++ "/") cabal
let travis = ownerTravis src ++ "/" ++ project
let appveyor = ownerAppveyor src ++ "/" ++ name
let badges =
["[![Hackage version](https://img.shields.io/hackage/v/" ++ name ++ ".svg?label=Hackage)]" ++
"(https://hackage.haskell.org/package/" ++ name ++ ")"
,"[![Stackage version](https://www.stackage.org/package/" ++ name ++ "/badge/lts?label=Stackage)]" ++
"(https://www.stackage.org/package/" ++ name ++ ")"
,"[![Linux Build Status](https://img.shields.io/travis/" ++ travis ++ ".svg?label=Linux%20build)]" ++
"(https://travis-ci.org/" ++ travis ++ ")"
,"[![Windows Build Status](https://img.shields.io/appveyor/ci/" ++ appveyor ++ ".svg?label=Windows%20build)]" ++
"(https://ci.appveyor.com/project/" ++ appveyor ++ ")"
,"[![Build Status](https://img.shields.io/travis/" ++ travis ++ ".svg)]" ++
"(https://travis-ci.org/" ++ travis ++ ")"
]
let line1 = head $ src ++ [""]
let bangs = length $ filter (== '!') line1
let found = length $ filter (`isInfixOf` line1) badges
when (found < 2) $
error $ "Expected first line of README.md to end with at least 2 badges, got " ++ show found
when (found /= bangs) $
error $ "Unexpected badges, found " ++ show bangs ++ ", but only recognised " ++ show found
getLatestYear :: IO String
getLatestYear = do
res <- systemOutput_ "git show -s --format=%ci HEAD"
let year = takeWhile isDigit res
when (length year /= 4) $ fail $ "Couldn't get date, " ++ res
return year
checkCabalFile :: IO ()
checkCabalFile = do
src <- fmap lines readCabal
let project = owner ("https://github.com/" ++ ownerGithub src ++ "/") src
test <- testedWith
let grab tag = [trimStart $ drop (length tag + 1) x | x <- relines src, (tag ++ ":") `isPrefixOf` x]
license <- catch_ (readFile' $ concat $ grab "license-file") $ \_ -> return ""
year <- getLatestYear
let github = ownerGithub src ++ "/" ++ project
let bad =
["Incorrect declaration style: " ++ x
| (x,':':_) <- map (break (== ':') . trimStart) src
, not $ any isSpace $ trim x, not $ "http" `isSuffixOf` x || "https" `isSuffixOf` x
, not $ all (\x -> isLower x || x == '-') x] ++
[year ++ " is not in the copyright year" | not $ year `isInfixOf` concat (grab "copyright")] ++
["copyright string is not at the start of the license-file" | not $ (concat (grab "copyright") `isInfixOf` concat (take 1 $ lines license)) || grab "license" == ["GPL"]] ++
["No correct source-repository link"
| let want = "source-repository head type: git location: https://github.com/" ++ github ++ ".git"
, not $ want `isInfixOf` unwords (words $ unlines src)] ++
["No bug-reports link" | grab "bug-reports" /= ["https://github.com/" ++ github ++ "/issues"]] ++
["Homepage no longer exists" | "~ndm" `isInfixOf` concat (grab "homepage")] ++
["Incorrect license" | grab "license" `notElem` [["BSD3"],["MIT"]]] ++
["Incorrect default language" | x <- grab "default-language", x /= "Haskell2010"] ++
["Invalid tested-with: " ++ show test | not $ validTests test] ++
["Bad stabilty, should be missing" | grab "stability" /= []] ++
-- ["Missing CHANGES.txt in extra-source-files" | ["CHANGES.txt","changelog.md"] `disjoint` concatMap words (grab "extra-source-files")] ++
-- ["Missing README.md in extra-source-files" | "README.md" `notElem` concatMap words (grab "extra-source-files")]
["Not all flag's have manual attributes" | let flag = length $ filter ("flag " `isPrefixOf`) src, let manual = length $ filter ("manual:" `isPrefixOf`) $ map trimStart src, flag /= manual]
unless (null bad) $ error $ unlines bad
validTests :: [String] -> Bool
validTests xs = length xs > 1 && xs `isPrefixOf` reverse ghcReleases
ownerGithub = owner "https://github.com/"
ownerTravis = owner "https://img.shields.io/travis/"
ownerAppveyor = owner "https://img.shields.io/appveyor/ci/"
owner :: String -> [String] -> String
owner fragment src = if x == "" then "ndmitchell" else x
where x = takeWhile (\x -> x /= '/' && x /= '\n') $ drop (length fragment) $ snd $ breakOn fragment $ unlines src
relines :: [String] -> [String]
relines (x:xs) | ":" `isInfixOf` x = unwords (x:a) : relines b
where (a,b) = break (\x -> trimStart x == x) xs
relines (x:xs) = x : relines xs
relines [] = []
readCabal :: IO String
readCabal = do
file <- findCabal
case file of
Nothing -> return []
Just file -> readFile' file
extractCabal :: String -> String -> String
extractCabal find = f . words . replace ":" " : "
where
f (name:":":val:_) | lower find == lower name = val
f (x:xs) = f xs
f [] = error "Failed to find the Cabal key " ++ find
findCabal :: IO (Maybe FilePath)
findCabal = do
x <- getDirectoryContents "."
return $ listToMaybe $ filter ((==) ".cabal" . takeExtension) x
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment