hspec-expectations-match (empty) → 0.1.0.0

raw patch · 9 files changed

+380/−0 lines, 9 filesdep +basedep +hspecdep +hspec-expectationssetup-changed

Dependencies added: base, hspec, hspec-expectations, hspec-expectations-match, template-haskell, transformers-base

Files

• CHANGELOG.md +3/−0
• README.md +25/−0
• Setup.hs +7/−0
• hspec-expectations-match.cabal +72/−0
• package.yaml +77/−0
• src/Test/Hspec/Expectations/Match.hs +163/−0
• stack.yaml +2/−0
• test/Main.hs +1/−0
• test/Test/Hspec/Expectations/MatchSpec.hs +30/−0

@@ -0,0 +1,3 @@+# 0.1.0.0 (November 15th, 2017)++- Initial release.

@@ -0,0 +1,25 @@+# hspec-expectations-match [![Build Status](https://travis-ci.org/cjdev/hspec-expectations-match.svg?branch=master)](https://travis-ci.org/cjdev/hspec-expectations-match)++`hspec-expectations-match` is a Haskell package that provides a single expectation for use with [`hspec`][hspec], `shouldMatch`. The `shouldMatch` expectation uses Template Haskell to assert that a value matches a particular pattern.++```haskell+{-# LANGUAGE TemplateHaskell #-}++ghci> $([|Just True|] `shouldMatch` [p|Just _|])+ghci> $([|Nothing|] `shouldMatch` [p|Just _|])+*** Exception: Nothing failed to match pattern (Just x)+```++Additionally, any bindings created by the pattern will be returned if the pattern is successfully matched, making it easier to extract the result of some assertion and use it to make further assertions.++```haskell+ghci> $([|Just True|] `shouldMatch` [p|Just x|])+True+ghci> $([|[1, 2]|] `shouldMatch` [p|[x, y]|])+(1, 2)+```++For more information, [see the documentation on Hackage][hspec-expectations-match].++[hspec]: https://hackage.haskell.org/package/hspec+[hspec-expectations-match]: https://hackage.haskell.org/package/hspec-expectations-match

@@ -0,0 +1,7 @@+-- This script is used to build and install your package. Typically you don't+-- need to change it. The Cabal documentation has more information about this+-- file: <https://www.haskell.org/cabal/users-guide/installing-packages.html>.+import qualified Distribution.Simple++main :: IO ()+main = Distribution.Simple.defaultMain

@@ -0,0 +1,72 @@+-- This file has been generated from package.yaml by hpack version 0.18.1.+--+-- see: https://github.com/sol/hpack++name:           hspec-expectations-match+version:        0.1.0.0+synopsis:       An hspec expectation that asserts a value matches a pattern.+description:    This package provides a single expectation for use with @hspec@,+                'shouldMatch'. The 'shouldMatch' expectation uses Template Haskell to assert+                that a value matches a particular pattern.+                .+                >>> $([|Just True|] `shouldMatch` [p|Just _|])+                >>> $([|Nothing|] `shouldMatch` [p|Just _|])+                .+                Additionally, any bindings created by the pattern will be returned if the+                pattern is successfully matched, making it easier to extract the result of+                some assertion and use it to make further assertions.+                .+                >>> $([|Just True|] `shouldMatch` [p|Just x|])+                True+                >>> $([|[1, 2]|] `shouldMatch` [p|[x, y]|])+                (1, 2)+category:       Testing+homepage:       https://github.com/cjdev/hspec-expectations-match#readme+bug-reports:    https://github.com/cjdev/hspec-expectations-match/issues+author:         Alexis King <lexi.lambda@gmail.com>+maintainer:     Alexis King <lexi.lambda@gmail.com>+copyright:      2017 CJ Affiliate by Conversant+license:        ISC+build-type:     Simple+cabal-version:  >= 1.10++extra-source-files:+    CHANGELOG.md+    package.yaml+    README.md+    stack.yaml++source-repository head+  type: git+  location: https://github.com/cjdev/hspec-expectations-match++library+  hs-source-dirs:+      src+  default-extensions: ApplicativeDo ConstraintKinds DefaultSignatures DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeOperators+  ghc-options: -Wall+  build-depends:+      base >= 4.9 && < 5+    , hspec-expectations >= 0.3.2 && < 1+    , template-haskell >= 2.11 && < 2.13+    , transformers-base < 1+  exposed-modules:+      Test.Hspec.Expectations.Match+  other-modules:+      Paths_hspec_expectations_match+  default-language: Haskell2010++test-suite hspec-expectations-th-test-suite+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs:+      test+  default-extensions: ApplicativeDo ConstraintKinds DefaultSignatures DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns OverloadedStrings RankNTypes ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeOperators+  ghc-options: -Wall -rtsopts -threaded -with-rtsopts=-N+  build-depends:+      base+    , hspec+    , hspec-expectations-match+  other-modules:+      Test.Hspec.Expectations.MatchSpec+  default-language: Haskell2010

