inspection-testing 0.4.2.2 → 0.4.2.4
raw patch · 5 files changed
+111/−36 lines, 5 filesdep ~basedep ~ghc
Dependency ranges changed: base, ghc
Files
- ChangeLog.md +10/−0
- examples/WorkerWrapper.hs +35/−0
- inspection-testing.cabal +26/−15
- src/Test/Inspection/Core.hs +30/−19
- src/Test/Inspection/Plugin.hs +10/−2
ChangeLog.md view
@@ -1,5 +1,15 @@ # Revision history for inspection-testing +## 0.4.2.4 -- 2020-01-26++* Now prints the name of the type class on which a test fails, thanks to+ Harendra Kumar+* More examples, thanks to Rafe++## 0.4.2.3 -- 2020-01-26++* Support GHC-8.10, thanks to Ryan Scott via head.hackage for the patch+ ## 0.4.2.1 -- 2019-06-07 * Bugfix release
+ examples/WorkerWrapper.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE TemplateHaskell #-}+module WorkerWrapper (main) where++import Test.Inspection++-- In this module, we are interested in checking if the worker-wrapper transformation is firing.+-- That transformation is described here:+-- https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/demand#worker-wrapper-split+-- In short, we don't want to be passing around the dictionary type below, but rather have GHC+-- generate a helper function @$wdictFold :: (m -> m -> m) -> m -> [m] -> m@, as this saves us some+-- wrapping and unwrapping work at each iteration.+--+-- GHC still generates a wrapper at the @dictFold@ name. That is, a function that still consumes the+-- @MonoidDict@ type, but unwraps it just once, before passing it off to @wdictFold@ to handle the+-- recuresion. As @dictFold@ refers to this wrapper, we cannot check that the @MonoidDict@ type is+-- unused in its definition.+--+-- So what are we to do? As the generated wrapper should have an @INLINE@ pragma, once we pass it in+-- the @MonoidDict@, we should be safely in worker-land, and not need to reference @MonoidDict@+-- again. Thus, we look at @appliedFold@, and assert that @MonoidDict@ never shows up -- as would be+-- expected if worker-wrapper fired as hoped.+data MonoidDict a = MonoidDict { dictMappend :: a -> a -> a, dictMempty :: a }++dictFold :: MonoidDict m -> [m] -> m+dictFold bm xs = case xs of+ [] -> dictMempty bm+ x:xs' -> dictMappend bm x $ dictFold bm xs'++appliedFold :: [Int] -> Int+appliedFold = dictFold $ MonoidDict (+) 0++inspect $ 'appliedFold `doesNotUse` 'MonoidDict++main :: IO ()+main = return ()
inspection-testing.cabal view
@@ -1,5 +1,5 @@ name: inspection-testing-version: 0.4.2.2+version: 0.4.2.4 synopsis: GHC plugin to do inspection testing description: Some carefully crafted libraries make promises to their users beyond functionality and performance.@@ -34,7 +34,7 @@ build-type: Simple extra-source-files: ChangeLog.md, README.md cabal-version: >=1.10-Tested-With: GHC == 8.0.2, GHC == 8.2.*, GHC == 8.4.*, GHC ==8.6.*, GHC ==8.8.*+Tested-With: GHC == 8.0.2, GHC == 8.2.*, GHC == 8.4.*, GHC ==8.6.*, GHC ==8.8.*, GHC ==8.10.* source-repository head type: git@@ -45,8 +45,8 @@ Test.Inspection.Plugin Test.Inspection.Core hs-source-dirs: src- build-depends: base >=4.9 && <4.14- build-depends: ghc >= 8.0.2 && <8.9+ build-depends: base >=4.9 && <4.15+ build-depends: ghc >= 8.0.2 && <8.11 build-depends: template-haskell build-depends: containers build-depends: transformers@@ -59,7 +59,7 @@ hs-source-dirs: examples main-is: NS_NP.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 ghc-options: -main-is NS_NP if impl(ghc < 8.4)@@ -70,7 +70,7 @@ hs-source-dirs: examples main-is: Simple.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 ghc-options: -main-is Simple if impl(ghc < 8.4)@@ -81,7 +81,7 @@ hs-source-dirs: examples main-is: SimpleTest.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin@@ -91,7 +91,7 @@ hs-source-dirs: examples main-is: DoesNotUse.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 ghc-options: -main-is DoesNotUse if impl(ghc < 8.4)@@ -102,7 +102,7 @@ hs-source-dirs: examples main-is: Fusion.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 ghc-options: -main-is Fusion if impl(ghc < 8.4)@@ -113,7 +113,7 @@ hs-source-dirs: examples main-is: Generics.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 ghc-options: -main-is Generics if impl(ghc < 8.4)@@ -124,7 +124,7 @@ hs-source-dirs: examples main-is: Dictionary.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 ghc-options: -main-is Dictionary if impl(ghc < 8.4)@@ -140,7 +140,7 @@ main-is: Text.hs if flag(more-tests) build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 build-depends: text ==1.2.2.2 build-depends: bytestring else@@ -156,7 +156,7 @@ main-is: GenericLens.hs if flag(more-tests) build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 build-depends: generic-lens ==0.4.1.0 else buildable: False@@ -170,7 +170,7 @@ hs-source-dirs: examples main-is: MutualRecursion.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010 ghc-options: -main-is MutualRecursion @@ -179,7 +179,18 @@ hs-source-dirs: examples main-is: Regression.hs build-depends: inspection-testing- build-depends: base >=4.9 && <4.14+ build-depends: base >=4.9 && <4.15 default-language: Haskell2010+ if impl(ghc < 8.4)+ ghc-options: -fplugin=Test.Inspection.Plugin++test-suite worker-wrapper+ type: exitcode-stdio-1.0+ hs-source-dirs: examples+ main-is: WorkerWrapper.hs+ build-depends: inspection-testing+ build-depends: base >=4.9 && <4.15+ default-language: Haskell2010+ ghc-options: -main-is WorkerWrapper if impl(ghc < 8.4) ghc-options: -fplugin=Test.Inspection.Plugin
src/Test/Inspection/Core.hs view
@@ -30,6 +30,7 @@ import qualified Data.Set as S import Control.Monad.State.Strict import Control.Monad.Trans.Maybe+import Data.List (nub) import Data.Maybe type Slice = [(Var, CoreExpr)]@@ -203,39 +204,49 @@ -- | Returns @True@ if the given core expression mentions no type constructor -- anywhere that has the given name. freeOfType :: Slice -> [Name] -> Maybe (Var, CoreExpr)-freeOfType slice tcNs = allTyCons (\tc -> getName tc `notElem` tcNs) slice+freeOfType slice tcNs =+ fmap (\(a,b,_) -> (a,b))+ $ allTyCons (\tc -> getName tc `notElem` tcNs) slice -allTyCons :: (TyCon -> Bool) -> Slice -> Maybe (Var, CoreExpr)-allTyCons predicate slice = listToMaybe [ (v,e) | (v,e) <- slice, not (go e) ]+-- | Check if all type constructors in a slice satisfy the given predicate.+-- Returns the binder, expression and failing constructors triple on failure.+allTyCons :: (TyCon -> Bool) -> Slice -> Maybe (Var, CoreExpr, [TyCon])+allTyCons ignore slice =+ listToMaybe+ [(v, e, nub tcs) | (v, e) <- slice, let tcs = go e, not (null tcs)] where goV v = goT (varType v) go (Var v) = goV v- go (Lit _ ) = True- go (App e a) = go e && go a- go (Lam b e) = goV b && go e- go (Let bind body) = all goB (flattenBinds [bind]) && go body- go (Case s b _ alts) = go s && goV b && all goA alts+ go (Lit _) = []+ go (App e a) = go e ++ go a+ go (Lam b e) = goV b ++ go e+ go (Let bind body) = concatMap goB (flattenBinds [bind]) ++ go body+ go (Case s b _ alts) = go s ++ goV b ++ concatMap goA alts go (Cast e _) = go e go (Tick _ e) = go e go (Type t) = (goT t)- go (Coercion _) = True+ go (Coercion _) = [] - goB (b, e) = goV b && go e+ goB (b, e) = goV b ++ go e - goA (_,pats, e) = all goV pats && go e+ goA (_,pats, e) = concatMap goV pats ++ go e - goT (TyVarTy _) = True- goT (AppTy t1 t2) = goT t1 && goT t2- goT (TyConApp tc ts) = predicate tc && all goT ts- -- ↑ This is the crucial bit+ goT (TyVarTy _) = []+ goT (AppTy t1 t2) = goT t1 ++ goT t2+ goT (TyConApp tc ts) = [tc | not (ignore tc)] ++ concatMap goT ts+ -- ↑ This is the crucial bit goT (ForAllTy _ t) = goT t #if MIN_VERSION_GLASGOW_HASKELL(8,2,0,0)- goT (FunTy t1 t2) = goT t1 && goT t2+ goT (FunTy+# if MIN_VERSION_GLASGOW_HASKELL(8,9,0,0)+ _+# endif+ t1 t2) = goT t1 ++ goT t2 #endif- goT (LitTy _) = True+ goT (LitTy _) = [] goT (CastTy t _) = goT t- goT (CoercionTy _) = True+ goT (CoercionTy _) = [] -- -- | Returns @True@ if the given core expression mentions no term variable -- anywhere that has the given name.@@ -311,6 +322,6 @@ goA a (_,_, e) = go a e -doesNotContainTypeClasses :: Slice -> [Name] -> Maybe (Var, CoreExpr)+doesNotContainTypeClasses :: Slice -> [Name] -> Maybe (Var, CoreExpr, [TyCon]) doesNotContainTypeClasses slice tcNs = allTyCons (\tc -> not (isClassTyCon tc) || any (getName tc ==) tcNs) slice
src/Test/Inspection/Plugin.hs view
@@ -249,7 +249,11 @@ case lookupNameInGuts guts n of Nothing -> pure . ResFailure $ ppr n <+> text "is not a local name" Just (v, _) -> case doesNotContainTypeClasses (slice binds v) ts of- Just (v',e') -> pure . ResFailure $ nest 4 (ppr v' <+> text "=" <+> ppr e')+ Just (v',e',tc) -> pure . ResFailure+ $ nest 4 $ vcat+ [ text "Found type classes: " <+> ppr tc+ , ppr v' <+> text "=" <+> ppr e'+ ] Nothing -> pure ResSuccess where binds = flattenBinds (mg_binds guts) @@ -292,7 +296,11 @@ dflags <- getDynFlags let noopt = optLevel dflags < 1 when noopt $- warnMsg $ fsep $ map text $ words "Test.Inspection: Compilation without -O detected. Expect optimizations to fail."+ warnMsg+#if MIN_VERSION_GLASGOW_HASKELL(8,9,0,0)+ NoReason+#endif+ $ fsep $ map text $ words "Test.Inspection: Compilation without -O detected. Expect optimizations to fail." let (guts', obligations) = extractObligations guts (toStore, stats) <- (concat `bimap` M.unionsWith (+)) . unzip <$>