inspection-testing 0.1.1 → 0.1.1.1

raw patch · 4 files changed

+100/−51 lines, 4 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• README.md +19/−9
• Test/Inspection/Plugin.hs +51/−27
• inspection-testing.cabal +25/−15

@@ -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

@@ -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?

@@ -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))

@@ -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