@@ -0,0 +1,77 @@+name: hspec-expectations-match+version: 0.1.0.0+category: Testing+synopsis: An hspec expectation that asserts a value matches a pattern.+description: |+  This package provides a single expectation for use with @hspec@,+  'shouldMatch'. The 'shouldMatch' expectation uses Template Haskell to assert+  that a value matches a particular pattern.++  >>> $([|Just True|] `shouldMatch` [p|Just _|])+  >>> $([|Nothing|] `shouldMatch` [p|Just _|])++  Additionally, any bindings created by the pattern will be returned if the+  pattern is successfully matched, making it easier to extract the result of+  some assertion and use it to make further assertions.++  >>> $([|Just True|] `shouldMatch` [p|Just x|])+  True+  >>> $([|[1, 2]|] `shouldMatch` [p|[x, y]|])+  (1, 2)++copyright: 2017 CJ Affiliate by Conversant+license: ISC+author: Alexis King <lexi.lambda@gmail.com>+maintainer: Alexis King <lexi.lambda@gmail.com>+github: cjdev/hspec-expectations-match++extra-source-files:+- CHANGELOG.md+- package.yaml+- README.md+- stack.yaml++ghc-options: -Wall+default-extensions:+- ApplicativeDo+- ConstraintKinds+- DefaultSignatures+- DeriveGeneric+- ExistentialQuantification+- FlexibleContexts+- FlexibleInstances+- FunctionalDependencies+- GADTs+- GeneralizedNewtypeDeriving+- KindSignatures+- LambdaCase+- MultiParamTypeClasses+- NamedFieldPuns+- OverloadedStrings+- RankNTypes+- ScopedTypeVariables+- StandaloneDeriving+- TupleSections+- TypeApplications+- TypeOperators++library:+  dependencies:+  - base >= 4.9 && < 5+  - hspec-expectations >= 0.3.2 && < 1+  - template-haskell >= 2.11 && < 2.13+  - transformers-base < 1+  source-dirs: src++tests:+  hspec-expectations-th-test-suite:+    dependencies:+    - base+    - hspec+    - hspec-expectations-match+    ghc-options:+    - -rtsopts+    - -threaded+    - -with-rtsopts=-N+    main: Main.hs+    source-dirs: test

