HTF 0.11.1.1 → 0.11.2
raw patch · 7 files changed
+88/−14 lines, 7 filesdep ~basedep ~text
Dependency ranges changed: base, text
Files
- ChangeLog +3/−0
- HTF.cabal +3/−2
- Test/Framework/HaskellParser.hs +4/−3
- Test/Framework/Preprocessor.hs +71/−4
- Test/Framework/TestReporter.hs +3/−3
- tests/TestHTF.hs +2/−2
- tests/Tutorial.hs +2/−0
ChangeLog view
@@ -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)
HTF.cabal view
@@ -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
Test/Framework/HaskellParser.hs view
@@ -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 '# <number> "<filename>"' -- (see http://gcc.gnu.org/onlinedocs/cpp/Preprocessor-Output.html#Preprocessor-Output)
Test/Framework/Preprocessor.hs view
@@ -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
Test/Framework/TestReporter.hs view
@@ -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)
tests/TestHTF.hs view
@@ -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!"
tests/Tutorial.hs view
@@ -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