diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for inspection-testing +## 0.1.1.1 -- 2017-11-12 + +* Show summary stats +* Pull in less tests, to make inclusion in stackage easier + ## 0.1.1 -- 2017-11-09 * More complete output when `(===)` fails diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -33,8 +33,8 @@ ``` $ ghc Simple.hs [1 of 1] Compiling Simple ( Simple.hs, Simple.o ) -examples/Simple.hs:14:1: inspecting lhs === rhs -Test.Inspection tested 1 obligation +examples/Simple.hs:14:1: lhs === rhs passed. +Test.Inspection tested 1 obligation. ``` See the [`examples/`](examples/) directory for more examples of working proofs. @@ -50,13 +50,23 @@ ``` then the compiler will tell you so, and abort the compilation: ``` -$ ghc Simple.hs -[1 of 1] Compiling Simple ( Simple.hs, Simple.o ) -examples/Simple.hs:20:1: inspecting bad1 === bad2 -Obligation fails - LHS: ghc-prim-0.5.1.0:GHC.Types.I# 4# - RHS: ghc-prim-0.5.1.0:GHC.Types.I# 5# -examples/Simple.hs: error: inspection testing unsuccessful +$ ghc Simple.hs -dsuppress-idinfo +[5 of 5] Compiling Simple ( examples/Simple.hs, examples/Simple.o ) +examples/Simple.hs:14:1: lhs === rhs passed. +examples/Simple.hs:20:1: bad1 === bad2 failed: + LHS: + bad1 :: Int + bad1 = I# 4# + + RHS: + bad2 :: Int + bad2 = I# 5# + + +examples/Simple.hs: error: + inspection testing unsuccessful + expected successes: 1 + unexpected failures: 1 ``` What can I check for? diff --git a/Test/Inspection/Plugin.hs b/Test/Inspection/Plugin.hs --- a/Test/Inspection/Plugin.hs +++ b/Test/Inspection/Plugin.hs @@ -8,8 +8,8 @@ import System.Exit import Data.Either import Data.Maybe -import Data.List -import Data.Bifunctor +import Data.Foldable +import qualified Data.Map.Strict as M import qualified Language.Haskell.TH.Syntax as TH import GhcPlugins hiding (SrcLoc) @@ -54,11 +54,11 @@ findObligationAnn _ = Nothing -prettyObligation :: Module -> Obligation -> String -prettyObligation mod (Obligation {..}) = +prettyObligation :: Module -> Obligation -> String -> String +prettyObligation mod (Obligation {..}) result = maybe "" myPrettySrcLoc srcLoc ++ ": " ++ - "inspecting " ++ prettyProperty mod target property ++ - (if expectFail then " (failure expected)" else "") + prettyProperty mod target property ++ + " " ++ result prettyProperty :: Module -> TH.Name -> Property -> String prettyProperty mod target (EqualTo n2 False) = showTHName mod target ++ " === " ++ showTHName mod n2 @@ -74,27 +74,41 @@ | moduleNameString (moduleName mod) == TH.modString m = TH.occString occ showTHName _ n = show n -checkObligation :: ModGuts -> Obligation -> CoreM Bool +data Stat = ExpSuccess | ExpFailure | UnexpSuccess | UnexpFailure + deriving (Enum, Eq, Ord, Bounded) +type Stats = M.Map Stat Int + +tick :: Stat -> Stats +tick s = M.singleton s 1 + +checkObligation :: ModGuts -> Obligation -> CoreM Stats checkObligation guts obl = do - putMsgS $ prettyObligation (mg_module guts) obl res <- checkProperty guts (target obl) (property obl) case (res, expectFail obl) of -- Property holds (Nothing, False) -> do - return True + putMsgS $ prettyObligation (mg_module guts) obl expSuccess + return (tick ExpSuccess) (Nothing, True) -> do - putMsgS "Obligation passes unexpectedly" - return False + putMsgS $ prettyObligation (mg_module guts) obl unexpSuccess + return (tick UnexpSuccess) -- Property does not hold (Just reportMsg, False) -> do - putMsgS "Obligation fails" + putMsgS $ prettyObligation (mg_module guts) obl unexpFailure reportMsg - return False + return (tick UnexpFailure) (Just _, True) -> do - return True + putMsgS $ prettyObligation (mg_module guts) obl expFailure + return (tick ExpFailure) + where + expSuccess = "passed." + unexpSuccess = "passed unexpectedly!" + unexpFailure = "failed:" + expFailure = "failed expectedly." + type Result = Maybe (CoreM ()) lookupNameInGuts :: ModGuts -> Name -> Maybe (Var, CoreExpr) @@ -166,22 +180,32 @@ warnMsg $ fsep $ map text $ words "Test.Inspection: Compilation without -O detected. Expect optimizations to fail." let (guts', obligations) = extractObligations guts - ok <- and <$> mapM (checkObligation guts') obligations - if ok - then do - let (_m,n) = bimap length length $ partition expectFail obligations - putMsg $ text "Test.Inspection tested" <+> ppr n <+> - text "obligation" <> (if n == 1 then empty else text "s") - else do - case upon_failure of - AbortCompilation -> do - errorMsg $ text "inspection testing unsuccessful" - liftIO $ exitFailure -- kill the compiler. Is there a nicer way? - KeepGoing -> do - warnMsg $ text "inspection testing unsuccessful" + stats <- M.unionsWith (+) <$> mapM (checkObligation guts') obligations + let n = sum stats :: Int + + let error_mesage = nest 2 $ + vcat [ nest 2 (desc s) <> colon <+> ppr n + | s <- [minBound..maxBound] + , Just n <- return $ M.lookup s stats] + + if M.lookup ExpSuccess stats == Just n + then putMsg $ text "Test.Inspection tested" <+> ppr n <+> + text "obligation" <> (if n == 1 then empty else text "s") <> dot + else case upon_failure of + AbortCompilation -> do + errorMsg $ text "inspection testing unsuccessful" $$ error_mesage + liftIO $ exitFailure -- kill the compiler. Is there a nicer way? + KeepGoing -> do + warnMsg $ text "inspection testing unsuccessful" $$ error_mesage + return guts' +desc :: Stat -> SDoc +desc ExpSuccess = text " expected successes" +desc UnexpSuccess = text "unexpected successes" +desc ExpFailure = text " expected failures" +desc UnexpFailure = text " unexpected failures" partitionMaybe :: (a -> Maybe b) -> [a] -> ([a], [b]) partitionMaybe f = partitionEithers . map (\x -> maybe (Left x) Right (f x)) diff --git a/inspection-testing.cabal b/inspection-testing.cabal --- a/inspection-testing.cabal +++ b/inspection-testing.cabal @@ -1,5 +1,5 @@ name: inspection-testing -version: 0.1.1 +version: 0.1.1.1 synopsis: GHC plugin to do inspection testing description: Some carefully crafted libraries make promises to their users beyond functionality and performance. @@ -62,16 +62,6 @@ ghc-options: -main-is NS_NP -test-suite generic-lens - type: exitcode-stdio-1.0 - hs-source-dirs: examples - main-is: GenericLens.hs - build-depends: inspection-testing - build-depends: base >=4.9 && <4.12 - build-depends: generic-lens ==0.4.0.1 - default-language: Haskell2010 - ghc-options: -main-is GenericLens - test-suite simple type: exitcode-stdio-1.0 hs-source-dirs: examples @@ -90,14 +80,34 @@ default-language: Haskell2010 ghc-options: -main-is Fusion +flag more-tests + description: Run tests that pull in specific versions of other packages + default: False + test-suite text type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Text.hs - build-depends: inspection-testing - build-depends: base >=4.9 && <4.12 - build-depends: text ==1.2.2.2 - build-depends: bytestring + if flag(more-tests) + build-depends: inspection-testing + build-depends: base >=4.9 && <4.12 + build-depends: text ==1.2.2.2 + build-depends: bytestring + else + buildable: False default-language: Haskell2010 ghc-options: -main-is Text + +test-suite generic-lens + type: exitcode-stdio-1.0 + hs-source-dirs: examples + main-is: GenericLens.hs + if flag(more-tests) + build-depends: inspection-testing + build-depends: base >=4.9 && <4.12 + build-depends: generic-lens ==0.4.0.1 + else + buildable: False + default-language: Haskell2010 + ghc-options: -main-is GenericLens