-- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests.
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, StandaloneDeriving #-}
module Main where
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.SmallCheck
import Test.SmallCheck
import Test.SmallCheck.Series
import Language.Haskell.Exts.Annotated
import System.IO
import Control.Monad
import Control.Applicative
import Data.List
import Data.Char
import Data.Function
import System.Directory
import System.Environment (getArgs)
import System.Exit (exitFailure)
import System.FilePath
main :: IO ()
main = do
files <- getDirectoryContents examplesDir
defaultMain . testGroup "Tests" =<<
sequence
[ parserTests files
, printerTests files
, return extProperties ]
-- | Where all the tests are to be found
examplesDir :: FilePath
examplesDir = "Test" </> "examples"
getParserFailing, getPrinterFailing :: IO [FilePath]
(getParserFailing, getPrinterFailing) = (get "failing.txt", get "printFail.txt")
where
get fname = liftM (map (head . words) . lines) . readFile $ "Test" </> fname
parserTests :: [FilePath] -> IO TestTree
parserTests files = testGroup "Parser tests" <$> do
failing <- getParserFailing
return [check (x `elem` failing) (examplesDir </> x) | x <- files, not $ "." `isPrefixOf` x]
check :: Bool -> FilePath -> TestTree
check expected file = testCase file $ do
res <- parseFile file
case res of
ParseOk x | expected -> assertFailure $ "Unexpected pass for " ++ file
| otherwise -> return ()
err | expected -> return ()
| otherwise -> assertFailure $ "Failure when parsing " ++ show file ++ "\n" ++ show err
printerTests :: [FilePath] -> IO TestTree
printerTests files = testGroup "Exact printer tests" <$> do
parserFailing <- getParserFailing
printerFailing <- getPrinterFailing
return
[ roundTrip (x `elem` printerFailing) (examplesDir </> x)
| x <- files
, not $ "." `isPrefixOf` x
, not $ x `elem` parserFailing ]
roundTrip :: Bool -> FilePath -> TestTree
roundTrip expected file = testCase file $ do
fc <- readFile file
pr <- parseFileWithComments (defaultParseMode { parseFilename = file }) file
case pr of
ParseOk (ast,cs) -> do
let res = exactPrint ast cs
xs = dropWhile (uncurry (==))
$ zip (map (reverse . dropWhile isSpace . reverse) $ lines fc)
(map (reverse . dropWhile isSpace . reverse) $ lines res)
case xs of
[] | expected -> assertFailure $ "Unexpected pass for " ++ file
| otherwise -> return ()
(lfc, lres):_
| expected -> return ()
| otherwise -> assertFailure $ unlines
[ "Result of print does not match input when printing " ++ show file
, "First unmatching lines are (line length):"
, " Input (" ++ show (length lfc) ++ "): " ++ lfc
, " Result (" ++ show (length lres) ++ "): " ++ lres
]
err -> assertFailure $ "Failure when parsing " ++ show file ++ "\n" ++ show err
instance Monad m => Serial m Language where
series = generate (const knownLanguages)
instance Monad m => Serial m Extension where
series = generate (const knownExtensions)
instance Monad m => Serial m KnownExtension where
series = generate $ const [ e | EnableExtension e <- knownExtensions ]
infix 3 ~~
(~~) :: Monad m => [Extension] -> [Extension] -> Property m
xts1 ~~ xts2 = forAll $ \lang -> ((==) `on` sort . toExtensionList lang) xts1 xts2
extProperties =
localOption (SmallCheckDepth 2) $ testGroup "Properties of LANGUAGE extensions" $
[ testProperty "identity" $ \x -> x ~~ x
, testProperty "idempotence" $ \x -> x ++ x ~~ x
, testProperty "right bias" $ \x y -> x ++ y ++ x ~~ y ++ x
, testProperty "closedness of implication" $ \x -> impliesExts (impliesExts x) == impliesExts x
, testProperty "closedness of toExtensionList" $ \l x -> let es = toExtensionList l x in es == impliesExts es
, testProperty "opposite extensions 1" $ \x -> [EnableExtension x, DisableExtension x] ~~ [DisableExtension x]
, testProperty "opposite extensions 2" $ \x -> [DisableExtension x, EnableExtension x] ~~ [EnableExtension x]
]