HTF 0.12.2.1 → 0.12.2.2
raw patch · 11 files changed
+189/−32 lines, 11 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog +8/−0
- HTF.cabal +3/−2
- HTFPP.hs +1/−1
- Test/Framework/Preprocessor.hs +83/−29
- tests/real-bbt/FailFast.hs +9/−0
- tests/real-bbt/MaxCurTime.hs +14/−0
- tests/real-bbt/MaxPrevTime.hs +13/−0
- tests/real-bbt/PrevFactor.hs +19/−0
- tests/real-bbt/SortByPrevTime.hs +13/−0
- tests/real-bbt/UniqTests1.hs +10/−0
- tests/real-bbt/UniqTests2.hs +16/−0
ChangeLog view
@@ -1,3 +1,11 @@+* 0.12.2.2 (2014-10-22)+ - fixed lexing bug (some source files were not parsed properly)+ - fixed bug where wrong module name was generated+ - fixed source distribution (not all files were included)++* 0.12.2.1 (2014-10-19)+ - fixed compile error with QuickCheck == 2.6+ * 0.12.2.0 (2014-10-18) - drop dependency on haskell-src-exts (took too long to compile) - only color error counts if they are > 0 (thanks to Matthias Fischmann)
HTF.cabal view
@@ -1,5 +1,5 @@ Name: HTF-Version: 0.12.2.1+Version: 0.12.2.2 License: LGPL License-File: LICENSE Copyright: (c) 2005-2014 Stefan Wehr@@ -234,7 +234,8 @@ unordered-containers >= 0.2 Default-language: Haskell2010 Other-Modules:- Foo.A, Foo.B, TestHTFHunitBackwardsCompatible+ Foo.A, Foo.B, TestHTFHunitBackwardsCompatible, FailFast, MaxCurTime,+ MaxPrevTime, PrevFactor, SortByPrevTime, UniqTests1, UniqTests2 Test-Suite TestThreadPools Main-is: ThreadPoolTest.hs
HTFPP.hs view
@@ -35,7 +35,7 @@ usage = hPutStrLn stderr ("Preprocessor for the Haskell Test Framework\n\n" ++- "Usage: " ++ progName ++ " [--hunit|--debug] [FILE1 [FILE2 [FILE3]]]\n\n" +++ "Usage: " ++ progName ++ " [--hunit|--debug|--version] [FILE1 [FILE2 [FILE3]]]\n\n" ++ "* If no argument is given, input is read from stdin and\n" ++ " output is written to stdout.\n" ++ "* If only FILE1 is given, input is read from this file\n" ++
Test/Framework/Preprocessor.hs view
@@ -27,8 +27,9 @@ ) where +-- import Debug.Trace import Control.Monad-import Data.Char ( isDigit, isSpace )+import Data.Char import "haskell-lexer" Language.Haskell.Lexer import Language.Preprocessor.Cpphs ( runCpphs, CpphsOptions(..),@@ -38,6 +39,7 @@ import Test.HUnit hiding (State) import Control.Monad.State.Strict import qualified Data.List as List+import Data.Maybe import Test.Framework.Location @@ -72,8 +74,8 @@ nameDefines :: ModuleInfo -> [(String, String)] nameDefines info =- [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleName info)),- (importedTestListName, importedTestListFullName (mi_moduleName info))]+ [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleNameWithDefault info)),+ (importedTestListName, importedTestListFullName (mi_moduleNameWithDefault info))] allAsserts :: [String] allAsserts =@@ -121,9 +123,12 @@ data ModuleInfo = ModuleInfo { mi_htfPrefix :: String , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition]- , mi_moduleName :: String }+ , mi_moduleName :: Maybe String } deriving (Show, Eq) +mi_moduleNameWithDefault :: ModuleInfo -> String+mi_moduleNameWithDefault = fromMaybe "Main" . mi_moduleName+ data ImportDecl = ImportDecl { imp_moduleName :: Name , imp_qualified :: Bool , imp_alias :: Maybe Name@@ -140,7 +145,8 @@ setModName :: String -> PMA () setModName name =- modify $ \mi -> mi { mi_moduleName = name }+ do oldName <- gets mi_moduleName+ when (isNothing oldName) $ modify $ \mi -> mi { mi_moduleName = Just name } addTestDef :: String -> String -> Location -> PMA () addTestDef name fullName loc =@@ -166,7 +172,7 @@ ModuleInfo { mi_htfPrefix = htfModule ++ "." , mi_htfImports = [] , mi_defs = []- , mi_moduleName = "Main" }+ , mi_moduleName = Nothing } in ModuleInfo { mi_htfPrefix = mi_htfPrefix revRes , mi_htfImports = reverse (mi_htfImports revRes) , mi_defs = reverse $ List.nubBy defEqByName (mi_defs revRes)@@ -255,25 +261,72 @@ tok:rest -> tok : cleanupTokens rest [] -> [] +-- char -> ' (graphic<' | \> | space | escape<\&>) '+-- graphic -> small | large | symbol | digit | special | : | " | '+-- escape -> \ ( charesc | ascii | decimal | o octal | x hexadecimal )+-- charesc -> a | b | f | n | r | t | v | \ | " | ' | &+-- ascii -> ^cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK+-- | BEL | BS | HT | LF | VT | FF | CR | SO | SI | DLE+-- | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN+-- | EM | SUB | ESC | FS | GS | RS | US | SP | DEL+-- cntrl -> ascLarge | @ | [ | \ | ] | ^ | _+-- decimal -> digit{digit}+-- octal -> octit{octit}+-- hexadecimal -> hexit{hexit}+-- octit -> 0 | 1 | ... | 7+-- hexit -> digit | A | ... | F | a | ... | f+-- special -> ( | ) | , | ; | [ | ] | `| { | }+-- Purpose of cleanupInputString: filter out template Haskell quotes cleanupInputString :: String -> String cleanupInputString s = case s of- '\'':'\\':rest -> -- escaped character literal- case span (/= '\'') rest of- (esc,'\'':rest) ->- "'\\" ++ esc ++ "'" ++ cleanupInputString rest- _ -> s -- should not happen- '\'':c:'\'':rest -> -- regular character literal- '\'':c:'\'':cleanupInputString rest- c:'\'':'\'':rest- | isSpace c -> -- TH type quote- cleanupInputString rest- c:'\'':rest -- TH name quote- | isSpace c ->- cleanupInputString rest+ '\'':rest ->+ case characterLitRest rest of+ Just (restLit, rest') ->+ '\'':restLit ++ cleanupInputString rest'+ Nothing ->+ '\'':cleanupInputString rest+ c:'\'':'\'':x:rest+ | isSpace c && isUpper x -> -- TH type quote+ c:x:cleanupInputString rest+ c:'\'':x:rest -- TH name quote+ | isSpace c && isNothing (characterLitRest (x:rest)) && isLower x ->+ c:x:cleanupInputString rest+ c:rest+ | not (isSpace c) ->+ case span (== '\'') rest of+ (quotes, rest') -> c : quotes ++ cleanupInputString rest' c:rest -> c : cleanupInputString rest [] -> []+ where+ characterLitRest s = -- expects that before the s there is a '+ case s of+ '\\':'\'':'\'':rest -> Just ("\\''", rest) -- '\''+ c:'\'':rest -> Just (c:"'", rest) -- regular character lit+ '\\':rest ->+ case span (/= '\'') rest of+ (esc,'\'':rest) ->+ Just (('\\':esc) ++ "'", rest)+ _ -> Just (s, "") -- should not happen+ _ -> Nothing +cleanupInputStringTest =+ do flip mapM_ untouched $ \s ->+ let cleanedUp = cleanupInputString s+ in if s /= cleanedUp+ then assertFailure ("Cleanup of " ++ show s ++ " is wrong: " ++ show cleanedUp +++ ", expected that input and output are the same")+ else return ()+ flip mapM_ touched $ \(input, output) ->+ let cleanedUp = cleanupInputString input+ in if output /= cleanedUp+ then assertFailure ("Cleanup of " ++ show input ++ " is wrong: " ++ show cleanedUp+ ++ ", expected " ++ show output)+ else return ()+ where+ untouched = [" '0'", " '\\''", " ' '", " '\o761'", " '\BEL'", " '\^@' ", "' '", "fixed' ' '"]+ touched = [(" 'foo abc", " foo abc"), (" ''T ", " T ")]+ type LocToken = (Token,(Loc,String)) data Loc@@ -383,7 +436,7 @@ , imp_qualified = False , imp_alias = Nothing , imp_loc = makeLoc "<input>" 7}]- , mi_moduleName = "FOO"+ , mi_moduleName = Just "FOO" , mi_defs = [TestDef "blub" (makeLoc "<input>" 10) "test_blub" ,TestDef "blah" (makeLoc "<input>" 11) "test_blah" ,PropDef "abc" (makeLoc "<input>" 12) "prop_abc"@@ -394,7 +447,7 @@ ,"prop_xyz = True"] ,ModuleInfo { mi_htfPrefix = "" , mi_htfImports = []- , mi_moduleName = "Foo.Bar"+ , mi_moduleName = Just "Foo.Bar" , mi_defs = [PropDef "xyz" (makeLoc "<input>" 3) "prop_xyz"] }) ,(unlines ["module Foo.Bar where"@@ -402,7 +455,7 @@ ,"prop_xyz = True"] ,ModuleInfo { mi_htfPrefix = "Blub." , mi_htfImports = []- , mi_moduleName = "Foo.Bar"+ , mi_moduleName = Just "Foo.Bar" , mi_defs = [PropDef "xyz" (makeLoc "<input>" 3) "prop_xyz"] }) ,(unlines ["module Foo.Bar where"@@ -410,7 +463,7 @@ ,"prop_xyz = True"] ,ModuleInfo { mi_htfPrefix = "Test.Framework." , mi_htfImports = []- , mi_moduleName = "Foo.Bar"+ , mi_moduleName = Just "Foo.Bar" , mi_defs = [PropDef "xyz" (makeLoc "<input>" 3) "prop_xyz"] })] @@ -458,11 +511,11 @@ } additionalCode :: ModuleInfo -> String additionalCode info =- thisModulesTestsFullName (mi_moduleName info) ++ " :: " +++ thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " :: " ++ mi_htfPrefix info ++ "TestSuite\n" ++- thisModulesTestsFullName (mi_moduleName info) ++ " = " +++ thisModulesTestsFullName (mi_moduleNameWithDefault info) ++ " = " ++ mi_htfPrefix info ++ "makeTestSuite" ++- " " ++ show (mi_moduleName info) +++ " " ++ show (mi_moduleNameWithDefault info) ++ " [\n" ++ List.intercalate ",\n" (map (codeForDef (mi_htfPrefix info)) (mi_defs info)) ++ "\n ]\n" ++ importedTestListCode info@@ -484,9 +537,9 @@ let l = mi_htfImports info in case l of [] -> ""- _ -> (importedTestListFullName (mi_moduleName info)+ _ -> (importedTestListFullName (mi_moduleNameWithDefault info) ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" ++- importedTestListFullName (mi_moduleName info)+ importedTestListFullName (mi_moduleNameWithDefault info) ++ " = [\n " ++ List.intercalate ",\n " (map htfTestsInModule l) ++ "\n ]\n")@@ -520,4 +573,5 @@ preprocessorTests = [("testAnalyze", testAnalyze)- ,("fixPositionsTest", fixPositionsTest)]+ ,("fixPositionsTest", fixPositionsTest)+ ,("cleanupInputStringTest", cleanupInputStringTest)]
+ tests/real-bbt/FailFast.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-}+module FailFast (failFastMain) where++import Test.Framework++test_1 = assertEqual 1 2+test_2 = assertEqual 1 2++failFastMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/MaxCurTime.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+module MaxCurTime (maxCurTimeMain) where++import Test.Framework+import Control.Concurrent+import System.IO.Unsafe++test_slow :: IO ()+test_slow = threadDelay 20000++prop_verySlow :: Int -> Bool+prop_verySlow _i = unsafePerformIO test_slow `seq` True++maxCurTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/MaxPrevTime.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+module MaxPrevTime (maxPrevTimeMain) where++import Test.Framework+import Control.Concurrent++test_slow :: IO ()+test_slow = threadDelay 20000++test_fast :: IO ()+test_fast = return ()++maxPrevTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/PrevFactor.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+module PrevFactor (prevFactorMain) where++import Test.Framework+import Test.Framework.TestManager+import System.Environment+import System.Exit+import Control.Concurrent++doTest :: Bool -> IO ()+doTest slow =+ if slow then threadDelay 100000 else threadDelay 1000++prevFactorMain args =+ do ecode <-+ case args of+ "SLOW":rest -> runTestWithArgs rest [doTest True]+ _ -> runTestWithArgs args [doTest False]+ exitWith ecode
+ tests/real-bbt/SortByPrevTime.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+module SortByPrevTime (sortByPrevTimeMain) where++import Test.Framework+import Control.Concurrent++test_slow :: IO ()+test_slow = threadDelay 300000++test_fast :: IO ()+test_fast = return ()++sortByPrevTimeMain args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/UniqTests1.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+module UniqTests1 (uniqTests1Main) where++import Test.Framework+import Control.Concurrent++test_fast :: IO ()+test_fast = return ()++uniqTests1Main args = htfMainWithArgs args htf_thisModulesTests
+ tests/real-bbt/UniqTests2.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -F -pgmF dist/build/htfpp/htfpp #-}+module UniqTests2 (uniqTests2Main) where++import Test.Framework+import Control.Concurrent++test_fast :: IO ()+test_fast =+ let l =+ flip map [True, False] $ \case+ True -> 1+ False -> 2+ in putStrLn (show l)++uniqTests2Main args = htfMainWithArgs args htf_thisModulesTests