diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). + +## [1.0.0] - 2026-07-10 + +### Added + +- Initial release. diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,287 @@ + EUROPEAN UNION PUBLIC LICENCE v. 1.2 + EUPL © the European Union 2007, 2016 + +This European Union Public Licence (the ‘EUPL’) applies to the Work (as defined +below) which is provided under the terms of this Licence. Any use of the Work, +other than as authorised under this Licence is prohibited (to the extent such +use is covered by a right of the copyright holder of the Work). + +The Work is provided under the terms of this Licence when the Licensor (as +defined below) has placed the following notice immediately following the +copyright notice for the Work: + + Licensed under the EUPL + +or has expressed by any other means his willingness to license under the EUPL. + +1. Definitions + +In this Licence, the following terms have the following meaning: + +- ‘The Licence’: this Licence. + +- ‘The Original Work’: the work or software distributed or communicated by the + Licensor under this Licence, available as Source Code and also as Executable + Code as the case may be. + +- ‘Derivative Works’: the works or software that could be created by the + Licensee, based upon the Original Work or modifications thereof. This Licence + does not define the extent of modification or dependence on the Original Work + required in order to classify a work as a Derivative Work; this extent is + determined by copyright law applicable in the country mentioned in Article 15. + +- ‘The Work’: the Original Work or its Derivative Works. + +- ‘The Source Code’: the human-readable form of the Work which is the most + convenient for people to study and modify. + +- ‘The Executable Code’: any code which has generally been compiled and which is + meant to be interpreted by a computer as a program. + +- ‘The Licensor’: the natural or legal person that distributes or communicates + the Work under the Licence. + +- ‘Contributor(s)’: any natural or legal person who modifies the Work under the + Licence, or otherwise contributes to the creation of a Derivative Work. + +- ‘The Licensee’ or ‘You’: any natural or legal person who makes any usage of + the Work under the terms of the Licence. + +- ‘Distribution’ or ‘Communication’: any act of selling, giving, lending, + renting, distributing, communicating, transmitting, or otherwise making + available, online or offline, copies of the Work or providing access to its + essential functionalities at the disposal of any other natural or legal + person. + +2. Scope of the rights granted by the Licence + +The Licensor hereby grants You a worldwide, royalty-free, non-exclusive, +sublicensable licence to do the following, for the duration of copyright vested +in the Original Work: + +- use the Work in any circumstance and for all usage, +- reproduce the Work, +- modify the Work, and make Derivative Works based upon the Work, +- communicate to the public, including the right to make available or display + the Work or copies thereof to the public and perform publicly, as the case may + be, the Work, +- distribute the Work or copies thereof, +- lend and rent the Work or copies thereof, +- sublicense rights in the Work or copies thereof. + +Those rights can be exercised on any media, supports and formats, whether now +known or later invented, as far as the applicable law permits so. + +In the countries where moral rights apply, the Licensor waives his right to +exercise his moral right to the extent allowed by law in order to make effective +the licence of the economic rights here above listed. + +The Licensor grants to the Licensee royalty-free, non-exclusive usage rights to +any patents held by the Licensor, to the extent necessary to make use of the +rights granted on the Work under this Licence. + +3. Communication of the Source Code + +The Licensor may provide the Work either in its Source Code form, or as +Executable Code. If the Work is provided as Executable Code, the Licensor +provides in addition a machine-readable copy of the Source Code of the Work +along with each copy of the Work that the Licensor distributes or indicates, in +a notice following the copyright notice attached to the Work, a repository where +the Source Code is easily and freely accessible for as long as the Licensor +continues to distribute or communicate the Work. + +4. Limitations on copyright + +Nothing in this Licence is intended to deprive the Licensee of the benefits from +any exception or limitation to the exclusive rights of the rights owners in the +Work, of the exhaustion of those rights or of other applicable limitations +thereto. + +5. Obligations of the Licensee + +The grant of the rights mentioned above is subject to some restrictions and +obligations imposed on the Licensee. Those obligations are the following: + +Attribution right: The Licensee shall keep intact all copyright, patent or +trademarks notices and all notices that refer to the Licence and to the +disclaimer of warranties. The Licensee must include a copy of such notices and a +copy of the Licence with every copy of the Work he/she distributes or +communicates. The Licensee must cause any Derivative Work to carry prominent +notices stating that the Work has been modified and the date of modification. + +Copyleft clause: If the Licensee distributes or communicates copies of the +Original Works or Derivative Works, this Distribution or Communication will be +done under the terms of this Licence or of a later version of this Licence +unless the Original Work is expressly distributed only under this version of the +Licence — for example by communicating ‘EUPL v. 1.2 only’. The Licensee +(becoming Licensor) cannot offer or impose any additional terms or conditions on +the Work or Derivative Work that alter or restrict the terms of the Licence. + +Compatibility clause: If the Licensee Distributes or Communicates Derivative +Works or copies thereof based upon both the Work and another work licensed under +a Compatible Licence, this Distribution or Communication can be done under the +terms of this Compatible Licence. For the sake of this clause, ‘Compatible +Licence’ refers to the licences listed in the appendix attached to this Licence. +Should the Licensee's obligations under the Compatible Licence conflict with +his/her obligations under this Licence, the obligations of the Compatible +Licence shall prevail. + +Provision of Source Code: When distributing or communicating copies of the Work, +the Licensee will provide a machine-readable copy of the Source Code or indicate +a repository where this Source will be easily and freely available for as long +as the Licensee continues to distribute or communicate the Work. + +Legal Protection: This Licence does not grant permission to use the trade names, +trademarks, service marks, or names of the Licensor, except as required for +reasonable and customary use in describing the origin of the Work and +reproducing the content of the copyright notice. + +6. Chain of Authorship + +The original Licensor warrants that the copyright in the Original Work granted +hereunder is owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each Contributor warrants that the copyright in the modifications he/she brings +to the Work are owned by him/her or licensed to him/her and that he/she has the +power and authority to grant the Licence. + +Each time You accept the Licence, the original Licensor and subsequent +Contributors grant You a licence to their contributions to the Work, under the +terms of this Licence. + +7. Disclaimer of Warranty + +The Work is a work in progress, which is continuously improved by numerous +Contributors. It is not a finished work and may therefore contain defects or +‘bugs’ inherent to this type of development. + +For the above reason, the Work is provided under the Licence on an ‘as is’ basis +and without warranties of any kind concerning the Work, including without +limitation merchantability, fitness for a particular purpose, absence of defects +or errors, accuracy, non-infringement of intellectual property rights other than +copyright as stated in Article 6 of this Licence. + +This disclaimer of warranty is an essential part of the Licence and a condition +for the grant of any rights to the Work. + +8. Disclaimer of Liability + +Except in the cases of wilful misconduct or damages directly caused to natural +persons, the Licensor will in no event be liable for any direct or indirect, +material or moral, damages of any kind, arising out of the Licence or of the use +of the Work, including without limitation, damages for loss of goodwill, work +stoppage, computer failure or malfunction, loss of data or any commercial +damage, even if the Licensor has been advised of the possibility of such damage. +However, the Licensor will be liable under statutory product liability laws as +far such laws apply to the Work. + +9. Additional agreements + +While distributing the Work, You may choose to conclude an additional agreement, +defining obligations or services consistent with this Licence. However, if +accepting obligations, You may act only on your own behalf and on your sole +responsibility, not on behalf of the original Licensor or any other Contributor, +and only if You agree to indemnify, defend, and hold each Contributor harmless +for any liability incurred by, or claims asserted against such Contributor by +the fact You have accepted any warranty or additional liability. + +10. Acceptance of the Licence + +The provisions of this Licence can be accepted by clicking on an icon ‘I agree’ +placed under the bottom of a window displaying the text of this Licence or by +affirming consent in any other similar way, in accordance with the rules of +applicable law. Clicking on that icon indicates your clear and irrevocable +acceptance of this Licence and all of its terms and conditions. + +Similarly, you irrevocably accept this Licence and all of its terms and +conditions by exercising any rights granted to You by Article 2 of this Licence, +such as the use of the Work, the creation by You of a Derivative Work or the +Distribution or Communication by You of the Work or copies thereof. + +11. Information to the public + +In case of any Distribution or Communication of the Work by means of electronic +communication by You (for example, by offering to download the Work from a +remote location) the distribution channel or media (for example, a website) must +at least provide to the public the information requested by the applicable law +regarding the Licensor, the Licence and the way it may be accessible, concluded, +stored and reproduced by the Licensee. + +12. Termination of the Licence + +The Licence and the rights granted hereunder will terminate automatically upon +any breach by the Licensee of the terms of the Licence. + +Such a termination will not terminate the licences of any person who has +received the Work from the Licensee under the Licence, provided such persons +remain in full compliance with the Licence. + +13. Miscellaneous + +Without prejudice of Article 9 above, the Licence represents the complete +agreement between the Parties as to the Work. + +If any provision of the Licence is invalid or unenforceable under applicable +law, this will not affect the validity or enforceability of the Licence as a +whole. Such provision will be construed or reformed so as necessary to make it +valid and enforceable. + +The European Commission may publish other linguistic versions or new versions of +this Licence or updated versions of the Appendix, so far this is required and +reasonable, without reducing the scope of the rights granted by the Licence. New +versions of the Licence will be published with a unique version number. + +All linguistic versions of this Licence, approved by the European Commission, +have identical value. Parties can take advantage of the linguistic version of +their choice. + +14. Jurisdiction + +Without prejudice to specific agreement between parties, + +- any litigation resulting from the interpretation of this License, arising + between the European Union institutions, bodies, offices or agencies, as a + Licensor, and any Licensee, will be subject to the jurisdiction of the Court + of Justice of the European Union, as laid down in article 272 of the Treaty on + the Functioning of the European Union, + +- any litigation arising between other parties and resulting from the + interpretation of this License, will be subject to the exclusive jurisdiction + of the competent court where the Licensor resides or conducts its primary + business. + +15. Applicable Law + +Without prejudice to specific agreement between parties, + +- this Licence shall be governed by the law of the European Union Member State + where the Licensor has his seat, resides or has his registered office, + +- this licence shall be governed by Belgian law if the Licensor has no seat, + residence or registered office inside a European Union Member State. + +Appendix + +‘Compatible Licences’ according to Article 5 EUPL are: + +- GNU General Public License (GPL) v. 2, v. 3 +- GNU Affero General Public License (AGPL) v. 3 +- Open Software License (OSL) v. 2.1, v. 3.0 +- Eclipse Public License (EPL) v. 1.0 +- CeCILL v. 2.0, v. 2.1 +- Mozilla Public Licence (MPL) v. 2 +- GNU Lesser General Public Licence (LGPL) v. 2.1, v. 3 +- Creative Commons Attribution-ShareAlike v. 3.0 Unported (CC BY-SA 3.0) for + works other than software +- European Union Public Licence (EUPL) v. 1.1, v. 1.2 +- Québec Free and Open-Source Licence — Reciprocity (LiLiQ-R) or Strong + Reciprocity (LiLiQ-R+). + +The European Commission may update this Appendix to later versions of the above +licences without producing a new version of the EUPL, as long as they provide +the rights granted in Article 2 of this Licence and protect the covered Source +Code from exclusive appropriation. + +All other changes or additions to this Appendix require the production of a new +EUPL version. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hspec-effectful.cabal b/hspec-effectful.cabal new file mode 100644 --- /dev/null +++ b/hspec-effectful.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 +name: hspec-effectful +version: 0.1.0.0 +synopsis: Effectful driver for Hspec +category: Test +description: + Adaptation of the @@ library for the @@ ecosystem. + +license: EUPL-1.2 +license-file: LICENCE +author: IDA +maintainer: IDA +homepage: https://digital-autonomy.institute +bug-reports: https://issues.digital-autonomy.institute +build-type: Simple +extra-doc-files: + CHANGELOG.md + +common common + default-language: GHC2021 + ghc-options: + -Weverything + -Wno-unsafe + -Wno-missing-safe-haskell-mode + -Wno-missing-export-lists + -Wno-missing-import-lists + -Wno-missing-kind-signatures + -Wno-all-missed-specialisations + + default-extensions: + ApplicativeDo + BlockArguments + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveGeneric + DerivingStrategies + DerivingVia + ExplicitNamespaces + GeneralizedNewtypeDeriving + LambdaCase + NoImplicitPrelude + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + RecordWildCards + RecursiveDo + TypeFamilies + ViewPatterns + + build-depends: + base >=4.16 && <5, + effectful >=2.6 && <2.7, + +library + import: common + hs-source-dirs: src + build-depends: + hspec >=2.11 && <2.12, + hspec-core >=2.11 && <2.12, + hspec-expectations >=0.8 && <0.9, + hspec-expectations-pretty-diff >=0.7 && <0.8, + hunit-effectful >=1.0 && <1.1, + + exposed-modules: + Effectful.Hspec + +test-suite test + import: common + type: exitcode-stdio-1.0 + ghc-options: -threaded + hs-source-dirs: test + main-is: Main.hs + build-depends: + hspec-effectful diff --git a/src/Effectful/Hspec.hs b/src/Effectful/Hspec.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Hspec.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE ImpredicativeTypes #-} +{-# OPTIONS_GHC -Wno-missing-role-annotations #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | +-- Module : Effectful.Hspec +-- Copyright : (c) 2026 Institute for Digital Autonomy +-- License : EUPL-1.2 +-- Maintainer : IDA +-- +-- Effectful bindings for the +-- built on top of @@. +-- +-- = Overview +-- +-- This library provides @Hspec@'s test combinators expressed in terms of the 'Hspec' effect. +-- This effect allows you to intersperse test assertions with arbitrary other effects. +-- +-- = Example usage +-- +-- Suppose we wish to test stateful operations on an account balance: +-- +-- > deposit :: (State Int :> es) => Int -> Eff es () +-- > deposit amount = modify (+ amount) +-- > +-- > balance :: (State Int :> es) => Eff es Int +-- > balance = get +-- +-- > withdraw :: (State Int :> es) => Int -> Eff es Bool +-- > withdraw amount = do +-- > funds <- balance +-- > if funds < amount +-- > then pure False +-- > else do +-- > put $ funds - amount +-- > pure True +-- +-- Use 'describe' to group related examples, 'it' to state individual expectations, +-- and setup/teardown combinators such as 'before_', 'after_', or 'around_' to +-- run the examples from a known initial state: +-- +-- > accountSpec :: (State Int :> es, Hspec :> es) => Eff es () +-- > accountSpec = describe "account" . before_ (put @Int 0) $ do +-- > it "accumulates deposits" $ do +-- > deposit 100 +-- > deposit 50 +-- > balance `shouldReturn` 150 +-- > +-- > it "checks for sufficient funds before withdrawing" $ do +-- > deposit 100 +-- > withdraw 30 `shouldReturn` True +-- > withdraw 1000 `shouldReturn` False +-- > balance `shouldReturn` 70 +-- +-- Finally, run the spec with 'runHspec', which also resolves the underlying 'HUnit' effect: +-- +-- > main :: IO () +-- > main = runEff . runHspec . evalState @Int 0 $ accountSpec +module Effectful.Hspec + ( -- * Effect + Hspec + , Expectation + , runHspecWith' + , runHspecWith + , runHspec' + , runHspec + + -- * Spec construction + , describe + , context + , it + , specify + , pending + , pendingWith + + -- * Skipping + , xit + , xspecify + , xdescribe + , xcontext + + -- * Focusing + , focus + , fit + , fspecify + , fdescribe + , fcontext + + -- * Setup / Teardown + , before_ + , beforeAll_ + , after_ + , afterAll_ + , around_ + , aroundAll_ + + -- * Expectations + , expectationFailure + , shouldBe + , shouldSatisfy + , shouldStartWith + , shouldEndWith + , shouldContain + , shouldMatchList + , shouldReturn + , shouldNotBe + , shouldNotSatisfy + , shouldNotContain + , shouldNotReturn + , shouldThrow + , anyException + , Config (..) + , defaultConfig + , Hspec.Spec + , HasCallStack + ) +where + +import Control.Monad (unless) +import Data.List qualified as List +import Data.Typeable (typeOf) +import Effectful +import Effectful.Dispatch.Static +import Effectful.Environment (runEnvironment, withArgs) +import Effectful.Exception (Exception, throwIO, try) +import Effectful.HUnit as HUnit +import Test.Hspec qualified as Hspec +import Test.Hspec.Core.Spec (ResultStatus (..)) +import Test.Hspec.Expectations (Selector, anyException) +import Test.Hspec.Expectations.Pretty.Matcher (matchList) +import Test.Hspec.Runner (Config (..), defaultConfig) +import Test.Hspec.Runner qualified as Hspec +import Prelude + +data Hspec :: Effect + +type instance DispatchOf Hspec = 'Static 'WithSideEffects + +data instance StaticRep Hspec = Hspec + { spec :: Hspec.Spec + , unlift :: forall r. Eff '[HUnit] r -> IO r + } + +type Expectation es = Assertion es + +runHspecWith' :: (IOE :> es, HUnit :> es) => Config -> Eff (Hspec ': es) a -> Eff es a +runHspecWith' config action = do + (a, Hspec{spec}) <- withEffToIO (ConcUnlift Ephemeral Unlimited) \unlift -> + unlift + . runStaticRep + Hspec + { spec = pure () + , unlift = unlift . inject + } + . inject + $ action + runEnvironment . withArgs [] . liftIO $ Hspec.hspecWith config spec + pure a + +runHspecWith :: (IOE :> es) => Config -> Eff (Hspec ': es) a -> Eff es a +runHspecWith = (runHUnit .) . (. inject) . runHspecWith' + +runHspec' :: (IOE :> es, HUnit :> es) => Eff (Hspec ': es) a -> Eff es a +runHspec' = runHspecWith' defaultConfig . inject + +runHspec :: (IOE :> es) => Eff (Hspec ': es) a -> Eff es a +runHspec = runHUnit . runHspec' . inject + +hunit :: (Hspec :> es) => Eff '[HUnit] r -> Eff es r +hunit action = do + Hspec{unlift} <- getStaticRep + unsafeEff_ . unlift . inject $ action + +-- | Lifted 'Hspec.describe' +describe :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a +describe label action = + stateStaticRepM \before -> do + putStaticRep before{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, before{spec = spec before >> Hspec.describe label (spec after)}) + +-- | Lifted 'Hspec.it' +it :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es () +it label action = do + ioAction <- + unsafeConcUnliftIO Ephemeral Unlimited \runInIO -> + pure (runInIO action) + stateStaticRep \hspec -> ((), hspec{spec = spec hspec >> Hspec.it label ioAction}) + +-- | Lifted 'Hspec.specify' +specify :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es () +specify = it + +-- | Lifted 'Hspec.context' +context :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a +context = describe + +-- | Lifted 'Hspec.pending' +pending :: (HasCallStack, Hspec :> es) => Eff es () +pending = getStaticRep @Hspec >> unsafeEff_ Hspec.pending + +pending_ :: Eff es () +pending_ = throwIO $ Pending Nothing Nothing + +-- | Lifted 'Hspec.pendingWith' +pendingWith :: (HasCallStack, Hspec :> es) => String -> Eff es () +pendingWith = (getStaticRep @Hspec >>) . unsafeEff_ . Hspec.pendingWith + +-- | Lifted 'Hspec.xit' +xit :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es () +xit = (before_ pending_ .) . it + +-- | Lifted 'Hspec.xspecify' +xspecify :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es () +xspecify = xit + +-- | Lifted 'Hspec.xdescribe' +xdescribe :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a +xdescribe = (before_ pending_ .) . describe + +-- | Lifted 'Hspec.xcontext' +xcontext :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a +xcontext = xdescribe + +-- | Lifted 'Hspec.focus' +focus :: (HasCallStack, Hspec :> es) => Eff es a -> Eff es a +focus action = + stateStaticRepM \before -> do + putStaticRep before{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, before{spec = spec before >> Hspec.focus (spec after)}) + +-- | Lifted 'Hspec.fit' +fit :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es () +fit = fmap focus . it + +-- | Lifted 'Hspec.fspecify' +fspecify :: (HasCallStack, Hspec :> es) => String -> Eff es () -> Eff es () +fspecify = fit + +-- | Lifted 'Hspec.fdescribe' +fdescribe :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a +fdescribe = fmap focus . describe + +-- | Lifted 'Hspec.fcontext' +fcontext :: (HasCallStack, Hspec :> es) => String -> Eff es a -> Eff es a +fcontext = fdescribe + +-- | Lifted 'Hspec.before_' +before_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a +before_ setup action = do + ioSetup <- + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + pure (unlift setup) + stateStaticRepM \prev -> do + putStaticRep prev{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, prev{spec = spec prev >> Hspec.before_ ioSetup (spec after)}) + +-- | Lifted 'Hspec.beforeAll_' +beforeAll_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a +beforeAll_ setup action = do + ioSetup <- + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + pure (unlift setup) + stateStaticRepM \prev -> do + putStaticRep prev{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, prev{spec = spec prev >> Hspec.beforeAll_ ioSetup (spec after)}) + +-- | Lifted 'Hspec.after_' +after_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a +after_ teardown action = do + ioTeardown <- + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + pure (unlift teardown) + stateStaticRepM \prev -> do + putStaticRep prev{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, prev{spec = spec prev >> Hspec.after_ ioTeardown (spec after)}) + +-- | Lifted 'Hspec.afterAll_' +afterAll_ :: (HasCallStack, Hspec :> es) => Eff es () -> Eff es a -> Eff es a +afterAll_ teardown action = do + ioTeardown <- + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + pure (unlift teardown) + stateStaticRepM \prev -> do + putStaticRep prev{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, prev{spec = spec prev >> Hspec.afterAll_ ioTeardown (spec after)}) + +-- | Lifted 'Hspec.around_' +around_ :: (HasCallStack, Hspec :> es) => (Eff es () -> Eff es ()) -> Eff es a -> Eff es a +around_ wrapper action = do + ioWrapper <- + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + pure (unlift . wrapper . unsafeEff_) + stateStaticRepM \prev -> do + putStaticRep prev{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, prev{spec = spec prev >> Hspec.around_ ioWrapper (spec after)}) + +-- | Lifted 'Hspec.aroundAll_' +aroundAll_ :: (HasCallStack, Hspec :> es) => (Eff es () -> Eff es ()) -> Eff es a -> Eff es a +aroundAll_ wrapper action = do + ioWrapper <- + unsafeConcUnliftIO Ephemeral Unlimited \unlift -> + pure (unlift . wrapper . unsafeEff_) + stateStaticRepM \prev -> do + putStaticRep prev{spec = pure ()} + result <- action + after <- getStaticRep + pure (result, prev{spec = spec prev >> Hspec.aroundAll_ ioWrapper (spec after)}) + +expectationFailure :: (HasCallStack, Hspec :> es) => String -> Expectation es +expectationFailure msg = hunit $ HUnit.assertFailure msg + +expectTrue + :: (HasCallStack, Hspec :> es) + => String + -> Bool + -> Expectation es +expectTrue msg b = unless b (expectationFailure msg) + +infix 1 `shouldBe` + , `shouldSatisfy` + , `shouldStartWith` + , `shouldEndWith` + , `shouldContain` + , `shouldMatchList` + , `shouldReturn` + , `shouldThrow` + +infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn` + +-- | +-- @actual \`shouldBe\` expected@ sets the expectation that @actual@ is equal +-- to @expected@. +shouldBe :: (HasCallStack, Show a, Eq a, Hspec :> es) => a -> a -> Expectation es +actual `shouldBe` expected = hunit $ actual @?= expected + +-- | +-- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@. +shouldSatisfy :: (HasCallStack, Show a, Hspec :> es) => a -> (a -> Bool) -> Expectation es +v `shouldSatisfy` p = expectTrue ("predicate failed on: " ++ show v) (p v) + +compareWith + :: (HasCallStack, Show a, Hspec :> es) + => (a -> a -> Bool) + -> String + -> a + -> a + -> Expectation es +compareWith comparator errorDesc result expected = expectTrue errorMsg (comparator expected result) + where + errorMsg = show result ++ " " ++ errorDesc ++ " " ++ show expected + +-- | +-- @list \`shouldStartWith\` prefix@ sets the expectation that @list@ starts with @prefix@, +shouldStartWith :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es +shouldStartWith = compareWith List.isPrefixOf "does not start with" + +-- | +-- @list \`shouldEndWith\` suffix@ sets the expectation that @list@ ends with @suffix@, +shouldEndWith :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es +shouldEndWith = compareWith List.isSuffixOf "does not end with" + +-- | +-- @list \`shouldContain\` sublist@ sets the expectation that @sublist@ is contained, +-- wholly and intact, anywhere in @list@. +shouldContain :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es +shouldContain = compareWith List.isInfixOf "does not contain" + +-- | +-- @xs \`shouldMatchList\` ys@ sets the expectation that @xs@ has the same +-- elements that @ys@ has, possibly in another order +shouldMatchList :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es +xs `shouldMatchList` ys = maybe (return ()) expectationFailure (matchList xs ys) + +-- | +-- @action \`shouldReturn\` expected@ sets the expectation that @action@ +-- returns @expected@. +shouldReturn :: (HasCallStack, Show a, Eq a, Hspec :> es) => Eff es a -> a -> Expectation es +action `shouldReturn` expected = action >>= (`shouldBe` expected) + +-- | +-- @actual \`shouldNotBe\` notExpected@ sets the expectation that @actual@ is not +-- equal to @notExpected@ +shouldNotBe :: (HasCallStack, Show a, Eq a, Hspec :> es) => a -> a -> Expectation es +actual `shouldNotBe` notExpected = expectTrue ("not expected: " ++ show actual) (actual /= notExpected) + +-- | +-- @v \`shouldNotSatisfy\` p@ sets the expectation that @p v@ is @False@. +shouldNotSatisfy :: (HasCallStack, Show a, Hspec :> es) => a -> (a -> Bool) -> Expectation es +v `shouldNotSatisfy` p = expectTrue ("predicate succeeded on: " ++ show v) ((not . p) v) + +-- | +-- @list \`shouldNotContain\` sublist@ sets the expectation that @sublist@ is not +-- contained anywhere in @list@. +shouldNotContain :: (HasCallStack, Show a, Eq a, Hspec :> es) => [a] -> [a] -> Expectation es +list `shouldNotContain` sublist = expectTrue errorMsg (not $ sublist `List.isInfixOf` list) + where + errorMsg = show list ++ " does contain " ++ show sublist + +-- | +-- @action \`shouldNotReturn\` notExpected@ sets the expectation that @action@ +-- does not return @notExpected@. +shouldNotReturn + :: (HasCallStack, Show a, Eq a, Hspec :> es) + => Eff es a + -> a + -> Expectation es +action `shouldNotReturn` notExpected = action >>= (`shouldNotBe` notExpected) + +-- | +-- @action \`shouldThrow\` selector@ sets the expectation that @action@ throws +-- an exception. The precise nature of the expected exception is described +-- with a 'Selector'. +shouldThrow + :: (HasCallStack, Exception e, Hspec :> es) + => Eff es a + -> Selector e + -> Expectation es +action `shouldThrow` p = do + r <- try action + case r of + Right _ -> + expectationFailure $ + "did not get expected exception: " ++ exceptionType + Left e -> + (`expectTrue` p e) $ + "predicate failed on expected exception: " ++ exceptionType ++ "\n" ++ show e + where + -- a string representation of the expected exception's type + exceptionType = (show . typeOf . instanceOf) p + where + instanceOf :: Selector a -> a + instanceOf _ = error "Effectful.Hspec.shouldThrow: broken Typeable instance" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -Wno-missing-local-signatures #-} +{-# OPTIONS_GHC -Wno-monomorphism-restriction #-} +{-# OPTIONS_GHC -Wno-type-defaults #-} + +module Main where + +import Effectful +import Effectful.Hspec +import Prelude + +main :: IO () +main = runEff . runHspec $ do + it "shouldBe" $ do + 10 `shouldBe` 10 + + it "shouldSatisfy" $ do + 10 `shouldSatisfy` (> 5) + + let xs = [1, 2, 3, 4, 5] :: [Int] + it "shouldStartWith" $ do + xs `shouldStartWith` [1, 2] + + it "shouldEndWith" $ do + xs `shouldEndWith` [4, 5] + + it "shouldContain" $ do + [1, 2, 3] `shouldContain` [2] + + it "shouldMatchList" $ do + [1, 2, 3] `shouldMatchList` [3, 2, 1] + + it "shouldReturn" $ do + let action = pure "hello" + action `shouldReturn` "hello" + + it "shouldThrow" $ do + let errorAction = error "boom" :: Eff es () + errorAction `shouldThrow` anyException + + it "shouldNotBe" do + 1 `shouldNotBe` 2 + + it "shouldNotSatisfy" do + 1 `shouldNotSatisfy` (> 10) + + it "shouldNotContain" do + [1, 2] `shouldNotContain` [3] + + it "handles shouldNotReturn" $ do + let action = pure (1 :: Int) :: Eff es Int + action `shouldNotReturn` 2