diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2012-2014, John P. Feltz +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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT OWNER 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ide-format/Main.hs b/ide-format/Main.hs new file mode 100644 --- /dev/null +++ b/ide-format/Main.hs @@ -0,0 +1,99 @@ +-- TODO verbosity options +-- FIXME atm this parser is VERY brittle, please email me if there are any +-- issues -J +module Main where +import System.IO +import System.Posix.IO +import Data.List +import Data.Either +import Text.Parsec.String (Parser) +import Prelude hiding (fail) +import Control.Applicative ((<*>),(<$>)) +import Data.String.Indent (indent) + +import Text.Parsec.Prim (parse, try, (<|>), many) +import Text.Parsec.Combinator (optionMaybe, count, many1, choice) +import Text.Parsec.Char (alphaNum, char, string, noneOf) +import Text.Parsec.Extra ( natural, eol, whitespace ) +import qualified Filesystem.Path.CurrentOS as FS +import Prelude hiding (FilePath) + +data Success = Success { successMsg :: String } deriving Show +data Failure = Failure { line :: Int, failureMsg :: String } deriving Show +data Test = Test { test :: String, result :: Either Failure Success } + deriving Show +data File = File { filepath :: FS.FilePath, tests :: [Test] } deriving Show + +fromResult :: FS.FilePath -> Test -> String +fromResult fp (Test t (Left (Failure l msg))) = + FS.encodeString fp ++ '|':show l ++ " error | " ++ t ++ '\n':indent 1 msg +fromResult _ (Test t (Right (Success msg))) = + t ++ "\n " ++ msg + +fromFile :: File -> String +fromFile f = + let (failures, successes) = partition failed (tests f) in + (++) (intercalate "\n" $ map toString failures) + ('\n': fromSuccesses successes) + where + failed :: Test -> Bool + failed (Test _ (Left (Failure _ _))) = True + failed (Test _ (Right (Success _))) = False + + toString :: Test -> String + toString = fromResult (filepath f) + + fromSuccesses :: [Test] -> String + fromSuccesses [] = [] + fromSuccesses list = FS.encodeString (filepath f) ++ " successes: \n" ++ + indent 2 (concatMap toString list) + +pathLine :: Parser FS.FilePath +pathLine = do + count 2 whitespace + non_ext <- many1 $ noneOf ".\SP\n\r" + ext <- string ".hs" + eol + return . FS.decodeString $ non_ext ++ ext + +messages :: Parser [String] +messages = do + count 6 whitespace + content <- many $ noneOf "\n\r" + many1 eol + rest <- optionMaybe (try messages) + return $ maybe [content] (content:) rest + +testP :: Parser Test +testP = do + count 4 whitespace + l <- natural + char ':' + whitespace + string "prop_" + prop_name <- many1 (alphaNum <|> char '_') + char ':' + many1 whitespace ; f <- status prop_name l ; eol + f . unlines <$> messages + where + status :: String -> Int -> Parser (String -> Test) + status prop_name l = do + lit <- choice $ map string ["OK", "FAIL"] + return $ + Test prop_name . + if lit == "OK" then Right . Success else Left . Failure l + +parser :: Parser [File] +parser = do + string "modules" + eol + many1 (File <$> pathLine <*> many1 (try testP)) + +parseResults :: String -> String +parseResults runner_output = + case parse parser "tasty consoleRunner output" runner_output of + Left errors -> show errors + Right files -> (intercalate "\n" . map fromFile $ files) ++ "\n" + +main :: IO () +main = fdToHandle stdInput >>= hGetContents >>= putStr . parseResults diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,180 @@ +-- FIXME reconcile issues with reports +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-orphans -fno-warn-unused-binds -fno-warn-unused-do-bind #-} +{-# LANGUAGE DeriveDataTypeable #-} + +import System.Console.CmdArgs hiding (ignore) +import System.Environment +import Control.Monad.Trans.Either + +import Control.Monad.IO.Class + +import qualified System.Console.CmdArgs.Explicit as Exp +import qualified Data.List as L +import qualified Data.Suite as S + +import qualified Data.Integrated as I +import qualified Data.Integrated.IOState as IOS +import Control.Monad.State +import Control.Lens +import qualified Filesystem.Path.CurrentOS as FS +import Prelude hiding (FilePath) +import Data.Aeson hiding (json) +import Data.AesonData +import Data.Suite.Ops +import Data.Integrated.TestModule (Map) +import qualified Data.Map as M +import Data.ModulePath +import Data.Property +import Data.String.Indent +import qualified Data.Suite as Su +import qualified Data.ByteString.Lazy.Char8 as BS + +data Args = + Args { + json :: Maybe String, + masking :: Bool, + ignore :: Bool, + suite :: String, + tests :: [String] + } deriving (Show, Data, Typeable) + +integration = + let + description = + "This program set-combines quickcheck property-containing modules with " + ++ "an IDE parsable test harness." + in + Args { + json = + def + -- &= typ "json file path" + &= help "generate a report of operations on the target suite in JSON" + &= opt "" + , masking = + def &= help "keep existing tests in suite not part of sync" + , ignore = + def &= help "ignore test file parse failures (only parsed will be set-combined)" + , suite = + def &= typ "" &= argPos 0 + , tests = + [] &= args &= typ "files/dirs" + } &= help "The tasty suite file integrator" + &= program "tasty-integrate" + &= summary "tasty-integrate v0.0 (C) John P. Feltz" + &= details [description] + &= verbosity + +fromArgs :: Args -> EitherT String IO I.Integrated +fromArgs a = + if (L.null . tests) a then + left "no tests provided" + else do + fs_state <- liftIO $ IOS.toState (tests a) (suite a) + integrated <- + liftIO $ do + (maybe_integrated, errors) <- runStateT (ranState fs_state) [] + putStr $ L.intercalate "\n" $ map show errors + return maybe_integrated + maybe (left "\n\nHalted due to errors.") right integrated + where + fromIgnore :: Bool -> I.ErrorObservance + fromIgnore True = I.Ignored + fromIgnore _ = I.Dependent + + ranState = I.toIntegrated (fromIgnore $ ignore a) (masking a) + +fromIntegrated :: Maybe Verbosity -> Maybe String -> I.Integrated -> IO () +fromIntegrated v j i = do + ops <- I.fromIntegrated (S.toBuf S.tastyImports) i + let (suite_fp, original_suite) = view I.suiteFile i + -- Print the summary + putStrLn ('\n': toSummary original_suite suite_fp ops v) + -- Write json to console or fileput if necessary + maybe (return ()) (writeJson suite_fp ops) j + where + writeJson :: FS.FilePath -> Ops -> String -> IO () + writeJson suite_fp ops p = + if L.null p then putStr "\n" >> putStrLn encoded else writeFile p encoded + where + encoded :: String + encoded = BS.unpack . encode $ AesonData ops suite_fp + +fromProps :: [Property] -> String +fromProps [] = "none" +fromProps non_empty = L.intercalate "\n" . map func $ non_empty + +toModuleListing :: Map -> String +toModuleListing m = + if M.null m then " none" else + L.intercalate "\n" . map (uncurry fromMod) . M.toList . M.map snd $ m + where + fromMod :: ModulePath -> [Property] -> String + fromMod mp props = show mp ++ '\n':indent 1 (fromProps props) + +toNumericListing :: Map -> String +toNumericListing m = + if M.null m then + "none" + else + indent 1 + (L.intercalate "\n" . map (uncurry fromMod) . M.toList . M.map snd $ m) + where + fromMod :: ModulePath -> [Property] -> String + fromMod mp props = + show mp ++ ", " ++ (show . L.length $ props) ++ " property(s)" + +toSummary :: Su.Suite -> FS.FilePath -> Ops -> Maybe Verbosity -> String +toSummary _ _ _ (Just Quiet) = "" +toSummary s fp ops (Just Loud) = fromOriginal toModuleListing s fp ops ++ "\n" +toSummary s fp ops _ = fromOriginal toNumericListing s fp ops ++ "\n" + +fromOps :: (Map -> String) -> Ops -> String +fromOps f ops = + L.intercalate "\n" $ + map (\(label, l) -> label ++ ": \n" ++ indent 1 (f . view l $ ops)) [ + ("added", added), + ("removed", removed), + ("modified", modified), + ("unmodified", unmodified) + ] + +fromOriginal :: (Map -> String) -> Su.Suite -> FS.FilePath -> Ops -> String +fromOriginal f Su.Uncreated suite_fp ops = + if not . M.null $ view added ops then + "(created) suite at: " ++ FS.encodeString suite_fp ++ "\n" + ++ "with: \n" ++ indent 1 (f (view added ops)) + else + "no suite created" +fromOriginal f (Su.Suite _) suite_fp ops = + if mutation then + "(changed) suite at: " ++ FS.encodeString suite_fp ++ "\n" + ++ "with: \n" ++ indent 1 (fromOps f ops) + else + "(unchanged) suite at: " ++ FS.encodeString suite_fp + where + mutation = + any (not . M.null . ($ ops) . view) [added, removed, modified] + +main :: IO () +main = do + env_args <- getArgs + + case Exp.process (cmdArgsMode integration) env_args of + Right parsed_args -> + case cmdArgsHelp parsed_args of + (Just h) -> putStr h + Nothing -> + let + program_args = cmdArgsValue parsed_args + v = cmdArgsVerbosity parsed_args + in do + result <- runEitherT . fromArgs $ program_args + case result of + Left e -> + dispatchHelp e + Right i -> + fromIntegrated v (json program_args) i + Left err -> dispatchHelp err + where + dispatchHelp :: String -> IO () + dispatchHelp err = putStr $ err ++ "\n " ++ "(--help for assistance)\n" diff --git a/tasty-integrate.cabal b/tasty-integrate.cabal new file mode 100644 --- /dev/null +++ b/tasty-integrate.cabal @@ -0,0 +1,102 @@ +name: tasty-integrate +version: 0.0.1 +license: BSD3 +license-file: LICENSE +author: John P. Feltz +maintainer: jfeltz@gmail.com +category: Testing +build-type: Simple +cabal-version: >=1.8 +synopsis: automated integration of QuickCheck properties into tasty suites +description: + This brings automated test-suite creation (such as what naturally + occurs in Eclipse) to the Haskell world. This is a set of programs to automate + the otherwise manual editing needed to combine new tests (QuickCheck) into + test-groupings (tasty test framework). + . + Given a set of Modules containing properties: + . + > $ ls tests/Data/* + > QcIntegrated.hs QcModulePath.hs QcSuite.hs + . + Example use on a suite already importing the Modules above: + . + > $ tasty-integrate --masking test-suites/Suites.hs tests/Data/QcIntegrated.hs + > (changed) suite at: test-suites/Suite.hs + > with: + > added: + > none + > removed: + > Data.QcModulePath, 2 property(s) + > Data.QcSuite, 1 property(s) + > modified: + > none + > unmodified: + > Data.QcIntegrated, 3 property(s) + . + The created suites are IDE parsable, and errors can resolve to their original file. + So using the provided ide-format program from this package: + . + > $ ./build/dist/suite/suite | ide-format + > tests/Data/QcSuite.hs|20 error | buf_isomorphism + > *** Failed! Falsifiable (after 1 test): + +executable ide-format + main-is: Main.hs + build-depends: base >=4.5 && <=4.6.0.1, + unix, + parsec >= 3.1.5, + system-filepath >= 0.4.9, + text + hs-source-dirs: ide-format, src + +executable tasty-integrate + main-is: Main.hs + build-depends: base >=4.5 && <=4.6.0.1, + containers, + transformers, + directory, + cmdargs == 0.10.2, + system-filepath >= 0.4.6, + language-haskell-extract, + haskell-src-exts, + regex-posix, + split, + mtl, + text, + either, + lens, + aeson == 0.6.2.1, + bytestring == 0.10.2.0, + tasty == 0.7, + tasty-quickcheck + + ghc-options: -Wall -rtsopts + hs-source-dirs: src + +test-suite suite + type: exitcode-stdio-1.0 + buildable: True + build-depends: base >=4.5 && <=4.6.0.1, + deepseq == 1.3.0.1, + stm == 2.4.2, + QuickCheck == 2.6, + tasty == 0.7, + tasty-quickcheck, + containers, + transformers, + directory, + system-filepath >= 0.4.6, + quickcheck-property-comb, + stringbuilder, + lens, + mtl, + split, + text, + regex-posix, + haskell-src-exts, + bytestring == 0.10.2.0 + + ghc-options: -Wall -rtsopts -fno-warn-unused-do-bind + hs-source-dirs: tests, src, test-suites + main-is: Suite.hs diff --git a/test-suites/Suite.hs b/test-suites/Suite.hs new file mode 100644 --- /dev/null +++ b/test-suites/Suite.hs @@ -0,0 +1,25 @@ +-- WARNING: This file is generated by tasty-integrate +-- Changes made will (probably) not be saved, see documentation. +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Main where +import qualified Data.QcIntegrated + (prop_toPartition, prop_fromPartition, + prop_fromTestpath_isomorphism) +import qualified Data.QcSuite (prop_buf_isomorphism) +import Test.Tasty +import Test.Tasty.QuickCheck + +main :: IO () +main + = defaultMain + (testGroup "modules" + [testGroup "tests/Data/QcIntegrated.hs" + [testProperty "42: prop_toPartition" + Data.QcIntegrated.prop_toPartition, + testProperty "186: prop_fromPartition" + Data.QcIntegrated.prop_fromPartition, + testProperty "429: prop_fromTestpath_isomorphism" + Data.QcIntegrated.prop_fromTestpath_isomorphism], + testGroup "tests/Data/QcSuite.hs" + [testProperty "20: prop_buf_isomorphism" + Data.QcSuite.prop_buf_isomorphism]])