2016-07-14 23:36:47 +03:00
|
|
|
{-# LANGUAGE DataKinds, FlexibleContexts, GeneralizedNewtypeDeriving #-}
|
2016-02-16 20:33:41 +03:00
|
|
|
module CorpusSpec where
|
|
|
|
|
2016-05-26 20:11:34 +03:00
|
|
|
import Data.String
|
2016-02-17 00:38:31 +03:00
|
|
|
import Diffing
|
2016-02-17 23:54:37 +03:00
|
|
|
import Renderer
|
2016-02-26 00:19:33 +03:00
|
|
|
import qualified Renderer.JSON as J
|
2016-02-25 23:32:39 +03:00
|
|
|
import qualified Renderer.Patch as P
|
|
|
|
import qualified Renderer.Split as Split
|
2016-02-17 00:38:31 +03:00
|
|
|
|
2016-07-14 23:36:47 +03:00
|
|
|
import Category
|
2016-02-18 01:42:27 +03:00
|
|
|
import Control.DeepSeq
|
2016-02-29 05:29:59 +03:00
|
|
|
import Data.Functor.Both
|
2016-02-17 00:38:31 +03:00
|
|
|
import Data.List as List
|
|
|
|
import Data.Map as Map
|
2016-07-14 23:36:47 +03:00
|
|
|
import Data.Record
|
2016-02-17 00:38:31 +03:00
|
|
|
import Data.Set as Set
|
2016-02-17 23:54:37 +03:00
|
|
|
import qualified Data.Text as T
|
2016-07-14 23:36:47 +03:00
|
|
|
import Info
|
2016-05-26 19:58:04 +03:00
|
|
|
import Prologue hiding (fst, snd)
|
2016-07-14 23:36:47 +03:00
|
|
|
import Range
|
2016-03-01 03:39:04 +03:00
|
|
|
import qualified Source as S
|
2016-02-17 00:38:31 +03:00
|
|
|
import System.FilePath
|
|
|
|
import System.FilePath.Glob
|
2016-02-16 20:33:41 +03:00
|
|
|
import Test.Hspec
|
2016-07-13 21:32:53 +03:00
|
|
|
import GHC.Show (Show(..))
|
2016-02-16 20:33:41 +03:00
|
|
|
|
|
|
|
spec :: Spec
|
2016-02-18 01:43:59 +03:00
|
|
|
spec = parallel $ do
|
2016-07-16 00:43:59 +03:00
|
|
|
describe "crashers crash" . runTestsIn "test/crashers-todo/" $ \ a b -> a `deepseq` pure (a == b) `shouldThrow` anyException
|
2016-02-29 06:18:44 +03:00
|
|
|
describe "crashers should not crash" $ runTestsIn "test/crashers/" shouldBe
|
|
|
|
describe "todos are incorrect" $ runTestsIn "test/diffs-todo/" shouldNotBe
|
|
|
|
describe "should produce the correct diff" $ runTestsIn "test/diffs/" shouldBe
|
2016-02-17 00:38:31 +03:00
|
|
|
|
2016-02-17 20:54:42 +03:00
|
|
|
it "lists example fixtures" $ do
|
2016-02-17 00:38:31 +03:00
|
|
|
examples "test/crashers/" `shouldNotReturn` []
|
2016-02-17 20:54:42 +03:00
|
|
|
examples "test/diffs/" `shouldNotReturn` []
|
2016-02-17 00:38:31 +03:00
|
|
|
|
|
|
|
where
|
2016-05-30 19:42:43 +03:00
|
|
|
runTestsIn :: FilePath -> (Verbatim -> Verbatim -> Expectation) -> SpecWith ()
|
2016-02-22 22:38:49 +03:00
|
|
|
runTestsIn directory matcher = do
|
2016-02-18 01:10:04 +03:00
|
|
|
paths <- runIO $ examples directory
|
|
|
|
let tests = correctTests =<< paths
|
2016-07-16 00:43:59 +03:00
|
|
|
traverse_ (\ (formatName, renderer, paths, output) -> it (normalizeName (fst paths) <> " (" <> formatName <> ")") $ testDiff renderer paths output matcher) tests
|
2016-02-18 01:10:04 +03:00
|
|
|
|
2016-03-01 20:34:40 +03:00
|
|
|
correctTests paths@(_, Nothing, Nothing, Nothing) = testsForPaths paths
|
2016-02-29 06:13:32 +03:00
|
|
|
correctTests paths = List.filter (\(_, _, _, output) -> isJust output) $ testsForPaths paths
|
2016-04-05 00:38:41 +03:00
|
|
|
testsForPaths (paths, json, patch, split) = [ ("json", J.json, paths, json), ("patch", P.patch, paths, patch), ("split", Split.split, paths, split) ]
|
2016-02-17 00:38:31 +03:00
|
|
|
|
|
|
|
-- | Return all the examples from the given directory. Examples are expected to
|
2016-02-27 03:04:47 +03:00
|
|
|
-- | have the form "foo.A.js", "foo.B.js", "foo.patch.js". Diffs are not
|
2016-02-17 00:38:31 +03:00
|
|
|
-- | required as the test may be verifying that the inputs don't crash.
|
2016-03-01 20:34:40 +03:00
|
|
|
examples :: FilePath -> IO [(Both FilePath, Maybe FilePath, Maybe FilePath, Maybe FilePath)]
|
2016-02-17 00:38:31 +03:00
|
|
|
examples directory = do
|
2016-02-17 23:59:16 +03:00
|
|
|
as <- toDict <$> globFor "*.A.*"
|
|
|
|
bs <- toDict <$> globFor "*.B.*"
|
2016-02-26 00:19:33 +03:00
|
|
|
jsons <- toDict <$> globFor "*.json.*"
|
2016-02-18 00:10:28 +03:00
|
|
|
patches <- toDict <$> globFor "*.patch.*"
|
|
|
|
splits <- toDict <$> globFor "*.split.*"
|
2016-02-17 23:59:16 +03:00
|
|
|
let keys = Set.unions $ keysSet <$> [as, bs]
|
2016-05-26 22:25:45 +03:00
|
|
|
pure $ (\name -> (both (as ! name) (bs ! name), Map.lookup name jsons, Map.lookup name patches, Map.lookup name splits)) <$> sort (Set.toList keys)
|
2016-02-17 00:38:31 +03:00
|
|
|
where
|
2016-05-30 19:38:21 +03:00
|
|
|
globFor :: FilePath -> IO [FilePath]
|
2016-02-17 00:38:31 +03:00
|
|
|
globFor p = globDir1 (compile p) directory
|
2016-03-11 22:21:42 +03:00
|
|
|
toDict list = Map.fromList ((normalizeName <$> list) `zip` list)
|
2016-02-17 00:38:31 +03:00
|
|
|
|
|
|
|
-- | Given a test name like "foo.A.js", return "foo.js".
|
|
|
|
normalizeName :: FilePath -> FilePath
|
|
|
|
normalizeName path = addExtension (dropExtension $ dropExtension path) (takeExtension path)
|
|
|
|
|
|
|
|
-- | Given file paths for A, B, and, optionally, a diff, return whether diffing
|
|
|
|
-- | the files will produce the diff. If no diff is provided, then the result
|
|
|
|
-- | is true, but the diff will still be calculated.
|
2016-07-16 00:49:09 +03:00
|
|
|
testDiff :: Renderer (Record '[Cost, Range, Category]) -> Both FilePath -> Maybe FilePath -> (Verbatim -> Verbatim -> Expectation) -> Expectation
|
2016-02-29 06:13:32 +03:00
|
|
|
testDiff renderer paths diff matcher = do
|
2016-02-29 05:08:07 +03:00
|
|
|
sources <- sequence $ readAndTranscodeFile <$> paths
|
2016-07-27 07:08:42 +03:00
|
|
|
actual <- Verbatim <$> diffFiles (decorateParser termCostDecorator parser) renderer (sourceBlobs sources)
|
2016-02-17 00:38:31 +03:00
|
|
|
case diff of
|
2016-03-02 20:09:58 +03:00
|
|
|
Nothing -> matcher actual actual
|
2016-02-17 00:38:31 +03:00
|
|
|
Just file -> do
|
2016-07-13 21:32:53 +03:00
|
|
|
expected <- Verbatim <$> readFile file
|
2016-02-29 06:18:44 +03:00
|
|
|
matcher actual expected
|
2016-04-02 20:28:17 +03:00
|
|
|
where parser = parserForFilepath (fst paths)
|
2016-04-05 01:00:25 +03:00
|
|
|
sourceBlobs sources = pure S.SourceBlob <*> sources <*> pure mempty <*> paths <*> pure (Just S.defaultPlainBlob)
|
2016-05-30 19:36:52 +03:00
|
|
|
|
2016-05-30 19:46:25 +03:00
|
|
|
-- | A wrapper around `Text` with a more readable `Show` instance.
|
2016-05-30 19:39:43 +03:00
|
|
|
newtype Verbatim = Verbatim Text
|
2016-05-30 19:42:19 +03:00
|
|
|
deriving (Eq, NFData)
|
2016-05-30 19:37:05 +03:00
|
|
|
|
|
|
|
instance Show Verbatim where
|
2016-05-30 19:44:09 +03:00
|
|
|
showsPrec _ (Verbatim text) = ('\n':) . (T.unpack text ++)
|