@@ -0,0 +1,163 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{-|+  This module implements an @hspec@ expectation, 'shouldMatch'. This is a+  Template Haskell function that makes it possible to assert that a value+  matches a particular pattern, and it even allows values bound by the pattern+  to be extracted.++  The function should be used with Template Haskell’s expression and pattern+  quoters, notated by @[| ... |]@ and @[p| ... |]@, respectively.+-}+module Test.Hspec.Expectations.Match+  ( shouldMatch+  ) where++import Control.Monad.Base (MonadBase, liftBase)+import Data.Maybe (fromMaybe)+import Test.Hspec.Expectations (expectationFailure)++import Language.Haskell.TH.Ppr+import Language.Haskell.TH.Syntax++assertPatternMatchFailure :: (MonadBase IO m, Show a) => String -> a -> m b+assertPatternMatchFailure pat val =+    liftBase (expectationFailure (showsPrec 11 val "" ++ " failed to match pattern " ++ pat))+    -- expectationFailure should always throw, but it returns IO (), not IO a,+    -- so we need to make the typechecker happy by handling the impossible case.+    *> pure (error "assertPatternMatchFailure: internal error")++-- | Asserts that a value matches a given pattern and returns the pattern’s+-- bindings if the match succeeds.+--+-- >>> a <- $([|Just True|] `shouldMatch` [p|Just x|])+-- >>> a+-- True+-- >>> a <- $([|Nothing|] `shouldMatch` [p|Just x|])+-- *** Exception: Nothing failed to match pattern (Just x)+--+-- If multiple values are bound by a pattern, they are returned in a tuple,+-- in the order they appear in the pattern.+--+-- >>> (b, c) <- $([|['x', 'y']|] `shouldMatch` [p|[x, y]|])+-- >>> b+-- 'x'+-- >>> c+-- 'y'+-- >>> (b, c) <- $([|['x', 'y']|] `shouldMatch` [p|[x, y, z]|])+-- *** Exception: ['x','y'] failed to match pattern [x, y, z]+shouldMatch :: Q Exp -> Q Pat -> Q Exp+shouldMatch qExpr qPat = do+  expr <- qExpr+  pat <- qPat+  patStr <- showsPat 11 pat++  valName <- newName "val"++  let successExpr = VarE 'pure `AppE` patBindingsToTupleExp pat+  let failureExpr = VarE 'assertPatternMatchFailure `AppE` LitE (StringL (patStr "")) `AppE` VarE valName++  pure $ CaseE expr+    [ Match pat (NormalB successExpr) []+    , Match (VarP valName) (NormalB failureExpr) []+    ]++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+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+    patBindings (UnboxedSumP pat _ _) = patBindings pat+#endif++-- The pretty-printer provided by template-haskell always prints things with+-- qualified names, which isn’t very pleasant for users trying to make sense of+-- expectation failures. While it’s unfortunately impossible to do the+-- completely correct thing here (we don’t know when a users’ code uses+-- qualified names, since TH discards that information), it seems like a better+-- default to print unqualified names in expectation failure messages.+showsPat :: Int -> Pat -> Q ShowS+showsPat prec p = case p of+    LitP lit -> pure $ showString (showLit lit)+    VarP nm -> pure $ showString (nameBase nm)+    TupP [] -> pure $ showString "()"+    TupP pats -> do+      pats' <- traverse (showsPat 0) pats+      pure $ showChar '(' . foldr1 (\s r -> s . showString ", " . r) pats' . showChar ')'+    UnboxedTupP [] -> pure $ showString "(# #)"+    UnboxedTupP pats -> do+      pats' <- traverse (showsPat 0) pats+      pure $ showString "(# " . foldr1 (\s r -> s . showString ", " . r) pats' . showString " #)"+    ConP nm [] -> pure $ showString (nameBase nm)+    ConP nm pats -> do+      pats' <- traverse (showsPat 11) pats+      pure . showParen (prec > 10) $+        showString (nameBase nm) . showChar ' ' . foldr1 (\s r -> s . showChar ' ' . r) pats'+    InfixP patA nm patB -> showInfix patA nm patB+    UInfixP patA nm patB -> showInfix patA nm patB+    ParensP pat -> showParen True <$> showsPat 0 pat+    TildeP pat -> (showChar '~' .) <$> showsPat 11 pat+    BangP pat -> (showChar '!' .) <$> showsPat 11 pat+    AsP nm pat -> ((showString (nameBase nm) . showChar '@') .) <$> showsPat 11 pat+    WildP -> pure $ showChar '_'+    RecP nm [] -> pure $ showString (nameBase nm) . showString " {}"+    RecP nm fieldPats -> do+      fieldPats' <- showFieldPats fieldPats+      pure $ showString (nameBase nm) . showString " { " . fieldPats' . showString " }"+    ListP [] -> pure $ showString "[]"+    ListP pats -> do+      pats' <- traverse (showsPat 0) pats+      pure $ showChar '[' . foldr1 (\s r -> s . showString ", " . r) pats' . showChar ']'+    SigP pat ty -> do+      pat' <- showsPat 10 pat+      pure . showParen (prec > 0) $ pat' . showString " :: " . showsPrec 10 (ppr ty)+    ViewP expr pat -> do+      pat' <- showsPat 10 pat+      pure . showParen (prec > 0) $ showsPrec 10 (ppr expr) . showString " -> " . pat'+#if MIN_VERSION_GLASGOW_HASKELL(8,2,1,0)+    UnboxedSumP pat alt arity -> do+      pat' <- showsPat 0 pat+      pure $+        showString "(#" . showString (replicate (alt - 1) '|') . pat'+        . showString (replicate (arity - alt) '|') . showString "#)"+#endif+  where+    showInfix patA nm patB = do+      Fixity nmPrec _ <- fromMaybe defaultFixity <$> reifyFixity nm+      patA' <- showsPat (nmPrec + 1) patA+      patB' <- showsPat (nmPrec + 1) patB+      pure . showParen (prec > nmPrec) $+        patA' . showChar ' ' . showString (nameBase nm) . showChar ' ' . patB'++    showFieldPats fieldPats = do+      fieldPats' <- traverse showFieldPat fieldPats+      pure $ foldr1 (\s r -> s . showString ", " . r) fieldPats'+    showFieldPat (nm, pat) = ((showString (nameBase nm) . showString " = ") .) <$> showsPat 0 pat++showLit :: Lit -> String+showLit (CharL c) = show c+showLit (StringL s) = show s+showLit (IntegerL i) = show i+showLit (RationalL r) = show (fromRational r :: Double)+showLit (IntPrimL i) = show i ++ "#"+showLit (WordPrimL i) = show i ++ "##"+showLit (FloatPrimL r) = show (fromRational r :: Float) ++ "#"+showLit (DoublePrimL r) = show (fromRational r :: Double) ++ "##"+showLit (StringPrimL s) = show s ++ "#"+showLit (CharPrimL c) = show c ++ "#"

