diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,6 @@ +* 0.11.2 (2014-02-07) + - fall-back to poor men's parser if parsing with haskell-src-exts fails + * 0.11.1.0 (2014-01-22) - htfpp now lexes input files as text, not as haskell src. This allows proper treatment of TH single quotes (fix for #26) diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,5 +1,5 @@ Name: HTF -Version: 0.11.1.1 +Version: 0.11.2 License: LGPL License-File: LICENSE Copyright: (c) 2005-2012 Stefan Wehr @@ -141,7 +141,8 @@ directory >= 1.0, array, random >= 1.0, - base == 4.* + base == 4.*, + text Other-Modules: Test.Framework.Preprocessor Test.Framework.HaskellParser diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs --- a/Test/Framework/HaskellParser.hs +++ b/Test/Framework/HaskellParser.hs @@ -21,9 +21,6 @@ import Data.Char ( isSpace, isDigit ) import qualified Data.List as List import Control.Exception ( evaluate, catch, SomeException ) -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding ( catch ) -#endif import qualified Language.Haskell.Exts as Exts import qualified Language.Haskell.Exts.Parser as Parser @@ -39,10 +36,12 @@ data Decl = Decl { decl_loc :: Location , decl_name :: Name } + deriving (Show) data Pragma = Pragma { pr_name :: String , pr_args :: String , pr_loc :: Location } + deriving (Show) data ParseResult a = ParseOK a | ParseError Location String @@ -50,11 +49,13 @@ , mod_imports :: [ImportDecl] , mod_decls :: [Decl] , mod_htfPragmas :: [Pragma] } + deriving (Show) data ImportDecl = ImportDecl { imp_moduleName :: Name , imp_qualified :: Bool , imp_alias :: Maybe Name , imp_loc :: Location } + deriving (Show) -- Returns for lines of the form '# ""' -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output) diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} -- --- Copyright (c) 2009-2012 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2009-2014 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -20,6 +21,7 @@ module Test.Framework.Preprocessor ( transform, progName ) where +import qualified Data.Text as T import Data.Char ( toLower, isSpace, isDigit ) import Data.Maybe ( mapMaybe ) import qualified Data.List as List @@ -109,11 +111,14 @@ , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition] , mi_moduleName :: String } + deriving (Show) data Definition = TestDef String Location String | PropDef String Location String + deriving (Show) data ImportOrPragma = IsImport ImportDecl | IsPragma Pragma + deriving (Show) analyse :: FilePath -> String -> IO (ParseResult ModuleInfo) @@ -167,14 +172,76 @@ getLine (IsImport imp) = (lineNumber (imp_loc imp)) getLine (IsPragma prag) = (lineNumber (pr_loc prag)) +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) + +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 + where + doAna [] (modName, revDefs, impDecls) = (modName, reverse 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 @-}" + +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 + transform :: Bool -> FilePath -> String -> IO String transform hunitBackwardsCompat originalFileName input = do analyseResult <- analyse originalFileName input case analyseResult of ParseError loc err -> - do warn ("Parsing of " ++ originalFileName ++ " failed at line " - ++ show (lineNumber loc) ++ ": " ++ err) - preprocess (ModuleInfo "" [] [] "UNKNOWN_MODULE") input + do poorInfo <- poorMensAnalyse originalFileName input + warn ("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 where diff --git a/Test/Framework/TestReporter.hs b/Test/Framework/TestReporter.hs --- a/Test/Framework/TestReporter.hs +++ b/Test/Framework/TestReporter.hs @@ -204,13 +204,13 @@ errors +++ " " +++ showC error) when (pending > 0) $ reportTR Info - ("\n" +++ pendings +++ renderTestNames' (reverse pendingL)) + ("\n" +++ pendings +++ "\n" +++ renderTestNames' (reverse pendingL)) when (failed > 0) $ reportTR Info - ("\n" +++ failures +++ renderTestNames' (reverse failedL)) + ("\n" +++ failures +++ "\n" +++ renderTestNames' (reverse failedL)) when (error > 0) $ reportTR Info - ("\n" +++ errors +++ renderTestNames' (reverse errorL)) + ("\n" +++ errors +++ "\n" +++ renderTestNames' (reverse errorL)) reportStringTR Info ("\nTotal execution time: " ++ show t ++ "ms") where showC x = noColor (show x) diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs --- a/tests/TestHTF.hs +++ b/tests/TestHTF.hs @@ -19,7 +19,6 @@ -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -- - import Test.Framework import Test.Framework.TestManager import Test.Framework.BlackBoxTest @@ -45,9 +44,10 @@ import {-@ HTF_TESTS @-} qualified Foo.A as A import {-@ HTF_TESTS @-} Foo.B +import Tutorial hiding (main) + data T = A | B deriving Eq - {- stringGap = "hello \ \world!" diff --git a/tests/Tutorial.hs b/tests/Tutorial.hs --- a/tests/Tutorial.hs +++ b/tests/Tutorial.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -F -pgmF ./dist/build/htfpp/htfpp #-} +module Tutorial where + import System.Environment ( getArgs ) import System.Exit ( exitWith ) import Test.Framework