daytripper (empty) → 0.1.0

raw patch · 4 files changed

+345/−0 lines, 4 filesdep +basedep +bytestringdep +daytripper

Dependencies added: base, bytestring, daytripper, directory, falsify, optparse-applicative, tagged, tasty, tasty-hunit

Files

README.md +9/−0
daytripper.cabal +114/−0
src/Test/Daytripper.hs +186/−0
test/Main.hs +36/−0

+ README.md view

@@ -0,0 +1,9 @@+# daytripper++Helpers for round-trip tests++You can control some parameters through Tasty:++`--daydripper-write-missing` or `TASTY_DAYTRIPPER_WRITE_MISSING=True` will write golden files if not found.++`--falsify-tests=N` or `TASTY_FALSIFY_TESTS=N` will set the number of tests per property.

+ daytripper.cabal view

@@ -0,0 +1,114 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           daytripper+version:        0.1.0+synopsis:       Helpers for round-trip tests+description:    Please see the README on GitHub at <https://github.com/ejconlon/daytripper#readme>+homepage:       https://github.com/ejconlon/daytripper#readme+bug-reports:    https://github.com/ejconlon/daytripper/issues+author:         Eric Conlon+maintainer:     ejconlon@gmail.com+copyright:      (c) 2023 Eric Conlon+license:        BSD3+build-type:     Simple+tested-with:+    GHC == 9.2.7+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/ejconlon/daytripper++library+  exposed-modules:+      Test.Daytripper+  other-modules:+      Paths_daytripper+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      ConstraintKinds+      DataKinds+      DeriveFunctor+      DeriveFoldable+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      KindSignatures+      MultiParamTypeClasses+      Rank2Types+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds+  build-depends:+      base >=4.12 && <5+    , bytestring ==0.11.*+    , directory ==1.3.*+    , falsify ==0.1.*+    , optparse-applicative ==0.17.*+    , tagged ==0.8.*+    , tasty ==1.4.*+    , tasty-hunit ==0.10.*+  default-language: GHC2021++test-suite daytripper-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_daytripper+  hs-source-dirs:+      test+  default-extensions:+      BangPatterns+      ConstraintKinds+      DataKinds+      DeriveFunctor+      DeriveFoldable+      DeriveGeneric+      DeriveTraversable+      DerivingStrategies+      DerivingVia+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      LambdaCase+      KindSignatures+      MultiParamTypeClasses+      Rank2Types+      ScopedTypeVariables+      StandaloneDeriving+      TupleSections+      TypeApplications+      TypeOperators+      TypeFamilies+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >=4.12 && <5+    , bytestring ==0.11.*+    , daytripper+    , directory ==1.3.*+    , falsify ==0.1.*+    , optparse-applicative ==0.17.*+    , tagged ==0.8.*+    , tasty ==1.4.*+    , tasty-hunit ==0.10.*+  default-language: GHC2021

+ src/Test/Daytripper.hs view

