hspec-expectations-match 0.1.1.0 → 0.2.0.0

raw patch · 5 files changed

+113/−21 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• hspec-expectations-match.cabal +1/−1
• package.yaml +1/−1
• src/Test/Hspec/Expectations/Match.hs +92/−18
• test/Test/Hspec/Expectations/MatchSpec.hs +15/−1

@@ -1,3 +1,7 @@+# 0.2.0.0 (November 17th, 2017)++- Added `assertDo`, which automatically instruments a `do` block with uses of `shouldReturnAndMatch`.+ # 0.1.1.0 (November 15th, 2017)  - Added `shouldReturnAndMatch`, which combines the action-running behavior of `shouldReturn` with the pattern-matching behavior of `shouldMatch`.

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           hspec-expectations-match-version:        0.1.1.0+version:        0.2.0.0 synopsis:       An hspec expectation that asserts a value matches a pattern. description:    This package provides expectations for use with @hspec@ that use Template                 Haskell to assert that a value matches a particular pattern.

@@ -1,5 +1,5 @@ name: hspec-expectations-match-version: 0.1.1.0+version: 0.2.0.0 category: Testing synopsis: An hspec expectation that asserts a value matches a pattern. description: |

@@ -14,6 +14,7 @@ module Test.Hspec.Expectations.Match   ( shouldMatch   , shouldReturnAndMatch+  , assertDo   ) where  import Control.Monad.Base (MonadBase, liftBase)@@ -89,25 +90,29 @@  patBindingsToTupleExp :: Pat -> Exp patBindingsToTupleExp = TupE . map VarE . patBindings-  where-    patBindings (LitP _) = []-    patBindings (VarP nm) = [nm]-    patBindings (TupP pats) = concatMap patBindings pats-    patBindings (UnboxedTupP pats) = concatMap patBindings pats-    patBindings (ConP _ pats) = concatMap patBindings pats-    patBindings (InfixP patA _ patB) = patBindings patA ++ patBindings patB-    patBindings (UInfixP patA _ patB) = patBindings patA ++ patBindings patB-    patBindings (ParensP pat) = patBindings pat-    patBindings (TildeP pat) = patBindings pat-    patBindings (BangP pat) = patBindings pat-    patBindings (AsP nm pat) = nm : patBindings pat-    patBindings WildP = []-    patBindings (RecP _ fieldPats) = concatMap (patBindings . snd) fieldPats-    patBindings (ListP pats) = concatMap patBindings pats-    patBindings (SigP pat _) = patBindings pat-    patBindings (ViewP _ pat) = patBindings pat++patBindingsToTuplePat :: Pat -> Pat+patBindingsToTuplePat = TupP . map VarP . patBindings++patBindings :: Pat -> [Name]+patBindings (LitP _) = []+patBindings (VarP nm) = [nm]+patBindings (TupP pats) = concatMap patBindings pats+patBindings (UnboxedTupP pats) = concatMap patBindings pats+patBindings (ConP _ pats) = concatMap patBindings pats+patBindings (InfixP patA _ patB) = patBindings patA ++ patBindings patB+patBindings (UInfixP patA _ patB) = patBindings patA ++ patBindings patB+patBindings (ParensP pat) = patBindings pat+patBindings (TildeP pat) = patBindings pat+patBindings (BangP pat) = patBindings pat+patBindings (AsP nm pat) = nm : patBindings pat+patBindings WildP = []+patBindings (RecP _ fieldPats) = concatMap (patBindings . snd) fieldPats+patBindings (ListP pats) = concatMap patBindings pats+patBindings (SigP pat _) = patBindings pat+patBindings (ViewP _ pat) = patBindings pat #if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)-    patBindings (UnboxedSumP pat _ _) = patBindings pat+patBindings (UnboxedSumP pat _ _) = patBindings pat #endif  -- The pretty-printer provided by template-haskell always prints things with@@ -185,3 +190,72 @@ showLit (DoublePrimL r) = show (fromRational r :: Double) ++ "##" showLit (StringPrimL s) = show s ++ "#" showLit (CharPrimL c) = show c ++ "#"++-- | Instruments a @do@ block by automatically inserting uses of+-- 'shouldReturnAndMatch' for monadic bindings. Specifically, the transformation+-- converts this:+--+-- @+-- \$('assertDo' [|do+--   [x, y] <- 'return' [1, 2]+--   x `'Test.Hspec.Expectations.shouldBe`` 1+--   y `'Test.Hspec.Expectations.shouldBe`` 2|])+-- @+--+-- ...into this:+--+-- @+-- do (x, y) <- $([|'return' [1, 2]|] `'shouldReturnAndMatch'` [p|[x, y]|])+--    x `'Test.Hspec.Expectations.shouldBe`` 1+--    y `'Test.Hspec.Expectations.shouldBe`` 2+-- @+--+-- This makes it much easier to read @do@ blocks that make significant use of+-- 'shouldReturnAndMatch'.+--+-- Note that this transformation /only/ applies to monadic bindings (not @let@+-- bindings), and it does not occur when the pattern on the left hand side+-- already fully covers all potential values (that is, when the pattern could+-- not possibly fail to match).+assertDo :: Q Exp -> Q Exp+assertDo qDoExp = qDoExp >>= \case+    DoE stmts -> DoE <$> traverse annotateStatement stmts+    _ -> fail "assertDo: expected a do block"+  where+    annotateStatement stmt@(BindS pat expr) = case pat of+      VarP _ -> pure stmt+      WildP -> pure stmt+      _ -> do+        hasOtherCases <- patternHasOtherCases pat+        if hasOtherCases+          then BindS (patBindingsToTuplePat pat) <$> shouldReturnAndMatch (pure expr) (pure pat)+          else pure stmt+    annotateStatement stmt = pure stmt++    patternHasOtherCases (LitP _) = pure True+    patternHasOtherCases (VarP _) = pure False+    patternHasOtherCases (TupP pats) = or <$> traverse patternHasOtherCases pats+    patternHasOtherCases (UnboxedTupP pats) = or <$> traverse patternHasOtherCases pats+    patternHasOtherCases (ConP nm pats) = do+      DataConI _ _ tyNm <- reify nm+      tyInfo <- reify tyNm+      conHasOtherCases <- case tyInfo of+        TyConI dec -> case dec of+          DataD _ _ _ _ cons _ -> pure (length cons > 1)+          NewtypeD{} -> pure False+          _ -> fail ("patternHasOtherCases: internal error; unexpected declaration in TyConI: " ++ show dec)+        _ -> fail ("patternHasOtherCases: internal error; unexpected Info in DataConI: " ++ show tyInfo)+      if conHasOtherCases+        then pure True+        else or <$> traverse patternHasOtherCases pats+    patternHasOtherCases (InfixP patA nm patB) = patternHasOtherCases (ConP nm [patA, patB])+    patternHasOtherCases (UInfixP patA nm patB) = patternHasOtherCases (ConP nm [patA, patB])+    patternHasOtherCases (ParensP pat) = patternHasOtherCases pat+    patternHasOtherCases (TildeP pat) = patternHasOtherCases pat+    patternHasOtherCases (BangP pat) = patternHasOtherCases pat+    patternHasOtherCases (AsP _ pat) = patternHasOtherCases pat+    patternHasOtherCases WildP = pure False+    patternHasOtherCases (RecP _ fieldPats) = or <$> traverse (patternHasOtherCases . snd) fieldPats+    patternHasOtherCases (ListP _) = pure True+    patternHasOtherCases (SigP pat _) = patternHasOtherCases pat+    patternHasOtherCases (ViewP _ _) = pure True

@@ -31,10 +31,24 @@       c `shouldBe` 'y'    describe "shouldReturnAndMatch" $-    it "matches the result of an action against a pattern" $ example $ do+    it "matches the result of an action against a pattern" $ do       $([|pure (Just True)|] `shouldReturnAndMatch` [p|Just _|])        $([|pure Nothing|] `shouldReturnAndMatch` [p|Just True|]) `shouldThrow` anyException        a <- $([|pure (Just True)|] `shouldReturnAndMatch` [p|Just x|])       a `shouldBe` True++  describe "assertDo" $+    it "automatically annotates pattern binds with shouldReturnAndMatch" $ do+      $(assertDo [|do+        () <- pure ()+        pure ()|])++      $(assertDo [|do+        Just x <- pure $ Just True+        x `shouldBe` True|])++      $(assertDo [|do+        Just x <- pure Nothing+        x `shouldBe` True|]) `shouldThrow` anyException