Skip to content

Instantly share code, notes, and snippets.

@berdario berdario/bisect_tests.hs
Last active Apr 25, 2017

Embed
What would you like to do?
#!/usr/bin/env stack
-- stack runghc --resolver lts-7.19 --install-ghc --package turtle -- -Wall
-- install stack with "curl -sSL https://get.haskellstack.org/ | sh"
-- create an AWS image with `env AWS_PROFILE=YOUR_PROFILE packer build -var 'stackage=lts-7.19' -var 'base_ami=ami-aaaaaaaa' bisect_tests.packer.json`
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Data.List (tails)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Turtle hiding (x)
data TestType = Unit | Integration | Functional deriving (Show, Read)
testTypeName :: TestType -> Text
testTypeName Unit = "unit:"
testTypeName Integration = "integration:"
testTypeName Functional = "functional:"
parser :: Parser (TestType, [Text], Text)
parser = (,,) <$> optRead "type" 't' "one of Unit, Integration, Functional"
<*> (T.words <$> argText "tests_pattern" "list of tests (space separated)")
<*> argText "failing_test" "test in which the conflict is manifested"
testApp :: TestType -> [Text] -> IO ExitCode
testApp testType tests = do
echo $ "testing with: " <> T.unwords tests
echo ""
proc "grails" (["test-app", testTypeName testType] ++ tests) mzero
type Runner = [Text] -> IO ExitCode
loop :: Runner -> [Text] -> Text -> IO [Text]
loop runner testList failing = do
res <- runMaybeT $ loop' runner failing (splitInto 2 testList)
`mplus` -- the minimum length might be > 2, and overlapping the half, thus let's also split at 1/3rd
loop' runner failing (splitInto 3 testList)
pure $ fromMaybe testList res
failWith :: a -> ExitCode -> Maybe a
failWith _ ExitSuccess = Nothing
failWith a (ExitFailure _) = Just a
failWithF :: (Functor f) => a -> f ExitCode -> MaybeT f a
failWithF x y = MaybeT $ failWith x <$> y
loop' :: Runner -> Text -> [[Text]] -> MaybeT IO [Text]
loop' _ _ ([]:_) = mzero
loop' runner failing testChunks = do
let candidates = map join $ combinations (length testChunks - 1) testChunks
slice <- msum (map
(\candidate -> failWithF candidate (runner $ candidate ++ [failing]))
candidates)
liftIO $ loop runner slice failing
combinations :: Int -> [a] -> [[a]]
combinations 0 _ = [[]]
combinations n xs = [y:ys| y:xs' <- tails xs
, ys <- combinations (n - 1) xs']
splitInto :: Int -> [a] -> [[a]]
splitInto chunks xs = reverse $ split (chunks - 1) (length xs `div` chunks) xs
split :: Int -> Int -> [a] -> [[a]]
split 0 _ xs = [xs]
split step chunkSize xs = right : split (step - 1) chunkSize left
where
(left, right) = splitAt (chunkSize * step) xs
main :: IO ()
main = do
(testType, testList, failing) <- options "Test bisector" parser
let testRunner = testApp testType
minimized <- loop testRunner testList failing
echo $ "Minimal test case: " <> T.unwords minimized <> " " <> failing
{
"variables": {
"stackage": null,
"base_ami": null,
"scripts_dir": "."
},
"builders": [{
"type": "amazon-ebs",
"region": "eu-west-1",
"source_ami": "{{user `base_ami`}}",
"instance_type": "m4.xlarge",
"vpc_id": "vpc-aaaaaaaa",
"subnet_id": "subnet-aaaaaaa",
"ssh_username": "ubuntu",
"ami_name": "bisect-tests worker {{timestamp}}"
}],
"provisioners": [{
"type": "shell-local",
"command": "stack ghc --resolver {{user `stackage`}} --install-ghc --package turtle {{user `scripts_dir`}}/bisect_tests.hs"
}, {
"type": "file",
"source": "{{user `scripts_dir`}}/bisect_tests",
"destination": "/tmp/bisect_tests"
}, {
"type": "shell",
"inline": [
"sleep 30",
"sudo mv /tmp/bisect_tests /usr/local/bin/bisect_tests"
]}
]
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.