diff --git a/.ghci b/.ghci new file mode 100644 --- /dev/null +++ b/.ghci @@ -0,0 +1,1 @@ +:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,15 @@ +dist +docs +wiki +TAGS +tags +wip +.DS_Store +.*.swp +.*.swo +*.o +*.hi +*~ +*# +.cabal-sandbox +cabal.sandbox.config diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/.vim.custom b/.vim.custom new file mode 100644 --- /dev/null +++ b/.vim.custom @@ -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 :exec ":!hasktags -x -c --ignore src" + +" 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" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +hcltest +==================== + +[![Build Status](https://secure.travis-ci.org/bennofs/hcltest.png?branch=master)](http://travis-ci.org/bennofs/hcltest) + + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -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 diff --git a/hcltest.cabal b/hcltest.cabal new file mode 100644 --- /dev/null +++ b/hcltest.cabal @@ -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 +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 diff --git a/src/Test/HClTest.hs b/src/Test/HClTest.hs new file mode 100644 --- /dev/null +++ b/src/Test/HClTest.hs @@ -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 diff --git a/src/Test/HClTest/Monad.hs b/src/Test/HClTest/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Test/HClTest/Monad.hs @@ -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) diff --git a/src/Test/HClTest/Program.hs b/src/Test/HClTest/Program.hs new file mode 100644 --- /dev/null +++ b/src/Test/HClTest/Program.hs @@ -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 "" "Output was too short." + | otherwise -> matchFailure str part "" "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 diff --git a/src/Test/HClTest/Setup.hs b/src/Test/HClTest/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Test/HClTest/Setup.hs @@ -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 "." diff --git a/src/Test/HClTest/Trace.hs b/src/Test/HClTest/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Test/HClTest/Trace.hs @@ -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" diff --git a/src/Test/Tasty/HClTest.hs b/src/Test/Tasty/HClTest.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/HClTest.hs @@ -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 diff --git a/tests/doctests.hsc b/tests/doctests.hsc new file mode 100644 --- /dev/null +++ b/tests/doctests.hsc @@ -0,0 +1,71 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- Copyright : (C) 2012-13 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- Maintainer : Edward Kmett +-- 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