xmonad-contrib/tests/genMain.hs

{-# LANGUAGE ViewPatterns #-}
{- | generate another Main from all modules in the current directory,
extracting all functions with @prop_@.

Usage (your QuickCheck-1 version may vary):

> ln -s ../../xmonad/tests/Properties.hs .
> runghc genMain.hs > Main.hs
> ghc -DTESTING -i.. -i. -package QuickCheck-1.2.0.0 Main.hs -e ':main 200'

-}
module Main where

import Control.Monad.List
import Data.Char
import Data.IORef
import Data.List
import qualified Data.Set as S
import System.Directory
import System.FilePath
import Text.PrettyPrint.HughesPJ

main = do
    imports <- newIORef S.empty
    props <- runListT $ do
        f @ ((isUpper -> True) : (takeExtension -> ".hs"))
            <- ListT (getDirectoryContents ".")
        guard $ f `notElem` ["Main.hs", "Common.hs", "Properties.hs"]
        let b = takeBaseName f
        nesting <- io $ newIORef 0
        decl : _ <- ListT $ (map words . lines) <$> readFile f
        case decl of
            "{-" -> io $ modifyIORef nesting succ
            "-}" -> io $ modifyIORef nesting pred
            _ -> return ()
        0 <- io $ readIORef nesting
        guard $ "prop_" `isPrefixOf` decl
        io $ modifyIORef imports (S.insert b)
        return (b ++ "." ++ decl)
    imports <- S.toList <$> readIORef imports
    print $ genModule imports props

genModule :: [String] -> [String] -> Doc
genModule imports props = vcat [header,imports', main ]
    where
        header = text "module Main where"
        imports' = text "import Test.QuickCheck; import Data.Maybe; \
                            \import System.Environment; import Text.Printf; \
                            \import Properties hiding (main); import Control.Monad"
                $$ vcat [ text "import qualified" <+> text im | im <- imports ]
        props' = [ parens $ doubleQuotes (text p) <> comma <> text "mytest" <+> text p
                            | p <- props ]
        main = hang (text "main = do") 4 $
                    text "n <- maybe (return 100) readIO . listToMaybe =<< getArgs"
                    $$
                    hang (text "let props = ") 8
                        (brackets $ foldr1 (\x xs -> x <> comma $$ xs) props')
                    $$
                    text "(results, passed) <- liftM unzip $ \
                            \mapM (\\(s,a) -> printf \"%-40s: \" s >> a n) props"
                    $$
                    text "printf \"Passed %d tests!\\n\" (sum passed)"
                    $$
                    text "when (any not results) $ fail \"Not all tests passed!\""

io x = liftIO x