@@ -0,0 +1,2 @@+resolver: lts-9.11+packages: [.]

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Hspec.Expectations.MatchSpec (spec) where++import Test.Hspec+import Test.Hspec.Expectations.Match++spec :: Spec+spec = describe "shouldMatch" $ do+  it "succeeds when a value matches a pattern" $ example $ do+    $([|Just True|] `shouldMatch` [p|Just True|])+    $([|Just True|] `shouldMatch` [p|Just _|])+    $([|Just False|] `shouldMatch` [p|Just _|])++    $([|17 :: Integer|] `shouldMatch` [p|((>= 15) -> True)|])++  it "fails when a value does not match a pattern" $ do+    $([|Just True|] `shouldMatch` [p|Nothing|]) `shouldThrow` anyException+    $([|Nothing|] `shouldMatch` [p|Just True|]) `shouldThrow` anyException++    $([|17 :: Integer|] `shouldMatch` [p|((<= 15) -> True)|]) `shouldThrow` anyException++  it "returns any bindings matched by a successful pattern" $ do+    a <- $([|Just True|] `shouldMatch` [p|Just x|])+    a `shouldBe` True++    (b, c) <- $([|['x', 'y']|] `shouldMatch` [p|[x, y]|])+    b `shouldBe` 'x'+    c `shouldBe` 'y'