hcltest (empty) → 0.1
raw patch · 15 files changed
+756/−0 lines, 15 filesdep +basedep +bytestringdep +concurrent-extrabuild-type:Customsetup-changed
Dependencies added: base, bytestring, concurrent-extra, directory, dlist, doctest, either, filepath, free, lens, lifted-base, mmorph, monad-control, mtl, optparse-applicative, process, random-shuffle, split, stm, tagged, tasty, temporary, text, transformers, transformers-base
Files
- .ghci +1/−0
- .gitignore +15/−0
- .travis.yml +37/−0
- .vim.custom +31/−0
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +43/−0
- hcltest.cabal +77/−0
- src/Test/HClTest.hs +9/−0
- src/Test/HClTest/Monad.hs +153/−0
- src/Test/HClTest/Program.hs +188/−0
- src/Test/HClTest/Setup.hs +28/−0
- src/Test/HClTest/Trace.hs +16/−0
- src/Test/Tasty/HClTest.hs +51/−0
- tests/doctests.hsc +71/−0
+ .ghci view
@@ -0,0 +1,1 @@+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
+ .gitignore view
@@ -0,0 +1,15 @@+dist+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox+cabal.sandbox.config
+ .travis.yml view
@@ -0,0 +1,37 @@+# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.+env:+ - GHCVER=7.4.2 CABALVER=1.16+ - GHCVER=7.6.3 CABALVER=1.18+ - GHCVER=head # see section about GHC HEAD snapshots++before_install:+ - sudo add-apt-repository -y ppa:hvr/ghc+ - sudo apt-get update+ - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER happy hlint+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH++install:+ - cabal-$CABALVER update+ - cabal-$CABALVER install --only-dependencies --enable-tests --enable-benchmarks -j++script:+ - cabal-$CABALVER configure --enable-tests --enable-benchmarks -v2 --ghc-options="-Wall -Werror"+ - cabal-$CABALVER build + - cabal-$CABALVER test+ - cabal-$CABALVER check+ - hlint src + - cabal-$CABALVER sdist # tests that a source-distribution can be generated++# The following scriptlet checks that the resulting source distribution can be built & installed+ - export SRC_TGZ=$(cabal-$CABALVER info . | awk '{print $2 ".tar.gz";exit}') ;+ cd dist/;+ if [ -f "$SRC_TGZ" ]; then+ cabal-$CABALVER install "$SRC_TGZ";+ else+ echo "expected '$SRC_TGZ' not found";+ exit 1;+ fi++matrix:+ allow_failures:+ - env: GHCVER=head
+ .vim.custom view
@@ -0,0 +1,31 @@+" Add the following to your .vimrc to automatically load this on startup++" if filereadable(".vim.custom")+" so .vim.custom+" endif++function StripTrailingWhitespace()+ let myline=line(".")+ let mycolumn = col(".")+ silent %s/ *$//+ call cursor(myline, mycolumn)+endfunction++" enable syntax highlighting+syntax on++" search for the tags file anywhere between here and /+set tags=TAGS;/++" highlight tabs and trailing spaces+set listchars=tab:‗‗,trail:‗+set list++" f2 runs hasktags+map <F2> :exec ":!hasktags -x -c --ignore src"<CR><CR>++" strip trailing whitespace before saving+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()++" rebuild hasktags after saving+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 2013 Benno Fünfstück++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,6 @@+hcltest+====================++[](http://travis-ci.org/bennofs/hcltest)++
+ Setup.hs view
@@ -0,0 +1,43 @@+#!/usr/bin/runhaskell+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++import Data.List ( nub )+import Data.Version ( showVersion )+import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )+import Distribution.Simple.BuildPaths ( autogenModulesDir )+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )+import Distribution.Verbosity ( Verbosity )+import System.FilePath ( (</>) )++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+ { buildHook = \pkg lbi hooks flags -> do+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi+ buildHook simpleUserHooks pkg lbi hooks flags+ }++generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()+generateBuildModule verbosity pkg lbi = do+ let dir = autogenModulesDir lbi+ createDirectoryIfMissingVerbose verbosity True dir+ withLibLBI pkg lbi $ \_ libcfg -> do+ withTestLBI pkg lbi $ \suite suitecfg -> do+ rewriteFile (map fixchar $ dir </> "Build_" ++ testName suite ++ ".hs") $ unlines+ [ "module Build_" ++ testName suite ++ " where"+ , "deps :: [String]"+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))+ ]+ where+ formatdeps = map (formatone . snd)+ formatone p = case packageName p of+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)+ fixchar '-' = '_'+ fixchar a = a++testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
+ hcltest.cabal view
@@ -0,0 +1,77 @@+name: hcltest+version: 0.1+license: BSD3+cabal-version: >= 1.10+license-file: LICENSE+author: Benno Fünfstück+maintainer: Benno Fünfstück <benno.fuenfstueck@gmail.com>+stability: experimental+homepage: http://github.com/bennofs/hcltest/+bug-reports: http://github.com/bennofs/hcltest/issues+copyright: Copyright (C) 2013 Benno Fünfstück+synopsis: A testing library for command line applications.+description: Allows to write tests for command line applications using haskell.+category: Testing +build-type: Custom++extra-source-files:+ .ghci+ .gitignore+ .travis.yml+ .vim.custom+ README.md++source-repository head+ type: git+ location: git://github.com/bennofs/hcltest.git++library+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >= 4.4 && < 5+ , bytestring+ , text+ , free+ , process+ , filepath+ , transformers >= 0.1.3.0+ , either+ , directory+ , dlist+ , temporary+ , mtl+ , lens+ , tasty+ , tagged+ , mmorph+ , random-shuffle+ , split+ , stm+ , optparse-applicative+ , monad-control+ , lifted-base+ , transformers-base+ , concurrent-extra+ exposed-modules:+ Test.HClTest+ Test.HClTest.Program+ Test.HClTest.Monad+ Test.HClTest.Setup+ Test.HClTest.Trace+ Test.Tasty.HClTest++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ default-language: Haskell2010+ build-depends:+ base+ , directory >= 1.0+ , doctest >= 0.9.1+ , filepath+ ghc-options: -Wall -threaded+ if impl(ghc<7.6.1)+ ghc-options: -Werror+ hs-source-dirs: tests
+ src/Test/HClTest.hs view
@@ -0,0 +1,9 @@+module Test.HClTest+ ( module X+ ) where++import Test.HClTest.Monad as X (Config(), HClTest())+import Test.HClTest.Monad as X hiding (wdLock, timeoutFactor, Config, HClTest)+import Test.HClTest.Program as X+import Test.HClTest.Setup as X+import Test.HClTest.Trace as X
+ src/Test/HClTest/Monad.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+-- | This module defines the basic test type, HClTest, which is a monad. It also provides functions+-- for creating and running tests. +module Test.HClTest.Monad+ ( HClTest(..)+ , Config(..)+ , runHClTest+ , runHClTestTrace+ , failTest+ , testStep+ , traceMsg+ , testIO+ , randomParallel+ , withWorkingDirectory+ , timeoutFactor+ , wdLock+ ) where++import Control.Applicative+import Control.Concurrent+import qualified Control.Concurrent.RLock as RLock+import Control.Concurrent.STM+import Control.Exception.Lifted+import Control.Lens+import Control.Monad.Base+import Control.Monad.IO.Class+import Control.Monad.Morph+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Maybe+import Control.Monad.Writer+import qualified Data.DList as DL+import Data.Foldable (for_)+import Data.List+import Data.List.Split+import System.Directory+import System.FilePath+import System.IO.Temp+import System.Random.Shuffle+import Test.HClTest.Trace++-- | The config is passed in a Reader to the test cases. +data Config = Config + { _wdLock :: RLock.RLock+ , _timeoutFactor :: Double+ }+makeLenses ''Config++-- | The HClTest monad. A HClTest action describes a single test case. The first argument is the type+-- of the trace entries. For tests, this should be 'Trace'. For a single test step, this should be 'String'.+newtype HClTest w a = HClTest { unHClTest :: ReaderT Config (MaybeT (WriterT (DL.DList w) IO)) a } deriving (Functor, Applicative, Monad, MonadIO, MonadPlus, Alternative, MonadReader Config)++instance MonadBase IO (HClTest w) where+ liftBase = liftIO++instance MonadBaseControl IO (HClTest w) where+ data StM (HClTest w) a = HClTestSt { unHClTestSt :: StM (ReaderT Config (MaybeT (WriterT (DL.DList w) IO))) a }+ liftBaseWith f = HClTest $ liftBaseWith (\k -> f (fmap HClTestSt . k . unHClTest ))+ restoreM = HClTest . restoreM . unHClTestSt+ ++-- | Run a HClTest. The first argument is the timeout for waiting for output+-- of the process, in milliseconds. The second argument is the test case.+--+-- This will run the test in a temporary working directory. Use the functions+-- in Test.HClTest.Setup to setup the environment.+runHClTestTrace :: Double -> HClTest Trace () -> IO (Bool, DL.DList Trace)+runHClTestTrace tf (HClTest a) = runWriterT $ do++ pwd <- liftIO getCurrentDirectory+ tmp <- liftIO $ getTemporaryDirectory >>= flip createTempDirectory "hcltest"+ liftIO $ setCurrentDirectory tmp+ tell $ pure $ Trace "Change to temporary directory" ["Working directory is now: " ++ tmp ++ "\n"]++ wdLockVar <- liftIO RLock.new+ s <- has _Just <$> runMaybeT (runReaderT a $ Config wdLockVar tf)+ ++ when s $ liftIO $ removeDirectoryRecursive tmp+ tell $ pure $ Trace (if s then "Removed temporary directory" else "Temporary directory not removed") []++ liftIO $ setCurrentDirectory pwd+ return s++-- | Like runHClTestTrace, but already shows the trace so that you get a string.+runHClTest :: Double -> HClTest Trace () -> IO (Bool,String)+runHClTest tf a = runHClTestTrace tf a & mapped._2 %~ unlines . map showTrace . DL.toList+ +-- | This is a HClTest action that always fails. The first argument is the trace to leave.+-- If you want to fail without leaving a trace, you can just use 'mzero'.+failTest :: a -> HClTest a b+failTest x = traceMsg x *> HClTest mzero++-- | Add a message to the log.+traceMsg :: a -> HClTest a ()+traceMsg = HClTest . tell . pure++-- | Run an IO action, and fail if that action returns false. The first argument+-- is a description of the IO action which will be used for the trace messages.+testIO :: String -> IO Bool -> HClTest Trace ()+testIO desc action = testStep ("Test :: " ++ desc) $ do+ success <- liftIO action+ unless success $ failTest "Failed" ++-- | A single test step. The first argument is a description of the step. The test step+-- can produce trace messages of type 'String'. Those will be collected an exactly one+-- 'Trace' will be emitted.+testStep :: String -> HClTest String a -> HClTest Trace a+testStep desc (HClTest action) = HClTest $ hoist (hoist k) action+ where k :: (Functor m, Monad m) => WriterT (DL.DList String) m a -> WriterT (DL.DList Trace) m a+ k a = do+ (b,w) <- lift $ runWriterT a+ b <$ tell (pure $ Trace desc $ DL.toList w)++-- | Run a number of tests in parallel, in random order. The first argument is the number of threads+-- to use. Note that if the test cases require different working directories, some of the threads+-- may block.+randomParallel :: Int -> [HClTest Trace ()] -> HClTest Trace ()+randomParallel n tests = do++ testsShuffled <- liftIO $ shuffleM tests+ let workLoads = transpose $ chunksOf n testsShuffled++ settings <- ask++ resultVar <- liftIO $ newTVarIO (mempty,mempty)+ nfinishedVar <- liftIO $ newTVarIO n+ liftIO $ for_ workLoads $ \workLoad -> forkIO $ do+ void $ runMaybeT $ for_ workLoad $ \test -> do+ (c,_) <- liftIO $ readTVarIO resultVar+ guard $ getAll c + (s,t) <- liftIO $ runWriterT $ fmap (has _Just) $ runMaybeT $ flip runReaderT settings $ unHClTest test+ liftIO $ atomically $ modifyTVar' resultVar (<> (All s,t))+ liftIO $ atomically $ modifyTVar' nfinishedVar pred+ + liftIO $ atomically $ readTVar nfinishedVar >>= check . (== 0)+ (success, trac) <- liftIO $ readTVarIO resultVar+ + HClTest $ tell trac+ guard $ getAll success ++-- | Run a test in the given directory.+withWorkingDirectory :: FilePath -> HClTest Trace a -> HClTest Trace a+withWorkingDirectory path a = do+ pwd <- liftIO getCurrentDirectory+ lock <- view wdLock+ liftIO $ RLock.acquire lock+ liftIO $ setCurrentDirectory path+ traceMsg $ Trace "Change working directory" ["Working directory is now: " ++ show (pwd </> path) ++ "\n"]+ a `finally` liftIO (setCurrentDirectory pwd >> RLock.release lock)
+ src/Test/HClTest/Program.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor #-}+-- | In this module there are functions for creating test cases that run+-- programs. It also provides functions for running programs that require input.+module Test.HClTest.Program+ ( Stream(..)+ , Driver(), runDriver+ , expect+ , expectEOF+ , send+ , testInteractive+ , testStdout+ , testExitCode+ ) where++import Control.Applicative+import Control.Lens+import Control.Monad+import Control.Monad.Free+import Control.Monad.Trans.Either+import Control.Monad.Writer+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Maybe+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import System.Exit+import System.IO+import System.Process+import System.Timeout+import Test.HClTest.Monad+import Test.HClTest.Trace++-- | A output stream. +data Stream = Stdout | Stderr deriving Show++-- | This is the functor from which the free monad Driver is generated. +-- It is an enumeration of possible primitive operations possible in the Driver monad.+data DriverF a = MatchStream Stream T.Text a+ | SendInput T.Text a+ | ExpectEOF Stream a+ deriving Functor++-- | The driver monad. The driver monad is used to run programs that require input. It allows+-- you to specify a "script" of actions, like "send input" or "expect output".+type Driver = Free DriverF++-- | Send some text to the process. The text will be encoded as UTF-8.+send :: T.Text -> Driver ()+send = liftF . flip SendInput ()++-- | Check that the process outputs the given text on the given output stream. This only+-- matches a prefix, so it also succeeds if the process produces more output. If you want+-- to check that this is the only output, use expectEOF.+expect :: Stream -> T.Text -> Driver ()+expect s = liftF . flip (MatchStream s) ()++-- | Check that the process' output ended.+expectEOF :: Stream -> Driver ()+expectEOF = liftF . flip ExpectEOF ()+ +-- | Run a driver. The first argument is the timeout for waiting for output of the process.+-- The second argument are handles to stdin, stdout and stderr of the process. The third+-- argument is the driver to run. This produces a test step.+runDriver :: Int -> (Handle, Handle, Handle) -> Driver a -> HClTest String a+runDriver time (stdinH,stdoutH,stderrH) = iterM interpret+ where interpret :: DriverF (HClTest String a) -> HClTest String a+ interpret (SendInput str next) = do+ liftIO $ do+ BS.hPut stdinH $ T.encodeUtf8 str+ hFlush stdinH+ traceMsg $ T.unpack $ ">>> " <> str+ next++ interpret (MatchStream s str next) = do+ let enc = T.encodeUtf8 str+ i <- liftIO $ tryGetTimeout (streamH s) time $ BS.length enc+ case i of+ Left (eof,part)+ | eof -> matchFailure str part "<EOF>" "Output was too short."+ | otherwise -> matchFailure str part "<Timeout>" "Response timount exceeded"+ Right full -> do+ unless (T.decodeUtf8 full == str) $ matchFailure str full "" "Output didn't match"+ traceMsg $ T.unpack $ T.decodeUtf8 full+ return ()+ next++ interpret (ExpectEOF s next) = do+ eof <- liftIO $ hIsEOF (streamH s)+ unless eof $ failTest $ unlines+ [ "- Output too long -"+ , "Stream: " ++ show s+ ]+ next++ streamH :: Stream -> Handle+ streamH Stderr = stderrH+ streamH Stdout = stdoutH++ matchFailure :: T.Text -> ByteString -> T.Text -> T.Text -> HClTest String a+ matchFailure ex got e desc = failTest $ T.unpack $ T.unlines + [ "- Match failure -"+ , "Expected: " <> ex+ , "Got: " <> T.decodeUtf8 got <> e+ , desc+ ]++-- | Try to read a number of bytes from the given handle, but fail if a timeout is reached.+-- The second argument is the timeout, the third is the number of bytes to read.+tryGetTimeout :: Handle -> Int -> Int -> IO (Either (Bool,BS.ByteString) BS.ByteString)+tryGetTimeout h time m = runEitherT $ do+ eof <- lift (hIsEOF h)+ when eof $ left (True,BS.empty)+ + hasInput <- lift $ hWaitForInput h time+ unless hasInput $ left (False,BS.empty)+ + inp <- lift $ BS.hGetNonBlocking h m+ if BS.length inp < m+ then do+ n <- lift $ tryGetTimeout h time $ m - BS.length inp+ either left right $ n & _Left._2 %~ mappend inp+ else return inp++-- | Read all available data from a handle. The first argument is a timeout for waiting for output. +-- If the process outputs nothing for more than timeout milliseconds, that is considered end of output.+hReadAvailable :: Int -> Handle -> IO BS.ByteString+hReadAvailable time h = do+ eof <- hIsEOF h+ if eof+ then return BS.empty+ else do+ hasInput <- hWaitForInput h time+ if hasInput+ then do+ c <- BS.hGetNonBlocking h 1024+ mappend c <$> hReadAvailable time h+ else return BS.empty++-- | Make a test step for an interactive program. The first argument is either the working directory+-- or Nothing, which doesn't change the working directory. The second argument is the timeout in seconds +-- for waiting for output of the process. The third argument is the executable file. The forth argument+-- are the arguments for the executable and the fifth is the driver to use. The driver should return+-- the expected exit code.+testInteractive :: Maybe FilePath -> Int -> FilePath -> [String] -> Driver ExitCode -> HClTest Trace ()+testInteractive wd time prog args driver = do++ let cmdline = prog ++ " " ++ unwords args+ (Just stdinH, Just stdoutH, Just stderrH, p) <- liftIO $ createProcess (proc prog args)+ { std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ , cwd = wd+ }++ testStep ("Run command :: " ++ cmdline ++ maybe "" (\x -> " [WD: " ++ x ++ "]") wd) $ do ++ exitCode <- runDriver time (stdinH,stdoutH,stderrH) driver++ liftIO $ hClose stdinH+ out <- liftIO $ hReadAvailable time stdoutH+ err <- liftIO $ hReadAvailable time stderrH+ traceMsg $ T.unpack $ T.decodeUtf8 out+ traceMsg $ T.unpack $ T.decodeUtf8 err+ + exitCode' <- liftIO $ timeout (time * 1000) $ waitForProcess p+ liftIO $ when (isNothing exitCode') $ terminateProcess p + + case exitCode' of+ Nothing -> failTest "- Process didn't exit -\n"+ Just exitCode'' -> + unless (exitCode'' == exitCode) $ failTest $ unlines+ [ "- Exit code didn't match - "+ , "Expected: " ++ show exitCode+ , "Got: " ++ show exitCode''+ ]++ return ()++-- | A restricted form of testInteractive that Only tests that the process produces the given output on stderr, and no more. See +-- 'testInteractive' for a description of the arguments.+testStdout :: Maybe FilePath -> Int -> FilePath -> [String] -> ExitCode -> T.Text -> HClTest Trace ()+testStdout wd time prog args exit out = testInteractive wd time prog args $ exit <$ expect Stdout out <* expectEOF Stdout++-- | A restricted form of testInteractive that only tests that the process exits with the given exit code.+-- See 'testInteractive' for a description of the arguments.+testExitCode :: Maybe FilePath -> Int -> FilePath -> [String] -> ExitCode -> HClTest Trace ()+testExitCode wd time prog args = testInteractive wd time prog args . return
+ src/Test/HClTest/Setup.hs view
@@ -0,0 +1,28 @@+module Test.HClTest.Setup + ( copyFiles+ , copyFilesHere+ ) where++import Control.Monad (foldM)+import Data.Foldable (for_)+import System.Directory+import System.FilePath++-- | partitionM is to partition like filterM is to filter.+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a])+partitionM f = flip foldM ([],[]) $ \(a,b) x -> do+ v <- f x+ return $ if v then (x:a,b) else (a,x:b)++-- | @copyFiles source target@ copies all the files in the @source@ directory to the directory @target@.+copyFiles :: FilePath -> FilePath -> IO ()+copyFiles source target = do+ (files,dirs) <- partitionM (doesFileExist . (source </>)) . filter (not . (`elem` [".",".."])) =<< getDirectoryContents source+ for_ files $ \file -> copyFile (source </> file) $ target </> file+ for_ dirs $ \dir -> do+ createDirectory $ target </> dir+ copyFiles (source </> dir) $ target </> dir++-- | @copyFilesHere source@ copies all the files from source to the current directory.+copyFilesHere :: FilePath -> IO ()+copyFilesHere = flip copyFiles "."
+ src/Test/HClTest/Trace.hs view
@@ -0,0 +1,16 @@+-- | A Trace is a log entry for a single test step.+module Test.HClTest.Trace+ ( Trace(..)+ , showTrace+ ) where++-- | A trace has a step description and some messages produced by that step in it.+data Trace = Trace+ { stepDescription :: String+ , messages :: [String]+ }+ +-- | Pretty print a trace. +showTrace :: Trace -> String+showTrace (Trace desc msgs) = concat $ header : msgs+ where header = "::: " ++ desc ++ "\n"
+ src/Test/Tasty/HClTest.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++-- | This module provides support for running hcltest cases using tasty.+module Test.Tasty.HClTest + ( hcltest+ , module X+ ) where++import Data.Proxy+import Data.Typeable+import Options.Applicative+import Test.HClTest as X+import Test.Tasty.Options+import Test.Tasty.Providers++newtype HClTasty = HClTasty (HClTest Trace ()) deriving Typeable++-- | Factor to apply to the test timeout. +newtype HClTestTimeoutFactor = HClTestTimeoutFactor Double deriving (Typeable, Ord, Num, Eq, Real)+instance IsOption HClTestTimeoutFactor where+ defaultValue = 1+ parseValue = fmap HClTestTimeoutFactor . safeRead+ optionName = return "hcltest-timeout-factor"+ optionHelp = return "If you set this value, all timeouts specified by the tests will get multiplied by it.\+ \This is useful to run tests made for a faster computer on a slower computer."++newtype HClTestSuccessLog = HClTestSuccessLog Bool deriving (Typeable)+instance IsOption HClTestSuccessLog where+ defaultValue = HClTestSuccessLog False+ parseValue = const $ return $ HClTestSuccessLog True+ optionName = return "hcltest-success-log"+ optionHelp = return "Also print the log when the test succeeded"+ optionCLParser = HClTestSuccessLog <$> switch (long "hcltest-success-log" <> help "Also print the log when the test succeeded")+ +instance IsTest HClTasty where+ testOptions = return+ [ Option (Proxy :: Proxy HClTestTimeoutFactor)+ , Option (Proxy :: Proxy HClTestSuccessLog)+ ]++ run opts (HClTasty t) _ = fmap toResult $ runHClTest factor t+ where HClTestTimeoutFactor factor = lookupOption opts+ HClTestSuccessLog sl = lookupOption opts+ toResult (True,l) = Result True $ if sl then l else ""+ toResult (False,l) = Result False l++-- | Make a new test case with the given name using a HClTest for testing.+hcltest :: TestName -> HClTest Trace () -> TestTree+hcltest n = singleTest n . HClTasty
+ tests/doctests.hsc view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- Copyright : (C) 2012-13 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability : provisional+-- Portability : portable+--+-- This module provides doctests for a project based on the actual versions+-- of the packages it was built with. It requires a corresponding Setup.lhs+-- to be added to the project+-----------------------------------------------------------------------------+module Main where++import Build_doctests (deps)+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++##ifdef mingw32_HOST_ARCH+##ifdef i386_HOST_ARCH+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##elif defined(x86_64_HOST_ARCH)+##define USE_CP+import Control.Applicative+import Control.Exception+import Foreign.C.Types+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt+##endif+##endif++-- | Run in a modified codepage where we can print UTF-8 values on Windows.+withUnicode :: IO a -> IO a+##ifdef USE_CP+withUnicode m = do+ cp <- c_GetConsoleCP+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp+##else+withUnicode m = m+##endif++main :: IO ()+main = withUnicode $ getSources >>= \sources -> doctest $+ "-isrc"+ : "-idist/build/autogen"+ : "-optP-include"+ : "-optPdist/build/autogen/cabal_macros.h"+ : "-hide-all-packages"+ : map ("-package="++) deps ++ sources++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c