diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +* 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) + * 0.12.1.0 (2014-09-16) - support for haskell-src-exts version 1.16 - Functor and Applicative instances for AssertBool diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,8 +1,8 @@ Name: HTF -Version: 0.12.1.0 +Version: 0.12.2.0 License: LGPL License-File: LICENSE -Copyright: (c) 2005-2012 Stefan Wehr +Copyright: (c) 2005-2014 Stefan Wehr Author: Stefan Wehr Maintainer: Stefan Wehr Stability: Beta @@ -81,8 +81,8 @@ the imported tests. See "Test.Framework.Tutorial" for details. Tested-With: - GHC==7.4.2, - GHC==7.6.2 + GHC==7.6.2, + GHC==7.8.2 Build-Type: Simple Cabal-Version: >= 1.10 Extra-Source-Files: @@ -133,13 +133,15 @@ Executable htfpp Main-Is: HTFPP.hs - Build-Depends: cpphs >= 1.12, - haskell-src-exts >= 1.14, - old-time >= 1.0, - directory >= 1.0, + Build-Depends: HUnit, array, - random >= 1.0, base == 4.*, + cpphs >= 1.12, + directory >= 1.0, + haskell-lexer, + mtl >= 1.1, + old-time >= 1.0, + random >= 1.0, text Other-Modules: Test.Framework.Preprocessor @@ -147,30 +149,31 @@ Default-language: Haskell2010 Library - Build-Depends: + Build-Depends: Diff >= 0.3, HUnit >= 1.2.5, QuickCheck >= 2.3, + aeson >= 0.6, + array, base == 4.*, - random >= 1.0, - containers >= 0.4.2.1, - process >= 1.0, + base64-bytestring, + bytestring >= 0.9, + containers >= 0.5, + cpphs >= 1.12, directory >= 1.0, - mtl >= 1.1, - monad-control >= 0.3, + haskell-lexer, + haskell-src, lifted-base >= 0.1, + monad-control >= 0.3, + mtl >= 1.1, + old-time >= 1.0, pretty >= 1.0, - Diff >= 0.3, - bytestring >= 0.9, + process >= 1.0, + random >= 1.0, regex-compat >= 0.92, - haskell-src-exts >= 1.11, - aeson >= 0.6, text >= 0.11, - old-time >= 1.0, - array, - xmlgen >= 0.6, - base64-bytestring, + time, vector, - time + xmlgen >= 0.6 if !os(windows) Build-Depends: unix >= 2.4 Exposed-Modules: @@ -192,6 +195,8 @@ Test.Framework.ThreadPool Test.Framework.AssertM Test.Framework.Colors + Test.Framework.PrettyHaskell + Test.Framework.Preprocessor Other-Modules: Test.Framework.Utils Test.Framework.Diff @@ -199,23 +204,36 @@ Default-language: Haskell2010 Ghc-Options: -W -fwarn-unused-imports -fwarn-unused-binds -fwarn-unused-matches -fwarn-unused-do-bind -fwarn-wrong-do-bind +Test-Suite MiscTests + Main-is: MiscTest.hs + Type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests + Build-depends: HTF, + HUnit, + base == 4.*, + mtl, + random + Default-language: Haskell2010 + Test-Suite TestHTF Main-is: TestHTF.hs Hs-Source-Dirs: tests, tests/real-bbt Type: exitcode-stdio-1.0 - Build-depends: base == 4.*, - bytestring >= 0.9, + Build-depends: HTF, aeson >= 0.6, - unordered-containers >= 0.2, - temporary >= 1.1, - text >= 0.11, - process >= 1.0, - filepath >= 1.1, + aeson-pretty, + base == 4.*, + bytestring >= 0.9, directory >= 1.0, - regex-compat >= 0.92, + filepath >= 1.1, + process >= 1.0, random, - HTF + regex-compat >= 0.92, + temporary >= 1.1, + text >= 0.11, + unordered-containers >= 0.2 Default-language: Haskell2010 + Ghc-Options: -keep-tmp-files -tmpdir ./tmp Other-Modules: Foo.A, Foo.B, TestHTFHunitBackwardsCompatible @@ -223,19 +241,8 @@ Main-is: ThreadPoolTest.hs Type: exitcode-stdio-1.0 Hs-Source-Dirs: tests - Build-depends: base == 4.*, - random, - mtl, - HTF - Default-language: Haskell2010 - -Test-Suite MiscTests - Main-is: MiscTest.hs - Type: exitcode-stdio-1.0 - Hs-Source-Dirs: tests - Build-depends: base == 4.*, - random, + Build-depends: HTF, + base == 4.*, mtl, - HTF, - HUnit + random Default-language: Haskell2010 diff --git a/HTFPP.hs b/HTFPP.hs --- a/HTFPP.hs +++ b/HTFPP.hs @@ -35,7 +35,7 @@ usage = hPutStrLn stderr ("Preprocessor for the Haskell Test Framework\n\n" ++ - "Usage: " ++ progName ++ " [--hunit] [FILE1 [FILE2 [FILE3]]]\n\n" ++ + "Usage: " ++ progName ++ " [--hunit|--debug] [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" ++ @@ -52,6 +52,7 @@ outputVersion :: IO () outputVersion = hPutStrLn stderr (showVersion Paths_HTF.version) + saveOpenFile :: FilePath -> IOMode -> IO Handle saveOpenFile path mode = openFile path mode `catch` exHandler @@ -72,10 +73,9 @@ when ("--version" `elem` args) $ do outputVersion exitWith ExitSuccess - let (restArgs, hunitBackwardsCompat) = - case reverse args of - "--hunit":rrest -> (reverse rrest, True) - rrest -> (reverse rrest, False) + let hunitBackwardsCompat = "--hunit" `elem` args + debug = "--debug" `elem` args + restArgs = flip filter args $ \x -> x /= "--hunit" && x /= "--debug" (origInputFilename, hIn, hOut) <- case restArgs of [] -> @@ -92,10 +92,11 @@ h2 <- saveOpenFile file3 WriteMode return (file1, h1, h2) _ -> - do usage + do hPutStrLn stderr ("Too many arguments: " ++ show restArgs) + usage exitWith (ExitFailure 1) input <- hGetContents hIn - output <- transform hunitBackwardsCompat origInputFilename input `catch` + output <- transform hunitBackwardsCompat debug origInputFilename input `catch` (\ (e::SomeException) -> do hPutStrLn stderr (progName ++ ": unexpected exception: " ++ diff --git a/Test/Framework/CmdlineOptions.hs b/Test/Framework/CmdlineOptions.hs --- a/Test/Framework/CmdlineOptions.hs +++ b/Test/Framework/CmdlineOptions.hs @@ -198,7 +198,7 @@ {- | -Parse commandline arguments into 'CmdlineOptions'. Here's a synopsis +Parse commandline arguments into 'CmdlineOptions'. Here is a synopsis of the format of the commandline arguments: > USAGE: COMMAND [OPTION ...] PATTERN ... diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -114,8 +114,6 @@ import qualified Control.Exception.Lifted as ExL import Control.Monad.Trans.Control import Control.Monad.Trans -import qualified Language.Haskell.Exts.Pretty as HE -import qualified Language.Haskell.Exts.Parser as HE import qualified Test.HUnit.Lang as HU import Data.List ( (\\) ) @@ -127,6 +125,7 @@ import Test.Framework.Colors import Test.Framework.Pretty import Test.Framework.AssertM +import Test.Framework.PrettyHaskell -- WARNING: do not forget to add a preprocessor macro for new assertions!! @@ -259,7 +258,7 @@ Nothing -> "" in noColor' (f True) (f False) (expP, actP, stringEq) = - case (pp exp, pp act) of + case (prettyHaskell' exp, prettyHaskell' act) of (Nothing, _) -> (exp, act, exp == act) (_, Nothing) -> (exp, act, exp == act) (Just expP, Just actP) @@ -268,19 +267,10 @@ then (exp, act, exp == act) else (expP, actP, True) | otherwise -> (expP, actP, False) - pp s = - case HE.parseExp s of - HE.ParseOk x -> Just $ HE.prettyPrint x - HE.ParseFailed{} -> Nothing notEqualityFailedMessage :: String -> String notEqualityFailedMessage exp = - (": Objects are equal\n" ++ pp exp) - where - pp s = - case HE.parseExp s of - HE.ParseOk x -> HE.prettyPrint x - HE.ParseFailed{} -> s + (": Objects are equal\n" ++ prettyHaskell exp) _assertEqual_ :: (Eq a, Show a, AssertM m) => String -> Location -> String -> a -> a -> m () diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PackageImports #-} -- -- Copyright (c) 2009-2014 Stefan Wehr - http://www.stefanwehr.de @@ -19,20 +21,24 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.Preprocessor ( transform, progName ) where +module Test.Framework.Preprocessor ( + transform, progName, preprocessorTests + +) where + import Control.Monad -import qualified Data.Text as T -import Data.Char ( toLower, isSpace, isDigit ) -import Data.Maybe ( mapMaybe ) -import qualified Data.List as List -import System.IO ( hPutStrLn, stderr ) +import Data.Char ( isDigit, isSpace ) +import "haskell-lexer" Language.Haskell.Lexer import Language.Preprocessor.Cpphs ( runCpphs, CpphsOptions(..), BoolOptions(..), defaultCpphsOptions) +import System.IO ( hPutStrLn, stderr ) +import Test.HUnit hiding (State) +import Control.Monad.State.Strict +import qualified Data.List as List -import Test.Framework.HaskellParser import Test.Framework.Location _DEBUG_ :: Bool @@ -112,172 +118,336 @@ expansion a suffix = "(" ++ prefix ++ a ++ suffix ++ " (" ++ prefix ++ "makeLoc __FILE__ __LINE__))" -warn :: String -> IO () -warn s = - hPutStrLn stderr $ progName ++ " warning: " ++ s - -note :: String -> IO () -note s = - when _DEBUG_ $ hPutStrLn stderr $ progName ++ " note: " ++ s - data ModuleInfo = ModuleInfo { mi_htfPrefix :: String , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition] , mi_moduleName :: String } - deriving (Show) + deriving (Show, Eq) +data ImportDecl = ImportDecl { imp_moduleName :: Name + , imp_qualified :: Bool + , imp_alias :: Maybe Name + , imp_loc :: Location } + deriving (Show, Eq) + data Definition = TestDef String Location String | PropDef String Location String deriving (Eq, Show) -data ImportOrPragma = IsImport ImportDecl | IsPragma Pragma - deriving (Show) +type Name = String -analyse :: FilePath -> String - -> IO (ParseResult ModuleInfo) -analyse originalFileName inputString = - do parseResult <- parse originalFileName inputString - case parseResult of - ParseOK (Module moduleName imports decls pragmas) -> - do -- putStrLn $ show decls - let defs = mapMaybe defFromDecl decls - htfImports = findHtfImports imports pragmas - htfPrefix <- - case mapMaybe prefixFromImport imports of - (s:_) -> return s - [] -> do warn ("No import found for " ++ htfModule ++ - " in " ++ originalFileName) - return (htfModule ++ ".") - return $ ParseOK (ModuleInfo htfPrefix htfImports defs moduleName) - ParseError loc err -> return (ParseError loc err) - where - prefixFromImport :: ImportDecl -> Maybe String - prefixFromImport (ImportDecl s qualified alias _) - | s == htfModule = - if qualified - then case alias of - Just s' -> Just $ s' ++ "." - Nothing -> Just $ s ++ "." - else Just "" - prefixFromImport _ = Nothing - defFromDecl :: Decl -> Maybe Definition - defFromDecl (Decl loc name) = defFromNameAndLoc name loc - defFromNameAndLoc :: Name -> Location -> Maybe Definition - defFromNameAndLoc name loc = - case name of - ('t':'e':'s':'t':'_':rest) | not (null rest) -> - Just (TestDef rest loc name) - ('p':'r':'o':'p':'_':rest) | not (null rest) -> - Just (PropDef rest loc name) - _ -> Nothing - findHtfImports allImports allPragmas = - let importPragmas = filter (\p -> pr_name p == "HTF_TESTS") allPragmas - importsAndPragmas = List.sortBy cmpByLine (map IsImport allImports ++ - map IsPragma importPragmas) - loop (IsImport imp : IsPragma prag : rest) = - if lineNumber (imp_loc imp) == lineNumber (pr_loc prag) - then imp : loop rest - else loop rest - loop (_ : rest) = loop rest - loop [] = [] - in loop importsAndPragmas - cmpByLine x y = getLine x `compare` getLine y - getLine (IsImport imp) = (lineNumber (imp_loc imp)) - getLine (IsPragma prag) = (lineNumber (pr_loc prag)) +type PMA a = State ModuleInfo a -breakOn :: T.Text -> T.Text -> Maybe (T.Text, T.Text) -breakOn t1 t2 = - let (pref, suf) = T.breakOn t1 t2 - in if pref == t2 - then Nothing - else Just (pref, T.drop (T.length t1) suf) +setModName :: String -> PMA () +setModName name = + modify $ \mi -> mi { mi_moduleName = name } -poorMensAnalyse :: FilePath -> String -> IO ModuleInfo -poorMensAnalyse originalFileName inputString = - let (modName, defs, impDecls) = doAna (zip [1..] (lines inputString)) ("", [], []) - in return $ ModuleInfo "Test.Framework." impDecls defs modName +addTestDef :: String -> String -> Location -> PMA () +addTestDef name fullName loc = + modify $ \mi -> mi { mi_defs = (TestDef name loc fullName) : mi_defs mi } + +addPropDef :: String -> String -> Location -> PMA () +addPropDef name fullName loc = + modify $ \mi -> mi { mi_defs = (PropDef name loc fullName) : mi_defs mi } + +addHtfImport :: ImportDecl -> PMA () +addHtfImport decl = + modify $ \mi -> mi { mi_htfImports = decl : mi_htfImports mi } + +setTestFrameworkImport :: String -> PMA () +setTestFrameworkImport name = + modify $ \mi -> mi { mi_htfPrefix = name } + +poorManAnalyzeTokens :: [LocToken] -> ModuleInfo +poorManAnalyzeTokens toks = + -- show toks `trace` + let revRes = + execState (loop toks) $ + ModuleInfo { mi_htfPrefix = htfModule ++ "." + , mi_htfImports = [] + , mi_defs = [] + , mi_moduleName = "Main" } + in ModuleInfo { mi_htfPrefix = mi_htfPrefix revRes + , mi_htfImports = reverse (mi_htfImports revRes) + , mi_defs = reverse $ List.nubBy defEqByName (mi_defs revRes) + , mi_moduleName = mi_moduleName revRes + } where defEqByName (TestDef n1 _ _) (TestDef n2 _ _) = n1 == n2 defEqByName (PropDef n1 _ _) (PropDef n2 _ _) = n1 == n2 defEqByName _ _ = False - doAna [] (modName, revDefs, impDecls) = (modName, reverse (List.nubBy defEqByName revDefs), reverse impDecls) - doAna ((lineNo, line) : restLines) (modName, defs, impDecls) = - case line of - 'm':'o':'d':'u':'l':'e':rest -> - if null modName - then doAna restLines (takeWhile (not . isSpace) (dropWhile isSpace rest), - defs, impDecls) - else doAna restLines (modName, defs, impDecls) - 't':'e':'s':'t':'_':rest -> - let testName = takeWhile (not . isSpace) rest - def = TestDef testName loc ("test_" ++ testName) - in doAna restLines (modName, def : defs, impDecls) - 'p':'r':'o':'p':'_':rest -> - let testName = takeWhile (not . isSpace) rest - def = PropDef testName loc ("prop_" ++ testName) - in doAna restLines (modName, def : defs, impDecls) - 'i':'m':'p':'o':'r':'t':rest -> - case breakOn importPragma (T.pack rest) of - Just (pref, suf) -> - case poorMensParseImportLine loc (pref `T.append` suf) of - Just impDecl -> doAna restLines (modName, defs, impDecl : impDecls) - Nothing -> doAna restLines (modName, defs, impDecls) - Nothing -> doAna restLines (modName, defs, impDecls) - _ -> doAna restLines (modName, defs, impDecls) - where - loc = makeLoc originalFileName lineNo - importPragma = T.pack "{-@ HTF_TESTS @-}" + loop toks = + case toks of + (Reservedid, (_, "module")) : rest -> + case rest of + (Conid, (_, name)):rest2 -> + do setModName name + loop rest2 + (Qconid, (_, name)):rest2 -> + do setModName name + loop rest2 + _ -> loop rest + (Varid, (loc, name)) : rest + | isStartOfLine loc -> + case name of + 't':'e':'s':'t':'_':shortName -> + do addTestDef shortName name (locToLocation loc) + loop rest + 'p':'r':'o':'p':'_':shortName -> + do addPropDef shortName name (locToLocation loc) + loop rest + _ -> loop rest + | otherwise -> loop rest + (Special, (loc, "import_HTF_TESTS")) : rest -> + case parseImport loc rest of + Just (imp, rest2) -> + do addHtfImport imp + loop rest2 + Nothing -> loop rest + (Reservedid, (loc, "import")) : rest -> + do case parseImport loc rest of + Nothing -> loop rest + Just (imp, rest2) -> + do when (imp_moduleName imp == htfModule) $ + let prefix = case (imp_alias imp, imp_qualified imp) of + (Just alias, True) -> alias + (Nothing, True) -> imp_moduleName imp + _ -> "" + in setTestFrameworkImport + (if null prefix then prefix else prefix ++ ".") + loop rest2 + _ : rest -> loop rest + [] -> return () + parseImport loc toks = + do let (qualified, toks2) = + case toks of + (Varid, (_, "qualified")):rest -> (True, rest) + _ -> (False, toks) + (name, toks3) <- + case toks2 of + (Conid, (_, name)):rest -> return (name, rest) + (Qconid, (_, name)):rest -> return (name, rest) + _ -> fail "no import" + let (mAlias, toks4) = + case toks3 of + (Varid, (_, "as")):(Conid, (_, alias)):rest -> (Just alias, rest) + _ -> (Nothing, toks3) + decl = ImportDecl { imp_moduleName = name + , imp_qualified = qualified + , imp_alias = mAlias + , imp_loc = locToLocation loc } + return (decl, toks4) + locToLocation loc = + makeLoc (l_file loc) (l_line loc) + isStartOfLine loc = + l_column loc == 1 -poorMensParseImportLine :: Location -> T.Text -> Maybe ImportDecl -poorMensParseImportLine loc t = - let (q, rest) = - case breakOn "qualified" t of - Nothing -> (False, T.strip t) - Just (_, rest) -> (True, T.strip rest) - modName = T.takeWhile (not . isSpace) rest - afterModName = T.strip $ T.drop (T.length modName) rest - in case breakOn "as" afterModName of - Nothing -> Just $ ImportDecl (T.unpack modName) q Nothing loc - Just (_, suf) -> - let strippedSuf = T.strip suf - alias = if T.null strippedSuf then Nothing else Just (T.unpack strippedSuf) - in Just $ ImportDecl (T.unpack modName) q alias loc +cleanupTokens :: [PosToken] -> [PosToken] +cleanupTokens toks = + -- Remove whitespace tokens, remove comments, but replace + -- 'import {-@ HTF_TESTS @-}' with a single + -- token Special with value "import_HTF_TESTS" + case toks of + (Whitespace, _):rest -> cleanupTokens rest + (NestedComment, (loc, "{-@ HTF_TESTS @-}")) : rest -> + (Special, (loc, "import_HTF_TESTS")) : + cleanupTokens rest + tok:rest -> tok : cleanupTokens rest + [] -> [] -transform :: Bool -> FilePath -> String -> IO String -transform hunitBackwardsCompat originalFileName input = - do analyseResult <- analyse originalFileName input - case analyseResult of - ParseError loc err -> - do poorInfo <- poorMensAnalyse originalFileName input - note ("Parsing of " ++ originalFileName ++ " failed at line " - ++ show (lineNumber loc) ++ ": " ++ err ++ - "\nFalling back to poor man's parser. This parser may " ++ - "return incomplete results. The result returned was: " ++ - "\nPrefix: " ++ mi_htfPrefix poorInfo ++ - "\nModule name: " ++ mi_moduleName poorInfo ++ - "\nDefinitions: " ++ show (mi_defs poorInfo) ++ - "\nHTF imports: " ++ show (mi_htfImports poorInfo)) - preprocess poorInfo input - ParseOK info -> - preprocess info input +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 + c:rest -> c : cleanupInputString rest + [] -> [] + +type LocToken = (Token,(Loc,String)) + +data Loc + = Loc + { l_file :: FilePath + , l_line :: Int + , l_column :: Int + } + deriving (Eq, Show) + +-- token stream should not contain whitespace +fixPositions :: FilePath -> [PosToken] -> [LocToken] +fixPositions originalFileName = loop Nothing where - preprocess :: ModuleInfo -> String -> IO String - preprocess info input = - do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName + loop mPragma toks = + case toks of + [] -> [] + (Varsym, (pos, "#")) : (Varid, (_, "line")) : (IntLit, (_, lineNo)) : (StringLit,(_, fileName)) : rest + | column pos == 1 -> + map (\(tt, (pos, x)) -> (tt, (fixPos Nothing pos, x))) (take 4 toks) ++ + loop (Just (line pos, fileName, read lineNo)) rest + (tt, (pos, x)) : rest -> + (tt, (fixPos mPragma pos, x)) : loop mPragma rest + fixPos mPragma pos = + case mPragma of + Nothing -> + Loc { l_column = column pos + , l_file = originalFileName + , l_line = line pos + } + Just (lineActivated, fileName, lineNo) -> + let offset = line pos - lineActivated - 1 + in Loc { l_column = column pos + , l_file = fileName + , l_line = lineNo + offset + } + +fixPositionsTest :: IO () +fixPositionsTest = + let toks = concatMap (\(f, i) -> f i) + (zip [tok, linePragma "bar" 10, tok, tok, linePragma "foo" 99, tok] [1..]) + fixedToks = fixPositions origFileName toks + expectedToks = concat $ + [tok' origFileName 1 + ,linePragma' "bar" 10 2 + ,tok' "bar" 10 + ,tok' "bar" 11 + ,linePragma' "foo" 99 5 + ,tok' "foo" 99] + in assertEqual (show expectedToks ++ "\n\n /= \n\n" ++ show toks) expectedToks fixedToks + where + origFileName = "spam" + tok line = [(Varid, (Pos 0 line 1, "_"))] + linePragma fname line lineHere = + let pos = Pos 0 lineHere 1 + in [(Varsym, (pos, "#")) + ,(Varid, (pos, "line")) + ,(IntLit, (pos, show line)) + ,(StringLit, (pos, fname))] + tok' fname line = + let loc = Loc fname line 1 + in [(Varid, (loc, "_"))] + linePragma' fname line lineHere = + let loc = Loc origFileName lineHere 1 + in [(Varsym, (loc, "#")) + ,(Varid, (loc, "line")) + ,(IntLit, (loc, show line)) + ,(StringLit,(loc, fname))] + +analyze :: FilePath -> String -> ModuleInfo +analyze originalFileName input = + poorManAnalyzeTokens (fixPositions originalFileName (cleanupTokens (lexerPass0 (cleanupInputString input)))) + +analyzeTests = + [(unlines ["module FOO where" + ,"import Test.Framework" + ,"import {-@ HTF_TESTS @-} qualified Foo as Bar" + ,"import {-@ HTF_TESTS @-} qualified Foo.X as Egg" + ,"import {-@ HTF_TESTS @-} Foo.Y as Spam" + ,"import {-@ HTF_TESTS @-} Foo.Z" + ,"import {-@ HTF_TESTS @-} Baz" + ,"deriveSafeCopy 1 'base ''T" + ,"$(deriveSafeCopy 2 'extension ''T)" + ,"test_blub test_foo = 1" + ,"test_blah test_foo = 1" + ,"prop_abc prop_foo = 2" + ,"prop_xyz = True"] + ,ModuleInfo { mi_htfPrefix = "" + , mi_htfImports = + [ImportDecl { imp_moduleName = "Foo" + , imp_qualified = True + , imp_alias = Just "Bar" + , imp_loc = makeLoc "" 3} + ,ImportDecl { imp_moduleName = "Foo.X" + , imp_qualified = True + , imp_alias = Just "Egg" + , imp_loc = makeLoc "" 4} + ,ImportDecl { imp_moduleName = "Foo.Y" + , imp_qualified = False + , imp_alias = Just "Spam" + , imp_loc = makeLoc "" 5} + ,ImportDecl { imp_moduleName = "Foo.Z" + , imp_qualified = False + , imp_alias = Nothing + , imp_loc = makeLoc "" 6} + ,ImportDecl { imp_moduleName = "Baz" + , imp_qualified = False + , imp_alias = Nothing + , imp_loc = makeLoc "" 7}] + , mi_moduleName = "FOO" + , mi_defs = [TestDef "blub" (makeLoc "" 10) "test_blub" + ,TestDef "blah" (makeLoc "" 11) "test_blah" + ,PropDef "abc" (makeLoc "" 12) "prop_abc" + ,PropDef "xyz" (makeLoc "" 13) "prop_xyz"] + }) + ,(unlines ["module Foo.Bar where" + ,"import Test.Framework as Blub" + ,"prop_xyz = True"] + ,ModuleInfo { mi_htfPrefix = "" + , mi_htfImports = [] + , mi_moduleName = "Foo.Bar" + , mi_defs = [PropDef "xyz" (makeLoc "" 3) "prop_xyz"] + }) + ,(unlines ["module Foo.Bar where" + ,"import qualified Test.Framework as Blub" + ,"prop_xyz = True"] + ,ModuleInfo { mi_htfPrefix = "Blub." + , mi_htfImports = [] + , mi_moduleName = "Foo.Bar" + , mi_defs = [PropDef "xyz" (makeLoc "" 3) "prop_xyz"] + }) + ,(unlines ["module Foo.Bar where" + ,"import qualified Test.Framework" + ,"prop_xyz = True"] + ,ModuleInfo { mi_htfPrefix = "Test.Framework." + , mi_htfImports = [] + , mi_moduleName = "Foo.Bar" + , mi_defs = [PropDef "xyz" (makeLoc "" 3) "prop_xyz"] + })] + +testAnalyze = + do mapM_ runTest (zip [1..] analyzeTests) + where + runTest (i, (src, mi)) = + let givenMi = analyze "" src + in if givenMi == mi + then return () + else assertFailure ("Error in test " ++ show i ++ + ", expected:\n" ++ show mi ++ + "\nGiven:\n" ++ show givenMi ++ + "\nSrc:\n" ++ src) + +transform :: Bool -> Bool -> FilePath -> String -> IO String +transform hunitBackwardsCompat debug originalFileName input = + let info = analyze originalFileName fixedInput + in preprocess info + where + preprocess :: ModuleInfo -> IO String + preprocess info = + do when debug $ hPutStrLn stderr ("Module info:\n" ++ show info) + preProcessedInput <- runCpphs (cpphsOptions info) originalFileName fixedInput return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n" + -- fixedInput serves two purposes: + -- 1. add a trailing \n + -- 2. turn lines of the form '# ""' into line directives '#line ' + -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output). + fixedInput :: String + fixedInput = (unlines . map fixLine . lines) input where - -- fixedInput serves two purposes: - -- 1. add a trailing \n - -- 2. turn lines of the form '# ""' into line directives '#line ' - -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output). - fixedInput :: String - fixedInput = (unlines . map fixLine . lines) input - where - fixLine s = - case parseCppLineInfoOut s of - Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName - _ -> s + fixLine s = + case parseCppLineInfoOut s of + Just (line, fileName) -> "#line " ++ line ++ " " ++ fileName + _ -> s cpphsOptions :: ModuleInfo -> CpphsOptions cpphsOptions info = defaultCpphsOptions { defines = @@ -328,3 +498,26 @@ (False, _) -> name (True, Just alias) -> alias ++ "." ++ name (True, _) -> imp_moduleName imp ++ "." ++ name + +-- Returns for lines of the form '# ""' +-- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output) +-- the value 'Just ""' +parseCppLineInfoOut :: String -> Maybe (String, String) +parseCppLineInfoOut line = + case line of + '#':' ':c:rest + | isDigit c -> + case List.span isDigit rest of + (restDigits, ' ' : '"' : rest) -> + case dropWhile (/= '"') (reverse rest) of + '"' : fileNameRev -> + let line = (c:restDigits) + file = "\"" ++ reverse fileNameRev ++ "\"" + in Just (line, file) + _ -> Nothing + _ -> Nothing + _ -> Nothing + +preprocessorTests = + [("testAnalyze", testAnalyze) + ,("fixPositionsTest", fixPositionsTest)] diff --git a/Test/Framework/PrettyHaskell.hs b/Test/Framework/PrettyHaskell.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/PrettyHaskell.hs @@ -0,0 +1,83 @@ +module Test.Framework.PrettyHaskell ( + + prettyHaskell, prettyHaskell', prettyHaskellTests + +) where + +import qualified Data.List as List +import Language.Haskell.Parser +import Language.Haskell.Pretty +import Test.HUnit +import Test.Framework.Utils + +prettyHaskell :: Show a => a -> String +prettyHaskell x = + case prettyHaskell' x of + Just s -> s + Nothing -> "FALLBACK: " ++ show x + +prettyHaskell' :: Show a => a -> Maybe String +prettyHaskell' x = + fmap (postProcess (show x)) (prettyHaskell'' x ) + +prettyHaskell'' :: Show a => a -> Maybe String +prettyHaskell'' x = + let str = show x + code = "module M where TOP = " ++ str + in case parseModule code of + ParseOk x -> Just (prettyPrint x) + ParseFailed _ _ -> Nothing + +postProcess :: String -> String -> String +postProcess fallback s = + case dropWhile (\l -> not ('=' `elem` l)) (lines s) of + [] -> fallback + (l:ls) -> + case List.span (/= '=') l of + (prefix, '=':' ':suffix) -> + let indentLen = length prefix + 2 + in strip $ unlines (suffix : (map (drop indentLen) ls)) + _ -> fallback + +prettyHaskellTests = + [("testPrettyHaskell", testPrettyHaskell)] + +data MySuperHero + = MySuperHero + { msh_age :: Int + , msh_name :: String + , msh_address :: String + , msh_fun :: Int + } + deriving (Show) + +data MySuperSuperHero + = MySuperSuperHero + { mssh_isHere :: Bool + , mssh_hero :: MySuperHero + } + deriving (Show) + +testPrettyHaskell = + do assertPretty "Just 1" (Just 1) + let hero = + MySuperHero + { msh_age = 35 + , msh_name = "FOO" + , msh_address = "address" + , msh_fun = 1 + } + assertPretty + ("MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" ++ + " msh_address = \"address\", msh_fun = 1}") + hero + assertPretty + ("MySuperSuperHero{mssh_isHere = True,\n" ++ + " mssh_hero =\n" ++ + " MySuperHero{msh_age = 35, msh_name = \"FOO\",\n" ++ + " msh_address = \"address\", msh_fun = 1}}") + (MySuperSuperHero { mssh_isHere = True, mssh_hero = hero }) + where + assertPretty s x = + assertEqual (s ++ " /=\n" ++ prettyHaskell x) + s (prettyHaskell x) diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -32,7 +32,7 @@ -- * Arguments for evaluating properties defaultArgs, getCurrentArgs, setDefaultArgs, - withQCArgs, WithQCArgs, + withQCArgs, WithQCArgs, setReplayFromString, -- * Pending properties qcPending, @@ -58,10 +58,11 @@ import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO) import Data.IORef +import System.Random import Test.QuickCheck -import Test.QuickCheck.Property hiding (reason) import Test.Framework.TestInterface +import Test.Framework.Utils _DEBUG_ :: Bool _DEBUG_ = False @@ -205,3 +206,22 @@ assertionAsProperty :: IO () -> Property assertionAsProperty action = ioProperty $ action >> return True + +-- | Sets the 'replay' parameter of the 'Args' datatype by parsing the given string. +setReplayFromString :: Args -> String -> Args +setReplayFromString args str = +#if !MIN_VERSION_QuickCheck(2,7,0) + case readM str of + Just x -> args { replay = x } + Nothing -> error ("Could not parse replay parameter from string " ++ show str) +#else + -- Starting with QC 2.7 the type of the replay field changed from + -- 'Maybe (StdGen, Int)' to 'Maybe (QCGen, Int' + case readM str of + Just x -> args { replay = x } + Nothing -> + case readM str of + Just (_ :: Maybe (StdGen, Int)) -> + error ("Your replay parameter has been produced with QuickCheck <= 2.6. It cannot be used with QuickCheck >= 2.7") + Nothing -> error ("Could not parse replay parameter from string " ++ show str) +#endif diff --git a/Test/Framework/TestReporter.hs b/Test/Framework/TestReporter.hs --- a/Test/Framework/TestReporter.hs +++ b/Test/Framework/TestReporter.hs @@ -196,9 +196,9 @@ timedOut = length (rgra_timedOut arg) filtered = length (rgra_filtered arg) total = passed + failed + error + pending - let pendings = colorize pendingColor "* Pending:" - failures = colorize warningColor "* Failures:" - errors = colorize warningColor "* Errors:" + let pendings = (if pending > 0 then colorize pendingColor else noColor) "* Pending:" + failures = (if failed > 0 then colorize warningColor else noColor) "* Failures:" + errors = (if error > 0 then colorize warningColor else noColor) "* Errors:" reportTR Info ("* Tests: " +++ showC total +++ "\n" +++ "* Passed: " +++ showC passed +++ "\n" +++ pendings +++ " " +++ showC pending +++ "\n" +++ diff --git a/run-all-tests.sh b/run-all-tests.sh --- a/run-all-tests.sh +++ b/run-all-tests.sh @@ -1,7 +1,17 @@ #!/bin/bash +SANDBOX_FILE="cabal.sandbox.config" +SANDBOX_DIR=".cabal-sandbox" + set -e -ghc-pkg unregister HTF || true +if [ -e "$SANDBOX_FILE" ] +then + have_sandbox=yes + cabal sandbox hc-pkg unregister HTF || true +else + have_sandbox=no + ghc-pkg unregister HTF || true +fi cabal configure --enable-tests || exit 1 cabal build || exit 1 @@ -9,6 +19,13 @@ cabal install || exit 1 cd sample + +if [ "$have_sandbox" == "yes" ] +then + rm -f cabal.sandbox.config + cabal sandbox init --sandbox ../"$SANDBOX_DIR" +fi + cabal configure --enable-tests || exit 1 cabal build || exit 1 cabal test || exit 1 diff --git a/sample/sample-HTF.cabal b/sample/sample-HTF.cabal --- a/sample/sample-HTF.cabal +++ b/sample/sample-HTF.cabal @@ -13,12 +13,12 @@ executable sample main-is: Main.hs other-modules: MyPkg.A MyPkg.B - build-depends: base, HTF == 0.11.* + build-depends: base, HTF == 0.12.* default-language: Haskell2010 test-suite sample-tests type: exitcode-stdio-1.0 main-is: TestMain.hs other-modules: MyPkg.A MyPkg.B - build-depends: base, HTF == 0.11.* + build-depends: base, HTF == 0.12.* default-language: Haskell2010 diff --git a/tests/Foo/test.h b/tests/Foo/test.h --- a/tests/Foo/test.h +++ b/tests/Foo/test.h @@ -4,3 +4,6 @@ y :: Int y = 2 + +test_h_FAIL = + assertEqual 4 5 diff --git a/tests/MiscTest.hs b/tests/MiscTest.hs --- a/tests/MiscTest.hs +++ b/tests/MiscTest.hs @@ -18,10 +18,12 @@ -- import Test.Framework.History +import Test.Framework.Preprocessor +import Test.Framework.PrettyHaskell import System.Exit import Test.HUnit -allTests = historyTests +allTests = historyTests ++ preprocessorTests ++ prettyHaskellTests main :: IO () main = diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs --- a/tests/TestHTF.hs +++ b/tests/TestHTF.hs @@ -36,11 +36,14 @@ import qualified Data.HashMap.Strict as M import qualified Data.HashSet as Set import qualified Data.Aeson as J +import qualified Data.Aeson.Encode.Pretty as J import Data.Aeson ( (.=) ) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import Data.Maybe import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Encoding.Error as T import qualified Data.List as List import qualified Text.Regex as R import {-@ HTF_TESTS @-} qualified TestHTFHunitBackwardsCompatible @@ -143,7 +146,7 @@ (xs::[Int]) == (reverse (reverse xs)) prop_fail'_FAIL = - withQCArgs (\a -> a { replay = read "Just (1292732529 652912053,3)" }) prop + prop where prop xs = xs == (reverse xs) where types = xs::[Int] @@ -177,6 +180,7 @@ -- $ find . -name '*.hs' | xargs egrep -w -o -h "[a-zA-Z0-9_']+_FAIL" | sed 's/test_//g; s/prop_//g' | sort -u ["1_FAIL" ,"a_FAIL" + ,"h_FAIL" ,"assertElem_FAIL" ,"assertEmpty_FAIL" ,"assertEqualNoShow_FAIL" @@ -260,6 +264,12 @@ ,"location" .= J.object ["file" .= J.String "./Foo/A.hs" ,"line" .= J.toJSON (11::Int)]]) check jsons (J.object ["type" .= J.String "test-end" + ,"test" .= J.object ["flatName" .= J.String "Foo.A:h_FAIL"]]) + (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/test.h" + ,"line" .= J.toJSON (8::Int)]] + ,"location" .= J.object ["file" .= J.String "./Foo/test.h" + ,"line" .= J.toJSON (9::Int)]]) + check jsons (J.object ["type" .= J.String "test-end" ,"test" .= J.object ["flatName" .= J.String "Main:subAssert_FAIL"]]) (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null ,"location" .= J.object ["file" .= J.String "TestHTF.hs" @@ -269,7 +279,7 @@ ,"line" .= J.toJSON (97+lineOffset)]]]]) where lineOffset :: Int - lineOffset = 9 + lineOffset = 12 checkStatus tuple@(pass, fail, error, pending, timedOut) json = {- {"location":null @@ -315,8 +325,8 @@ case filter (\j -> matches j pred) jsons of [json] -> if not (matches json assert) - then error ("Predicate " ++ show pred ++ " match JSON " ++ show json ++ ", but assertion " ++ - show assert ++ " not satisfied") + then error ("Predicate\n" ++ ppJ pred ++ " match JSON\n" ++ ppJ json ++ ", but assertion\n" ++ + ppJ assert ++ " not satisfied") else return () l -> error ("not exactly one JSON matches predicate " ++ show pred ++ " but " ++ show l) matches :: J.Value -> J.Value -> Bool @@ -348,6 +358,11 @@ else case splitJson rest of [] -> error "invalid json output from HTF" (x:xs) -> (start `BSL.append` x : xs) + ppJ json = + T.unpack $ + T.decodeUtf8With T.lenientDecode $ + BSL.toStrict $ + J.encodePretty' (J.Config 2 J.compare) json runRealBlackBoxTests = do b <- doesDirectoryExist "tests/bbt" diff --git a/tests/compile-errors/run-tests.sh b/tests/compile-errors/run-tests.sh --- a/tests/compile-errors/run-tests.sh +++ b/tests/compile-errors/run-tests.sh @@ -2,9 +2,21 @@ cd "$(dirname $0)" -FLAGS="-hide-all-packages -package base -package-conf ../../dist/package.conf.inplace -package HTF --make" -lineno=7 +FLAGS="-hide-all-packages -package base -package-db ../../dist/package.conf.inplace -package HTF --make" +SANDBOX_FILE="../../cabal.sandbox.config" +SANDBOX_DIR="../../.cabal-sandbox" +GHC_VERSION=$(ghc --version | sed 's/.*version //g') +if [ -e "$SANDBOX_FILE" ] +then + for pkg_db in $(ls -d -1 $SANDBOX_DIR/*$GHC_VERSION*-packages.conf.d) + do + FLAGS="$FLAGS -package-db $pkg_db" + done +fi +echo $FLAGS + +lineno=7 function check() { test="$1"