diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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); diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -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`. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,10 @@ ## quickcheck-state-machine [![Hackage](https://img.shields.io/hackage/v/quickcheck-state-machine.svg)](https://hackage.haskell.org/package/quickcheck-state-machine) +[![Build +status](https://github.com/stevana/quickcheck-state-machine/actions/workflows/main.yaml/badge.svg)](https://github.com/stevana/quickcheck-state-machine/actions) +[![Stackage Nightly](http://stackage.org/package/quickcheck-state-machine/badge/nightly)](http://stackage.org/nightly/package/quickcheck-state-machine) +[![Stackage LTS](http://stackage.org/package/quickcheck-state-machine/badge/lts)](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. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/quickcheck-state-machine.cabal b/quickcheck-state-machine.cabal --- a/quickcheck-state-machine.cabal +++ b/quickcheck-state-machine.cabal @@ -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 -homepage: https://github.com/stevana/quickcheck-state-machine#readme -license: BSD3 -license-file: LICENSE -author: Stevan Andjelkovic -maintainer: Stevan Andjelkovic -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 +homepage: https://github.com/stevana/quickcheck-state-machine#readme +license: BSD-3-Clause +license-file: LICENSE +author: Stevan Andjelkovic +maintainer: Stevan Andjelkovic +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 diff --git a/src/Test/StateMachine.hs b/src/Test/StateMachine.hs --- a/src/Test/StateMachine.hs +++ b/src/Test/StateMachine.hs @@ -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 diff --git a/src/Test/StateMachine/Lockstep/NAry.hs b/src/Test/StateMachine/Lockstep/NAry.hs --- a/src/Test/StateMachine/Lockstep/NAry.hs +++ b/src/Test/StateMachine/Lockstep/NAry.hs @@ -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 diff --git a/src/Test/StateMachine/Markov.hs b/src/Test/StateMachine/Markov.hs deleted file mode 100644 --- a/src/Test/StateMachine/Markov.hs +++ /dev/null @@ -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 --- 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=<(" ++ show (lookupStates from to successes) ++ "" - ++ ", " ++ show (lookupStates from to failures) ++ ")>]\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) diff --git a/src/Test/StateMachine/Sequential.hs b/src/Test/StateMachine/Sequential.hs --- a/src/Test/StateMachine/Sequential.hs +++ b/src/Test/StateMachine/Sequential.hs @@ -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 diff --git a/src/Test/StateMachine/TreeDiff.hs b/src/Test/StateMachine/TreeDiff.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/TreeDiff.hs @@ -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 diff --git a/src/Test/StateMachine/TreeDiff/Class.hs b/src/Test/StateMachine/TreeDiff/Class.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/TreeDiff/Class.hs @@ -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 diff --git a/src/Test/StateMachine/TreeDiff/Expr.hs b/src/Test/StateMachine/TreeDiff/Expr.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/TreeDiff/Expr.hs @@ -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 diff --git a/src/Test/StateMachine/TreeDiff/List.hs b/src/Test/StateMachine/TreeDiff/List.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/TreeDiff/List.hs @@ -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) diff --git a/src/Test/StateMachine/TreeDiff/Pretty.hs b/src/Test/StateMachine/TreeDiff/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/TreeDiff/Pretty.hs @@ -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 diff --git a/src/Test/StateMachine/TreeDiff/Tree.hs b/src/Test/StateMachine/TreeDiff/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Test/StateMachine/TreeDiff/Tree.hs @@ -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 diff --git a/src/Test/StateMachine/Types/References.hs b/src/Test/StateMachine/Types/References.hs --- a/src/Test/StateMachine/Types/References.hs +++ b/src/Test/StateMachine/Types/References.hs @@ -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 ------------------------------------------------------------------------ diff --git a/test/CrudWebserverDb.hs b/test/CrudWebserverDb.hs --- a/test/CrudWebserverDb.hs +++ b/test/CrudWebserverDb.hs @@ -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 ------------------------------------------------------------------------ diff --git a/test/Echo.hs b/test/Echo.hs --- a/test/Echo.hs +++ b/test/Echo.hs @@ -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 diff --git a/test/Hanoi.hs b/test/Hanoi.hs --- a/test/Hanoi.hs +++ b/test/Hanoi.hs @@ -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 ------------------------------------------------------------------------ diff --git a/test/ProcessRegistry.hs b/test/ProcessRegistry.hs --- a/test/ProcessRegistry.hs +++ b/test/ProcessRegistry.hs @@ -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) diff --git a/test/RQlite.hs b/test/RQlite.hs deleted file mode 100644 --- a/test/RQlite.hs +++ /dev/null @@ -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 diff --git a/test/SQLite.hs b/test/SQLite.hs --- a/test/SQLite.hs +++ b/test/SQLite.hs @@ -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 diff --git a/test/Schema.hs b/test/Schema.hs --- a/test/Schema.hs +++ b/test/Schema.hs @@ -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 diff --git a/test/ShrinkingProps.hs b/test/ShrinkingProps.hs --- a/test/ShrinkingProps.hs +++ b/test/ShrinkingProps.hs @@ -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') ------------------------------------------------------------------------ diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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)))