HTF 0.12.1.0 → 0.12.2.0

raw patch · 15 files changed

+581/−234 lines, 15 filesdep +aeson-prettydep +haskell-lexerdep +haskell-srcdep −haskell-src-extsdep ~HUnitdep ~basedep ~randomPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-pretty, haskell-lexer, haskell-src

Dependencies removed: haskell-src-exts

Dependency ranges changed: HUnit, base, random

API changes (from Hackage documentation)

Files

• ChangeLog +4/−0
• HTF.cabal +54/−47
• HTFPP.hs +8/−7
• Test/Framework/CmdlineOptions.hs +1/−1
• Test/Framework/HUnitWrapper.hs +3/−13
• Test/Framework/Preprocessor.hs +344/−151
• Test/Framework/PrettyHaskell.hs +83/−0
• Test/Framework/QuickCheckWrapper.hs +22/−2
• Test/Framework/TestReporter.hs +3/−3
• run-all-tests.sh +18/−1
• sample/sample-HTF.cabal +2/−2
• tests/Foo/test.h +3/−0
• tests/MiscTest.hs +3/−1
• tests/TestHTF.hs +19/−4
• tests/compile-errors/run-tests.sh +14/−2

@@ -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

@@ -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 <wehr@factisresearch.com> Maintainer:       Stefan Wehr <wehr@factisresearch.com> 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

@@ -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: " ++

@@ -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 ...

@@ -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 ()

@@ -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 "<input>" 3}+                     ,ImportDecl { imp_moduleName = "Foo.X"+                                 , imp_qualified = True+                                 , imp_alias = Just "Egg"+                                 , imp_loc = makeLoc "<input>" 4}+                     ,ImportDecl { imp_moduleName = "Foo.Y"+                                 , imp_qualified = False+                                 , imp_alias = Just "Spam"+                                 , imp_loc = makeLoc "<input>" 5}+                     ,ImportDecl { imp_moduleName = "Foo.Z"+                                 , imp_qualified = False+                                 , imp_alias = Nothing+                                 , imp_loc = makeLoc "<input>" 6}+                     ,ImportDecl { imp_moduleName = "Baz"+                                 , imp_qualified = False+                                 , imp_alias = Nothing+                                 , imp_loc = makeLoc "<input>" 7}]+                 , mi_moduleName = "FOO"+                 , mi_defs = [TestDef "blub" (makeLoc "<input>" 10) "test_blub"+                             ,TestDef "blah" (makeLoc "<input>" 11) "test_blah"+                             ,PropDef "abc" (makeLoc "<input>" 12) "prop_abc"+                             ,PropDef "xyz" (makeLoc "<input>" 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 "<input>" 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 "<input>" 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 "<input>" 3) "prop_xyz"]+                 })]++testAnalyze =+    do mapM_ runTest (zip [1..] analyzeTests)+    where+      runTest (i, (src, mi)) =+          let givenMi = analyze "<input>" 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 '# <number> "<filename>"' into line directives '#line <number> <filename>'+      -- (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 '# <number> "<filename>"' into line directives '#line <number> <filename>'-              -- (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 '# <number> "<filename>"'+-- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output)+-- the value 'Just <number> "<filename>"'+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)]

@@ -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)

@@ -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

@@ -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" +++

@@ -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

@@ -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

@@ -4,3 +4,6 @@  y :: Int y = 2++test_h_FAIL =+    assertEqual 4 5

@@ -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 =

@@ -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"

@@ -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"