Commits

Bryan O'Sullivan committed 39e66be

Silly unit tests for stdio actions - top-level hpc coverage up to 91%

Comments (0)

Files changed (4)

 	$(ghc) $(ghc-hpc-flags) $(ghc-test-flags) $(ghc-opt-flags) -ihpcdir \
 	  --make -threaded -o $@ $<
 
+stdio-hpc: StdioCoverage.hs $(lib-srcs:%=../%)
+	-mkdir -p hpcdir
+	@rm -f $@.tix
+	$(ghc) $(ghc-hpc-flags) $(ghc-test-flags) $(ghc-opt-flags) -ihpcdir \
+	  --make -threaded -o $@ $<
+
+coverage: coverage-html/hpc_index.html
+
+coverage-html/hpc_index.html: qc-hpc
+	@rm -f qc-hpc.tix stdio-hpc.tix coverage.tix
+	./qc-hpc -a 100 +RTS -N
+	bash ./cover-stdio.sh
+	hpc combine --output=coverage.tix --exclude=Main \
+	  qc-hpc.tix stdio-hpc.tix
+	hpc markup coverage --exclude=Main --exclude=Properties --exclude=Main \
+	  --exclude=Data.Text.Fusion.CaseMapping --exclude StdioCoverage \
+	  --exclude=SlowFunctions --exclude=TestUtils \
+	  --exclude=QuickCheckUtils --srcdir=.. --srcdir=. --destdir=$(dir $@)
+	@echo xdg-open $@
+
 Regressions.o: TestUtils.o
 
 regressions: Regressions.o TestUtils.o
 	$(ghc) $(ghc-test-flags) -o $@ $^ $(lib)
 
-coverage: qc-hpc-html/hpc_index.html
-
-qc-hpc-html/hpc_index.html: qc-hpc
-	./qc-hpc -a 100 +RTS -N
-	hpc markup qc-hpc --exclude=Main --exclude=Properties \
-	  --exclude=Data.Text.Fusion.CaseMapping \
-	  --exclude=SlowFunctions --exclude=TestUtils \
-	  --exclude=QuickCheckUtils --srcdir=.. --srcdir=. --destdir=$(dir $@)
-
 Benchmarks.o: ghc-opt-flags = -O
 bm Benchmarks.o: ghc-flags += -package utf8-string
 bm: Benchmarks.o
 	curl -O http://projects.haskell.org/text/text-testdata.tar.bz2
 
 clean:
-	-rm -rf *.o *.hi *.tix bm qc qc-hpc hpcdir .hpc qc-hpc-html
+	-rm -rf *.o *.hi *.tix bm qc qc-hpc stdio-hpc hpcdir .hpc coverage-html

tests/Properties.hs

 import qualified Data.Text.IO as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.IO as TL
+import qualified Data.Text.Lazy.Internal as TL
 import qualified Data.Text.Lazy.Builder as TB
 import qualified Data.Text.Encoding as E
 import Data.Text.Encoding.Error

tests/StdioCoverage.hs

+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO as TL
+import System.Environment (getArgs)
+import System.Exit (exitFailure)
+import System.IO (hPutStrLn, stderr)
+
+main = do
+  args <- getArgs
+  case args of
+    ["T.readFile", name] -> T.putStr =<< T.readFile name
+    ["T.writeFile", name, t] -> T.writeFile name (T.pack t)
+    ["T.appendFile", name, t] -> T.appendFile name (T.pack t)
+    ["T.interact"] -> T.interact id
+    ["T.getContents"] -> T.putStr =<< T.getContents
+    ["T.getLine"] -> T.putStrLn =<< T.getLine
+
+    ["TL.readFile", name] -> TL.putStr =<< TL.readFile name
+    ["TL.writeFile", name, t] -> TL.writeFile name (TL.pack t)
+    ["TL.appendFile", name, t] -> TL.appendFile name (TL.pack t)
+    ["TL.interact"] -> TL.interact id
+    ["TL.getContents"] -> TL.putStr =<< TL.getContents
+    ["TL.getLine"] -> TL.putStrLn =<< TL.getLine
+    _ -> hPutStrLn stderr "invalid directive!" >> exitFailure

tests/cover-stdio.sh

+#!/bin/bash
+
+exe=./stdio-hpc
+
+rm -f $exe.tix
+
+f=$(mktemp stdio-f.XXXXXX)
+g=$(mktemp stdio-g.XXXXXX)
+
+for t in T TL; do
+    echo $t.readFile > $f
+    $exe $t.readFile $f > $g
+    if ! diff -u $f $g; then
+	errs=$((errs+1))
+	echo FAIL: $t.readFile 1>&2
+    fi
+
+    $exe $t.writeFile $f $t.writeFile
+    echo -n $t.writeFile > $g
+    if ! diff -u $f $g; then
+	errs=$((errs+1))
+	echo FAIL: $t.writeFile 1>&2
+    fi
+
+    echo -n quux > $f
+    $exe $t.appendFile $f $t.appendFile
+    echo -n quux$t.appendFile > $g
+    if ! diff -u $f $g; then
+	errs=$((errs+1))
+	echo FAIL: $t.appendFile 1>&2
+    fi
+
+    echo $t.interact | $exe $t.interact > $f
+    echo $t.interact > $g
+    if ! diff -u $f $g; then
+	errs=$((errs+1))
+	echo FAIL: $t.interact 1>&2
+    fi
+
+    echo $t.getContents | $exe $t.getContents > $f
+    echo $t.getContents > $g
+    if ! diff -u $f $g; then
+	errs=$((errs+1))
+	echo FAIL: $t.getContents 1>&2
+    fi
+
+    echo $t.getLine | $exe $t.getLine > $f
+    echo $t.getLine > $g
+    if ! diff -u $f $g; then
+	errs=$((errs+1))
+	echo FAIL: $t.getLine 1>&2
+    fi
+done
+
+rm -f $f $g
+
+exit $errs