quickcheck-state-machine 0.7.3 → 0.8.0
raw patch · 26 files changed
+1313/−1598 lines, 26 filesdep +MemoTriedep +base-compatdep +generics-sopdep −hs-rqlitedep −markov-chain-usage-modeldep −matrixdep ~QuickCheckdep ~aesondep ~ansi-wl-pprintsetup-changed
Dependencies added: MemoTrie, base-compat, generics-sop, pretty
Dependencies removed: hs-rqlite, markov-chain-usage-model, matrix, tree-diff
Dependency ranges changed: QuickCheck, aeson, ansi-wl-pprint, array, bifunctors, bytestring, containers, directory, doctest, exceptions, filelock, filepath, generic-data, graphviz, hashable, hashtables, http-client, monad-logger, mtl, network, persistent, persistent-postgresql, persistent-sqlite, persistent-template, postgresql-simple, pretty-show, process, quickcheck-instances, random, resource-pool, resourcet, servant, servant-client, servant-server, sop-core, split, stm, strict, string-conversions, tasty, tasty-hunit, tasty-quickcheck, text, time, unliftio, unliftio-core, vector, wai, warp
Files
- CHANGELOG.md +34/−0
- CONTRIBUTING.md +4/−3
- LICENSE +1/−1
- README.md +5/−1
- Setup.hs +0/−2
- quickcheck-state-machine.cabal +162/−163
- src/Test/StateMachine.hs +2/−4
- src/Test/StateMachine/Lockstep/NAry.hs +3/−3
- src/Test/StateMachine/Markov.hs +0/−532
- src/Test/StateMachine/Sequential.hs +11/−9
- src/Test/StateMachine/TreeDiff.hs +21/−0
- src/Test/StateMachine/TreeDiff/Class.hs +481/−0
- src/Test/StateMachine/TreeDiff/Expr.hs +102/−0
- src/Test/StateMachine/TreeDiff/List.hs +63/−0
- src/Test/StateMachine/TreeDiff/Pretty.hs +253/−0
- src/Test/StateMachine/TreeDiff/Tree.hs +98/−0
- src/Test/StateMachine/Types/References.hs +2/−2
- test/CrudWebserverDb.hs +4/−4
- test/Echo.hs +1/−2
- test/Hanoi.hs +3/−3
- test/ProcessRegistry.hs +4/−45
- test/RQlite.hs +0/−761
- test/SQLite.hs +48/−47
- test/Schema.hs +2/−2
- test/ShrinkingProps.hs +4/−4
- test/Spec.hs +5/−10
CHANGELOG.md view
@@ -1,3 +1,37 @@+#### 0.8.0 (2023-11-17)++* BREAKING CHANGE: Remove `markov-chain-usage-model` dependency and the related+ `Test.StateMachine.Markov` module. The tests of the dependency started+ failing:+ https://github.com/advancedtelematic/markov-chain-usage-model/issues/44 , and+ I don't think anyone is using that functionality anyway, so I decided to+ remove it (please let me know if this breaks your tests);++* Disable `ProcessRegistry` test for now, the generator needs to be migrated+ away from using the removed `Markov` module;++* Remove RQLite test as it was causing build issues with newer versions of GHC;++* Add support for newer versions of GHC (9.2.8, 9.4.7, and 9.6.3);++* Remove support for GHC 8.4.4, we need QuantifiedConstraints to build latest+ version of servant;++* Remove support for GHC 8.6.5 (released 23rd April 2019);++* Remove stack support;++* Add nix support;++* Add back CI support via GitHub Actions (remove old travis config);++* Remove the tree-diff dependency, and copy in the relevant bits that we need+ from the 0.0.2.1 version instead. The reason for this is that after that+ version the license was changed from BSD to GPL and pinning the dependency to+ that version doesn't compile with newer GHC versions, by inlining tree-diff we+ are in control of its dependecy bounds (and can thus make it compile with+ newer versions of GHC).+ #### 0.7.3 (2023-6-1) * Fix compatibility with GHC 9.6 (PR #20, thanks @erikd);
CONTRIBUTING.md view
@@ -4,10 +4,11 @@ 1. Update CHANGELOG.md; 2. Bump version in .cabal file and fix bounds;- 3. Make tarball with `stack sdist --pvp-bounds lower`;- 4. Upload tarball as a+ 3. Check cabal file with `cabal check`;+ 4. Make tarball with `cabal sdist`;+ 5. Upload tarball as a package [candidate](https://hackage.haskell.org/packages/candidates/upload), and if everything looks good then release it;- 5. Git tag the version: `git tag -a v$VERSION -m "Tag v$VERISON" && git push+ 6. Git tag the version: `git tag -a v$VERSION -m "Tag v$VERISON" && git push origin v$VERSION`.
LICENSE view
@@ -1,7 +1,7 @@ Copyright (c) 2017-2023 Stevan Andjelkovic, Daniel Gustafsson, Jacob Stanley, Xia Li-yao, Robert Danitz, Thomas Winant, Edsko de Vries, Momoko Hattori, Kostas Dermentzis, Adam Boniecki,- Javier Sagredo+ Javier Sagredo, Oleg Grenrus All rights reserved.
README.md view
@@ -1,6 +1,10 @@ ## quickcheck-state-machine [](https://hackage.haskell.org/package/quickcheck-state-machine)+[](https://github.com/stevana/quickcheck-state-machine/actions)+[](http://stackage.org/nightly/package/quickcheck-state-machine)+[](http://stackage.org/lts/package/quickcheck-state-machine) `quickcheck-state-machine` is a Haskell library, based on [QuickCheck](https://hackage.haskell.org/package/QuickCheck), for testing@@ -637,7 +641,7 @@ directory. To get a better feel for the examples it might be helpful to `git clone` this-repo, `cd` into it, fire up `stack ghci --test`, load the different examples,+repo, `cd` into it, fire up `cabal repl test`, load the different examples, e.g. `:l test/CrudWebserverDb.hs`, and run the different properties interactively.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
quickcheck-state-machine.cabal view
@@ -1,173 +1,172 @@-name: quickcheck-state-machine-version: 0.7.3-synopsis: Test monadic programs using state machine based models-description: See README at <https://github.com/stevana/quickcheck-state-machine#readme>-homepage: https://github.com/stevana/quickcheck-state-machine#readme-license: BSD3-license-file: LICENSE-author: Stevan Andjelkovic-maintainer: Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>-copyright: Copyright (C) 2017-2018, ATS Advanced Telematic Systems GmbH;- 2018-2019, HERE Europe B.V.;- 2019-2023, Stevan Andjelkovic.-category: Testing-build-type: Simple-extra-source-files: README.md- , CHANGELOG.md- , CONTRIBUTING.md-cabal-version: >=1.10-tested-with: GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.7, GHC == 9.6.1+cabal-version: 3.0+name: quickcheck-state-machine+version: 0.8.0+synopsis: Test monadic programs using state machine based models+description:+ See README at <https://github.com/stevana/quickcheck-state-machine#readme> +homepage: https://github.com/stevana/quickcheck-state-machine#readme+license: BSD-3-Clause+license-file: LICENSE+author: Stevan Andjelkovic+maintainer: Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>+copyright:+ Copyright (C) 2017-2018, ATS Advanced Telematic Systems GmbH;+ 2018-2019, HERE Europe B.V.;+ 2019-2023, Stevan Andjelkovic.++category: Testing+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ CONTRIBUTING.md+ README.md++tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.2.8 || ==9.4.7 || ==9.6.3+ library- hs-source-dirs: src- ghc-options:- -Weverything- -Wno-missing-exported-signatures- -Wno-missing-import-lists- -Wno-missed-specialisations- -Wno-all-missed-specialisations- -Wno-unsafe- -Wno-safe- -Wno-missing-local-signatures- -Wno-monomorphism-restriction- -Wno-prepositive-qualified-module- -Wno-missing-safe-haskell-mode- -Wno-missing-kind-signatures- exposed-modules: Test.StateMachine- , Test.StateMachine.BoxDrawer- , Test.StateMachine.ConstructorName- , Test.StateMachine.DotDrawing- , Test.StateMachine.Labelling- , Test.StateMachine.Lockstep.Auxiliary- , Test.StateMachine.Lockstep.NAry- , Test.StateMachine.Lockstep.Simple- , Test.StateMachine.Logic- , Test.StateMachine.Markov- , Test.StateMachine.Parallel- , Test.StateMachine.Sequential- , Test.StateMachine.Types- , Test.StateMachine.Types.Environment- , Test.StateMachine.Types.GenSym- , Test.StateMachine.Types.History- , Test.StateMachine.Types.Rank2- , Test.StateMachine.Types.References- , Test.StateMachine.Utils- , Test.StateMachine.Z- other-modules:- Paths_quickcheck_state_machine+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules:+ Test.StateMachine+ Test.StateMachine.BoxDrawer+ Test.StateMachine.ConstructorName+ Test.StateMachine.DotDrawing+ Test.StateMachine.Labelling+ Test.StateMachine.Lockstep.Auxiliary+ Test.StateMachine.Lockstep.NAry+ Test.StateMachine.Lockstep.Simple+ Test.StateMachine.Logic+ Test.StateMachine.Parallel+ Test.StateMachine.Sequential+ Test.StateMachine.TreeDiff+ Test.StateMachine.TreeDiff.Class+ Test.StateMachine.TreeDiff.Expr+ Test.StateMachine.TreeDiff.List+ Test.StateMachine.TreeDiff.Pretty+ Test.StateMachine.TreeDiff.Tree+ Test.StateMachine.Types+ Test.StateMachine.Types.Environment+ Test.StateMachine.Types.GenSym+ Test.StateMachine.Types.History+ Test.StateMachine.Types.Rank2+ Test.StateMachine.Types.References+ Test.StateMachine.Utils+ Test.StateMachine.Z++ other-modules: Paths_quickcheck_state_machine+ autogen-modules: Paths_quickcheck_state_machine++ -- GHC boot library dependencies:+ -- (https://gitlab.haskell.org/ghc/ghc/-/blob/master/packages) build-depends:- ansi-wl-pprint >=0.6.7.3,- base >=4.10 && <5,- containers >=0.5.7.1,- directory >=1.0.0.0,- exceptions >=0.8.3,- filepath >=1.0,- generic-data >=0.3.0.0,- graphviz >= 2999.20.0.3,- markov-chain-usage-model >=0.0.0,- matrix >=0.3.5.0,- mtl >=2.2.1,- time >=1.7,- pretty-show >=1.6.16,- process >=1.2.0.0,- QuickCheck >=2.12,- random >=1.1,- sop-core,- split,- text,- tree-diff >=0.0.2.1,- unliftio >=0.2.7.0- default-language: Haskell2010+ , base >=4.10 && <5+ , containers >=0.5.7.1 && <0.7+ , directory >=1.0.0.0 && <1.4+ , exceptions >=0.8.3 && <0.11+ , filepath >=1.0 && <1.5+ , mtl >=2.2.1 && <2.4+ , process >=1.2.0.0 && <1.7+ , text >=1.2.3.1 && <2.1+ , time >=1.7 && <1.13 -test-suite quickcheck-state-machine-test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs- build-depends: aeson,- array,- base,- bifunctors,- bytestring,- containers,- directory,- doctest,- filelock,- filepath,- hashable,- hashtables,- hs-rqlite >= 0.1.2.0,- http-client,- monad-logger,- mtl,- network,- -- if we want to use later versions of persistent, we- -- need to make some minor changes to the test suite:- persistent >= 2.10.4 && < 2.11,- persistent-postgresql,- persistent-sqlite < 2.11,- persistent-template < 2.11,- postgresql-simple,- pretty-show,- process,- QuickCheck,- quickcheck-instances,- quickcheck-state-machine,- random,- resourcet,- resource-pool,- servant,- servant-client,- servant-server,- split,- stm,- strict,- string-conversions,- tasty,- tasty-hunit,- tasty-quickcheck,- text,- tree-diff,- vector >=0.12.0.1,- wai,- warp,- unliftio,- unliftio-core+ build-depends:+ , ansi-wl-pprint >=0.6.7.3 && <1.1+ , generic-data >=0.3.0.0 && <1.2+ , graphviz >=2999.20.0.3 && <2999.21+ , pretty-show >=1.6.16 && <1.11+ , QuickCheck >=2.12 && <2.15+ , random >=1.1 && <1.3+ , sop-core >=0.5.0.2 && <0.6+ , split >=0.2.3.5 && <0.3+ , unliftio >=0.2.7.0 && <0.3 - other-modules: Bookstore,- CircularBuffer,- Cleanup,- CrudWebserverDb,- DieHard,- Echo,- ErrorEncountered,- Hanoi,- IORefs,- MemoryReference,- Mock,- Overflow,- ProcessRegistry,- Schema,- RQlite,- ShrinkingProps,- SQLite,- TicketDispenser,- UnionFind+ -- tree-diff dependencies:+ build-depends:+ , base-compat >=0.9.3 && <0.14+ , bytestring >=0.10.4.0 && <0.12+ , generics-sop >=0.3.1.0 && <0.6+ , MemoTrie >=0.6.8 && <0.7+ , pretty >=1.1.1.1 && <1.2+ , vector >=0.12.0.1 && <0.14 + default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ , aeson >=1.4.6.0 && <2.3+ , array >=0.5.4.0 && <0.6+ , base+ , bifunctors >=5.5.7 && <5.7+ , bytestring+ , containers+ , directory+ , doctest >=0.16.2 && <0.23+ , filelock >=0.1.1.4 && <0.2+ , filepath+ , hashable >=1.3.0.0 && <1.5+ , hashtables >=1.2.3.4 && <1.4+ , http-client >=0.6.4.1 && <0.8+ , monad-logger >=0.3.32 && <0.4+ , mtl+ , network >=3.1.1.1 && <3.2+ , persistent >=2.10.5.2 && <2.15+ , persistent-postgresql >=2.10.1.2 && <2.14+ , persistent-sqlite >=2.10.6.2 && <2.14+ , persistent-template >=2.8.2.3 && <2.13+ , postgresql-simple >=0.6.2 && <0.8+ , pretty-show+ , process+ , QuickCheck+ , quickcheck-instances >=0.3.22 && <0.4+ , quickcheck-state-machine+ , random+ , resource-pool >=0.2.3.2 && <0.5+ , resourcet >=1.2.3 && <1.4+ , servant >=0.16.2 && <0.21+ , servant-client >=0.16.0.1 && <0.21+ , servant-server >=0.16.2 && <0.21+ , split >=0.2.3.5 && <0.3+ , stm >=2.5.0.0 && <2.6+ , strict >=0.3.2 && <0.6+ , string-conversions >=0.4.0.1 && <0.5+ , tasty >=1.2.3 && <1.6+ , tasty-hunit >=0.10.0.2 && <0.11+ , tasty-quickcheck >=0.10.1.1 && <0.11+ , text+ , unliftio+ , unliftio-core >=0.1.2.0 && <0.3+ , vector+ , wai >=3.2.2.1 && <3.3+ , warp >=3.3.9 && <3.4++ other-modules:+ Bookstore+ CircularBuffer+ Cleanup+ CrudWebserverDb+ DieHard+ Echo+ ErrorEncountered+ Hanoi+ IORefs+ MemoryReference+ Mock+ Overflow+ ProcessRegistry+ Schema+ ShrinkingProps+ SQLite+ TicketDispenser+ UnionFind+ ghc-options:- -threaded -rtsopts -with-rtsopts=-N- -fno-ignore-asserts- -Weverything- -Wno-missing-exported-signatures- -Wno-missing-import-lists- -Wno-missed-specialisations- -Wno-all-missed-specialisations- -Wno-unsafe- -Wno-safe- -Wno-missing-local-signatures- -Wno-monomorphism-restriction- -Wno-prepositive-qualified-module- -Wno-missing-safe-haskell-mode- default-language: Haskell2010+ -threaded -rtsopts -with-rtsopts=-N -fno-ignore-asserts -Wall++ default-language: Haskell2010 source-repository head type: git
src/Test/StateMachine.hs view
@@ -69,7 +69,6 @@ , CommandNames(..) , module Test.StateMachine.Logic- , module Test.StateMachine.Markov -- * Re-export , ToExpr@@ -77,14 +76,13 @@ ) where -import Data.TreeDiff- (ToExpr, toExpr) import Prelude () import Test.StateMachine.ConstructorName import Test.StateMachine.Logic-import Test.StateMachine.Markov import Test.StateMachine.Parallel import Test.StateMachine.Sequential+import Test.StateMachine.TreeDiff+ (ToExpr, toExpr) import Test.StateMachine.Types
src/Test/StateMachine/Lockstep/NAry.hs view
@@ -61,17 +61,17 @@ import Prelude import Test.QuickCheck import Test.QuickCheck.Monadic-import Test.StateMachine- hiding (showLabelledExamples, showLabelledExamples')+import Test.StateMachine hiding+ (showLabelledExamples, showLabelledExamples') import qualified Data.Monoid as M-import qualified Data.TreeDiff as TD import qualified Test.StateMachine.Labelling as Label import qualified Test.StateMachine.Sequential as Seq import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.StateMachine.Lockstep.Auxiliary+import qualified Test.StateMachine.TreeDiff as TD {------------------------------------------------------------------------------- Test type-level parameters
− src/Test/StateMachine/Markov.hs
@@ -1,532 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---------------------------------------------------------------------------------- |--- Module : Test.StateMachine.Markov--- Copyright : (C) 2019, Stevan Andjelkovic--- License : BSD-style (see the file LICENSE)------ Maintainer : Stevan Andjelkovic <stevan.andjelkovic@strath.ac.uk>--- Stability : provisional--- Portability : non-portable (GHC extensions)------ This module contains helper functions for testing using Markov chains.-----------------------------------------------------------------------------------module Test.StateMachine.Markov- ( Markov- , makeMarkov- , toAdjacencyMap- , (-<)- , (>-)- , (/-)- , markovGenerator- , coverMarkov- , tabulateMarkov- , transitionMatrix- , stimulusMatrix- , historyObservations- , markovToDot- , markovToPs- , StatsDb(..)- , PropertyName- , nullStatsDb- , fileStatsDb- , persistStats- , computeReliability- , printReliability- , quickCheckReliability- , testChainToDot- )- where--import Control.Arrow- ((&&&))-import Data.Bifunctor- (bimap)-import Data.Either- (partitionEithers)-import Data.List- (genericLength)-import qualified Data.Set as Set-import Data.Map- (Map)-import qualified Data.Map as Map-import Data.Matrix- (Matrix, elementwise, fromLists, matrix, ncols,- nrows, submatrix, toLists, zero, getElem)-import Data.Maybe- (fromMaybe)-import Generic.Data- (FiniteEnum, GBounded, GEnum, gfiniteEnumFromTo,- gmaxBound, gminBound, gtoFiniteEnum, gfromFiniteEnum)-import GHC.Generics- (Generic, Rep)-import Prelude hiding- (readFile)-import System.Directory- (removeFile)-import System.FilePath.Posix- (replaceExtension)-import System.IO- (IOMode(ReadWriteMode), hGetContents, openFile)-import System.Process- (callProcess)-import Test.QuickCheck- (Gen, Property, Testable, coverTable, frequency,- property, quickCheck, tabulate)-import Test.QuickCheck.Monadic- (PropertyM, run)-import Test.QuickCheck.Property- (Callback(PostTest),- CallbackKind(NotCounterexample), callback)-import Text.Read- (readMaybe)--import MarkovChain--import Test.StateMachine.Logic- (boolean)-import Test.StateMachine.Types- (Command, Commands, Counter, History, Operation(..),- StateMachine(..), getCommand, makeOperations,- newCounter, unCommands, unHistory)-import Test.StateMachine.Types.GenSym- (runGenSym)-import Test.StateMachine.Types.References- (Concrete, Symbolic)------------------------------------------------------------------------------ | Markov chain.-newtype Markov state cmd_ prob = Markov- { unMarkov :: Map state [Transition state cmd_ prob] }--data Transition state cmd_ prob = Transition- { command :: cmd_- , probability :: prob- , to :: state- }---- | Constructor for 'Markov' chains.-makeMarkov :: Ord state- => [Map state [Transition state cmd_ prob]] -> Markov state cmd_ prob-makeMarkov = Markov . Map.unions---- | Expose inner graph structure of markov chain-toAdjacencyMap- :: Ord state- => Markov state cmd_ prob- -> Map state (Map state (cmd_, prob))-toAdjacencyMap (Markov m) =- fmap (foldr f mempty) m- where- f Transition{..} = Map.insert to (command, probability)--infixl 5 -<---- | Infix operator for starting to creating a transition in the 'Markov' chain,--- finish the transition with one of '(>-)' or '(/-)' depending on whether the--- transition has a specific or a uniform probability.-(-<) :: Fractional prob- => state -> [Either (cmd_, state) ((cmd_, prob), state)]- -> Map state [Transition state cmd_ prob]-from -< es = Map.singleton from (map go es)- where- go (Left (command, to)) = Transition command uniform to- go (Right ((command, probability), to)) = Transition {..}-- (ls, rs) = partitionEithers es- uniform = (100 - sum (map (snd . fst) rs)) / genericLength ls- -- ^ Note: If `length ls == 0` then `uniform` is not used, so division by- -- zero doesn't happen.--infixl 5 >----- | Finish making a transition with a specified probability distribution.-(>-) :: (cmd_, prob) -> state -> Either (cmd_, state) ((cmd_, prob), state)-(cmd, prob) >- state = Right ((cmd, prob), state)--infixl 5 /----- | Finish making a transition with an uniform probability distribution.-(/-) :: cmd_ -> state -> Either (cmd_, state) ((cmd_, prob), state)-cmd /- state = Left (cmd, state)------------------------------------------------------------------------------ | Create a generator from a 'Markov' chain.-markovGenerator :: forall state cmd_ cmd model. (Show state, Show cmd_)- => (Ord state, Ord cmd_)- => Markov state cmd_ Double- -> Map cmd_ (model Symbolic -> Gen (cmd Symbolic))- -> (model Symbolic -> state)- -> (state -> Bool)- -> (model Symbolic -> Maybe (Gen (cmd Symbolic)))-markovGenerator markov gens partition isSink model- | isSink (partition model) = Nothing- | otherwise = Just (frequency (go (partition model)))- where- go :: state -> [(Int, Gen (cmd Symbolic))]- go state- = map (round . probability- &&& (\cmd_ -> fromMaybe (errMissing cmd_) (Map.lookup cmd_ gens) model) . command)- . fromMaybe errDeadlock- . Map.lookup state- . unMarkov- $ markov- where- errDeadlock = error- ("markovGenerator: deadlock, no commands can be generated in given state: "- ++ show state)-- errMissing cmd_ = error- ("markovGenerator: don't know how to generate the command: "- ++ show cmd_)---- | Variant of QuickCheck's 'coverTable' which works on 'Markov' chains.-coverMarkov :: (Show state, Show cmd_, Testable prop)- => Markov state cmd_ Double -> prop -> Property-coverMarkov markov prop = foldr go (property prop) (Map.toList (unMarkov markov))- where- go (from, ts) = coverTable (show from)- (map (\Transition{..} -> (toTransitionString command to, probability)) ts)--toTransitionString :: (Show state, Show cmd_) => cmd_ -> state -> String-toTransitionString cmd to = "-< " ++ show cmd ++ " >- " ++ show to---- | Variant of QuickCheck's 'tabulate' which works for 'Markov' chains.-tabulateMarkov :: forall model state cmd cmd_ m resp prop. Testable prop- => (Show state, Show cmd_)- => StateMachine model cmd m resp- -> (model Symbolic -> state)- -> (cmd Symbolic -> cmd_)- -> Commands cmd resp- -> prop- -> Property-tabulateMarkov sm partition constructor cmds0 =- tabulateTransitions (commandsToTransitions sm cmds0)- where- tabulateTransitions :: [(state, Transition state cmd_ prob)]- -> prop- -> Property- tabulateTransitions ts prop = foldr go (property prop) ts- where- go (from, Transition {..}) = tabulate (show from) [ toTransitionString command to ]-- commandsToTransitions :: StateMachine model cmd m resp- -> Commands cmd resp- -> [(state, Transition state cmd_ ())]- commandsToTransitions StateMachine { initModel, transition, mock } =- go initModel newCounter [] . unCommands- where- go :: model Symbolic -> Counter -> [(state, Transition state cmd_ ())]- -> [Command cmd resp] -> [(state, Transition state cmd_ ())]- go _model _counter acc [] = acc- go model counter acc (cmd : cmds) = go model' counter' ((from, t) : acc) cmds- where- from = partition model- cmd' = getCommand cmd- model' = transition model cmd' resp-- (resp, counter') = runGenSym (mock model cmd') counter-- t = Transition- { command = constructor cmd'- , probability = ()- , to = partition model'- }----------------------------------------------------------------------------enumMatrix :: forall e a. (Generic e, GEnum FiniteEnum (Rep e), GBounded (Rep e))- => ((e, e) -> a)- -> Matrix a-enumMatrix f = matrix dimension dimension (f . bimap g g)- where- g :: Int -> e- g = gtoFiniteEnum . pred -- We need the predecessor because 'matrix' starts- -- indexing from 1.-- dimension :: Int- dimension = length es-- es :: [e]- es = gfiniteEnumFromTo gminBound gmaxBound--transitionMatrix :: forall state cmd_. Ord state- => (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))- => Markov state cmd_ Double- -> Matrix Double-transitionMatrix markov = enumMatrix go- where- go :: (state, state) -> Double- go (state, state') = fromMaybe 0- (Map.lookup state' =<< Map.lookup state availableStates)-- availableStates :: Map state (Map state Double)- availableStates- = fmap (Map.fromList . map (to &&& (/ 100) . probability))- . unMarkov- $ markov--enumMatrix'- :: forall state cmd a- . (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))- => (Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd))- => ((state, cmd) -> a)- -> Matrix a-enumMatrix' f = matrix m n (f . bimap g h)- where- g :: Int -> state- g = gtoFiniteEnum . pred -- We need the predecessor because 'matrix' starts- -- indexing from 1.-- h :: Int -> cmd- h = gtoFiniteEnum . pred-- m :: Int- m = length states-- n :: Int- n = length cmds-- states :: [state]- states = gfiniteEnumFromTo gminBound gmaxBound-- cmds :: [cmd]- cmds = gfiniteEnumFromTo gminBound gmaxBound--stimulusMatrix- :: forall state cmd. (Ord state, Ord cmd)- => (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))- => (Generic cmd, GEnum FiniteEnum (Rep cmd), GBounded (Rep cmd))- => Markov state cmd Double- -> Matrix Double-stimulusMatrix markov = enumMatrix' go- where- go :: (state, cmd) -> Double- go (state, cmd) = fromMaybe 0- (Map.lookup cmd =<< Map.lookup state availableCmds)-- availableCmds :: Map state (Map cmd Double)- availableCmds- = fmap (Map.fromList . map (command &&& (/ 100) . probability))- . unMarkov- $ markov----------------------------------------------------------------------------historyObservations :: forall model cmd m resp state cmd_ prob. Ord state- => Ord cmd_- => (Generic state, GEnum FiniteEnum (Rep state), GBounded (Rep state))- => StateMachine model cmd m resp- -> Markov state cmd_ prob- -> (model Concrete -> state)- -> (cmd Concrete -> cmd_)- -> History cmd resp- -> ( Matrix Double- , Matrix Double- )-historyObservations StateMachine { initModel, transition, postcondition } markov partition constructor- = go initModel Map.empty Map.empty . makeOperations . unHistory- where- go _model ss fs [] =- ( enumMatrix @state (fromMaybe 0 . flip Map.lookup ss)- , enumMatrix @state (fromMaybe 0 . flip Map.lookup fs)- )- go model ss fs (op : ops) = case op of- Operation cmd resp _pid ->- let- state = partition model- model' = transition model cmd resp- state' = partition model'- incr = Map.insertWith (\_new old -> old + 1) (state, state') 1- in- if boolean (postcondition model cmd resp)- then go model' (incr ss) fs ops- else go model' ss (incr fs) ops-- Crash cmd _err _pid ->- let- state = partition model- state' = fromMaybe err- (Map.lookup (constructor cmd) =<< Map.lookup state nextState)- incr = Map.insertWith (\_new old -> old + 1) (state, state') 1- in- go model ss (incr fs) ops- where- err = error "historyObservations: impossible."-- nextState :: Map state (Map cmd_ state)- nextState- = fmap (Map.fromList . map (command &&& to))- . unMarkov- $ markov----------------------------------------------------------------------------markovToDot :: (Show state, Show cmd_, Show prob)- => state -> state -> Markov state cmd_ prob -> String-markovToDot source sink = go ("digraph g {\n" ++ nodeColours) . Map.toList . unMarkov- where- nodeColours :: String- nodeColours = string (show source) ++ " [color=\"green\"]\n" ++- string (show sink) ++ " [color=\"red\"]\n"-- go acc [] = acc ++ "}"- go acc ((from, via) : more) = go acc' more- where- acc' :: String- acc' = acc ++- unlines [ string (show from) ++- " -> " ++- string (show to) ++- " [label=" ++ string (show cmd ++ "\\n(" ++ show prob ++ "%)") ++ "]"- | Transition cmd prob to <- via- ]--string :: String -> String-string s = "\"" ++ s ++ "\""--markovToPs :: (Show state, Show cmd_, Show prob)- => state -> state -> Markov state cmd_ prob -> FilePath -> IO ()-markovToPs source sink markov out = do- let dotFile = replaceExtension out "dot"- writeFile dotFile (markovToDot source sink markov)- callProcess "dot" ["-Tps", dotFile, "-o", out]----------------------------------------------------------------------------data StatsDb m = StatsDb- { store :: (Matrix Double, Matrix Double) -> m ()- , load :: m (Maybe (Matrix Double, Matrix Double))- }--type PropertyName = String--nullStatsDb :: Monad m => StatsDb m-nullStatsDb = StatsDb- { store = const (return ())- , load = return Nothing- }--fileStatsDb :: FilePath -> PropertyName -> StatsDb IO-fileStatsDb fp name = StatsDb- { store = store- , load = load- }- where- store :: (Matrix Double, Matrix Double) -> IO ()- store observed = do- appendFile (fp ++ "-" ++ name) (show (bimap toLists toLists observed) ++ "\n")-- load :: IO (Maybe (Matrix Double, Matrix Double))- load = do- mprior <- parse <$> readFile' (fp ++ "-" ++ name ++ "-cache")- mnew <- parseMany <$> readFile' (fp ++ "-" ++ name)-- let sumElem :: [Matrix Double] -> Matrix Double- sumElem = foldl1 (elementwise (+))-- let mprior' = case (mprior, mnew) of- (Just (sprior, fprior), Just new) ->- Just (bimap (sumElem . (sprior :)) (sumElem . (fprior :)) (unzip new))- (Nothing, Just new) -> Just (bimap sumElem sumElem (unzip new))- (Just prior, Nothing) -> Just prior- (Nothing, Nothing) -> Nothing-- case mprior' of- Just prior' -> writeFile (fp ++ "-" ++ name ++ "-cache") (show (bimap toLists toLists prior'))- Nothing -> return ()-- removeFile (fp ++ "-" ++ name)-- return mprior'-- where- parseMany :: String -> Maybe [(Matrix Double, Matrix Double)]- parseMany = mapM parse . lines-- parse :: String -> Maybe (Matrix Double, Matrix Double)- parse = fmap (bimap fromLists fromLists) . readMaybe-- readFile' :: FilePath -> IO String- readFile' file = hGetContents =<< openFile file ReadWriteMode--persistStats :: Monad m- => StatsDb m -> (Matrix Double, Matrix Double) -> PropertyM m ()-persistStats StatsDb { store } = run . store--computeReliability :: Monad m- => StatsDb m -> Matrix Double -> (Matrix Double, Matrix Double)- -> m (Double, Double)-computeReliability StatsDb { load } usage observed = do- mpriors <- load-- return (singleUseReliability (reduce usage) mpriors (bimap reduce reduce observed))- where- n = ncols usage- m = pred n- reduce = submatrix 1 m 1 n--printReliability :: Testable prop- => StatsDb IO -> Matrix Double -> (Matrix Double, Matrix Double)- -> prop -> Property-printReliability sdb usage observed = callback $ PostTest NotCounterexample $ \_state _result ->- print =<< computeReliability sdb usage observed--quickCheckReliability :: Testable prop- => StatsDb IO -> Matrix Double -> prop -> IO ()-quickCheckReliability sdb usage prop = do- quickCheck prop- print =<< computeReliability sdb usage observed- where- observed = ( zero (nrows usage) (ncols usage)- , zero (nrows usage) (ncols usage)- )--testChainToDot :: forall state cmd_ prob m. (Show state, Ord state, Monad m)- => (Generic state, GEnum FiniteEnum (Rep state))- => StatsDb m -> state -> state -> Markov state cmd_ prob -> m String-testChainToDot StatsDb { load } source sink markov = do- mpriors <- load- case mpriors of- Nothing -> error "testChainToDot: no test chain exists"- Just priors -> return- (go ("digraph g {\n" ++ nodeColours) priors markovStatePairs)- where- nodeColours :: String- nodeColours = string (show source) ++ " [color=\"green\"]\n" ++- string (show sink) ++ " [color=\"red\"]\n"-- go :: String -> (Matrix Double, Matrix Double) -> [(state, state)] -> String- go acc _priors [] = acc ++ "}"- go acc (successes, failures) ((from, to) : more) = go acc' (successes, failures) more- where- acc' :: String- acc' = acc ++- string (show from) ++- " -> " ++- string (show to) ++- " [label=<(<font color='green'>" ++ show (lookupStates from to successes) ++ "</font>"- ++ ", <font color='red'>" ++ show (lookupStates from to failures) ++ "</font>)>]\n"-- markovStatePairs :: [(state, state)]- markovStatePairs- = Set.toList- . foldl (\ih (from, tos) -> ih `Set.union`- foldl (\ih' to -> Set.insert (from, to) ih') Set.empty tos)- Set.empty- . map (fmap (map to))- . Map.toList- . unMarkov- $ markov-- lookupStates :: state -> state -> Matrix Double -> Int- lookupStates from to = round . getElem (gfromFiniteEnum from + 1) (gfromFiniteEnum to + 1)
src/Test/StateMachine/Sequential.hs view
@@ -56,11 +56,12 @@ where import Control.Exception- (SomeException, SomeAsyncException (..), displayException,- fromException)-import Control.Monad (when)+ (SomeAsyncException(..), SomeException,+ displayException, fromException)+import Control.Monad+ (when) import Control.Monad.Catch- (MonadCatch(..), MonadMask (..), catch, ExitCase (..))+ (ExitCase(..), MonadCatch(..), MonadMask(..), catch) import Control.Monad.State.Strict (StateT, evalStateT, get, lift, put, runStateT) import Data.Bifunctor@@ -81,9 +82,7 @@ (Proxy(..)) import qualified Data.Set as S import Data.Time- (defaultTimeLocale, formatTime, getZonedTime)-import Data.TreeDiff- (ToExpr, ansiWlBgEditExprCompact, ediff)+ (defaultTimeLocale, formatTime, getZonedTime) import Prelude import System.Directory (createDirectoryIfMissing)@@ -100,20 +99,23 @@ (PropertyM, run) import Test.QuickCheck.Random (mkQCGen)+import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.PrettyPrint.ANSI.Leijen (Doc)-import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Show.Pretty (ppShow) import UnliftIO (MonadIO, TChan, atomically, liftIO, newTChanIO, tryReadTChan, writeTChan)-import UnliftIO.Exception (throwIO)+import UnliftIO.Exception+ (throwIO) import Test.StateMachine.ConstructorName import Test.StateMachine.Labelling (Event(..), execCmds) import Test.StateMachine.Logic+import Test.StateMachine.TreeDiff+ (ToExpr, ansiWlBgEditExprCompact, ediff) import Test.StateMachine.Types import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.StateMachine.Utils
+ src/Test/StateMachine/TreeDiff.hs view
@@ -0,0 +1,21 @@+-- | Diffing of (expression) trees.+--+-- Diffing arbitrary Haskell data. First we convert values to untyped+-- haskell-like expression 'Expr' using generically derivable 'ToExpr' class.+-- Then we can diff two 'Expr' values.+-- The conversion and diffing is done by 'ediff' function.+-- See type and function haddocks for an examples.+--+-- Interesting modules:+--+-- * "Data.TreeDiff.Class" for a 'ToExpr' class and 'ediff' utility.+--+module Test.StateMachine.TreeDiff (+ module Test.StateMachine.TreeDiff.Expr,+ module Test.StateMachine.TreeDiff.Class,+ module Test.StateMachine.TreeDiff.Pretty,+ ) where++import Test.StateMachine.TreeDiff.Expr+import Test.StateMachine.TreeDiff.Class+import Test.StateMachine.TreeDiff.Pretty
+ src/Test/StateMachine/TreeDiff/Class.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | A 'ToExpr' class.+module Test.StateMachine.TreeDiff.Class (+ ediff,+ ediff',+ ToExpr (..),+ defaultExprViaShow,+ -- * SOP+ sopToExpr,+ ) where++import Data.Foldable (toList)+import Data.Proxy (Proxy (..))+import Test.StateMachine.TreeDiff.Expr+import Data.List.Compat (uncons)+import Generics.SOP+ (All, All2, ConstructorInfo (..), DatatypeInfo (..), FieldInfo (..),+ I (..), K (..), NP (..), SOP (..), constructorInfo, hcliftA2, hcmap,+ hcollapse, mapIK)+import Generics.SOP.GGP (GCode, GDatatypeInfo, GFrom, gdatatypeInfo, gfrom)+import GHC.Generics (Generic)++import qualified Data.Map as Map++-- Instances+import Control.Applicative (Const (..), ZipList (..))+import Data.Fixed (Fixed, HasResolution)+import Data.Functor.Identity (Identity (..))+import Data.Int+import Data.List.NonEmpty (NonEmpty (..))+import Data.Void (Void)+import Data.Word+import Numeric.Natural (Natural)++import qualified Data.Monoid as Mon+import qualified Data.Ratio as Ratio+import qualified Data.Semigroup as Semi++-- containers+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Tree as Tree++-- text+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT++-- time+import qualified Data.Time as Time++-- bytestring+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+-- import qualified Data.ByteString.Short as SBS++-- scientific+-- import qualified Data.Scientific as Sci++-- uuid-types+-- import qualified Data.UUID.Types as UUID++-- vector+import qualified Data.Vector as V+import qualified Data.Vector.Primitive as VP+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU++-- tagged+-- import Data.Tagged (Tagged (..))++-- hashable+-- import Data.Hashable (Hashed, unhashed)++-- unordered-containers+-- import qualified Data.HashMap.Strict as HM+-- import qualified Data.HashSet as HS++-- aeson+-- import qualified Data.Aeson as Aeson++-- | Difference between two 'ToExpr' values.+--+-- >>> let x = (1, Just 2) :: (Int, Maybe Int)+-- >>> let y = (1, Nothing)+-- >>> prettyEditExpr (ediff x y)+-- _×_ 1 -(Just 2) +Nothing+--+-- >>> data Foo = Foo { fooInt :: Either Char Int, fooBool :: [Maybe Bool], fooString :: String } deriving (Eq, Generic)+-- >>> instance ToExpr Foo+--+-- >>> prettyEditExpr $ ediff (Foo (Right 2) [Just True] "fo") (Foo (Right 3) [Just True] "fo")+-- Foo {fooBool = [Just True], fooInt = Right -2 +3, fooString = "fo"}+--+-- >>> prettyEditExpr $ ediff (Foo (Right 42) [Just True, Just False] "old") (Foo (Right 42) [Nothing, Just False, Just True] "new")+-- Foo+-- {fooBool = [-Just True, +Nothing, Just False, +Just True],+-- fooInt = Right 42,+-- fooString = -"old" +"new"}+--+ediff :: ToExpr a => a -> a -> Edit EditExpr+ediff x y = exprDiff (toExpr x) (toExpr y)++-- | Compare different types.+--+-- /Note:/ Use with care as you can end up comparing apples with oranges.+--+-- >>> prettyEditExpr $ ediff' ["foo", "bar"] [Just "foo", Nothing]+-- [-"foo", +Just "foo", -"bar", +Nothing]+--+ediff' :: (ToExpr a, ToExpr b) => a -> b -> Edit EditExpr+ediff' x y = exprDiff (toExpr x) (toExpr y)++-- | 'toExpr' converts a Haskell value into+-- untyped Haskell-like syntax tree, 'Expr'.+--+-- >>> toExpr ((1, Just 2) :: (Int, Maybe Int))+-- App "_\215_" [App "1" [],App "Just" [App "2" []]]+--+class ToExpr a where+ toExpr :: a -> Expr+ default toExpr+ :: (Generic a, All2 ToExpr (GCode a), GFrom a, GDatatypeInfo a)+ => a -> Expr+ toExpr x = sopToExpr (gdatatypeInfo (Proxy :: Proxy a)) (gfrom x)++ listToExpr :: [a] -> Expr+ listToExpr = Lst . map toExpr++instance ToExpr Expr where+ toExpr = id++-- | An alternative implementation for literal types. We use 'show'+-- representation of them.+defaultExprViaShow :: Show a => a -> Expr+defaultExprViaShow x = App (show x) []++-- | >>> prettyExpr $ sopToExpr (gdatatypeInfo (Proxy :: Proxy String)) (gfrom "foo")+-- _:_ 'f' "oo"+sopToExpr :: (All2 ToExpr xss) => DatatypeInfo xss -> SOP I xss -> Expr+sopToExpr di (SOP xss) = hcollapse $ hcliftA2+ (Proxy :: Proxy (All ToExpr))+ (\ci xs -> K (sopNPToExpr isNewtype ci xs))+ (constructorInfo di)+ xss+ where+ isNewtype = case di of+ Newtype {} -> True+ ADT {} -> False++sopNPToExpr :: All ToExpr xs => Bool -> ConstructorInfo xs -> NP I xs -> Expr+sopNPToExpr _ (Infix cn _ _) xs = App ("_" ++ cn ++ "_") $ hcollapse $+ hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs+sopNPToExpr _ (Constructor cn) xs = App cn $ hcollapse $+ hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs+sopNPToExpr True (Record cn _) xs = App cn $ hcollapse $+ hcmap (Proxy :: Proxy ToExpr) (mapIK toExpr) xs+sopNPToExpr False (Record cn fi) xs = Rec cn $ Map.fromList $ hcollapse $+ hcliftA2 (Proxy :: Proxy ToExpr) mk fi xs+ where+ mk :: ToExpr x => FieldInfo x -> I x -> K (FieldName, Expr) x+ mk (FieldInfo fn) (I x) = K (fn, toExpr x)++-------------------------------------------------------------------------------+-- Instances+-------------------------------------------------------------------------------++instance ToExpr () where toExpr = defaultExprViaShow+instance ToExpr Bool where toExpr = defaultExprViaShow+instance ToExpr Ordering where toExpr = defaultExprViaShow++instance ToExpr Integer where toExpr = defaultExprViaShow+instance ToExpr Natural where toExpr = defaultExprViaShow++instance ToExpr Float where toExpr = defaultExprViaShow+instance ToExpr Double where toExpr = defaultExprViaShow++instance ToExpr Int where toExpr = defaultExprViaShow+instance ToExpr Int8 where toExpr = defaultExprViaShow+instance ToExpr Int16 where toExpr = defaultExprViaShow+instance ToExpr Int32 where toExpr = defaultExprViaShow+instance ToExpr Int64 where toExpr = defaultExprViaShow++instance ToExpr Word where toExpr = defaultExprViaShow+instance ToExpr Word8 where toExpr = defaultExprViaShow+instance ToExpr Word16 where toExpr = defaultExprViaShow+instance ToExpr Word32 where toExpr = defaultExprViaShow+instance ToExpr Word64 where toExpr = defaultExprViaShow++instance ToExpr (Proxy a) where toExpr = defaultExprViaShow++-- | >>> prettyExpr $ toExpr 'a'+-- 'a'+--+-- >>> prettyExpr $ toExpr "Hello world"+-- "Hello world"+--+-- >>> prettyExpr $ toExpr "Hello\nworld"+-- concat ["Hello\n", "world"]+--+-- >>> traverse_ (print . prettyExpr . toExpr) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- concat ["foo\n", "bar"]+-- concat ["foo\n", "bar\n"]+--+instance ToExpr Char where+ toExpr = defaultExprViaShow+ listToExpr = stringToExpr "concat" . unconcat uncons++stringToExpr+ :: Show a+ => String -- ^ name of concat+ -> [a]+ -> Expr+stringToExpr _ [] = App "\"\"" []+stringToExpr _ [l] = defaultExprViaShow l+stringToExpr cn ls = App cn [Lst (map defaultExprViaShow ls)]++-- | Split on '\n'.+--+-- prop> \xs -> xs == concat (unconcat uncons xs)+unconcat :: forall a. (a -> Maybe (Char, a)) -> a -> [String]+unconcat uncons_ = go where+ go :: a -> [String]+ go xs = case span_ xs of+ ~(ys, zs)+ | null ys -> []+ | otherwise -> ys : go zs++ span_ :: a -> (String, a)+ span_ xs = case uncons_ xs of+ Nothing -> ("", xs)+ Just ~(x, xs')+ | x == '\n' -> ("\n", xs')+ | otherwise -> case span_ xs' of+ ~(ys, zs) -> (x : ys, zs)++instance ToExpr a => ToExpr (Maybe a) where+ toExpr Nothing = App "Nothing" []+ toExpr (Just x) = App "Just" [toExpr x]++instance (ToExpr a, ToExpr b) => ToExpr (Either a b) where+ toExpr (Left x) = App "Left" [toExpr x]+ toExpr (Right y) = App "Right" [toExpr y]++instance ToExpr a => ToExpr [a] where+ toExpr = listToExpr++instance (ToExpr a, ToExpr b) => ToExpr (a, b) where+ toExpr (a, b) = App "_×_" [toExpr a, toExpr b]+instance (ToExpr a, ToExpr b, ToExpr c) => ToExpr (a, b, c) where+ toExpr (a, b, c) = App "_×_×_" [toExpr a, toExpr b, toExpr c]+instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d) => ToExpr (a, b, c, d) where+ toExpr (a, b, c, d) = App "_×_×_×_" [toExpr a, toExpr b, toExpr c, toExpr d]+instance (ToExpr a, ToExpr b, ToExpr c, ToExpr d, ToExpr e) => ToExpr (a, b, c, d, e) where+ toExpr (a, b, c, d, e) = App "_×_×_×_×_" [toExpr a, toExpr b, toExpr c, toExpr d, toExpr e]++-- | >>> prettyExpr $ toExpr (3 % 12 :: Rational)+-- _%_ 1 4+instance (ToExpr a, Integral a) => ToExpr (Ratio.Ratio a) where+ toExpr r = App "_%_" [ toExpr $ Ratio.numerator r, toExpr $ Ratio.denominator r ]+instance HasResolution a => ToExpr (Fixed a) where toExpr = defaultExprViaShow++-- | >>> prettyExpr $ toExpr $ Identity 'a'+-- Identity 'a'+instance ToExpr a => ToExpr (Identity a) where+ toExpr (Identity x) = App "Identity" [toExpr x]++instance ToExpr a => ToExpr (Const a b)+instance ToExpr a => ToExpr (ZipList a)++instance ToExpr a => ToExpr (NonEmpty a) where+ toExpr (x :| xs) = App "NE.fromList" [toExpr (x : xs)]++instance ToExpr Void where+ toExpr _ = App "error" [toExpr "Void"]++-------------------------------------------------------------------------------+-- Monoid/semigroups+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (Mon.Dual a) where+instance ToExpr a => ToExpr (Mon.Sum a) where+instance ToExpr a => ToExpr (Mon.Product a) where+instance ToExpr a => ToExpr (Mon.First a) where+instance ToExpr a => ToExpr (Mon.Last a) where++-- instance ToExpr a => ToExpr (Semi.Option a) where+instance ToExpr a => ToExpr (Semi.Min a) where+instance ToExpr a => ToExpr (Semi.Max a) where+instance ToExpr a => ToExpr (Semi.First a) where+instance ToExpr a => ToExpr (Semi.Last a) where++-------------------------------------------------------------------------------+-- containers+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (Tree.Tree a) where+ toExpr (Tree.Node x xs) = App "Node" [toExpr x, toExpr xs]++instance (ToExpr k, ToExpr v) => ToExpr (Map.Map k v) where+ toExpr x = App "Map.fromList" [ toExpr $ Map.toList x ]+instance (ToExpr k) => ToExpr (Set.Set k) where+ toExpr x = App "Set.fromList" [ toExpr $ Set.toList x ]+instance (ToExpr v) => ToExpr (IntMap.IntMap v) where+ toExpr x = App "IntMap.fromList" [ toExpr $ IntMap.toList x ]+instance ToExpr IntSet.IntSet where+ toExpr x = App "IntSet.fromList" [ toExpr $ IntSet.toList x ]+instance (ToExpr v) => ToExpr (Seq.Seq v) where+ toExpr x = App "Seq.fromList" [ toExpr $ toList x ]++-------------------------------------------------------------------------------+-- text+-------------------------------------------------------------------------------++-- | >>> traverse_ (print . prettyExpr . toExpr . LT.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- LT.concat ["foo\n", "bar"]+-- LT.concat ["foo\n", "bar\n"]+instance ToExpr LT.Text where+ toExpr = stringToExpr "LT.concat" . unconcat LT.uncons++-- | >>> traverse_ (print . prettyExpr . toExpr . T.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- T.concat ["foo\n", "bar"]+-- T.concat ["foo\n", "bar\n"]+instance ToExpr T.Text where+ toExpr = stringToExpr "T.concat" . unconcat T.uncons++-------------------------------------------------------------------------------+-- time+-------------------------------------------------------------------------------++-- | >>> prettyExpr $ toExpr $ ModifiedJulianDay 58014+-- Day "2017-09-18"+instance ToExpr Time.Day where+ toExpr d = App "Day" [ toExpr (show d) ]++instance ToExpr Time.UTCTime where+ toExpr t = App "UTCTime" [ toExpr (show t) ]++-------------------------------------------------------------------------------+-- bytestring+-------------------------------------------------------------------------------++-- | >>> traverse_ (print . prettyExpr . toExpr . LBS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- LBS.concat ["foo\n", "bar"]+-- LBS.concat ["foo\n", "bar\n"]+instance ToExpr LBS.ByteString where+ toExpr = stringToExpr "LBS.concat" . bsUnconcat LBS.null LBS.elemIndex LBS.splitAt++-- | >>> traverse_ (print . prettyExpr . toExpr . BS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- BS.concat ["foo\n", "bar"]+-- BS.concat ["foo\n", "bar\n"]+instance ToExpr BS.ByteString where+ toExpr = stringToExpr "BS.concat" . bsUnconcat BS.null BS.elemIndex BS.splitAt++-- | >>> traverse_ (print . prettyExpr . toExpr . SBS.toShort . BS8.pack) ["", "\n", "foo", "foo\n", "foo\nbar", "foo\nbar\n"]+-- ""+-- "\n"+-- "foo"+-- "foo\n"+-- mconcat ["foo\n", "bar"]+-- mconcat ["foo\n", "bar\n"]+-- instance ToExpr SBS.ShortByteString where+-- toExpr = stringToExpr "mconcat" . bsUnconcat BS.null BS.elemIndex BS.splitAt . SBS.fromShort++bsUnconcat+ :: forall bs int. Num int+ => (bs -> Bool)+ -> (Word8 -> bs -> Maybe int)+ -> (int -> bs -> (bs, bs))+ -> bs+ -> [bs]+bsUnconcat null_ elemIndex_ splitAt_ = go where+ go :: bs -> [bs]+ go bs+ | null_ bs = []+ | otherwise = case elemIndex_ 10 bs of+ Nothing -> [bs]+ Just i -> case splitAt_ (i + 1) bs of+ (bs0, bs1) -> bs0 : go bs1++-------------------------------------------------------------------------------+-- scientific+-------------------------------------------------------------------------------++-- | >>> prettyExpr $ toExpr (123.456 :: Scientific)+-- scientific 123456 `-3`+-- instance ToExpr Sci.Scientific where+-- toExpr s = App "scientific" [ toExpr $ Sci.coefficient s, toExpr $ Sci.base10Exponent s ]++-------------------------------------------------------------------------------+-- uuid-types+-------------------------------------------------------------------------------++-- | >>> prettyExpr $ toExpr UUID.nil+-- UUID "00000000-0000-0000-0000-000000000000"+-- instance ToExpr UUID.UUID where+-- toExpr u = App "UUID" [ toExpr $ UUID.toString u ]++-------------------------------------------------------------------------------+-- vector+-------------------------------------------------------------------------------++instance ToExpr a => ToExpr (V.Vector a) where+ toExpr x = App "V.fromList" [ toExpr $ V.toList x ]+instance (ToExpr a, VU.Unbox a) => ToExpr (VU.Vector a) where+ toExpr x = App "VU.fromList" [ toExpr $ VU.toList x ]+instance (ToExpr a, VS.Storable a) => ToExpr (VS.Vector a) where+ toExpr x = App "VS.fromList" [ toExpr $ VS.toList x ]+instance (ToExpr a, VP.Prim a) => ToExpr (VP.Vector a) where+ toExpr x = App "VP.fromList" [ toExpr $ VP.toList x ]++-------------------------------------------------------------------------------+-- tagged+-------------------------------------------------------------------------------++-- instance ToExpr a => ToExpr (Tagged t a) where+-- toExpr (Tagged x) = App "Tagged" [ toExpr x ]++-------------------------------------------------------------------------------+-- hashable+-------------------------------------------------------------------------------++-- instance ToExpr a => ToExpr (Hashed a) where+-- toExpr x = App "hashed" [ toExpr $ unhashed x ]++-------------------------------------------------------------------------------+-- unordered-containers+-------------------------------------------------------------------------------++-- instance (ToExpr k, ToExpr v) => ToExpr (HM.HashMap k v) where+-- toExpr x = App "HM.fromList" [ toExpr $ HM.toList x ]+-- instance (ToExpr k) => ToExpr (HS.HashSet k) where+-- toExpr x = App "HS.fromList" [ toExpr $ HS.toList x ]++-------------------------------------------------------------------------------+-- aeson+-------------------------------------------------------------------------------++-- instance ToExpr Aeson.Value++-------------------------------------------------------------------------------+-- Doctest+-------------------------------------------------------------------------------++-- $setup+-- >>> :set -XDeriveGeneric+-- >>> :set -XDeriveGeneric+-- >>> import Data.Foldable (traverse_)+-- >>> import Data.Ratio ((%))+-- >>> import Data.Time (Day (..))+-- >>> import Data.Scientific (Scientific)+-- >>> import Data.TreeDiff.Pretty+-- >>> import qualified Data.ByteString.Char8 as BS8+-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS8
+ src/Test/StateMachine/TreeDiff/Expr.hs view
@@ -0,0 +1,102 @@+-- | This module uses 'Expr' for richer diffs than based on 'Tree'.+module Test.StateMachine.TreeDiff.Expr (+ -- * Types+ Expr (..),+ ConstructorName,+ FieldName,+ EditExpr (..),+ Edit (..),+ exprDiff,+ ) where++import Prelude ()+import Prelude.Compat++import Data.Map (Map)+import Test.StateMachine.TreeDiff.List++import qualified Data.Map as Map+import qualified Test.QuickCheck as QC++-- | Constructor name is a string+type ConstructorName = String+--+-- | Record field name is a string too.+type FieldName = String++-- | A untyped Haskell-like expression.+--+-- Having richer structure than just 'Tree' allows to have richer diffs.+data Expr+ = App ConstructorName [Expr] -- ^ application+ | Rec ConstructorName (Map FieldName Expr) -- ^ record constructor+ | Lst [Expr] -- ^ list constructor+ deriving (Eq, Show)++instance QC.Arbitrary Expr where+ arbitrary = QC.scale (min 25) $ QC.sized arb where+ arb n | n <= 0 = QC.oneof+ [ (`App` []) <$> arbName+ , (`Rec` mempty) <$> arbName+ ]+ arb n | otherwise = do+ n' <- QC.choose (0, n `div` 3)+ QC.oneof+ [ App <$> arbName <*> QC.liftArbitrary (arb n')+ , Rec <$> arbName <*> QC.liftArbitrary (arb n')+ , Lst <$> QC.liftArbitrary (arb n')+ ]++ shrink (Lst es) = es+ ++ [ Lst es' | es' <- QC.shrink es ]+ shrink (Rec n fs) = Map.elems fs+ ++ [ Rec n' fs | n' <- QC.shrink n ]+ ++ [ Rec n fs' | fs' <- QC.shrink fs ]+ shrink (App n es) = es+ ++ [ App n' es | n' <- QC.shrink n ]+ ++ [ App n es' | es' <- QC.shrink es ]++arbName :: QC.Gen String+arbName = QC.frequency+ [ (10, QC.liftArbitrary $ QC.elements $ ['a'..'z'] ++ ['0' .. '9'] ++ "+-_:")+ , (1, show <$> (QC.arbitrary :: QC.Gen String))+ , (1, QC.arbitrary)+ , (1, QC.elements ["_×_", "_×_×_", "_×_×_×_"])+ ]++-- | Diff two 'Expr'.+--+-- For examples see 'ediff' in "Data.TreeDiff.Class".+exprDiff :: Expr -> Expr -> Edit EditExpr+exprDiff = impl+ where+ impl ea eb | ea == eb = Cpy (EditExp ea)++ impl ea@(App a as) eb@(App b bs)+ | a == b = Cpy $ EditApp a (map recurse (diffBy (==) as bs))+ | otherwise = Swp (EditExp ea) (EditExp eb)+ impl ea@(Rec a as) eb@(Rec b bs)+ | a == b = Cpy $ EditRec a $ Map.unions [inter, onlyA, onlyB]+ | otherwise = Swp (EditExp ea) (EditExp eb)+ where+ inter = Map.intersectionWith exprDiff as bs+ onlyA = fmap (Del . EditExp) (Map.difference as inter)+ onlyB = fmap (Ins . EditExp) (Map.difference bs inter)+ impl (Lst as) (Lst bs) =+ Cpy $ EditLst (map recurse (diffBy (==) as bs))++ -- If higher level doesn't match, just swap.+ impl a b = Swp (EditExp a) (EditExp b)++ recurse (Ins x) = Ins (EditExp x)+ recurse (Del y) = Del (EditExp y)+ recurse (Cpy z) = Cpy (EditExp z)+ recurse (Swp x y) = impl x y++-- | Type used in the result of 'ediff'.+data EditExpr+ = EditApp ConstructorName [Edit EditExpr]+ | EditRec ConstructorName (Map FieldName (Edit EditExpr))+ | EditLst [Edit EditExpr]+ | EditExp Expr -- ^ unchanged tree+ deriving Show
+ src/Test/StateMachine/TreeDiff/List.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | A list diff.+module Test.StateMachine.TreeDiff.List (diffBy, Edit (..)) where++import Data.List.Compat (sortOn)+import qualified Data.MemoTrie as M+import qualified Data.Vector as V++-- | List edit operations+--+-- The 'Swp' constructor is redundant, but it let us spot+-- a recursion point when performing tree diffs.+data Edit a+ = Ins a -- ^ insert+ | Del a -- ^ delete+ | Cpy a -- ^ copy unchanged+ | Swp a a -- ^ swap, i.e. delete + insert+ deriving Show++-- | List difference.+--+-- >>> diffBy (==) "hello" "world"+-- [Swp 'h' 'w',Swp 'e' 'o',Swp 'l' 'r',Cpy 'l',Swp 'o' 'd']+--+-- >>> diffBy (==) "kitten" "sitting"+-- [Swp 'k' 's',Cpy 'i',Cpy 't',Cpy 't',Swp 'e' 'i',Cpy 'n',Ins 'g']+--+-- prop> \xs ys -> length (diffBy (==) xs ys) >= max (length xs) (length (ys :: String))+-- prop> \xs ys -> length (diffBy (==) xs ys) <= length xs + length (ys :: String)+--+-- /Note:/ currently this has O(n*m) memory requirements, for the sake+-- of more obviously correct implementation.+--+diffBy :: forall a. (a -> a -> Bool) -> [a] -> [a] -> [Edit a]+diffBy eq xs' ys' = reverse (snd (lcs (V.length xs) (V.length ys)))+ where+ xs = V.fromList xs'+ ys = V.fromList ys'++ lcs = M.memo2 impl++ impl :: Int -> Int -> (Int, [Edit a])+ impl 0 0 = (0, [])+ impl 0 m = case lcs 0 (m-1) of+ (w, edit) -> (w + 1, Ins (ys V.! (m - 1)) : edit)+ impl n 0 = case lcs (n -1) 0 of+ (w, edit) -> (w + 1, Del (xs V.! (n - 1)) : edit)++ impl n m = head $ sortOn fst+ [ edit+ , bimap (+1) (Ins y :) (lcs n (m - 1))+ , bimap (+1) (Del x :) (lcs (n - 1) m)+ ]+ where+ x = xs V.! (n - 1)+ y = ys V.! (m - 1)++ edit+ | eq x y = bimap id (Cpy x :) (lcs (n - 1) (m - 1))+ | otherwise = bimap (+1) (Swp x y :) (lcs (n -1 ) (m - 1))++bimap :: (a -> c) -> (b -> d) -> (a, b) -> (c, d)+bimap f g (x, y) = (f x, g y)
+ src/Test/StateMachine/TreeDiff/Pretty.hs view
@@ -0,0 +1,253 @@+-- | Utilities to pretty print 'Expr' and 'EditExpr'+module Test.StateMachine.TreeDiff.Pretty (+ -- * Explicit dictionary+ Pretty (..),+ ppExpr,+ ppEditExpr,+ ppEditExprCompact,+ -- * pretty+ prettyPretty,+ prettyExpr,+ prettyEditExpr,+ prettyEditExprCompact,+ -- * ansi-wl-pprint+ ansiWlPretty,+ ansiWlExpr,+ ansiWlEditExpr,+ ansiWlEditExprCompact,+ -- ** background+ ansiWlBgPretty,+ ansiWlBgExpr,+ ansiWlBgEditExpr,+ ansiWlBgEditExprCompact,+ -- * Utilities+ escapeName,+ ) where++import Data.Char (isAlphaNum, isPunctuation, isSymbol, ord)+import Data.Either (partitionEithers)+import Test.StateMachine.TreeDiff.Expr+import Numeric (showHex)+import Text.Read (readMaybe)+++import qualified Data.Map as Map+import qualified Text.PrettyPrint as HJ+import qualified Text.PrettyPrint.ANSI.Leijen as WL++-- | Because we don't want to commit to single pretty printing library,+-- we use explicit dictionary.+data Pretty doc = Pretty+ { ppCon :: ConstructorName -> doc+ , ppRec :: [(FieldName, doc)] -> doc+ , ppLst :: [doc] -> doc+ , ppCpy :: doc -> doc+ , ppIns :: doc -> doc+ , ppDel :: doc -> doc+ , ppSep :: [doc] -> doc+ , ppParens :: doc -> doc+ , ppHang :: doc -> doc -> doc+ }++-- | Escape field or constructor name+--+-- >>> putStrLn $ escapeName "Foo"+-- Foo+--+-- >>> putStrLn $ escapeName "_×_"+-- _×_+--+-- >>> putStrLn $ escapeName "-3"+-- `-3`+--+-- >>> putStrLn $ escapeName "kebab-case"+-- kebab-case+--+-- >>> putStrLn $ escapeName "inner space"+-- `inner space`+--+-- >>> putStrLn $ escapeName $ show "looks like a string"+-- "looks like a string"+--+-- >>> putStrLn $ escapeName $ show "tricky" ++ " "+-- `"tricky" `+--+-- >>> putStrLn $ escapeName "[]"+-- `[]`+--+-- >>> putStrLn $ escapeName "_,_"+-- `_,_`+--+escapeName :: String -> String+escapeName n+ | null n = "``"+ | isValidString n = n+ | all valid' n && headNotMP n = n+ | otherwise = "`" ++ concatMap e n ++ "`"+ where+ e '`' = "\\`"+ e '\\' = "\\\\"+ e ' ' = " "+ e c | not (valid c) = "\\x" ++ showHex (ord c) ";"+ e c = [c]++ valid c = isAlphaNum c || isSymbol c || isPunctuation c+ valid' c = valid c && c `notElem` "[](){}`\","++ headNotMP ('-' : _) = False+ headNotMP ('+' : _) = False+ headNotMP _ = True++ isValidString s+ | length s >= 2 && head s == '"' && last s == '"' =+ case readMaybe s :: Maybe String of+ Just _ -> True+ Nothing -> False+ isValidString _ = False++-- | Pretty print an 'Expr' using explicit pretty-printing dictionary.+ppExpr :: Pretty doc -> Expr -> doc+ppExpr p = ppExpr' p False++ppExpr' :: Pretty doc -> Bool -> Expr -> doc+ppExpr' p = impl where+ impl _ (App x []) = ppCon p (escapeName x)+ impl b (App x xs) = ppParens' b $ ppHang p (ppCon p (escapeName x)) $+ ppSep p $ map (impl True) xs+ impl _ (Rec x xs) = ppHang p (ppCon p (escapeName x)) $ ppRec p $+ map ppField' $ Map.toList xs+ impl _ (Lst xs) = ppLst p (map (impl False) xs)++ ppField' (n, e) = (escapeName n, impl False e)++ ppParens' True = ppParens p+ ppParens' False = id++-- | Pretty print an @'Edit' 'EditExpr'@ using explicit pretty-printing dictionary.+ppEditExpr :: Pretty doc -> Edit EditExpr -> doc+ppEditExpr = ppEditExpr' False++-- | Like 'ppEditExpr' but print unchanged parts only shallowly+ppEditExprCompact :: Pretty doc -> Edit EditExpr -> doc+ppEditExprCompact = ppEditExpr' True++ppEditExpr' :: Bool -> Pretty doc -> Edit EditExpr -> doc+ppEditExpr' compact p = ppSep p . ppEdit False+ where+ ppEdit b (Cpy (EditExp expr)) = [ ppCpy p $ ppExpr' p b expr ]+ ppEdit b (Cpy expr) = [ ppEExpr b expr ]+ ppEdit b (Ins expr) = [ ppIns p (ppEExpr b expr) ]+ ppEdit b (Del expr) = [ ppDel p (ppEExpr b expr) ]+ ppEdit b (Swp x y) =+ [ ppDel p (ppEExpr b x)+ , ppIns p (ppEExpr b y)+ ]++ ppEExpr _ (EditApp x []) = ppCon p (escapeName x)+ ppEExpr b (EditApp x xs) = ppParens' b $ ppHang p (ppCon p (escapeName x)) $+ ppSep p $ concatMap (ppEdit True) xs+ ppEExpr _ (EditRec x xs) = ppHang p (ppCon p (escapeName x)) $ ppRec p $+ justs ++ [ (n, ppCon p "...") | n <- take 1 nothings ]+ where+ xs' = map ppField' $ Map.toList xs+ (nothings, justs) = partitionEithers xs'++ ppEExpr _ (EditLst xs) = ppLst p (concatMap (ppEdit False) xs)+ ppEExpr b (EditExp x) = ppExpr' p b x++ ppField' (n, Cpy (EditExp e)) | compact, not (isScalar e) = Left n+ ppField' (n, e) = Right (escapeName n, ppSep p $ ppEdit False e)++ ppParens' True = ppParens p+ ppParens' False = id++ isScalar (App _ []) = True+ isScalar _ = False++-------------------------------------------------------------------------------+-- pretty+-------------------------------------------------------------------------------++-- | 'Pretty' via @pretty@ library.+prettyPretty :: Pretty HJ.Doc+prettyPretty = Pretty+ { ppCon = HJ.text+ , ppRec = HJ.braces . HJ.sep . HJ.punctuate HJ.comma+ . map (\(fn, d) -> HJ.text fn HJ.<+> HJ.equals HJ.<+> d)+ , ppLst = HJ.brackets . HJ.sep . HJ.punctuate HJ.comma+ , ppCpy = id+ , ppIns = \d -> HJ.char '+' HJ.<> d+ , ppDel = \d -> HJ.char '-' HJ.<> d+ , ppSep = HJ.sep+ , ppParens = HJ.parens+ , ppHang = \d1 d2 -> HJ.hang d1 2 d2+ }++-- | Pretty print 'Expr' using @pretty@.+--+-- >>> prettyExpr $ Rec "ex" (Map.fromList [("[]", App "bar" [])])+-- ex {`[]` = bar}+prettyExpr :: Expr -> HJ.Doc+prettyExpr = ppExpr prettyPretty++-- | Pretty print @'Edit' 'EditExpr'@ using @pretty@.+prettyEditExpr :: Edit EditExpr -> HJ.Doc+prettyEditExpr = ppEditExpr prettyPretty++-- | Compact 'prettyEditExpr'.+prettyEditExprCompact :: Edit EditExpr -> HJ.Doc+prettyEditExprCompact = ppEditExprCompact prettyPretty++-------------------------------------------------------------------------------+-- ansi-wl-pprint+-------------------------------------------------------------------------------++-- | 'Pretty' via @ansi-wl-pprint@ library (with colors).+ansiWlPretty :: Pretty WL.Doc+ansiWlPretty = Pretty+ { ppCon = WL.text+ , ppRec = WL.encloseSep WL.lbrace WL.rbrace WL.comma+ . map (\(fn, d) -> WL.text fn WL.<+> WL.equals WL.</> d)+ , ppLst = WL.list+ , ppCpy = WL.dullwhite+ , ppIns = \d -> WL.green $ WL.plain $ WL.char '+' WL.<> d+ , ppDel = \d -> WL.red $ WL.plain $ WL.char '-' WL.<> d+ , ppSep = WL.sep+ , ppParens = WL.parens+ , ppHang = \d1 d2 -> WL.hang 2 (d1 WL.</> d2)+ }++-- | Pretty print 'Expr' using @ansi-wl-pprint@.+ansiWlExpr :: Expr -> WL.Doc+ansiWlExpr = ppExpr ansiWlPretty++-- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.+ansiWlEditExpr :: Edit EditExpr -> WL.Doc+ansiWlEditExpr = ppEditExpr ansiWlPretty++-- | Compact 'ansiWlEditExpr'+ansiWlEditExprCompact :: Edit EditExpr -> WL.Doc+ansiWlEditExprCompact = ppEditExprCompact ansiWlPretty++-------------------------------------------------------------------------------+-- Background+-------------------------------------------------------------------------------++-- | Like 'ansiWlPretty' but color the background.+ansiWlBgPretty :: Pretty WL.Doc+ansiWlBgPretty = ansiWlPretty+ { ppIns = \d -> WL.ondullgreen $ WL.white $ WL.plain $ WL.char '+' WL.<> d+ , ppDel = \d -> WL.ondullred $ WL.white $ WL.plain $ WL.char '-' WL.<> d+ }++-- | Pretty print 'Expr' using @ansi-wl-pprint@.+ansiWlBgExpr :: Expr -> WL.Doc+ansiWlBgExpr = ppExpr ansiWlBgPretty++-- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.+ansiWlBgEditExpr :: Edit EditExpr -> WL.Doc+ansiWlBgEditExpr = ppEditExpr ansiWlBgPretty++-- | Compact 'ansiWlBgEditExpr'.+ansiWlBgEditExprCompact :: Edit EditExpr -> WL.Doc+ansiWlBgEditExprCompact = ppEditExprCompact ansiWlBgPretty
+ src/Test/StateMachine/TreeDiff/Tree.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE CPP #-}+-- | Tree diffing working on @containers@ 'Tree'.+module Test.StateMachine.TreeDiff.Tree (treeDiff, EditTree (..), Edit (..)) where++import Data.Tree (Tree (..))+import Test.StateMachine.TreeDiff.List++#ifdef __DOCTEST__+import qualified Text.PrettyPrint as PP+#endif++-- | A breadth-traversal diff.+--+-- It's different from @gdiff@, as it doesn't produce a flat edit script,+-- but edit script iself is a tree. This makes visualising the diff much+-- simpler.+--+-- ==== Examples+--+-- Let's start from simple tree. We pretty print them as s-expressions.+--+-- >>> let x = Node 'a' [Node 'b' [], Node 'c' [return 'd', return 'e'], Node 'f' []]+-- >>> ppTree PP.char x+-- (a b (c d e) f)+--+-- If we modify an argument in a tree, we'll notice it's changed:+--+-- >>> let y = Node 'a' [Node 'b' [], Node 'c' [return 'x', return 'e'], Node 'f' []]+-- >>> ppTree PP.char y+-- (a b (c x e) f)+--+-- >>> ppEditTree PP.char (treeDiff x y)+-- (a b (c -d +x e) f)+--+-- If we modify a constructor, the whole sub-trees is replaced, though there+-- might be common subtrees.+--+-- >>> let z = Node 'a' [Node 'b' [], Node 'd' [], Node 'f' []]+-- >>> ppTree PP.char z+-- (a b d f)+--+-- >>> ppEditTree PP.char (treeDiff x z)+-- (a b -(c d e) +d f)+--+-- If we add arguments, they are spotted too:+--+-- >>> let w = Node 'a' [Node 'b' [], Node 'c' [return 'd', return 'x', return 'e'], Node 'f' []]+-- >>> ppTree PP.char w+-- (a b (c d x e) f)+--+-- >>> ppEditTree PP.char (treeDiff x w)+-- (a b (c d +x e) f)+--+treeDiff :: Eq a => Tree a -> Tree a -> Edit (EditTree a)+treeDiff ta@(Node a as) tb@(Node b bs)+ | a == b = Cpy $ EditNode a (map rec (diffBy (==) as bs))+ | otherwise = Swp (treeToEdit ta) (treeToEdit tb)+ where+ rec (Ins x) = Ins (treeToEdit x)+ rec (Del y) = Del (treeToEdit y)+ rec (Cpy z) = Cpy (treeToEdit z)+ rec (Swp x y) = treeDiff x y++-- | Type used in the result of 'treeDiff'.+--+-- It's essentially a 'Tree', but the forest list is changed from+-- @[tree a]@ to @['Edit' (tree a)]@. This highlights that+-- 'treeDiff' performs a list diff on each tree level.+data EditTree a+ = EditNode a [Edit (EditTree a)]+ deriving Show++treeToEdit :: Tree a -> EditTree a+treeToEdit = go where go (Node x xs) = EditNode x (map (Cpy . go) xs)++#ifdef __DOCTEST__+ppTree :: (a -> PP.Doc) -> Tree a -> PP.Doc+ppTree pp = ppT+ where+ ppT (Node x []) = pp x+ ppT (Node x xs) = PP.parens $ PP.hang (pp x) 2 $+ PP.sep $ map ppT xs++ppEditTree :: (a -> PP.Doc) -> Edit (EditTree a) -> PP.Doc+ppEditTree pp = PP.sep . ppEdit+ where+ ppEdit (Cpy tree) = [ ppTree tree ]+ ppEdit (Ins tree) = [ PP.char '+' PP.<> ppTree tree ]+ ppEdit (Del tree) = [ PP.char '-' PP.<> ppTree tree ]+ ppEdit (Swp a b) =+ [ PP.char '-' PP.<> ppTree a+ , PP.char '+' PP.<> ppTree b+ ]++ ppTree (EditNode x []) = pp x+ ppTree (EditNode x xs) = PP.parens $ PP.hang (pp x) 2 $+ PP.sep $ concatMap ppEdit xs+#endif
src/Test/StateMachine/Types/References.hs view
@@ -37,14 +37,14 @@ import Data.Functor.Classes (Eq1, Ord1, Show1, compare1, eq1, liftCompare, liftEq, liftShowsPrec, showsPrec1)-import Data.TreeDiff- (Expr(App), ToExpr, toExpr) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Prelude +import Test.StateMachine.TreeDiff+ (Expr(App), ToExpr, toExpr) import qualified Test.StateMachine.Types.Rank2 as Rank2 ------------------------------------------------------------------------
test/CrudWebserverDb.hs view
@@ -89,8 +89,6 @@ import Data.Text (Text) import qualified Data.Text as T-import Data.TreeDiff- (Expr(App)) import Database.Persist.Class import Database.Persist.Postgresql (ConnectionPool, ConnectionString, SqlBackend,@@ -111,8 +109,8 @@ import qualified Network.Wai.Handler.Warp as Warp import Prelude import Servant- ((:<|>)(..), (:>), Application, Capture, Delete,- Get, JSON, Post, Put, ReqBody, Server, serve)+ (Application, Capture, Delete, Get, JSON, Post, Put,+ ReqBody, Server, serve, (:<|>)(..), (:>)) import Servant.Client (BaseUrl(..), ClientEnv(..), ClientM, Scheme(Http), client, mkClientEnv, runClientM)@@ -132,6 +130,8 @@ (Async, MonadIO, async, cancel, liftIO, waitEither) import Test.StateMachine+import Test.StateMachine.TreeDiff+ (Expr(App)) import qualified Test.StateMachine.Types.Rank2 as Rank2 ------------------------------------------------------------------------
test/Echo.hs view
@@ -36,8 +36,7 @@ import Test.QuickCheck.Monadic (monadicIO) import UnliftIO- (TVar, atomically, liftIO, newTVarIO, readTVar,- writeTVar)+ (TVar, atomically, newTVarIO, readTVar, writeTVar) import Test.StateMachine import Test.StateMachine.Types as QC
test/Hanoi.hs view
@@ -32,8 +32,6 @@ import Data.Kind (Type) import Data.Maybe-import Data.TreeDiff.Expr- () import GHC.Generics (Generic, Generic1) import Prelude@@ -44,7 +42,9 @@ (monadicIO) import Test.StateMachine-import qualified Test.StateMachine.Types.Rank2 as Rank2+import Test.StateMachine.TreeDiff.Expr+ ()+import qualified Test.StateMachine.Types.Rank2 as Rank2 ------------------------------------------------------------------------
test/ProcessRegistry.hs view
@@ -404,7 +404,7 @@ ] generator :: Model Symbolic -> Maybe (Gen (Action Symbolic))-generator = markovGenerator markov gens partition sinkState+generator _ = Nothing shrinker :: Model Symbolic -> Action Symbolic -> [Action Symbolic] shrinker _model _act = []@@ -428,41 +428,6 @@ sm = StateMachine initModel transition precondition postcondition Nothing generator shrinker semantics mock noCleanup -markov :: Markov State Action_ Double-markov = makeMarkov- [ Zero :*: Zero -< [ Spawn_ /- One :*: Zero ]-- , One :*: Zero -< [ Spawn_ /- Two :*: Zero- , Register_ /- One :*: One- , (BadRegister_, 10) >- One :*: Zero- , (Kill_, 20) >- Zero :*: Zero- ]-- , One :*: One -< [ (Spawn_, 40) >- Two :*: One- , BadRegister_ /- One :*: One- , (Unregister_, 20) >- One :*: Zero- , BadUnregister_ /- One :*: One- , (WhereIs_, 20) >- One :*: One- ]-- , Two :*: Zero -< [ (Register_, 80) >- Two :*: One- , (Kill_, 20) >- One :*: Zero- ]-- , Two :*: One -< [ (Register_, 30) >- Two :*: Two- , (Kill_, 10) >- One :*: One- , (Unregister_, 20) >- Two :*: Zero- , (BadUnregister_, 10) >- Two :*: One- , (WhereIs_, 20) >- Two :*: One- , (Exit_, 10) >- Stop- ]-- , Two :*: Two -< [ (Exit_, 30) >- Stop- , (Unregister_, 20) >- Two :*: One- , (WhereIs_, 50) >- Two :*: Two- ]- ]- ------------------------------------------------------------------------ -- Requirements from the paper "How well are your requirements tested?"@@ -560,19 +525,13 @@ ------------------------------------------------------------------------ -prop_processRegistry :: StatsDb IO -> Property-prop_processRegistry sdb = forAllCommands sm (Just 100000) $ \cmds -> monadicIO $ do+prop_processRegistry :: Property+prop_processRegistry = forAllCommands sm (Just 100000) $ \cmds -> monadicIO $ do liftIO ioReset (hist, _model, res) <- runCommands sm cmds - let observed = historyObservations sm markov partition constructor hist- reqs = tag (execCmds sm cmds)-- persistStats sdb observed+ let reqs = tag (execCmds sm cmds) prettyCommands' sm tag cmds hist $ tabulate "_Requirements" (map show reqs)- $ coverMarkov markov- $ tabulateMarkov sm partition constructor cmds- $ printReliability sdb (transitionMatrix markov) observed $ res === Ok .&&. reqs === tag (execHistory sm hist)
− test/RQlite.hs
@@ -1,761 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE UndecidableInstances #-}--module RQlite (- Level (..)- , prop_sequential_rqlite- , prop_parallel_rqlite- , prop_nparallel_rqlite- , runCmds- ) where--import Control.Concurrent- (threadDelay)-import Control.Concurrent.MVar-import Control.Exception- (bracketOnError, try)-import Control.Monad- (void, when)-import Control.Monad.IO.Class- (liftIO)-import Data.Aeson hiding- (Result)-import Data.Foldable-import Data.Functor.Classes-import Data.Kind-import qualified Data.List as L-import Data.Map- (Map)-import qualified Data.Map as M-import Data.Maybe-import Data.TreeDiff-import GHC.Generics-import Prelude-import "hs-rqlite" Rqlite-import "hs-rqlite" Rqlite.Status-import System.Directory-import System.IO-import System.Process-import System.Random-import Test.QuickCheck hiding- (Result)-import Test.QuickCheck.Monadic-import Test.StateMachine-import Test.StateMachine.DotDrawing-import Test.StateMachine.Types- (History(..), ParallelCommandsF(..), interleavings)-import qualified Test.StateMachine.Types.Rank2 as Rank2-import Test.StateMachine.Types.References----------------------------------------------------------------------------newtype At t r = At { unAt :: t (NodeRef r) }- deriving stock (Generic)--instance Show (t (NodeRef r)) => Show (At t r) where- show = show . unAt--data Person = Person- { name :: String- , age :: Int- }- deriving stock (Show, Read, Eq, Generic)---- HTTP requests utilities--instance FromJSON Person where- parseJSON j = do- (n, a) <- parseJSON j- return $ Person n a--createQ :: String-createQ = "CREATE TABLE Person (name text, age Int)"--insertQuery :: String -> Person -> IO PostResult-insertQuery host Person{..} =- postQuery True host $ "INSERT INTO Person(name, age) VALUES('" ++ name ++ "', " ++ show age ++ ")"--selectQuery :: Maybe Level -> String -> IO (GetResult Person)-selectQuery lvl host = do- putStrLnM $ "querying " ++ host- getQuery lvl host True "SELECT * FROM Person"--createQuery :: String -> IO PostResult-createQuery host = postQuery True host createQ------------------------------ Docker utilities--data Container = Container {- counter :: Int- , cn :: Int- , nodeName :: String- , cport :: Int-} deriving stock (Generic)--instance Eq Container where- n1 == n2 = counter n1 == counter n2--instance Show Container where- show Container{..} = "Node@" ++ show cport--instance ToExpr Container where- toExpr Container{..} = App ("Node@" ++ show cport) []--ignoreIOError :: IO a -> IO ()-ignoreIOError action = do- (_ :: Either IOError a) <- try action- return ()--stopContainer :: String -> IO ()-stopContainer ndName = do- stdErr <- openFile "/dev/null" AppendMode- -- stopping or removing a non-existing container should be a no-op- ignoreIOError $ readCreateProcess (proc "docker"- [ "stop"- , ndName- ]) {std_err = UseHandle stdErr}- ""- ignoreIOError $ readCreateProcess (proc "docker"- [ "rm"- , ndName- ]) {std_err = UseHandle stdErr}- ""--mkNodeTime :: Int -> Int -> Timeout -> Timeout -> Maybe Int -> IO Container-mkNodeTime c n timeout elTimeout mjoin = do- (ndName, p) <- setupNode n timeout elTimeout mjoin- return $ Container c n ndName p--stopNode :: Container -> IO ()-stopNode Container {..} = stopContainer nodeName--setupNode :: Int -> Timeout -> Timeout -> Maybe Int -> IO (String, Int)-setupNode n timeout elTimeout mjoin = do- r :: Word <- randomIO- let p = leaderPort + 2 * n- p' = 4002 + 2 * n- ip = "172.19.0." ++ show (10 + n) -- http- ip' = "172.18.0." ++ show (10 + n)- mjoin' = fmap (\j -> "http://" ++ httpHost j) mjoin- ndName = mkNodeName r- jls = case mjoin' of- Nothing -> []- Just join -> ["-join", join]- stopContainer ndName-- void $ readProcess "docker"- ([ "create"- , "--net"- , "rqlite-http"- , "--ip"- , ip- , "-p"- , show p ++ ":" ++ show p- , "--name"- , ndName- , "rqlite/rqlite:4.5.0"- , "-http-addr"- , ip ++ ":" ++ show p- , "-raft-addr"- , ip' ++ ":" ++ show p'- , "-raft-timeout"- , show timeout- , "-raft-election-timeout"- , show elTimeout- ] ++ jls) ""-- -- connect the container to the rqlite network.- void $ readProcess "docker"- [ "network"- , "connect"- , "--ip"- , ip'- , "rqlite-network"- , ndName- ] ""-- stdOut' <- openFile (testPath ++ "/out-" ++ show n) AppendMode- stdErr' <- openFile (testPath ++ "/err-" ++ show n) AppendMode- stdIn' <- openFile "/dev/null" ReadMode- -- we don't use readProcess here, because we don't want to block.- void $ createProcess (proc "docker"- [ "start"- , "-a" -- this attaches the stdout and stderr to the one we specify.- , ndName- ]) {std_in = UseHandle stdIn', std_out = UseHandle stdOut', std_err = UseHandle stdErr'}-- putStrLnM "RAN"- return (ndName, p)---pauseNode :: Container -> IO ()-pauseNode Container{..} =- void $ readProcess "docker"- [ "pause"- , nodeName- ] ""--unPauseNode :: Container -> IO ()-unPauseNode Container{..} =- void $ readProcess "docker"- [ "unpause"- , nodeName- ] ""--mkNodeName :: Word -> String-mkNodeName n = "rqlite-node-" ++ show n--disconnectNode :: String -> IO ()-disconnectNode ndName =- void $ readProcess "docker"- [ "network"- , "disconnect"- , "rqlite-network"- , ndName- ] ""--connectNode :: Container -> IO ()-connectNode Container {..} =- void $ readProcess "docker"- [ "network"- , "connect"- , "--ip"- , "172.18.0." ++ show (10 + cn)- , "rqlite-network"- , nodeName- ] ""--createRQNetworks :: IO ()-createRQNetworks = do- -- this way we don't "polute" test output with messages (i.e. network- -- may already be present).- stdErr <- openFile "/dev/null" AppendMode- void $ ignoreIOError $ readCreateProcess (proc "docker"- [ "network"- , "create"- , "--subnet"- , "172.19.0.0/16"- , "rqlite-http"]) {std_err = UseHandle stdErr}- ""- void $ ignoreIOError $ readCreateProcess (proc "docker"- [ "network"- , "create"- , "--subnet"- , "172.18.0.0/16"- , "rqlite-network"]) {std_err = UseHandle stdErr}- ""---- retryUntilElections :: IO a -> IO a--- retryUntilElections action = go 20--- where--- go n = do--- res <- try action--- let retry e = if n > 0 then do--- putStrLnM "LeadershipLost. Retrying"--- threadDelay 500000--- go (n-1)--- else throwIO e--- case res of--- Right a -> return a--- Left e@(LeadershipLost _) -> retry e--- Left e@NotLeader -> retry e--- Left e -> throwIO e-----------------------------sameElements :: Eq a => [a] -> [a] -> Bool-sameElements x y = null (x L.\\ y) && null (y L.\\ x)--type NodeRef = Reference Container--data Model r = Model {- dbModel :: DBModel- , nodes :: [(NodeRef r, Int)]- } deriving stock (Generic, Show)--data DBModel = DBModel {- persons :: [Person]- , nodeState :: Map Int NodeState- , cutLines :: [(Int, Int)]- , cWhere :: Int- , cRef :: Int- } deriving stock (Generic, Show)--type Join = Maybe Int--data Timeout =- Ms Int- | Sec Int--instance Show Timeout where- show (Ms n) = show n ++ "ms"- show (Sec n) = show n ++ "s"--data Cmd node =- Spawn Int Timeout Timeout Join- | ReSpawn Int Int Timeout Timeout Join- | Disconnect node- | Connect node- | Stop node- | Insert node Person- | Get node (Maybe Level)- | Pause node- | UnPause node- | Delay Int- deriving stock (Generic, Show, Functor, Foldable, Traversable)--newtype Resp node = Resp (Either SomeError (Success node))- deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic)--newtype SomeError = SomeError String- deriving stock (Show, Eq)--data Success node =- Unit- | Spawned node- | Got [Person]- deriving stock (Show, Functor, Foldable, Traversable, Generic)--deriving stock instance Generic1 (At Cmd)-deriving anyclass instance Rank2.Functor (At Cmd)-deriving anyclass instance Rank2.Foldable (At Cmd)-deriving anyclass instance Rank2.Traversable (At Cmd)--deriving anyclass instance ToExpr DBModel-deriving anyclass instance ToExpr (Model Concrete)-deriving anyclass instance ToExpr Person--deriving stock instance Generic1 (At Resp)-deriving anyclass instance Rank2.Functor (At Resp)-deriving anyclass instance Rank2.Foldable (At Resp)-deriving anyclass instance Rank2.Traversable (At Resp)--instance Eq node => Eq (Success node) where- Unit == Unit = True- (Got ps) == (Got ps') = sameElements ps ps'- Spawned n == Spawned n' = n == n'- _ == _ = False--instance CommandNames (At Cmd) where- cmdName (At Spawn {}) = "Spawn"- cmdName (At ReSpawn {}) = "ReSpawn"- cmdName (At Connect {}) = "Connect"- cmdName (At Disconnect {}) = "Disconnect"- cmdName (At Stop {}) = "Stop"- cmdName (At Insert {}) = "Insert"- cmdName (At Get {}) = "Get"- cmdName (At Pause {}) = "Pause"- cmdName (At UnPause {}) = "UnPause"- cmdName (At Delay {}) = "Delay"--unitResp :: Resp node-unitResp = Resp (Right Unit)--data Event (r :: Type -> Type) = Event- { eventBefore :: Model r- , eventCmd :: At Cmd r- , eventAfter :: Model r- , eventMockResp :: Resp Int- }--lockstep :: forall (r :: Type -> Type).- (Eq1 r, Show1 r)- => Model r- -> At Cmd r- -> At Resp r- -> Event r-lockstep model@Model {..} cmd (At resp) = Event- { eventBefore = model- , eventCmd = cmd- , eventAfter = model'- , eventMockResp = mockResp- }- where- (mockResp, dbModel') = step model cmd- newNodes = zip (toList resp) (toList mockResp)- model' = Model {- dbModel = dbModel'- , nodes = nodes `union'` newNodes- }--union' :: forall k v. (Eq k, Eq v, Show k, Show v)- => [(k, v)] -- Mapping known to have duplicate keys- -> [(k, v)] -- With potential duplicates- -> [(k, v)]-union' acc [] = acc-union' acc ((k, v) : kvs) =- case lookup k acc of- Just v' | v /= v' -> error $ renderError v'- _otherwise -> union' ((k, v) : acc) kvs- where- renderError :: v -> String- renderError v' = unwords [- "Key"- , show k- , "with two different values"- , show v- , "and"- , show v'- ]--(!) :: Eq1 r => [(NodeRef r, v)] -> NodeRef r -> v-env ! r = case lookup r env of- Just a -> a- Nothing -> error "(!): key not found"--step :: Eq1 r => Model r -> At Cmd r -> (Resp Int, DBModel)-step (Model m@DBModel{..} nodes) (At cmd) = case cmd of- Insert _ p -> (unitResp, m {persons = p : persons})- Get _ _ -> (Resp $ Right $ Got $ persons, m)- Spawn wh _ _ _ -> ( Resp $ Right $ Spawned cRef, m {- nodeState = M.insert cRef (Running wh) nodeState- , cWhere = wh + 1 -- while shrinking, node locations may not be consecutive.- , cRef = cRef + 1- })- ReSpawn pRef wh _ _ _ ->- ( Resp $ Right $ Spawned cRef, m {- nodeState = M.union (M.fromList [(cRef, Running wh), (pRef, Done)]) nodeState- , cRef = cRef + 1- })- Connect ref -> (unitResp, m {- nodeState = M.update connectST (nodes ! ref) nodeState- })- Disconnect ref -> (unitResp, m {- nodeState = M.update disconnectST (nodes ! ref) nodeState- })- Stop ref -> (unitResp, m {- nodeState = M.update stopST (nodes ! ref) nodeState- })- Pause ref -> (unitResp, m {- nodeState = M.update pauseST (nodes ! ref) nodeState- })- UnPause ref -> (unitResp, m {- nodeState = M.update unPauseST (nodes ! ref) nodeState- })- Delay _ -> (unitResp, m)--data NodeState- = Running Int- | Disconnected Int- | Stopped Int- | Paused Int- | Done- deriving stock (Show, Generic)- deriving anyclass ToExpr--connectST :: NodeState -> Maybe NodeState-connectST (Disconnected wh) = Just $ Running wh-connectST st = error $ "is not dicsonnected but " ++ show st--disconnectST :: NodeState -> Maybe NodeState-disconnectST (Running wh) = Just $ Disconnected wh-disconnectST st = error $ "is not running but " ++ show st--stopST :: NodeState -> Maybe NodeState-stopST (Running wh) = Just $ Stopped wh-stopST st = error $ "is not running but " ++ show st--pauseST :: NodeState -> Maybe NodeState-pauseST (Running wh) = Just $ Paused wh-pauseST st = error $ "is not running but " ++ show st--unPauseST :: NodeState -> Maybe NodeState-unPauseST (Paused wh) = Just $ Running wh-unPauseST st = error $ "is not paused but " ++ show st--runsMp :: Int -> Map Int NodeState -> Bool-runsMp n mp = case M.lookup n mp of- Just (Running _) -> True- _ -> False--pausedMP :: Int -> Map Int NodeState -> Bool-pausedMP n mp = case M.lookup n mp of- Just (Paused _) -> True- _ -> False--disconnectedMP :: Int -> Map Int NodeState -> Bool-disconnectedMP n mp = case M.lookup n mp of- Just (Disconnected _) -> True- _ -> False--stoppedMp :: Int -> Map Int NodeState -> Bool-stoppedMp n mp = case M.lookup n mp of- Just (Stopped _) -> True- _ -> False--getRunning :: Map Int NodeState -> [(Int, Int)]-getRunning = mapMaybe f . M.toList- where- f (a, Running wh) = Just (a, wh)- f _ = Nothing--getNotRunning :: Map Int NodeState -> [Int]-getNotRunning = mapMaybe f . M.toList- where- f (a, Stopped _) = Just a- f (a, Done) = Just a- f (a, Disconnected _) = Just a- f (a, Paused _) = Just a- f _ = Nothing--isStopped :: NodeState -> Bool-isStopped (Stopped _) = True-isStopped _ = False--isDisconnected :: NodeState -> Bool-isDisconnected (Disconnected _) = True-isDisconnected _ = False--initModel :: Model r-initModel = Model (DBModel [] M.empty [] 0 0) []--transition :: forall r. (Eq1 r, Show1 r) => Model r -> At Cmd r -> At Resp r -> Model r-transition model cmd = eventAfter . lockstep model cmd--precondition :: Model Symbolic -> At Cmd Symbolic -> Logic-precondition (Model DBModel{..} nodes) (At cmd) = case cmd of- Spawn n _ _ j- -> Boolean $ length (getRunning nodeState) <= 2- && (not (null (getRunning nodeState)) || n == 0)- && joinsRunning j nodeState- && n < 3- ReSpawn prevRef _ _ _ j- -> Boolean $ elem prevRef (snd <$> nodes)- && stoppedMp prevRef nodeState- && length (getRunning nodeState) <= 2- && joinsRunning j nodeState- Stop n -> Boolean $ elem n (fst <$> nodes)- && runsMp (nodes ! n) nodeState- && nodes ! n /= 0- && null (getNotRunning nodeState)- && length (getRunning nodeState) == 3- Disconnect n- -> Boolean $ elem n (fst <$> nodes)- && runsMp (nodes ! n) nodeState- && null (getNotRunning nodeState)- && nodes ! n /= 0- && length (getRunning nodeState) == 3- Connect n -> Boolean $ elem n (fst <$> nodes)- && disconnectedMP (nodes ! n) nodeState- Insert n _ -> Boolean $ elem n (fst <$> nodes)- && runsMp (nodes ! n) nodeState- Get n _ -> Boolean $ elem n (fst <$> nodes)- && runsMp (nodes ! n) nodeState- Pause n -> Boolean $ elem n (fst <$> nodes)- && runsMp (nodes ! n) nodeState- UnPause n -> Boolean $ elem n (fst <$> nodes)- && pausedMP (nodes ! n) nodeState- Delay _ -> Top--postcondition :: Model Concrete -> At Cmd Concrete -> At Resp Concrete -> Logic-postcondition m cmd resp =- toMock (eventAfter ev) resp .== eventMockResp ev- where- ev = lockstep m cmd resp--toMock :: Eq1 r => Model r -> At Resp r -> Resp Int-toMock Model{..} (At r) = fmap- (\n -> fromMaybe (error "could not find person ref") $ Prelude.lookup n nodes) r--shrinker :: Model Symbolic -> At Cmd Symbolic -> [At Cmd Symbolic]-shrinker _ _ = []--semantics :: MVar Int -> At Cmd Concrete -> IO (At Resp Concrete)-semantics counter (At cmd) = At . Resp <$> case cmd of- Insert node p -> do- _ <- insertQuery (httpHost $ cn $ concrete node) p- return $ Right Unit- Get node lvl -> do- res <- selectQuery lvl $ httpHost $ cn $ concrete node- return $ case res of- GetResult p -> Right $ Got p- GetError e -> Left $ SomeError $ show e- Spawn n t elt join -> do- putStrLnM $ "Starting at " ++ show n ++ " joining " ++ show join- c <- modifyMVar counter $ \m -> return (m + 1, m)- bracketOnError (mkNodeTime c n t elt join)- stopNode- $ \rqNode -> do- threadDelay 500000- _ <- retryUntilAlive $ httpHost n- _ <- createQuery $ httpHost n- return $ Right $ Spawned $ reference rqNode- ReSpawn n _ t elt join -> do- putStrLnM $ "Restarting at " ++ show n ++ " joining " ++ show join- c <- modifyMVar counter $ \m -> return (m + 1, m)- bracketOnError (mkNodeTime c n t elt join)- stopNode- $ \rqNode -> do- threadDelay 500000- _ <- retryUntilAlive $ httpHost n- return $ Right $ Spawned $ reference rqNode- Stop node -> do- putStrLnM $ "Stopping at " ++ show (cport $ concrete node)- stopNode $ concrete node- return $ Right Unit- Disconnect node -> do- disconnectNode $ nodeName $ concrete node- return $ Right Unit- Connect node -> do- connectNode $ concrete node- _ <- retryUntilAlive $ httpHost $ cn $ concrete node- return $ Right Unit- Pause node -> do- pauseNode $ concrete node- return $ Right Unit- UnPause node -> do- unPauseNode $ concrete node- return $ Right Unit- Delay n -> do- threadDelay n- return $ Right Unit--httpHost :: Int -> String-httpHost n = "172.19.0." ++ show (10 + n) ++ ":" ++ show (leaderPort + 2 * n)--mock :: Model Symbolic -> At Cmd Symbolic -> GenSym (At Resp Symbolic)-mock (Model DBModel{..} _) (At cmd) = At <$> case cmd of- Spawn {} -> Resp . Right . Spawned <$> genSym- ReSpawn {} -> Resp . Right . Spawned <$> genSym- Stop {} -> return unitResp- Disconnect {} -> return unitResp- Connect {} -> return unitResp- Insert {} -> return unitResp- Get {} -> return $ Resp $ Right $ Got persons- Pause {} -> return unitResp- UnPause {} -> return unitResp- Delay {} -> return unitResp--sm :: Maybe Level -> IO (StateMachine Model (At Cmd) IO (At Resp))-sm lvl = do- createRQNetworks- removePathForcibly testPath- createDirectory testPath- threadDelay 10000- counter <- newMVar 0- pure $ StateMachine initModel transition precondition postcondition- Nothing (generatorImpl lvl) shrinker (semantics counter) mock garbageCollect--smUnused :: Maybe Level -> StateMachine Model (At Cmd) IO (At Resp)-smUnused lvl = StateMachine initModel transition precondition postcondition- Nothing (generatorImpl lvl) shrinker e mock garbageCollect- where- e = error "SUT must not be used"--prop_sequential_rqlite :: Maybe Level -> Property-prop_sequential_rqlite lvl =- forAllCommands (smUnused lvl) (Just 7) $ \cmds -> checkCommandNames cmds $ monadicIO $ do- (hist, _, res) <- runCommandsWithSetup (sm lvl) cmds- prettyCommands (smUnused lvl) hist $ res === Ok--prop_parallel_rqlite :: Maybe Level -> Property-prop_parallel_rqlite lvl =- forAllParallelCommands (smUnused lvl) (Just 7) $ \cmds -> checkCommandNamesParallel cmds $ monadicIO $- prettyParallelCommandsWithOpts cmds (Just $ GraphOptions "rqlite-test-output.png" Png)- =<< runParallelCommandsNTimesWithSetup 2 (sm lvl) cmds--prop_nparallel_rqlite :: Int -> Maybe Level -> Property-prop_nparallel_rqlite np lvl =- forAllNParallelCommands (smUnused lvl) np $ \cmds -> monadicIO $ do- prettyNParallelCommandsWithOpts cmds (Just $ GraphOptions "rqlite-test-output.png" Png)- =<< runNParallelCommandsNTimesWithSetup 1 (sm lvl) cmds---runCmds :: ParallelCommandsF [] (At Cmd) (At Resp) -> Property-runCmds cmds = withMaxSuccess 1 $ noShrinking $ monadicIO $ do- ls <- runNParallelCommandsNTimesWithSetup 1 (sm $ Just Weak) cmds- prettyNParallelCommandsWithOpts cmds (Just $ GraphOptions "rqlite-test-output.png" Png) ls- liftIO $ print $ (\(a, _, _) -> a) $ head ls- liftIO $ print $ interleavings $ unHistory $ (\(a, _, _) -> a) $ head ls--garbageCollect :: Model Concrete -> IO ()-garbageCollect (Model _ nodes) =- forM_ nodes $ \(Reference (Concrete node), p) -> do- putStrLnM $ "stopping " ++ show p- stopNode node--generatorImpl :: Maybe Level -> Model Symbolic -> Maybe (Gen (At Cmd Symbolic))-generatorImpl _ (Model _ []) = Just $ return $ At initCmd-generatorImpl lvl (Model DBModel{..} nodes) = Just $ At <$> do- node <- fst <$> elements nodes- let- reconnect :: (Int, Gen (Cmd (NodeRef Symbolic)))- reconnect = case find (isDisconnected . snd) (M.toList nodeState) of- (Just (_, Disconnected _)) ->- (100, return $ Connect node)- _ -> (0, undefined)- frequency- [ (5, Insert node <$> arbitrary)- , (5, return $ Get node lvl)- , (if cWhere <= 3 then 20 else 0, return $ mkSpawn Nothing cWhere $ joinNode False nodeState)- , (if cWhere == 3 then 20 else 0, return $ Stop node)- , (if cWhere == 3 then 20 else 0, return $ Disconnect node)- , respawn- , reconnect]- where-- respawn :: (Int, Gen (Cmd (NodeRef Symbolic)))- respawn = case find (isStopped . snd) (M.toList nodeState) of- (Just (ref, Stopped n)) ->- -- Sometimes, when a node respawns the rqlite files are not found- -- and the test fails. I'm not sure why this happens.- -- Until this is properly fixed, we disable this command.- (0, return $ mkSpawn (Just ref) n $ joinNode True nodeState)- _ -> (0, undefined)--joinNode :: Bool -> Map Int NodeState -> Maybe Int-joinNode avoid0 ndState =- case snd <$> getRunning ndState of- [] -> Nothing- rs -> Just $ case (elem 0 rs, L.delete 0 rs, avoid0) of- (False, _, _) -> head rs- (True, _, False) -> 0- (True, rs', True) -> head rs'--joinsRunning :: Maybe Int -> Map Int NodeState -> Bool-joinsRunning Nothing _ = True-joinsRunning (Just n) mp = elem n $ snd <$> getRunning mp--initCmd :: Cmd node-initCmd = Spawn 0 (Sec 1) (Sec 1) Nothing--mkSpawn :: Maybe Int -> Int -> Maybe Int -> Cmd node-mkSpawn respawm n =- (case respawm of- Nothing -> Spawn- Just ref -> ReSpawn ref) n (Sec 1) (Sec 1)--testPath :: String-testPath = "rqlite-test-output"--names :: [String]-names = ["John", "Stevan", "Kostas", "Curry", "Robert"]--leaderPort :: Int-leaderPort = 4001--instance Arbitrary Person where- arbitrary = do- n <- elements names- a <- choose (0, 100)- return $ Person n a--putStrLnM :: String -> IO ()-putStrLnM str = when isDebugging $ putStrLn str--isDebugging :: Bool-isDebugging = False
test/SQLite.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-}@@ -16,8 +17,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-identities #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module SQLite ( prop_sequential_sqlite@@ -27,13 +27,14 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception+import Control.Monad import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Control.Monad.Logger import Control.Monad.Reader import Data.Bifoldable import Data.Bifunctor-import qualified Data.Bifunctor.TH as TH+import qualified Data.Bifunctor.TH as TH import Data.Bitraversable import Data.Functor.Classes import Data.Kind@@ -43,10 +44,9 @@ import Data.Pool import Data.Text (Text, pack)-import Data.TreeDiff.Expr import Database.Persist import Database.Persist.Sqlite-import Database.Sqlite hiding+import Database.Sqlite hiding (step) import GHC.Generics (Generic, Generic1)@@ -56,23 +56,14 @@ import Test.QuickCheck.Monadic import Test.StateMachine import Test.StateMachine.DotDrawing+import Test.StateMachine.TreeDiff.Expr import Test.StateMachine.Types-import qualified Test.StateMachine.Types.Rank2 as Rank2+import qualified Test.StateMachine.Types.Rank2 as Rank2 import Schema ------------------------------------------------------------------------ -newtype At t r = At {unAt :: t (PRef r) (CRef r)}- deriving stock (Generic)--type PRef = Reference (Key Person)-type CRef = Reference (Key Car)--deriving stock instance Show1 r => Show (At Resp r)-deriving stock instance Show1 r => Show (At Cmd r)-deriving stock instance Eq1 r => Eq (At Resp r)- data TableEntity = TPerson Person | TCar Car@@ -84,8 +75,45 @@ data Cmd kp kh = Insert TableEntity | SelectList Tag- deriving stock (Show, Generic1)+ deriving stock (Show, Generic1, Functor) +TH.deriveBifunctor ''Cmd+TH.deriveBifoldable ''Cmd+TH.deriveBitraversable ''Cmd++data Success kp kc =+ Unit ()+ | InsertedPerson kp+ | InsertedCar kc+ | List [TableEntity]+ deriving stock (Show, Eq, Generic1, Functor)++TH.deriveBifunctor ''Success+TH.deriveBifoldable ''Success+TH.deriveBitraversable ''Success++newtype Resp kp kc = Resp (Either SqliteException (Success kp kc))+ deriving stock (Show, Generic1, Functor)++instance (Eq kp, Eq kc) => Eq (Resp kp kc) where+ (Resp (Left e1)) == (Resp (Left e2)) = seError e1 == seError e2+ (Resp (Right r1)) == (Resp (Right r2)) = r1 == r2+ _ == _ = False++TH.deriveBifunctor ''Resp+TH.deriveBifoldable ''Resp+TH.deriveBitraversable ''Resp++newtype At t r = At {unAt :: t (PRef r) (CRef r)}+ deriving stock (Generic)++type PRef = Reference (Key Person)+type CRef = Reference (Key Car)++deriving stock instance Show1 r => Show (At Resp r)+deriving stock instance Show1 r => Show (At Cmd r)+deriving stock instance Eq1 r => Eq (At Resp r)+ data Model (r :: Type -> Type) = Model { dbModel :: DBModel , knownPerson :: [(PRef r, Int)]@@ -102,14 +130,6 @@ initModelImpl :: Model r initModelImpl = Model (DBModel [] 0 [] 0) [] [] -newtype Resp kp kc = Resp (Either SqliteException (Success kp kc))- deriving stock (Show, Generic1)--instance (Eq kp, Eq kc) => Eq (Resp kp kc) where- (Resp (Left e1)) == (Resp (Left e2)) = seError e1 == seError e2- (Resp (Right r1)) == (Resp (Right r2)) = r1 == r2- _ == _ = False- getPers :: Resp kp kc -> [kp] getPers (Resp (Right (InsertedPerson kp))) = [kp] getPers _ = []@@ -118,13 +138,6 @@ getCars (Resp (Right (InsertedCar kc))) = [kc] getCars _ = [] -data Success kp kc =- Unit ()- | InsertedPerson kp- | InsertedCar kc- | List [TableEntity]- deriving stock (Show, Eq, Generic1)- data Event r = Event { eventBefore :: Model r , eventCmd :: At Cmd r@@ -443,13 +456,13 @@ mkAsyncWithPool :: AsyncQueue r -> Pool r -> AsyncWithPool r mkAsyncWithPool = AsyncWithPool -createSqliteAsyncQueue :: (MonadLogger m, MonadUnliftIO m)+createSqliteAsyncQueue :: (MonadLoggerIO m, MonadUnliftIO m) => Text -> m (AsyncQueue SqlBackend) createSqliteAsyncQueue str = do- logFunc <- askLogFunc+ logFunc <- askLoggerIO liftIO $ asyncQueueBound 1000 $ open' str logFunc -createSqliteAsyncPool :: (MonadLogger m, MonadUnliftIO m)+createSqliteAsyncPool :: (MonadLoggerIO m, MonadUnliftIO m) => Text -> Int -> m (AsyncWithPool SqlBackend) createSqliteAsyncPool str n = do q <- createSqliteAsyncQueue str@@ -478,15 +491,3 @@ closeSqlAsyncQueue :: AsyncQueue SqlBackend -> IO () closeSqlAsyncQueue q = waitQueue q close'--TH.deriveBifunctor ''Success-TH.deriveBifoldable ''Success-TH.deriveBitraversable ''Success--TH.deriveBifunctor ''Resp-TH.deriveBitraversable ''Resp-TH.deriveBifoldable ''Resp--TH.deriveBifunctor ''Cmd-TH.deriveBifoldable ''Cmd-TH.deriveBitraversable ''Cmd
test/Schema.hs view
@@ -13,7 +13,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -Wno-redundant-constraints #-}+{-# LANGUAGE DataKinds #-} module Schema ( Person (..)@@ -29,7 +29,7 @@ import Prelude import Test.QuickCheck -share [mkPersist sqlSettings, mkSave "entityDefs"] [persistLowerCase|+share [mkPersist sqlSettings, mkEntityDefList "entityDefs"] [persistLowerCase| Person name String age Int
test/ShrinkingProps.hs view
@@ -45,8 +45,6 @@ import Data.Set (Set) import qualified Data.Set as Set-import Data.TreeDiff- (defaultExprViaShow) import Data.Typeable (Typeable) import GHC.Generics@@ -67,11 +65,13 @@ import Test.StateMachine import qualified Test.StateMachine.Parallel as QSM import qualified Test.StateMachine.Sequential as QSM+import Test.StateMachine.TreeDiff+ (defaultExprViaShow) import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.StateMachine.Utils- (Shrunk(..), shrinkListS', shrinkListS',- shrinkListS'', shrinkPairS')+ (Shrunk(..), shrinkListS', shrinkListS'',+ shrinkPairS') ------------------------------------------------------------------------
test/Spec.hs view
@@ -31,16 +31,13 @@ import MemoryReference import Mock import Overflow-import ProcessRegistry+-- import ProcessRegistry import qualified ShrinkingProps import SQLite-import Test.StateMachine.Markov- (PropertyName, StatsDb, fileStatsDb) import TicketDispenser import qualified UnionFind -- RQlite tests fail, see #14-import RQlite ------------------------------------------------------------------------ @@ -196,9 +193,10 @@ , testProperty "2-Parallel" (prop_echoNParallelOK 2) , testProperty "3-Parallel" (prop_echoNParallelOK 3) ]- , testGroup "ProcessRegistry"- [ testProperty "Sequential" (prop_processRegistry (statsDb "processRegistry"))- ]+ -- XXX: The generator function needs to be reimplemented.+ -- , testGroup "ProcessRegistry"+ -- [ testProperty "Sequential" prop_processRegistry+ -- ] , testGroup "UnionFind" [ testProperty "Sequential" UnionFind.prop_unionFindSequential ] , testGroup "Lockstep"@@ -206,9 +204,6 @@ ] ] where- statsDb :: PropertyName -> StatsDb IO- statsDb = fileStatsDb "/tmp/stats-db"- webServer docker bug port test prop | docker = withResource (WS.setup bug WS.connectionString port) WS.cleanup (const (testProperty test (prop port)))