@@ -0,0 +1,186 @@+module Test.Daytripper+  ( MonadExpect (..)+  , Expect+  , expectBefore+  , expectDuring+  , expectAfter+  , mkExpect+  , RT+  , mkPropRT+  , mkFileRT+  , mkUnitRT+  , testRT+  , DaytripperWriteMissing (..)+  , daytripperIngredients+  , daytripperMain+  )+where++import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Foldable (for_)+import Data.Proxy (Proxy (..))+import Data.Tagged (Tagged, untag)+import Options.Applicative (flag', help, long)+import System.Directory (doesFileExist)+import System.IO.Unsafe (unsafePerformIO)+import Test.Falsify.Generator (Gen)+import Test.Falsify.Predicate qualified as FR+import Test.Falsify.Property (Property)+import Test.Falsify.Property qualified as FP+import Test.Tasty (TestName, TestTree, askOption, defaultIngredients, defaultMainWithIngredients, includingOptions)+import Test.Tasty.Falsify (testProperty)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.Ingredients (Ingredient)+import Test.Tasty.Options (IsOption (..), OptionDescription (..), safeRead)++-- | Interface for asserting and performing IO in tests.+-- TODO Migrate to 'MonadIO' superclass when Falsify supports it.+class MonadFail m => MonadExpect m where+  expectLiftIO :: IO a -> m a+  expectAssertEq :: (Eq a, Show a) => a -> a -> m ()++instance MonadExpect IO where+  expectLiftIO = id+  expectAssertEq = (@?=)++instance MonadExpect Property where+  expectLiftIO = pure . unsafePerformIO+  expectAssertEq x y = FP.assert (FR.eq FR..$ ("LHS", x) FR..$ ("RHS", y))++-- | A general type of test expectation. Captures two stages of processing an input,+-- first encoding, then decoding. The monad is typically something implementing+-- 'MonadExpect', with assertions performed before returning values for further processing.+-- The input is possibly missing, in which case we test decoding only.+type Expect m a b c = Either b a -> m (b, m c)++-- | Assert something before processing (before encoding and before decoding)+expectBefore :: Monad m => (a -> m ()) -> Expect m a b c -> Expect m a b c+expectBefore f ex i = for_ i f >> ex i++-- | Assert something during processing (after encoding and before decoding)+expectDuring :: Monad m => (a -> b -> m ()) -> Expect m a b c -> Expect m a b c+expectDuring f ex i = ex i >>= \p@(b, _) -> p <$ for_ i (`f` b)++-- | Asserting something after processing (after encoding and after decoding)+expectAfter :: Monad m => (a -> b -> c -> m ()) -> Expect m a b c -> Expect m a b c+expectAfter f ex i = ex i >>= \(b, end) -> end >>= \c -> (b, pure c) <$ for_ i (\a -> f a b c)++-- | One way of definining expectations from a pair of encode/decode functions.+-- Generalizes decoding in 'Maybe' or 'Either'.+mkExpect+  :: (MonadExpect m, Eq (f a), Show (f a), Applicative f)+  => (a -> m b)+  -> (b -> m (f a))+  -> Expect m a b (f a)+mkExpect f g i = do+  b <- either pure f i+  pure . (b,) $ do+    fa <- g b+    for_ i (expectAssertEq fa . pure)+    pure fa++-- | Simple way to run an expectation, ignoring the intermediate value.+runExpect :: Monad m => Expect m a b c -> a -> m c+runExpect f a = f (Right a) >>= snd++data PropRT where+  PropRT :: Show a => TestName -> Expect Property a b c -> Gen a -> PropRT++-- | Create a property-based roundtrip test+mkPropRT :: Show a => TestName -> Expect Property a b c -> Gen a -> RT+mkPropRT name expec gen = RTProp (PropRT name expec gen)++testPropRT :: PropRT -> TestTree+testPropRT (PropRT name expec gen) =+  testProperty name (FP.gen gen >>= void . runExpect expec)++data FileRT where+  FileRT+    :: TestName+    -> Expect IO a ByteString c+    -> FilePath+    -> Maybe a+    -> FileRT++-- | Create a file-based ("golden") roundtrip test+mkFileRT+  :: TestName+  -> Expect IO a ByteString c+  -> FilePath+  -> Maybe a+  -> RT+mkFileRT name expec fn mval = RTFile (FileRT name expec fn mval)++testFileRT :: FileRT -> TestTree+testFileRT (FileRT name expec fn mval) = askOption $ \dwm ->+  testCase name $ do+    exists <- doesFileExist fn+    (mcon, eval) <-+      if exists+        then do+          con <- BS.readFile fn+          pure (Just con, maybe (Left con) Right mval)+        else case (dwm, mval) of+          (DaytripperWriteMissing True, Just val) -> pure (Nothing, Right val)+          _ -> fail ("File missing: " ++ fn)+    (bs, end) <- expec eval+    for_ mcon (bs @?=)+    _ <- end+    case mcon of+      Nothing -> BS.writeFile fn bs+      Just _ -> pure ()++data UnitRT where+  UnitRT :: TestName -> Expect IO a b c -> a -> UnitRT++-- | Create a unit roundtrip test+mkUnitRT :: TestName -> Expect IO a b c -> a -> RT+mkUnitRT name expec val = RTUnit (UnitRT name expec val)++testUnitRT :: UnitRT -> TestTree+testUnitRT (UnitRT name expec val) =+  testCase name (void (runExpect expec val))++data RT+  = RTProp !PropRT+  | RTFile !FileRT+  | RTUnit !UnitRT++-- | Run a roundtrip test+testRT :: RT -> TestTree+testRT = \case+  RTProp x -> testPropRT x+  RTFile x -> testFileRT x+  RTUnit x -> testUnitRT x++-- | By passing the appropriate arguments to Tasty (`--daytripper-write-missing` or+-- `TASTY_DAYTRIPPER_WRITE_MISSING=True`) we can fill in the contents of missing files+-- with the results of running tests.+newtype DaytripperWriteMissing = DaytripperWriteMissing {unDaytripperWriteMissing :: Bool}+  deriving stock (Show)+  deriving newtype (Eq, Ord)++instance IsOption DaytripperWriteMissing where+  defaultValue = DaytripperWriteMissing False+  parseValue = fmap DaytripperWriteMissing . safeRead+  optionName = return "daytripper-write-missing"+  optionHelp = return "Write missing test files"+  optionCLParser =+    DaytripperWriteMissing+      <$> flag'+        True+        ( long (untag (optionName :: Tagged DaytripperWriteMissing String))+            <> help (untag (optionHelp :: Tagged DaytripperWriteMissing String))+        )++-- | Tasty ingredients with write-missing support+daytripperIngredients :: [Ingredient]+daytripperIngredients =+  includingOptions [Option (Proxy :: Proxy DaytripperWriteMissing)]+    : defaultIngredients++-- | Tasty main with write-missing support+daytripperMain :: TestTree -> IO ()+daytripperMain = defaultMainWithIngredients daytripperIngredients

+ test/Main.hs view

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module Main+  ( main+  )+where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Test.Daytripper (Expect, MonadExpect (..), daytripperMain, mkExpect, mkFileRT, mkPropRT, mkUnitRT, testRT)+import Test.Falsify.Generator qualified as Gen+import Test.Tasty (testGroup)++expec :: MonadExpect m => Expect m ByteString ByteString (Maybe ByteString)+expec = mkExpect enc dec+ where+  enc a = pure (a <> a)+  dec b =+    pure $+      let a = BS.take (div (BS.length b) 2) b+      in  if b == a <> a+            then Just a+            else Nothing++main :: IO ()+main =+  daytripperMain $+    testGroup "Daytripper" $+      fmap+        testRT+        [ mkPropRT "prop" expec (Gen.choose (pure "a") (pure "b"))+        , mkUnitRT "unit" expec "a"+        , mkFileRT "file just" expec "testdata/b.txt" (Just "b")+        , mkFileRT "file nothing" expec "testdata/c.txt" Nothing+        ]