inspection-testing 0.4.1 → 0.4.1.1

raw patch · 5 files changed

+25/−19 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• examples/DoesNotUse.hs +2/−2
• inspection-testing.cabal +1/−1
• src/Test/Inspection/Core.hs +16/−14
• src/Test/Inspection/Plugin.hs +2/−2

@@ -1,5 +1,9 @@ # Revision history for inspection-testing +## 0.4.1.1 -- 2018-11-17++* Fix a bug with `doesNotUse` and data constructors+ ## 0.4.1 -- 2018-11-17  * New obligation `doesNotUse`

@@ -7,13 +7,13 @@ matches (Just _) = True matches Nothing = False -partial (Just _) = Nothing+partial (Just _) = Left   inspect $ ('matches `doesNotUse` 'Just) { expectFail = True } inspect $ 'matches `doesNotUse` 'patError inspect $ ('partial `doesNotUse` 'patError) { expectFail = True }-inspect $ ('partial `doesNotUse` 'Nothing) { expectFail = True }+inspect $ ('partial `doesNotUse` 'Left) { expectFail = True }  main :: IO () main = return ()

@@ -1,5 +1,5 @@ name:                inspection-testing-version:             0.4.1+version:             0.4.1.1 synopsis:            GHC plugin to do inspection testing description:         Some carefully crafted libraries make promises to their                      users beyond functionality and performance.

@@ -53,7 +53,6 @@     go (Lit _ )                    = pure ()     go (App e arg) | isTyCoArg arg = go e     go (App e arg)                 = go e >> go arg-    go (Lam b e) | isTyVar b       = go e     go (Lam _ e)                   = go e     go (Let bind body)             = mapM_ go (rhssOfBind bind) >> go body     go (Case s _ _ alts)           = go s >> mapM_ goA alts@@ -198,8 +197,8 @@  -- | 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 tcN = allTyCons (\tc -> getName tc /= tcN) slice+freeOfType :: Slice -> [Name] -> Maybe (Var, CoreExpr)+freeOfType slice tcNs = 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) ]@@ -235,29 +234,32 @@ -- -- | Returns @True@ if the given core expression mentions no term variable -- anywhere that has the given name.-freeOfTerm :: Slice -> Name -> Maybe (Var, CoreExpr)-freeOfTerm slice needle = listToMaybe [ (v,e) | (v,e) <- slice, not (go e) ]+freeOfTerm :: Slice -> [Name] -> Maybe (Var, CoreExpr)+freeOfTerm slice needles = listToMaybe [ (v,e) | (v,e) <- slice, not (go e) ]   where-    goV v | Var.varName v == needle = False-          | otherwise               = True+    isNeedle n = n `elem` needles +    goV v | isNeedle (Var.varName v)  = False+          | Just dc <- isDataConId_maybe v+          , isNeedle (dataConName dc) = False+          | otherwise                 = True+     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 (Lam _ e)         = 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 (Case s _ _ alts) = go s && all goA alts     go (Cast e _)        = go e     go (Tick _ e)        = go e     go (Type _)          = True     go (Coercion _)      = True -    goB (b, e) = goV b && go e+    goB (_, e) = go e -    goA (ac,pats, e) = goAltCon ac && all goV pats && go e+    goA (ac, _, e) = goAltCon ac && go e -    goAltCon (DataAlt dc) | dataConName dc == needle = False-                          | otherwise                = True+    goAltCon (DataAlt dc) | isNeedle (dataConName dc) = False     goAltCon _ = True  @@ -273,7 +275,7 @@   where     go _ (Var v)       | isDataConWorkId v, idArity v > 0 = False-    go a (Var v)                         = (a >= idArity v)+    go a (Var v)                         = a >= idArity v     go _ (Lit _ )                        = True     go a (App e arg) | isTypeArg arg     = go a e     go a (App e arg)                     = go (a+1) e && goArg arg

@@ -188,7 +188,7 @@     ns <- mapM fromTHName thns     case lookupNameInGuts guts n of         Nothing -> pure . Just $ ppr n <+> text "is not a local name"-        Just (v, _) -> case msum $ map (freeOfTerm (slice binds v)) ns of+        Just (v, _) -> case freeOfTerm (slice binds v) ns of             Just _ -> pure . Just $ pprSlice (slice binds v)             Nothing -> pure Nothing   where binds = flattenBinds (mg_binds guts)@@ -198,7 +198,7 @@     ts <- mapM fromTHName thts     case lookupNameInGuts guts n of         Nothing -> pure . Just $ ppr n <+> text "is not a local name"-        Just (v, _) -> case msum $ map (freeOfType (slice binds v)) ts of+        Just (v, _) -> case freeOfType (slice binds v) ts of             Just _ -> pure . Just $ pprSlice (slice binds v)             Nothing -> pure Nothing   where binds = flattenBinds (mg_binds guts)